perl-5.12.0-RC0/0000755000175000017500000000000011351321567012133 5ustar jessejesseperl-5.12.0-RC0/README.apollo0000444000175000017500000000147511235207726014306 0ustar jessejesseIf you read this file _as_is_, just ignore the funny characters you see. It is written in the POD format (see pod/perlpod.pod) which is specially designed to be readable as is. =head1 NAME README.apollo - Perl version 5 on Apollo DomainOS =head1 DESCRIPTION The following tests are known to fail as of Perl 5.005_03: comp/decl..........FAILED at test 0 op/write...........FAILED at test 0 lib/filefind.......FAILED at test 2 lib/io_udp.........FAILED at test 2 lib/findbin........stat(/ressel/ABT/USER/vta/jk/proj.local/perl/perl5.005_03-MAINT_TRIAL_5/t/lib/): No such file or directory at ../lib/FindBin.pm line 162 stat(/ressel/ABT/USER/vta/jk/proj.local/perl/perl5.005_03-MAINT_TRIAL_5/t/lib/): No such file or directory at ../lib/FindBin.pm line 163 FAILED at test 1 =head1 AUTHOR Johann Klasek perl-5.12.0-RC0/perl.h0000444000175000017500000053132711325127001013243 0ustar jessejesse/* perl.h * * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 * 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ #ifndef H_PERL #define H_PERL 1 #ifdef PERL_FOR_X2P /* * This file is being used for x2p stuff. * Above symbol is defined via -D in 'x2p/Makefile.SH' * Decouple x2p stuff from some of perls more extreme eccentricities. */ #undef MULTIPLICITY #undef USE_STDIO #define USE_STDIO #endif /* PERL_FOR_X2P */ #if defined(DGUX) #include #endif #ifdef VOIDUSED # undef VOIDUSED #endif #define VOIDUSED 1 #ifdef PERL_MICRO # include "uconfig.h" #else # ifndef USE_CROSS_COMPILE # include "config.h" # else # include "xconfig.h" # endif #endif /* See L for detailed notes on * PERL_IMPLICIT_CONTEXT and PERL_IMPLICIT_SYS */ /* Note that from here --> to <-- the same logic is * repeated in makedef.pl, so be certain to update * both places when editing. */ #ifdef PERL_IMPLICIT_SYS /* PERL_IMPLICIT_SYS implies PerlMemShared != PerlMem so use slab allocator to avoid lots of MUTEX overhead */ # ifndef PL_OP_SLAB_ALLOC # define PL_OP_SLAB_ALLOC # endif #endif #ifdef USE_ITHREADS # if !defined(MULTIPLICITY) # define MULTIPLICITY # endif #endif #ifdef PERL_GLOBAL_STRUCT_PRIVATE # ifndef PERL_GLOBAL_STRUCT # define PERL_GLOBAL_STRUCT # endif #endif #ifdef PERL_GLOBAL_STRUCT # ifndef MULTIPLICITY # define MULTIPLICITY # endif #endif #ifdef MULTIPLICITY # ifndef PERL_IMPLICIT_CONTEXT # define PERL_IMPLICIT_CONTEXT # endif #endif /* undef WIN32 when building on Cygwin (for libwin32) - gph */ #ifdef __CYGWIN__ # undef WIN32 # undef _WIN32 #endif #if defined(__SYMBIAN32__) || (defined(__VC32__) && defined(WINS)) # ifndef SYMBIAN # define SYMBIAN # endif #endif #ifdef __SYMBIAN32__ # include "symbian/symbian_proto.h" #endif /* Any stack-challenged places. The limit varies (and often * is configurable), but using more than a kilobyte of stack * is usually dubious in these systems. */ #if defined(EPOC) || defined(__SYMBIAN32__) /* EPOC/Symbian: need to work around the SDK features. * * On WINS: MS VC5 generates calls to _chkstk, * * if a "large" stack frame is allocated. * * gcc on MARM does not generate calls like these. */ # define USE_HEAP_INSTEAD_OF_STACK #endif #/* Use the reentrant APIs like localtime_r and getpwent_r */ /* Win32 has naturally threadsafe libraries, no need to use any _r variants. */ #if defined(USE_ITHREADS) && !defined(USE_REENTRANT_API) && !defined(NETWARE) && !defined(WIN32) && !defined(PERL_DARWIN) # define USE_REENTRANT_API #endif /* <--- here ends the logic shared by perl.h and makedef.pl */ /* * PERL_DARWIN for MacOSX (__APPLE__ exists but is not officially sanctioned) * (The -DPERL_DARWIN comes from the hints/darwin.sh.) * __bsdi__ for BSD/OS */ #if defined(__FreeBSD__) || defined(__NetBSD__) || defined(__OpenBSD__) || defined(PERL_DARWIN) || defined(__bsdi__) || defined(BSD41) || defined(BSD42) || defined(BSD43) || defined(BSD44) # ifndef BSDish # define BSDish # endif #endif #undef START_EXTERN_C #undef END_EXTERN_C #undef EXTERN_C #ifdef __cplusplus # define START_EXTERN_C extern "C" { # define END_EXTERN_C } # define EXTERN_C extern "C" #else # define START_EXTERN_C # define END_EXTERN_C # define EXTERN_C extern #endif #ifdef PERL_GLOBAL_STRUCT # ifndef PERL_GET_VARS # ifdef PERL_GLOBAL_STRUCT_PRIVATE EXTERN_C struct perl_vars* Perl_GetVarsPrivate(); # define PERL_GET_VARS() Perl_GetVarsPrivate() /* see miniperlmain.c */ # ifndef PERLIO_FUNCS_CONST # define PERLIO_FUNCS_CONST /* Can't have these lying around. */ # endif # else # define PERL_GET_VARS() PL_VarsPtr # endif # endif #endif #define pVAR register struct perl_vars* my_vars PERL_UNUSED_DECL #ifdef PERL_GLOBAL_STRUCT # define dVAR pVAR = (struct perl_vars*)PERL_GET_VARS() #else # define dVAR dNOOP #endif #ifdef PERL_IMPLICIT_CONTEXT # ifndef MULTIPLICITY # define MULTIPLICITY # endif # define tTHX PerlInterpreter* # define pTHX register tTHX my_perl PERL_UNUSED_DECL # define aTHX my_perl # ifdef PERL_GLOBAL_STRUCT # define dTHXa(a) dVAR; pTHX = (tTHX)a # else # define dTHXa(a) pTHX = (tTHX)a # endif # ifdef PERL_GLOBAL_STRUCT # define dTHX dVAR; pTHX = PERL_GET_THX # else # define dTHX pTHX = PERL_GET_THX # endif # define pTHX_ pTHX, # define aTHX_ aTHX, # define pTHX_1 2 # define pTHX_2 3 # define pTHX_3 4 # define pTHX_4 5 # define pTHX_5 6 # define pTHX_6 7 # define pTHX_7 8 # define pTHX_8 9 # define pTHX_9 10 # if defined(DEBUGGING) && !defined(PERL_TRACK_MEMPOOL) # define PERL_TRACK_MEMPOOL # endif #else # undef PERL_TRACK_MEMPOOL #endif #define STATIC static #define CPERLscope(x) x #define CPERLarg void #define CPERLarg_ #define _CPERLarg #define PERL_OBJECT_THIS #define _PERL_OBJECT_THIS #define PERL_OBJECT_THIS_ #define CALL_FPTR(fptr) (*fptr) #define CALLRUNOPS CALL_FPTR(PL_runops) #define CALLREGCOMP(sv, flags) Perl_pregcomp(aTHX_ (sv),(flags)) #define CALLREGCOMP_ENG(prog, sv, flags) \ CALL_FPTR(((prog)->comp))(aTHX_ sv, flags) #define CALLREGEXEC(prog,stringarg,strend,strbeg,minend,screamer,data,flags) \ CALL_FPTR(RX_ENGINE(prog)->exec)(aTHX_ (prog),(stringarg),(strend), \ (strbeg),(minend),(screamer),(data),(flags)) #define CALLREG_INTUIT_START(prog,sv,strpos,strend,flags,data) \ CALL_FPTR(RX_ENGINE(prog)->intuit)(aTHX_ (prog), (sv), (strpos), \ (strend),(flags),(data)) #define CALLREG_INTUIT_STRING(prog) \ CALL_FPTR(RX_ENGINE(prog)->checkstr)(aTHX_ (prog)) #define CALLREGFREE(prog) \ Perl_pregfree(aTHX_ (prog)) #define CALLREGFREE_PVT(prog) \ if(prog) CALL_FPTR(RX_ENGINE(prog)->free)(aTHX_ (prog)) #define CALLREG_NUMBUF_FETCH(rx,paren,usesv) \ CALL_FPTR(RX_ENGINE(rx)->numbered_buff_FETCH)(aTHX_ (rx),(paren),(usesv)) #define CALLREG_NUMBUF_STORE(rx,paren,value) \ CALL_FPTR(RX_ENGINE(rx)->numbered_buff_STORE)(aTHX_ (rx),(paren),(value)) #define CALLREG_NUMBUF_LENGTH(rx,sv,paren) \ CALL_FPTR(RX_ENGINE(rx)->numbered_buff_LENGTH)(aTHX_ (rx),(sv),(paren)) #define CALLREG_NAMED_BUFF_FETCH(rx, key, flags) \ CALL_FPTR(RX_ENGINE(rx)->named_buff)(aTHX_ (rx), (key), NULL, ((flags) | RXapif_FETCH)) #define CALLREG_NAMED_BUFF_STORE(rx, key, value, flags) \ CALL_FPTR(RX_ENGINE(rx)->named_buff)(aTHX_ (rx), (key), (value), ((flags) | RXapif_STORE)) #define CALLREG_NAMED_BUFF_DELETE(rx, key, flags) \ CALL_FPTR(RX_ENGINE(rx)->named_buff)(aTHX_ (rx),(key), NULL, ((flags) | RXapif_DELETE)) #define CALLREG_NAMED_BUFF_CLEAR(rx, flags) \ CALL_FPTR(RX_ENGINE(rx)->named_buff)(aTHX_ (rx), NULL, NULL, ((flags) | RXapif_CLEAR)) #define CALLREG_NAMED_BUFF_EXISTS(rx, key, flags) \ CALL_FPTR(RX_ENGINE(rx)->named_buff)(aTHX_ (rx), (key), NULL, ((flags) | RXapif_EXISTS)) #define CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags) \ CALL_FPTR(RX_ENGINE(rx)->named_buff_iter)(aTHX_ (rx), NULL, ((flags) | RXapif_FIRSTKEY)) #define CALLREG_NAMED_BUFF_NEXTKEY(rx, lastkey, flags) \ CALL_FPTR(RX_ENGINE(rx)->named_buff_iter)(aTHX_ (rx), (lastkey), ((flags) | RXapif_NEXTKEY)) #define CALLREG_NAMED_BUFF_SCALAR(rx, flags) \ CALL_FPTR(RX_ENGINE(rx)->named_buff)(aTHX_ (rx), NULL, NULL, ((flags) | RXapif_SCALAR)) #define CALLREG_NAMED_BUFF_COUNT(rx) \ CALL_FPTR(RX_ENGINE(rx)->named_buff)(aTHX_ (rx), NULL, NULL, RXapif_REGNAMES_COUNT) #define CALLREG_NAMED_BUFF_ALL(rx, flags) \ CALL_FPTR(RX_ENGINE(rx)->named_buff)(aTHX_ (rx), NULL, NULL, flags) #define CALLREG_PACKAGE(rx) \ CALL_FPTR(RX_ENGINE(rx)->qr_package)(aTHX_ (rx)) #if defined(USE_ITHREADS) #define CALLREGDUPE(prog,param) \ Perl_re_dup(aTHX_ (prog),(param)) #define CALLREGDUPE_PVT(prog,param) \ (prog ? CALL_FPTR(RX_ENGINE(prog)->dupe)(aTHX_ (prog),(param)) \ : (REGEXP *)NULL) #endif /* * Because of backward compatibility reasons the PERL_UNUSED_DECL * cannot be changed from postfix to PERL_UNUSED_DECL(x). Sigh. * * Note that there are C compilers such as MetroWerks CodeWarrior * which do not have an "inlined" way (like the gcc __attribute__) of * marking unused variables (they need e.g. a #pragma) and therefore * cpp macros like PERL_UNUSED_DECL cannot work for this purpose, even * if it were PERL_UNUSED_DECL(x), which it cannot be (see above). * */ #if defined(__SYMBIAN32__) && defined(__GNUC__) # ifdef __cplusplus # define PERL_UNUSED_DECL # else # define PERL_UNUSED_DECL __attribute__((unused)) # endif #endif #ifndef PERL_UNUSED_DECL # if defined(HASATTRIBUTE_UNUSED) && !defined(__cplusplus) # define PERL_UNUSED_DECL __attribute__unused__ # else # define PERL_UNUSED_DECL # endif #endif /* gcc -Wall: * for silencing unused variables that are actually used most of the time, * but we cannot quite get rid of, such as "ax" in PPCODE+noargs xsubs */ #ifndef PERL_UNUSED_ARG # if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */ # include # define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x)) # else # define PERL_UNUSED_ARG(x) ((void)x) # endif #endif #ifndef PERL_UNUSED_VAR # define PERL_UNUSED_VAR(x) ((void)x) #endif #ifdef USE_ITHREADS # define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl) #else # define PERL_UNUSED_CONTEXT #endif #define NOOP /*EMPTY*/(void)0 #if !defined(HASATTRIBUTE_UNUSED) && defined(__cplusplus) #define dNOOP /*EMPTY*/(void)0 /* Older g++ has no __attribute((unused))__ */ #else #define dNOOP extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL #endif #ifndef pTHX /* Don't bother defining tTHX and sTHX; using them outside * code guarded by PERL_IMPLICIT_CONTEXT is an error. */ # define pTHX void # define pTHX_ # define aTHX # define aTHX_ # define dTHXa(a) dNOOP # define dTHX dNOOP # define pTHX_1 1 # define pTHX_2 2 # define pTHX_3 3 # define pTHX_4 4 # define pTHX_5 5 # define pTHX_6 6 # define pTHX_7 7 # define pTHX_8 8 # define pTHX_9 9 #endif #ifndef dVAR # define dVAR dNOOP #endif /* these are only defined for compatibility; should not be used internally */ #if !defined(pTHXo) && !defined(PERL_CORE) # define pTHXo pTHX # define pTHXo_ pTHX_ # define aTHXo aTHX # define aTHXo_ aTHX_ # define dTHXo dTHX # define dTHXoa(x) dTHXa(x) #endif #ifndef pTHXx # define pTHXx register PerlInterpreter *my_perl # define pTHXx_ pTHXx, # define aTHXx my_perl # define aTHXx_ aTHXx, # define dTHXx dTHX #endif /* Under PERL_IMPLICIT_SYS (used in Windows for fork emulation) * PerlIO_foo() expands to PL_StdIO->pFOO(PL_StdIO, ...). * dTHXs is therefore needed for all functions using PerlIO_foo(). */ #ifdef PERL_IMPLICIT_SYS # ifdef PERL_GLOBAL_STRUCT_PRIVATE # define dTHXs dVAR; dTHX # else # define dTHXs dTHX # endif #else # ifdef PERL_GLOBAL_STRUCT_PRIVATE # define dTHXs dVAR # else # define dTHXs dNOOP # endif #endif /* Some platforms require marking function declarations * for them to be exportable. Used in perlio.h, proto.h * is handled either by the makedef.pl or by defining the * PERL_CALLCONV to be something special. See also the * definition of XS() in XSUB.h. */ #ifndef PERL_EXPORT_C # ifdef __cplusplus # define PERL_EXPORT_C extern "C" # else # define PERL_EXPORT_C extern # endif #endif #ifndef PERL_XS_EXPORT_C # ifdef __cplusplus # define PERL_XS_EXPORT_C extern "C" # else # define PERL_XS_EXPORT_C # endif #endif #ifdef OP_IN_REGISTER # ifdef __GNUC__ # define stringify_immed(s) #s # define stringify(s) stringify_immed(s) register struct op *Perl_op asm(stringify(OP_IN_REGISTER)); # endif #endif /* gcc (-ansi) -pedantic doesn't allow gcc statement expressions, * g++ allows them but seems to have problems with them * (insane errors ensue). * g++ does not give insane errors now (RMB 2008-01-30, gcc 4.2.2). */ #if defined(PERL_GCC_PEDANTIC) || \ (defined(__GNUC__) && defined(__cplusplus) && \ ((__GNUC__ < 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ < 2)))) # ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN # define PERL_GCC_BRACE_GROUPS_FORBIDDEN # endif #endif #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) # ifndef PERL_USE_GCC_BRACE_GROUPS # define PERL_USE_GCC_BRACE_GROUPS # endif #endif /* * STMT_START { statements; } STMT_END; * can be used as a single statement, as in * if (x) STMT_START { ... } STMT_END; else ... * * Trying to select a version that gives no warnings... */ #if !(defined(STMT_START) && defined(STMT_END)) # ifdef PERL_USE_GCC_BRACE_GROUPS # define STMT_START (void)( /* gcc supports "({ STATEMENTS; })" */ # define STMT_END ) # else /* Now which other defined()s do we need here ??? */ # if (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__) # define STMT_START if (1) # define STMT_END else (void)0 # else # define STMT_START do # define STMT_END while (0) # endif # endif #endif #define WITH_THX(s) STMT_START { dTHX; s; } STMT_END #define WITH_THR(s) WITH_THX(s) #ifndef BYTEORDER /* Should never happen -- byteorder is in config.h */ # define BYTEORDER 0x1234 #endif /* Overall memory policy? */ #ifndef CONSERVATIVE # define LIBERAL 1 #endif #if 'A' == 65 && 'I' == 73 && 'J' == 74 && 'Z' == 90 #define ASCIIish #else #undef ASCIIish #endif /* * The following contortions are brought to you on behalf of all the * standards, semi-standards, de facto standards, not-so-de-facto standards * of the world, as well as all the other botches anyone ever thought of. * The basic theory is that if we work hard enough here, the rest of the * code can be a lot prettier. Well, so much for theory. Sorry, Henry... */ /* define this once if either system, instead of cluttering up the src */ #if defined(MSDOS) || defined(atarist) || defined(WIN32) || defined(NETWARE) #define DOSISH 1 #endif #if defined(__STDC__) || defined(_AIX) || defined(__stdc__) || defined(__cplusplus) || defined(EPOC) || defined(NETWARE) || defined(__SYMBIAN32__) # define STANDARD_C 1 #endif #if defined(__cplusplus) || defined(WIN32) || defined(__sgi) || defined(__EMX__) || defined(__DGUX) || defined(EPOC) || defined(__QNX__) || defined(NETWARE) || defined(PERL_MICRO) # define DONT_DECLARE_STD 1 #endif #if defined(HASVOLATILE) || defined(STANDARD_C) # define VOL volatile #else # define VOL #endif #define TAINT (PL_tainted = TRUE) #define TAINT_NOT (PL_tainted = FALSE) #define TAINT_IF(c) if (c) { PL_tainted = TRUE; } #define TAINT_ENV() if (PL_tainting) { taint_env(); } #define TAINT_PROPER(s) if (PL_tainting) { taint_proper(NULL, s); } /* XXX All process group stuff is handled in pp_sys.c. Should these defines move there? If so, I could simplify this a lot. --AD 9/96. */ /* Process group stuff changed from traditional BSD to POSIX. perlfunc.pod documents the traditional BSD-style syntax, so we'll try to preserve that, if possible. */ #ifdef HAS_SETPGID # define BSD_SETPGRP(pid, pgrp) setpgid((pid), (pgrp)) #else # if defined(HAS_SETPGRP) && defined(USE_BSD_SETPGRP) # define BSD_SETPGRP(pid, pgrp) setpgrp((pid), (pgrp)) # else # ifdef HAS_SETPGRP2 /* DG/UX */ # define BSD_SETPGRP(pid, pgrp) setpgrp2((pid), (pgrp)) # endif # endif #endif #if defined(BSD_SETPGRP) && !defined(HAS_SETPGRP) # define HAS_SETPGRP /* Well, effectively it does . . . */ #endif /* getpgid isn't POSIX, but at least Solaris and Linux have it, and it makes our life easier :-) so we'll try it. */ #ifdef HAS_GETPGID # define BSD_GETPGRP(pid) getpgid((pid)) #else # if defined(HAS_GETPGRP) && defined(USE_BSD_GETPGRP) # define BSD_GETPGRP(pid) getpgrp((pid)) # else # ifdef HAS_GETPGRP2 /* DG/UX */ # define BSD_GETPGRP(pid) getpgrp2((pid)) # endif # endif #endif #if defined(BSD_GETPGRP) && !defined(HAS_GETPGRP) # define HAS_GETPGRP /* Well, effectively it does . . . */ #endif /* These are not exact synonyms, since setpgrp() and getpgrp() may have different behaviors, but perl.h used to define USE_BSDPGRP (prior to 5.003_05) so some extension might depend on it. */ #if defined(USE_BSD_SETPGRP) || defined(USE_BSD_GETPGRP) # ifndef USE_BSDPGRP # define USE_BSDPGRP # endif #endif /* HP-UX 10.X CMA (Common Multithreaded Architecure) insists that pthread.h must be included before all other header files. */ #if defined(USE_ITHREADS) && defined(PTHREAD_H_FIRST) && defined(I_PTHREAD) # include #endif #ifndef _TYPES_ /* If types.h defines this it's easy. */ # ifndef major /* Does everyone's types.h define this? */ # include # endif #endif #ifdef __cplusplus # ifndef I_STDARG # define I_STDARG 1 # endif #endif #ifdef I_STDARG # include #else # ifdef I_VARARGS # include # endif #endif #ifdef USE_NEXT_CTYPE #if NX_CURRENT_COMPILER_RELEASE >= 500 # include #else # if NX_CURRENT_COMPILER_RELEASE >= 400 # include # else /* NX_CURRENT_COMPILER_RELEASE < 400 */ # include # endif /* NX_CURRENT_COMPILER_RELEASE >= 400 */ #endif /* NX_CURRENT_COMPILER_RELEASE >= 500 */ #else /* !USE_NEXT_CTYPE */ #include #endif /* USE_NEXT_CTYPE */ #ifdef METHOD /* Defined by OSF/1 v3.0 by ctype.h */ #undef METHOD #endif #ifdef PERL_MICRO # define NO_LOCALE #endif #ifdef I_LOCALE # include #endif #if !defined(NO_LOCALE) && defined(HAS_SETLOCALE) # define USE_LOCALE # if !defined(NO_LOCALE_COLLATE) && defined(LC_COLLATE) \ && defined(HAS_STRXFRM) # define USE_LOCALE_COLLATE # endif # if !defined(NO_LOCALE_CTYPE) && defined(LC_CTYPE) # define USE_LOCALE_CTYPE # endif # if !defined(NO_LOCALE_NUMERIC) && defined(LC_NUMERIC) # define USE_LOCALE_NUMERIC # endif #endif /* !NO_LOCALE && HAS_SETLOCALE */ #include #ifdef I_SYS_PARAM # ifdef PARAM_NEEDS_TYPES # include # endif # include #endif /* Use all the "standard" definitions? */ #if defined(STANDARD_C) && defined(I_STDLIB) # include #endif /* If this causes problems, set i_unistd=undef in the hint file. */ #ifdef I_UNISTD # include #endif /* for WCOREDUMP */ #ifdef I_SYS_WAIT # include #endif #ifdef __SYMBIAN32__ # undef _SC_ARG_MAX /* Symbian has _SC_ARG_MAX but no sysconf() */ #endif #if defined(HAS_SYSCALL) && !defined(HAS_SYSCALL_PROTO) && !defined(PERL_MICRO) EXTERN_C int syscall(int, ...); #endif #if defined(HAS_USLEEP) && !defined(HAS_USLEEP_PROTO) && !defined(PERL_MICRO) EXTERN_C int usleep(unsigned int); #endif /* Funky places that do not have socket stuff. */ #if defined(__LIBCATAMOUNT__) # define MYSWAP #endif #ifdef PERL_MICRO /* Last chance to export Perl_my_swap */ # define MYSWAP #endif #ifdef PERL_CORE /* macros for correct constant construction */ # if INTSIZE >= 2 # define U16_CONST(x) ((U16)x##U) # else # define U16_CONST(x) ((U16)x##UL) # endif # if INTSIZE >= 4 # define U32_CONST(x) ((U32)x##U) # else # define U32_CONST(x) ((U32)x##UL) # endif # ifdef HAS_QUAD # if INTSIZE >= 8 # define U64_CONST(x) ((U64)x##U) # elif LONGSIZE >= 8 # define U64_CONST(x) ((U64)x##UL) # elif QUADKIND == QUAD_IS_LONG_LONG # define U64_CONST(x) ((U64)x##ULL) # else /* best guess we can make */ # define U64_CONST(x) ((U64)x##UL) # endif # endif /* byte-swapping functions for big-/little-endian conversion */ # define _swab_16_(x) ((U16)( \ (((U16)(x) & U16_CONST(0x00ff)) << 8) | \ (((U16)(x) & U16_CONST(0xff00)) >> 8) )) # define _swab_32_(x) ((U32)( \ (((U32)(x) & U32_CONST(0x000000ff)) << 24) | \ (((U32)(x) & U32_CONST(0x0000ff00)) << 8) | \ (((U32)(x) & U32_CONST(0x00ff0000)) >> 8) | \ (((U32)(x) & U32_CONST(0xff000000)) >> 24) )) # ifdef HAS_QUAD # define _swab_64_(x) ((U64)( \ (((U64)(x) & U64_CONST(0x00000000000000ff)) << 56) | \ (((U64)(x) & U64_CONST(0x000000000000ff00)) << 40) | \ (((U64)(x) & U64_CONST(0x0000000000ff0000)) << 24) | \ (((U64)(x) & U64_CONST(0x00000000ff000000)) << 8) | \ (((U64)(x) & U64_CONST(0x000000ff00000000)) >> 8) | \ (((U64)(x) & U64_CONST(0x0000ff0000000000)) >> 24) | \ (((U64)(x) & U64_CONST(0x00ff000000000000)) >> 40) | \ (((U64)(x) & U64_CONST(0xff00000000000000)) >> 56) )) # endif /*----------------------------------------------------------------------------*/ # if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 /* little-endian */ /*----------------------------------------------------------------------------*/ # define my_htole16(x) (x) # define my_letoh16(x) (x) # define my_htole32(x) (x) # define my_letoh32(x) (x) # define my_htobe16(x) _swab_16_(x) # define my_betoh16(x) _swab_16_(x) # define my_htobe32(x) _swab_32_(x) # define my_betoh32(x) _swab_32_(x) # ifdef HAS_QUAD # define my_htole64(x) (x) # define my_letoh64(x) (x) # define my_htobe64(x) _swab_64_(x) # define my_betoh64(x) _swab_64_(x) # endif # define my_htoles(x) (x) # define my_letohs(x) (x) # define my_htolei(x) (x) # define my_letohi(x) (x) # define my_htolel(x) (x) # define my_letohl(x) (x) # if SHORTSIZE == 1 # define my_htobes(x) (x) # define my_betohs(x) (x) # elif SHORTSIZE == 2 # define my_htobes(x) _swab_16_(x) # define my_betohs(x) _swab_16_(x) # elif SHORTSIZE == 4 # define my_htobes(x) _swab_32_(x) # define my_betohs(x) _swab_32_(x) # elif SHORTSIZE == 8 # define my_htobes(x) _swab_64_(x) # define my_betohs(x) _swab_64_(x) # else # define PERL_NEED_MY_HTOBES # define PERL_NEED_MY_BETOHS # endif # if INTSIZE == 1 # define my_htobei(x) (x) # define my_betohi(x) (x) # elif INTSIZE == 2 # define my_htobei(x) _swab_16_(x) # define my_betohi(x) _swab_16_(x) # elif INTSIZE == 4 # define my_htobei(x) _swab_32_(x) # define my_betohi(x) _swab_32_(x) # elif INTSIZE == 8 # define my_htobei(x) _swab_64_(x) # define my_betohi(x) _swab_64_(x) # else # define PERL_NEED_MY_HTOBEI # define PERL_NEED_MY_BETOHI # endif # if LONGSIZE == 1 # define my_htobel(x) (x) # define my_betohl(x) (x) # elif LONGSIZE == 2 # define my_htobel(x) _swab_16_(x) # define my_betohl(x) _swab_16_(x) # elif LONGSIZE == 4 # define my_htobel(x) _swab_32_(x) # define my_betohl(x) _swab_32_(x) # elif LONGSIZE == 8 # define my_htobel(x) _swab_64_(x) # define my_betohl(x) _swab_64_(x) # else # define PERL_NEED_MY_HTOBEL # define PERL_NEED_MY_BETOHL # endif # define my_htolen(p,n) NOOP # define my_letohn(p,n) NOOP # define my_htoben(p,n) my_swabn(p,n) # define my_betohn(p,n) my_swabn(p,n) /*----------------------------------------------------------------------------*/ # elif BYTEORDER == 0x4321 || BYTEORDER == 0x87654321 /* big-endian */ /*----------------------------------------------------------------------------*/ # define my_htobe16(x) (x) # define my_betoh16(x) (x) # define my_htobe32(x) (x) # define my_betoh32(x) (x) # define my_htole16(x) _swab_16_(x) # define my_letoh16(x) _swab_16_(x) # define my_htole32(x) _swab_32_(x) # define my_letoh32(x) _swab_32_(x) # ifdef HAS_QUAD # define my_htobe64(x) (x) # define my_betoh64(x) (x) # define my_htole64(x) _swab_64_(x) # define my_letoh64(x) _swab_64_(x) # endif # define my_htobes(x) (x) # define my_betohs(x) (x) # define my_htobei(x) (x) # define my_betohi(x) (x) # define my_htobel(x) (x) # define my_betohl(x) (x) # if SHORTSIZE == 1 # define my_htoles(x) (x) # define my_letohs(x) (x) # elif SHORTSIZE == 2 # define my_htoles(x) _swab_16_(x) # define my_letohs(x) _swab_16_(x) # elif SHORTSIZE == 4 # define my_htoles(x) _swab_32_(x) # define my_letohs(x) _swab_32_(x) # elif SHORTSIZE == 8 # define my_htoles(x) _swab_64_(x) # define my_letohs(x) _swab_64_(x) # else # define PERL_NEED_MY_HTOLES # define PERL_NEED_MY_LETOHS # endif # if INTSIZE == 1 # define my_htolei(x) (x) # define my_letohi(x) (x) # elif INTSIZE == 2 # define my_htolei(x) _swab_16_(x) # define my_letohi(x) _swab_16_(x) # elif INTSIZE == 4 # define my_htolei(x) _swab_32_(x) # define my_letohi(x) _swab_32_(x) # elif INTSIZE == 8 # define my_htolei(x) _swab_64_(x) # define my_letohi(x) _swab_64_(x) # else # define PERL_NEED_MY_HTOLEI # define PERL_NEED_MY_LETOHI # endif # if LONGSIZE == 1 # define my_htolel(x) (x) # define my_letohl(x) (x) # elif LONGSIZE == 2 # define my_htolel(x) _swab_16_(x) # define my_letohl(x) _swab_16_(x) # elif LONGSIZE == 4 # define my_htolel(x) _swab_32_(x) # define my_letohl(x) _swab_32_(x) # elif LONGSIZE == 8 # define my_htolel(x) _swab_64_(x) # define my_letohl(x) _swab_64_(x) # else # define PERL_NEED_MY_HTOLEL # define PERL_NEED_MY_LETOHL # endif # define my_htolen(p,n) my_swabn(p,n) # define my_letohn(p,n) my_swabn(p,n) # define my_htoben(p,n) NOOP # define my_betohn(p,n) NOOP /*----------------------------------------------------------------------------*/ # else /* all other byte-orders */ /*----------------------------------------------------------------------------*/ # define PERL_NEED_MY_HTOLE16 # define PERL_NEED_MY_LETOH16 # define PERL_NEED_MY_HTOBE16 # define PERL_NEED_MY_BETOH16 # define PERL_NEED_MY_HTOLE32 # define PERL_NEED_MY_LETOH32 # define PERL_NEED_MY_HTOBE32 # define PERL_NEED_MY_BETOH32 # ifdef HAS_QUAD # define PERL_NEED_MY_HTOLE64 # define PERL_NEED_MY_LETOH64 # define PERL_NEED_MY_HTOBE64 # define PERL_NEED_MY_BETOH64 # endif # define PERL_NEED_MY_HTOLES # define PERL_NEED_MY_LETOHS # define PERL_NEED_MY_HTOBES # define PERL_NEED_MY_BETOHS # define PERL_NEED_MY_HTOLEI # define PERL_NEED_MY_LETOHI # define PERL_NEED_MY_HTOBEI # define PERL_NEED_MY_BETOHI # define PERL_NEED_MY_HTOLEL # define PERL_NEED_MY_LETOHL # define PERL_NEED_MY_HTOBEL # define PERL_NEED_MY_BETOHL /*----------------------------------------------------------------------------*/ # endif /* end of byte-order macros */ /*----------------------------------------------------------------------------*/ /* The old value was hard coded at 1008. (4096-16) seems to be a bit faster, at least on FreeBSD. YMMV, so experiment. */ #ifndef PERL_ARENA_SIZE #define PERL_ARENA_SIZE 4080 #endif /* Maximum level of recursion */ #ifndef PERL_SUB_DEPTH_WARN #define PERL_SUB_DEPTH_WARN 100 #endif #endif /* PERL_CORE */ /* We no longer default to creating a new SV for GvSV. Do this before embed. */ #ifndef PERL_CREATE_GVSV # ifndef PERL_DONT_CREATE_GVSV # define PERL_DONT_CREATE_GVSV # endif #endif #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME) #define PERL_USES_PL_PIDSTATUS #endif #if !defined(OS2) && !defined(WIN32) && !defined(DJGPP) && !defined(EPOC) && !defined(__SYMBIAN32__) #define PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION #endif /* Cannot include embed.h here on Win32 as win32.h has not yet been included and defines some config variables e.g. HAVE_INTERP_INTERN */ #if !defined(PERL_FOR_X2P) && !(defined(WIN32)||defined(VMS)) # include "embed.h" # ifndef PERL_MAD # undef op_getmad # define op_getmad(arg,pegop,slot) NOOP # endif #endif #define MEM_SIZE Size_t /* Round all values passed to malloc up, by default to a multiple of sizeof(size_t) */ #ifndef PERL_STRLEN_ROUNDUP_QUANTUM #define PERL_STRLEN_ROUNDUP_QUANTUM Size_t_size #endif #if defined(STANDARD_C) && defined(I_STDDEF) # include # define STRUCT_OFFSET(s,m) offsetof(s,m) #else # define STRUCT_OFFSET(s,m) (Size_t)(&(((s *)0)->m)) #endif #ifndef __SYMBIAN32__ # if defined(I_STRING) || defined(__cplusplus) # include # else # include # endif #endif /* This comes after so we don't try to change the standard * library prototypes; we'll use our own in proto.h instead. */ #ifdef MYMALLOC # ifdef PERL_POLLUTE_MALLOC # ifndef PERL_EXTMALLOC_DEF # define Perl_malloc malloc # define Perl_calloc calloc # define Perl_realloc realloc # define Perl_mfree free # endif # else # define EMBEDMYMALLOC /* for compatibility */ # endif # define safemalloc Perl_malloc # define safecalloc Perl_calloc # define saferealloc Perl_realloc # define safefree Perl_mfree # define CHECK_MALLOC_TOO_LATE_FOR_(code) STMT_START { \ if (!PL_tainting && MallocCfg_ptr[MallocCfg_cfg_env_read]) \ code; \ } STMT_END # define CHECK_MALLOC_TOO_LATE_FOR(ch) \ CHECK_MALLOC_TOO_LATE_FOR_(MALLOC_TOO_LATE_FOR(ch)) # define panic_write2(s) write(2, s, strlen(s)) # define CHECK_MALLOC_TAINT(newval) \ CHECK_MALLOC_TOO_LATE_FOR_( \ if (newval) { \ panic_write2("panic: tainting with $ENV{PERL_MALLOC_OPT}\n");\ exit(1); }) # define MALLOC_CHECK_TAINT(argc,argv,env) STMT_START { \ if (doing_taint(argc,argv,env)) { \ MallocCfg_ptr[MallocCfg_skip_cfg_env] = 1; \ }} STMT_END; #else /* MYMALLOC */ # define safemalloc safesysmalloc # define safecalloc safesyscalloc # define saferealloc safesysrealloc # define safefree safesysfree # define CHECK_MALLOC_TOO_LATE_FOR(ch) ((void)0) # define CHECK_MALLOC_TAINT(newval) ((void)0) # define MALLOC_CHECK_TAINT(argc,argv,env) #endif /* MYMALLOC */ /* diag_listed_as: "-T" is on the #! line, it must also be used on the command line */ #define TOO_LATE_FOR_(ch,what) Perl_croak(aTHX_ "\"-%c\" is on the #! line, it must also be used on the command line%s", (char)(ch), what) #define TOO_LATE_FOR(ch) TOO_LATE_FOR_(ch, "") #define MALLOC_TOO_LATE_FOR(ch) TOO_LATE_FOR_(ch, " with $ENV{PERL_MALLOC_OPT}") #define MALLOC_CHECK_TAINT2(argc,argv) MALLOC_CHECK_TAINT(argc,argv,NULL) #if !defined(HAS_STRCHR) && defined(HAS_INDEX) && !defined(strchr) #define strchr index #define strrchr rindex #endif #ifdef I_MEMORY # include #endif #ifdef HAS_MEMCPY # if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY) # ifndef memcpy extern char * memcpy (char*, char*, int); # endif # endif #else # ifndef memcpy # ifdef HAS_BCOPY # define memcpy(d,s,l) bcopy(s,d,l) # else # define memcpy(d,s,l) my_bcopy(s,d,l) # endif # endif #endif /* HAS_MEMCPY */ #ifdef HAS_MEMSET # if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY) # ifndef memset extern char *memset (char*, int, int); # endif # endif #else # undef memset # define memset(d,c,l) my_memset(d,c,l) #endif /* HAS_MEMSET */ #if !defined(HAS_MEMMOVE) && !defined(memmove) # if defined(HAS_BCOPY) && defined(HAS_SAFE_BCOPY) # define memmove(d,s,l) bcopy(s,d,l) # else # if defined(HAS_MEMCPY) && defined(HAS_SAFE_MEMCPY) # define memmove(d,s,l) memcpy(d,s,l) # else # define memmove(d,s,l) my_bcopy(s,d,l) # endif # endif #endif #if defined(mips) && defined(ultrix) && !defined(__STDC__) # undef HAS_MEMCMP #endif #if defined(HAS_MEMCMP) && defined(HAS_SANE_MEMCMP) # if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY) # ifndef memcmp extern int memcmp (char*, char*, int); # endif # endif # ifdef BUGGY_MSC # pragma function(memcmp) # endif #else # ifndef memcmp # define memcmp my_memcmp # endif #endif /* HAS_MEMCMP && HAS_SANE_MEMCMP */ #ifndef memzero # ifdef HAS_MEMSET # define memzero(d,l) memset(d,0,l) # else # ifdef HAS_BZERO # define memzero(d,l) bzero(d,l) # else # define memzero(d,l) my_bzero(d,l) # endif # endif #endif #ifndef PERL_MICRO #ifndef memchr # ifndef HAS_MEMCHR # define memchr(s,c,n) ninstr((char*)(s), ((char*)(s)) + n, &(c), &(c) + 1) # endif #endif #endif #ifndef HAS_BCMP # ifndef bcmp # define bcmp(s1,s2,l) memcmp(s1,s2,l) # endif #endif /* !HAS_BCMP */ #ifdef I_NETINET_IN # include #endif #ifdef I_ARPA_INET # include #endif #if defined(SF_APPEND) && defined(USE_SFIO) && defined(I_SFIO) /* defines SF_APPEND and might define SF_APPEND * (the neo-BSD seem to do this). */ # undef SF_APPEND #endif #ifdef I_SYS_STAT # include #endif /* Microsoft VC's sys/stat.h defines all S_Ixxx macros except S_IFIFO. This definition should ideally go into win32/win32.h, but S_IFIFO is used later here in perl.h before win32/win32.h is being included. */ #if !defined(S_IFIFO) && defined(_S_IFIFO) # define S_IFIFO _S_IFIFO #endif /* The stat macros for Amdahl UTS, Unisoft System V/88 (and derivatives like UTekV) are broken, sometimes giving false positives. Undefine them here and let the code below set them to proper values. The ghs macro stands for GreenHills Software C-1.8.5 which is the C compiler for sysV88 and the various derivatives. This header file bug is corrected in gcc-2.5.8 and later versions. --Kaveh Ghazi (ghazi@noc.rutgers.edu) 10/3/94. */ #if defined(uts) || (defined(m88k) && defined(ghs)) # undef S_ISDIR # undef S_ISCHR # undef S_ISBLK # undef S_ISREG # undef S_ISFIFO # undef S_ISLNK #endif #ifdef I_TIME # include #endif #ifdef I_SYS_TIME # ifdef I_SYS_TIME_KERNEL # define KERNEL # endif # include # ifdef I_SYS_TIME_KERNEL # undef KERNEL # endif #endif #if defined(HAS_TIMES) && defined(I_SYS_TIMES) # include #endif #if defined(HAS_STRERROR) && (!defined(HAS_MKDIR) || !defined(HAS_RMDIR)) # undef HAS_STRERROR #endif #include #if defined(WIN32) && defined(PERL_IMPLICIT_SYS) # define WIN32SCK_IS_STDSCK /* don't pull in custom wsock layer */ #endif /* In Tru64 use the 4.4BSD struct msghdr, not the 4.3 one. * This is important for using IPv6. * For OSF/1 3.2, however, defining _SOCKADDR_LEN would be * a bad idea since it breaks send() and recv(). */ #if defined(__osf__) && defined(__alpha) && !defined(_SOCKADDR_LEN) && !defined(DEC_OSF1_3_X) # define _SOCKADDR_LEN #endif #if defined(HAS_SOCKET) && !defined(VMS) && !defined(WIN32) /* VMS/WIN32 handle sockets via vmsish.h/win32.h */ # include # if defined(USE_SOCKS) && defined(I_SOCKS) # if !defined(INCLUDE_PROTOTYPES) # define INCLUDE_PROTOTYPES /* for */ # define PERL_SOCKS_NEED_PROTOTYPES # endif # include # ifdef PERL_SOCKS_NEED_PROTOTYPES /* keep cpp space clean */ # undef INCLUDE_PROTOTYPES # undef PERL_SOCKS_NEED_PROTOTYPES # endif # endif # ifdef I_NETDB # ifdef NETWARE # include # endif # include # endif # ifndef ENOTSOCK # ifdef I_NET_ERRNO # include # endif # endif #endif /* sockatmark() is so new (2001) that many places might have it hidden * behind some -D_BLAH_BLAH_SOURCE guard. The __THROW magic is required * e.g. in Gentoo, see http://bugs.gentoo.org/show_bug.cgi?id=12605 */ #if defined(HAS_SOCKATMARK) && !defined(HAS_SOCKATMARK_PROTO) # if defined(__THROW) && defined(__GLIBC__) int sockatmark(int) __THROW; # else int sockatmark(int); # endif #endif #if defined(__osf__) && defined(__cplusplus) && !defined(_XOPEN_SOURCE_EXTENDED) /* Tru64 "cxx" (C++), see hints/dec_osf.sh for why the _XOPEN_SOURCE_EXTENDED cannot be defined. */ EXTERN_C int fchdir(int); EXTERN_C int flock(int, int); EXTERN_C int fseeko(FILE *, off_t, int); EXTERN_C off_t ftello(FILE *); #endif #if defined(__SUNPRO_CC) /* SUNWspro CC (C++) */ EXTERN_C char *crypt(const char *, const char *); EXTERN_C char **environ; #endif #if defined(__cplusplus) # if defined(__OpenBSD__) || defined(__FreeBSD__) || defined(__NetBSD__) EXTERN_C char **environ; # elif defined(__CYGWIN__) EXTERN_C char *crypt(const char *, const char *); #endif #endif #ifdef SETERRNO # undef SETERRNO /* SOCKS might have defined this */ #endif #ifdef VMS # define SETERRNO(errcode,vmserrcode) \ STMT_START { \ set_errno(errcode); \ set_vaxc_errno(vmserrcode); \ } STMT_END # define dSAVEDERRNO int saved_errno; unsigned saved_vms_errno # define dSAVE_ERRNO int saved_errno = errno; unsigned saved_vms_errno = vaxc$errno # define SAVE_ERRNO ( saved_errno = errno, saved_vms_errno = vaxc$errno ) # define RESTORE_ERRNO SETERRNO(saved_errno, saved_vms_errno) # define LIB_INVARG LIB$_INVARG # define RMS_DIR RMS$_DIR # define RMS_FAC RMS$_FAC # define RMS_FEX RMS$_FEX # define RMS_FNF RMS$_FNF # define RMS_IFI RMS$_IFI # define RMS_ISI RMS$_ISI # define RMS_PRV RMS$_PRV # define SS_ACCVIO SS$_ACCVIO # define SS_DEVOFFLINE SS$_DEVOFFLINE # define SS_IVCHAN SS$_IVCHAN # define SS_NORMAL SS$_NORMAL #else # define SETERRNO(errcode,vmserrcode) (errno = (errcode)) # define dSAVEDERRNO int saved_errno # define dSAVE_ERRNO int saved_errno = errno # define SAVE_ERRNO (saved_errno = errno) # define RESTORE_ERRNO (errno = saved_errno) # define LIB_INVARG 0 # define RMS_DIR 0 # define RMS_FAC 0 # define RMS_FEX 0 # define RMS_FNF 0 # define RMS_IFI 0 # define RMS_ISI 0 # define RMS_PRV 0 # define SS_ACCVIO 0 # define SS_DEVOFFLINE 0 # define SS_IVCHAN 0 # define SS_NORMAL 0 #endif #define ERRSV GvSVn(PL_errgv) #define CLEAR_ERRSV() STMT_START { \ if (!GvSV(PL_errgv)) { \ sv_setpvs(GvSV(gv_add_by_type(PL_errgv, SVt_PV)), ""); \ } else if (SvREADONLY(GvSV(PL_errgv))) { \ SvREFCNT_dec(GvSV(PL_errgv)); \ GvSV(PL_errgv) = newSVpvs(""); \ } else { \ SV *const errsv = GvSV(PL_errgv); \ sv_setpvs(errsv, ""); \ if (SvMAGICAL(errsv)) { \ mg_free(errsv); \ } \ SvPOK_only(errsv); \ } \ } STMT_END #ifdef PERL_CORE # define DEFSV (0 + GvSVn(PL_defgv)) #else # define DEFSV GvSVn(PL_defgv) #endif #define DEFSV_set(sv) (GvSV(PL_defgv) = (sv)) #define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) #define ERRHV GvHV(PL_errgv) /* XXX unused, here for compatibility */ #ifndef errno extern int errno; /* ANSI allows errno to be an lvalue expr. * For example in multithreaded environments * something like this might happen: * extern int *_errno(void); * #define errno (*_errno()) */ #endif #ifdef HAS_STRERROR # ifdef VMS char *strerror (int,...); # else #ifndef DONT_DECLARE_STD char *strerror (int); #endif # endif # ifndef Strerror # define Strerror strerror # endif #else # ifdef HAS_SYS_ERRLIST extern int sys_nerr; extern char *sys_errlist[]; # ifndef Strerror # define Strerror(e) \ ((e) < 0 || (e) >= sys_nerr ? "(unknown)" : sys_errlist[e]) # endif # endif #endif #ifdef I_SYS_IOCTL # ifndef _IOCTL_ # include # endif #endif #if defined(mc300) || defined(mc500) || defined(mc700) || defined(mc6000) # ifdef HAS_SOCKETPAIR # undef HAS_SOCKETPAIR # endif # ifdef I_NDBM # undef I_NDBM # endif #endif #ifndef HAS_SOCKETPAIR # ifdef HAS_SOCKET # define socketpair Perl_my_socketpair # endif #endif #if INTSIZE == 2 # define htoni htons # define ntohi ntohs #else # define htoni htonl # define ntohi ntohl #endif /* Configure already sets Direntry_t */ #if defined(I_DIRENT) # include /* NeXT needs dirent + sys/dir.h */ # if defined(I_SYS_DIR) && (defined(NeXT) || defined(__NeXT__)) # include # endif #else # ifdef I_SYS_NDIR # include # else # ifdef I_SYS_DIR # ifdef hp9000s500 # include /* may be wrong in the future */ # else # include # endif # endif # endif #endif #ifdef PERL_MICRO # ifndef DIR # define DIR void # endif #endif #ifdef FPUTS_BOTCH /* work around botch in SunOS 4.0.1 and 4.0.2 */ # ifndef fputs # define fputs(sv,fp) fprintf(fp,"%s",sv) # endif #endif /* * The following gobbledygook brought to you on behalf of __STDC__. * (I could just use #ifndef __STDC__, but this is more bulletproof * in the face of half-implementations.) */ #if defined(I_SYSMODE) && !defined(PERL_MICRO) #include #endif #ifndef S_IFMT # ifdef _S_IFMT # define S_IFMT _S_IFMT # else # define S_IFMT 0170000 # endif #endif #ifndef S_ISDIR # define S_ISDIR(m) ((m & S_IFMT) == S_IFDIR) #endif #ifndef S_ISCHR # define S_ISCHR(m) ((m & S_IFMT) == S_IFCHR) #endif #ifndef S_ISBLK # ifdef S_IFBLK # define S_ISBLK(m) ((m & S_IFMT) == S_IFBLK) # else # define S_ISBLK(m) (0) # endif #endif #ifndef S_ISREG # define S_ISREG(m) ((m & S_IFMT) == S_IFREG) #endif #ifndef S_ISFIFO # ifdef S_IFIFO # define S_ISFIFO(m) ((m & S_IFMT) == S_IFIFO) # else # define S_ISFIFO(m) (0) # endif #endif #ifndef S_ISLNK # ifdef _S_ISLNK # define S_ISLNK(m) _S_ISLNK(m) # else # ifdef _S_IFLNK # define S_ISLNK(m) ((m & S_IFMT) == _S_IFLNK) # else # ifdef S_IFLNK # define S_ISLNK(m) ((m & S_IFMT) == S_IFLNK) # else # define S_ISLNK(m) (0) # endif # endif # endif #endif #ifndef S_ISSOCK # ifdef _S_ISSOCK # define S_ISSOCK(m) _S_ISSOCK(m) # else # ifdef _S_IFSOCK # define S_ISSOCK(m) ((m & S_IFMT) == _S_IFSOCK) # else # ifdef S_IFSOCK # define S_ISSOCK(m) ((m & S_IFMT) == S_IFSOCK) # else # define S_ISSOCK(m) (0) # endif # endif # endif #endif #ifndef S_IRUSR # ifdef S_IREAD # define S_IRUSR S_IREAD # define S_IWUSR S_IWRITE # define S_IXUSR S_IEXEC # else # define S_IRUSR 0400 # define S_IWUSR 0200 # define S_IXUSR 0100 # endif #endif #ifndef S_IRGRP # ifdef S_IRUSR # define S_IRGRP (S_IRUSR>>3) # define S_IWGRP (S_IWUSR>>3) # define S_IXGRP (S_IXUSR>>3) # else # define S_IRGRP 0040 # define S_IWGRP 0020 # define S_IXGRP 0010 # endif #endif #ifndef S_IROTH # ifdef S_IRUSR # define S_IROTH (S_IRUSR>>6) # define S_IWOTH (S_IWUSR>>6) # define S_IXOTH (S_IXUSR>>6) # else # define S_IROTH 0040 # define S_IWOTH 0020 # define S_IXOTH 0010 # endif #endif #ifndef S_ISUID # define S_ISUID 04000 #endif #ifndef S_ISGID # define S_ISGID 02000 #endif #ifndef S_IRWXU # define S_IRWXU (S_IRUSR|S_IWUSR|S_IXUSR) #endif #ifndef S_IRWXG # define S_IRWXG (S_IRGRP|S_IWGRP|S_IXGRP) #endif #ifndef S_IRWXO # define S_IRWXO (S_IROTH|S_IWOTH|S_IXOTH) #endif /* BeOS 5.0 and Haiku R1 seem to define S_IREAD and S_IWRITE in * which would get included through , but that is 3000 * lines in the future. --jhi */ #if !defined(S_IREAD) && !(defined(__BEOS__) || defined(__HAIKU__)) # define S_IREAD S_IRUSR #endif #if !defined(S_IWRITE) && !(defined(__BEOS__) || defined(__HAIKU__)) # define S_IWRITE S_IWUSR #endif #ifndef S_IEXEC # define S_IEXEC S_IXUSR #endif #ifdef ff_next # undef ff_next #endif #if defined(cray) || defined(gould) || defined(i860) || defined(pyr) # define SLOPPYDIVIDE #endif #ifdef UV #undef UV #endif #ifdef SPRINTF_E_BUG # define sprintf UTS_sprintf_wrap #endif /* For the times when you want the return value of sprintf, and you want it to be the length. Can't have a thread variable passed in, because C89 has no varargs macros. */ #ifdef SPRINTF_RETURNS_STRLEN # define my_sprintf sprintf #else # define my_sprintf Perl_my_sprintf #endif /* * If we have v?snprintf() and the C99 variadic macros, we can just * use just the v?snprintf(). It is nice to try to trap the buffer * overflow, however, so if we are DEBUGGING, and we cannot use the * gcc statement expressions, then use the function wrappers which try * to trap the overflow. If we can use the gcc statement expressions, * we can try that even with the version that uses the C99 variadic * macros. */ /* Note that we do not check against snprintf()/vsnprintf() returning * negative values because that is non-standard behaviour and we use * snprintf/vsnprintf only iff HAS_VSNPRINTF has been defined, and * that should be true only if the snprintf()/vsnprintf() are true * to the standard. */ #if defined(HAS_SNPRINTF) && defined(HAS_C99_VARIADIC_MACROS) && !(defined(DEBUGGING) && !defined(PERL_USE_GCC_BRACE_GROUPS)) && !defined(PERL_GCC_PEDANTIC) # ifdef PERL_USE_GCC_BRACE_GROUPS # define my_snprintf(buffer, len, ...) ({ int __len__ = snprintf(buffer, len, __VA_ARGS__); if ((len) > 0 && (Size_t)__len__ >= (len)) Perl_croak_nocontext("panic: snprintf buffer overflow"); __len__; }) # define PERL_MY_SNPRINTF_GUARDED # else # define my_snprintf(buffer, len, ...) snprintf(buffer, len, __VA_ARGS__) # endif #else # define my_snprintf Perl_my_snprintf # define PERL_MY_SNPRINTF_GUARDED #endif #if defined(HAS_VSNPRINTF) && defined(HAS_C99_VARIADIC_MACROS) && !(defined(DEBUGGING) && !defined(PERL_USE_GCC_BRACE_GROUPS)) && !defined(PERL_GCC_PEDANTIC) # ifdef PERL_USE_GCC_BRACE_GROUPS # define my_vsnprintf(buffer, len, ...) ({ int __len__ = vsnprintf(buffer, len, __VA_ARGS__); if ((len) > 0 && (Size_t)__len__ >= (len)) Perl_croak_nocontext("panic: vsnprintf buffer overflow"); __len__; }) # define PERL_MY_VSNPRINTF_GUARDED # else # define my_vsnprintf(buffer, len, ...) vsnprintf(buffer, len, __VA_ARGS__) # endif #else # define my_vsnprintf Perl_my_vsnprintf # define PERL_MY_VSNPRINTF_GUARDED #endif #ifdef HAS_STRLCAT # define my_strlcat strlcat #else # define my_strlcat Perl_my_strlcat #endif #ifdef HAS_STRLCPY # define my_strlcpy strlcpy #else # define my_strlcpy Perl_my_strlcpy #endif /* Configure gets this right but the UTS compiler gets it wrong. -- Hal Morris */ #ifdef UTS # undef UVTYPE # define UVTYPE unsigned #endif /* The IV type is supposed to be long enough to hold any integral value or a pointer. --Andy Dougherty August 1996 */ typedef IVTYPE IV; typedef UVTYPE UV; #if defined(USE_64_BIT_INT) && defined(HAS_QUAD) # if QUADKIND == QUAD_IS_INT64_T && defined(INT64_MAX) # define IV_MAX INT64_MAX # define IV_MIN INT64_MIN # define UV_MAX UINT64_MAX # ifndef UINT64_MIN # define UINT64_MIN 0 # endif # define UV_MIN UINT64_MIN # else # define IV_MAX PERL_QUAD_MAX # define IV_MIN PERL_QUAD_MIN # define UV_MAX PERL_UQUAD_MAX # define UV_MIN PERL_UQUAD_MIN # endif # define IV_IS_QUAD # define UV_IS_QUAD #else # if defined(INT32_MAX) && IVSIZE == 4 # define IV_MAX INT32_MAX # define IV_MIN INT32_MIN # ifndef UINT32_MAX_BROKEN /* e.g. HP-UX with gcc messes this up */ # define UV_MAX UINT32_MAX # else # define UV_MAX 4294967295U # endif # ifndef UINT32_MIN # define UINT32_MIN 0 # endif # define UV_MIN UINT32_MIN # else # define IV_MAX PERL_LONG_MAX # define IV_MIN PERL_LONG_MIN # define UV_MAX PERL_ULONG_MAX # define UV_MIN PERL_ULONG_MIN # endif # if IVSIZE == 8 # define IV_IS_QUAD # define UV_IS_QUAD # ifndef HAS_QUAD # define HAS_QUAD # endif # else # undef IV_IS_QUAD # undef UV_IS_QUAD # undef HAS_QUAD # endif #endif #ifndef HAS_QUAD # undef PERL_NEED_MY_HTOLE64 # undef PERL_NEED_MY_LETOH64 # undef PERL_NEED_MY_HTOBE64 # undef PERL_NEED_MY_BETOH64 #endif #if defined(uts) || defined(UTS) # undef UV_MAX # define UV_MAX (4294967295u) #endif #define IV_DIG (BIT_DIGITS(IVSIZE * 8)) #define UV_DIG (BIT_DIGITS(UVSIZE * 8)) #ifndef NO_PERL_PRESERVE_IVUV #define PERL_PRESERVE_IVUV /* We like our integers to stay integers. */ #endif /* * The macros INT2PTR and NUM2PTR are (despite their names) * bi-directional: they will convert int/float to or from pointers. * However the conversion to int/float are named explicitly: * PTR2IV, PTR2UV, PTR2NV. * * For int conversions we do not need two casts if pointers are * the same size as IV and UV. Otherwise we need an explicit * cast (PTRV) to avoid compiler warnings. */ #if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) # define PTRV UV # define INT2PTR(any,d) (any)(d) #else # if PTRSIZE == LONGSIZE # define PTRV unsigned long # define PTR2ul(p) (unsigned long)(p) # else # define PTRV unsigned # endif #endif #ifndef INT2PTR # define INT2PTR(any,d) (any)(PTRV)(d) #endif #ifndef PTR2ul # define PTR2ul(p) INT2PTR(unsigned long,p) #endif #define NUM2PTR(any,d) (any)(PTRV)(d) #define PTR2IV(p) INT2PTR(IV,p) #define PTR2UV(p) INT2PTR(UV,p) #define PTR2NV(p) NUM2PTR(NV,p) #define PTR2nat(p) (PTRV)(p) /* pointer to integer of PTRSIZE */ /* According to strict ANSI C89 one cannot freely cast between * data pointers and function (code) pointers. There are at least * two ways around this. One (used below) is to do two casts, * first the other pointer to an (unsigned) integer, and then * the integer to the other pointer. The other way would be * to use unions to "overlay" the pointers. For an example of * the latter technique, see union dirpu in struct xpvio in sv.h. * The only feasible use is probably temporarily storing * function pointers in a data pointer (such as a void pointer). */ #define DPTR2FPTR(t,p) ((t)PTR2nat(p)) /* data pointer to function pointer */ #define FPTR2DPTR(t,p) ((t)PTR2nat(p)) /* function pointer to data pointer */ #ifdef USE_LONG_DOUBLE # if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE == DOUBLESIZE # define LONG_DOUBLE_EQUALS_DOUBLE # endif # if !(defined(HAS_LONG_DOUBLE) && (LONG_DOUBLESIZE > DOUBLESIZE)) # undef USE_LONG_DOUBLE /* Ouch! */ # endif #endif #ifdef OVR_DBL_DIG /* Use an overridden DBL_DIG */ # ifdef DBL_DIG # undef DBL_DIG # endif # define DBL_DIG OVR_DBL_DIG #else /* The following is all to get DBL_DIG, in order to pick a nice default value for printing floating point numbers in Gconvert (see config.h). (It also has other uses, such as figuring out if a given precision of printing can be done with a double instead of a long double - Allen). */ #ifdef I_LIMITS #include #endif #ifdef I_FLOAT #include #endif #ifndef HAS_DBL_DIG #define DBL_DIG 15 /* A guess that works lots of places */ #endif #endif #ifdef OVR_LDBL_DIG /* Use an overridden LDBL_DIG */ # ifdef LDBL_DIG # undef LDBL_DIG # endif # define LDBL_DIG OVR_LDBL_DIG #else /* The following is all to get LDBL_DIG, in order to pick a nice default value for printing floating point numbers in Gconvert. (see config.h) */ # ifdef I_LIMITS # include # endif # ifdef I_FLOAT # include # endif # ifndef HAS_LDBL_DIG # if LONG_DOUBLESIZE == 10 # define LDBL_DIG 18 /* assume IEEE */ # else # if LONG_DOUBLESIZE == 12 # define LDBL_DIG 18 /* gcc? */ # else # if LONG_DOUBLESIZE == 16 # define LDBL_DIG 33 /* assume IEEE */ # else # if LONG_DOUBLESIZE == DOUBLESIZE # define LDBL_DIG DBL_DIG /* bummer */ # endif # endif # endif # endif # endif #endif /* * This is for making sure we have a good DBL_MAX value, if possible, * either for usage as NV_MAX or for usage in figuring out if we can * fit a given long double into a double, if bug-fixing makes it * necessary to do so. - Allen */ #ifdef I_LIMITS # include #endif #ifdef I_VALUES # if !(defined(DBL_MIN) && defined(DBL_MAX) && defined(I_LIMITS)) # include # if defined(MAXDOUBLE) && !defined(DBL_MAX) # define DBL_MAX MAXDOUBLE # endif # if defined(MINDOUBLE) && !defined(DBL_MIN) # define DBL_MIN MINDOUBLE # endif # endif #endif /* defined(I_VALUES) */ typedef NVTYPE NV; #ifdef I_IEEEFP # include #endif #ifdef USE_LONG_DOUBLE # ifdef I_SUNMATH # include # endif # define NV_DIG LDBL_DIG # ifdef LDBL_MANT_DIG # define NV_MANT_DIG LDBL_MANT_DIG # endif # ifdef LDBL_MIN # define NV_MIN LDBL_MIN # endif # ifdef LDBL_MAX # define NV_MAX LDBL_MAX # endif # ifdef LDBL_MIN_10_EXP # define NV_MIN_10_EXP LDBL_MIN_10_EXP # endif # ifdef LDBL_MAX_10_EXP # define NV_MAX_10_EXP LDBL_MAX_10_EXP # endif # ifdef LDBL_EPSILON # define NV_EPSILON LDBL_EPSILON # endif # ifdef LDBL_MAX # define NV_MAX LDBL_MAX /* Having LDBL_MAX doesn't necessarily mean that we have LDBL_MIN... -Allen */ # else # ifdef HUGE_VALL # define NV_MAX HUGE_VALL # else # ifdef HUGE_VAL # define NV_MAX ((NV)HUGE_VAL) # endif # endif # endif # ifdef HAS_SQRTL # define Perl_cos cosl # define Perl_sin sinl # define Perl_sqrt sqrtl # define Perl_exp expl # define Perl_log logl # define Perl_atan2 atan2l # define Perl_pow powl # define Perl_floor floorl # define Perl_ceil ceill # define Perl_fmod fmodl # endif /* e.g. libsunmath doesn't have modfl and frexpl as of mid-March 2000 */ # ifdef HAS_MODFL # define Perl_modf(x,y) modfl(x,y) /* eg glibc 2.2 series seems to provide modfl on ppc and arm, but has no prototype in */ # ifndef HAS_MODFL_PROTO EXTERN_C long double modfl(long double, long double *); # endif # else # if defined(HAS_AINTL) && defined(HAS_COPYSIGNL) extern long double Perl_my_modfl(long double x, long double *ip); # define Perl_modf(x,y) Perl_my_modfl(x,y) # endif # endif # ifdef HAS_FREXPL # define Perl_frexp(x,y) frexpl(x,y) # else # if defined(HAS_ILOGBL) && defined(HAS_SCALBNL) extern long double Perl_my_frexpl(long double x, int *e); # define Perl_frexp(x,y) Perl_my_frexpl(x,y) # endif # endif # ifndef Perl_isnan # ifdef HAS_ISNANL # define Perl_isnan(x) isnanl(x) # endif # endif # ifndef Perl_isinf # ifdef HAS_FINITEL # define Perl_isinf(x) !(finitel(x)||Perl_isnan(x)) # endif # endif #else # define NV_DIG DBL_DIG # ifdef DBL_MANT_DIG # define NV_MANT_DIG DBL_MANT_DIG # endif # ifdef DBL_MIN # define NV_MIN DBL_MIN # endif # ifdef DBL_MAX # define NV_MAX DBL_MAX # endif # ifdef DBL_MIN_10_EXP # define NV_MIN_10_EXP DBL_MIN_10_EXP # endif # ifdef DBL_MAX_10_EXP # define NV_MAX_10_EXP DBL_MAX_10_EXP # endif # ifdef DBL_EPSILON # define NV_EPSILON DBL_EPSILON # endif # ifdef DBL_MAX /* XXX Does DBL_MAX imply having DBL_MIN? */ # define NV_MAX DBL_MAX # define NV_MIN DBL_MIN # else # ifdef HUGE_VAL # define NV_MAX HUGE_VAL # endif # endif # define Perl_cos cos # define Perl_sin sin # define Perl_sqrt sqrt # define Perl_exp exp # define Perl_log log # define Perl_atan2 atan2 # define Perl_pow pow # define Perl_floor floor # define Perl_ceil ceil # define Perl_fmod fmod # define Perl_modf(x,y) modf(x,y) # define Perl_frexp(x,y) frexp(x,y) #endif /* rumor has it that Win32 has _fpclass() */ /* SGI has fpclassl... but not with the same result values, * and it's via a typedef (not via #define), so will need to redo Configure * to use. Not worth the trouble, IMO, at least until the below is used * more places. Also has fp_class_l, BTW, via fp_class.h. Feel free to check * with me for the SGI manpages, SGI testing, etcetera, if you want to * try getting this to work with IRIX. - Allen */ #if !defined(Perl_fp_class) && (defined(HAS_FPCLASS)||defined(HAS_FPCLASSL)) # ifdef I_IEEFP # include # endif # ifdef I_FP # include # endif # if defined(USE_LONG_DOUBLE) && defined(HAS_FPCLASSL) # define Perl_fp_class() fpclassl(x) # else # define Perl_fp_class() fpclass(x) # endif # define Perl_fp_class_snan(x) (Perl_fp_class(x)==FP_CLASS_SNAN) # define Perl_fp_class_qnan(x) (Perl_fp_class(x)==FP_CLASS_QNAN) # define Perl_fp_class_nan(x) (Perl_fp_class(x)==FP_CLASS_SNAN||Perl_fp_class(x)==FP_CLASS_QNAN) # define Perl_fp_class_ninf(x) (Perl_fp_class(x)==FP_CLASS_NINF) # define Perl_fp_class_pinf(x) (Perl_fp_class(x)==FP_CLASS_PINF) # define Perl_fp_class_inf(x) (Perl_fp_class(x)==FP_CLASS_NINF||Perl_fp_class(x)==FP_CLASS_PINF) # define Perl_fp_class_nnorm(x) (Perl_fp_class(x)==FP_CLASS_NNORM) # define Perl_fp_class_pnorm(x) (Perl_fp_class(x)==FP_CLASS_PNORM) # define Perl_fp_class_norm(x) (Perl_fp_class(x)==FP_CLASS_NNORM||Perl_fp_class(x)==FP_CLASS_PNORM) # define Perl_fp_class_ndenorm(x) (Perl_fp_class(x)==FP_CLASS_NDENORM) # define Perl_fp_class_pdenorm(x) (Perl_fp_class(x)==FP_CLASS_PDENORM) # define Perl_fp_class_denorm(x) (Perl_fp_class(x)==FP_CLASS_NDENORM||Perl_fp_class(x)==FP_CLASS_PDENORM) # define Perl_fp_class_nzero(x) (Perl_fp_class(x)==FP_CLASS_NZERO) # define Perl_fp_class_pzero(x) (Perl_fp_class(x)==FP_CLASS_PZERO) # define Perl_fp_class_zero(x) (Perl_fp_class(x)==FP_CLASS_NZERO||Perl_fp_class(x)==FP_CLASS_PZERO) #endif #if !defined(Perl_fp_class) && defined(HAS_FP_CLASS) && !defined(PERL_MICRO) # include # if !defined(FP_SNAN) && defined(I_FP_CLASS) # include # endif # define Perl_fp_class(x) fp_class(x) # define Perl_fp_class_snan(x) (fp_class(x)==FP_SNAN) # define Perl_fp_class_qnan(x) (fp_class(x)==FP_QNAN) # define Perl_fp_class_nan(x) (fp_class(x)==FP_SNAN||fp_class(x)==FP_QNAN) # define Perl_fp_class_ninf(x) (fp_class(x)==FP_NEG_INF) # define Perl_fp_class_pinf(x) (fp_class(x)==FP_POS_INF) # define Perl_fp_class_inf(x) (fp_class(x)==FP_NEG_INF||fp_class(x)==FP_POS_INF) # define Perl_fp_class_nnorm(x) (fp_class(x)==FP_NEG_NORM) # define Perl_fp_class_pnorm(x) (fp_class(x)==FP_POS_NORM) # define Perl_fp_class_norm(x) (fp_class(x)==FP_NEG_NORM||fp_class(x)==FP_POS_NORM) # define Perl_fp_class_ndenorm(x) (fp_class(x)==FP_NEG_DENORM) # define Perl_fp_class_pdenorm(x) (fp_class(x)==FP_POS_DENORM) # define Perl_fp_class_denorm(x) (fp_class(x)==FP_NEG_DENORM||fp_class(x)==FP_POS_DENORM) # define Perl_fp_class_nzero(x) (fp_class(x)==FP_NEG_ZERO) # define Perl_fp_class_pzero(x) (fp_class(x)==FP_POS_ZERO) # define Perl_fp_class_zero(x) (fp_class(x)==FP_NEG_ZERO||fp_class(x)==FP_POS_ZERO) #endif #if !defined(Perl_fp_class) && defined(HAS_FPCLASSIFY) # include # define Perl_fp_class(x) fpclassify(x) # define Perl_fp_class_nan(x) (fp_classify(x)==FP_SNAN||fp_classify(x)==FP_QNAN) # define Perl_fp_class_inf(x) (fp_classify(x)==FP_INFINITE) # define Perl_fp_class_norm(x) (fp_classify(x)==FP_NORMAL) # define Perl_fp_class_denorm(x) (fp_classify(x)==FP_SUBNORMAL) # define Perl_fp_class_zero(x) (fp_classify(x)==FP_ZERO) #endif #if !defined(Perl_fp_class) && defined(HAS_CLASS) # include # ifndef _cplusplus # define Perl_fp_class(x) class(x) # else # define Perl_fp_class(x) _class(x) # endif # define Perl_fp_class_snan(x) (Perl_fp_class(x)==FP_NANS) # define Perl_fp_class_qnan(x) (Perl_fp_class(x)==FP_NANQ) # define Perl_fp_class_nan(x) (Perl_fp_class(x)==FP_SNAN||Perl_fp_class(x)==FP_QNAN) # define Perl_fp_class_ninf(x) (Perl_fp_class(x)==FP_MINUS_INF) # define Perl_fp_class_pinf(x) (Perl_fp_class(x)==FP_PLUS_INF) # define Perl_fp_class_inf(x) (Perl_fp_class(x)==FP_MINUS_INF||Perl_fp_class(x)==FP_PLUS_INF) # define Perl_fp_class_nnorm(x) (Perl_fp_class(x)==FP_MINUS_NORM) # define Perl_fp_class_pnorm(x) (Perl_fp_class(x)==FP_PLUS_NORM) # define Perl_fp_class_norm(x) (Perl_fp_class(x)==FP_MINUS_NORM||Perl_fp_class(x)==FP_PLUS_NORM) # define Perl_fp_class_ndenorm(x) (Perl_fp_class(x)==FP_MINUS_DENORM) # define Perl_fp_class_pdenorm(x) (Perl_fp_class(x)==FP_PLUS_DENORM) # define Perl_fp_class_denorm(x) (Perl_fp_class(x)==FP_MINUS_DENORM||Perl_fp_class(x)==FP_PLUS_DENORM) # define Perl_fp_class_nzero(x) (Perl_fp_class(x)==FP_MINUS_ZERO) # define Perl_fp_class_pzero(x) (Perl_fp_class(x)==FP_PLUS_ZERO) # define Perl_fp_class_zero(x) (Perl_fp_class(x)==FP_MINUS_ZERO||Perl_fp_class(x)==FP_PLUS_ZERO) #endif /* rumor has it that Win32 has _isnan() */ #ifndef Perl_isnan # ifdef HAS_ISNAN # define Perl_isnan(x) isnan((NV)x) # else # ifdef Perl_fp_class_nan # define Perl_isnan(x) Perl_fp_class_nan(x) # else # ifdef HAS_UNORDERED # define Perl_isnan(x) unordered((x), 0.0) # else # define Perl_isnan(x) ((x)!=(x)) # endif # endif # endif #endif #ifdef UNDER_CE int isnan(double d); #endif #ifndef Perl_isinf # ifdef HAS_ISINF # define Perl_isinf(x) isinf((NV)x) # else # ifdef Perl_fp_class_inf # define Perl_isinf(x) Perl_fp_class_inf(x) # else # define Perl_isinf(x) ((x)==NV_INF) # endif # endif #endif #ifndef Perl_isfinite # ifdef HAS_FINITE # define Perl_isfinite(x) finite((NV)x) # else # ifdef HAS_ISFINITE # define Perl_isfinite(x) isfinite(x) # else # ifdef Perl_fp_class_finite # define Perl_isfinite(x) Perl_fp_class_finite(x) # else # define Perl_isfinite(x) !(Perl_is_inf(x)||Perl_is_nan(x)) # endif # endif # endif #endif /* The default is to use Perl's own atof() implementation (in numeric.c). * Usually that is the one to use but for some platforms (e.g. UNICOS) * it is however best to use the native implementation of atof. * You can experiment with using your native one by -DUSE_PERL_ATOF=0. * Some good tests to try out with either setting are t/base/num.t, * t/op/numconvert.t, and t/op/pack.t. Note that if using long doubles * you may need to be using a different function than atof! */ #ifndef USE_PERL_ATOF # ifndef _UNICOS # define USE_PERL_ATOF # endif #else # if USE_PERL_ATOF == 0 # undef USE_PERL_ATOF # endif #endif #ifdef USE_PERL_ATOF # define Perl_atof(s) Perl_my_atof(s) # define Perl_atof2(s, n) Perl_my_atof2(aTHX_ (s), &(n)) #else # define Perl_atof(s) (NV)atof(s) # define Perl_atof2(s, n) ((n) = atof(s)) #endif /* Previously these definitions used hardcoded figures. * It is hoped these formula are more portable, although * no data one way or another is presently known to me. * The "PERL_" names are used because these calculated constants * do not meet the ANSI requirements for LONG_MAX, etc., which * need to be constants acceptable to #if - kja * define PERL_LONG_MAX 2147483647L * define PERL_LONG_MIN (-LONG_MAX - 1) * define PERL ULONG_MAX 4294967295L */ #ifdef I_LIMITS /* Needed for cast_xxx() functions below. */ # include #endif /* Included values.h above if necessary; still including limits.h down here, * despite doing above, because math.h might have overriden... XXX - Allen */ /* * Try to figure out max and min values for the integral types. THE CORRECT * SOLUTION TO THIS MESS: ADAPT enquire.c FROM GCC INTO CONFIGURE. The * following hacks are used if neither limits.h or values.h provide them: * U_MAX: for types >= int: ~(unsigned TYPE)0 * for types < int: (unsigned TYPE)~(unsigned)0 * The argument to ~ must be unsigned so that later signed->unsigned * conversion can't modify the value's bit pattern (e.g. -0 -> +0), * and it must not be smaller than int because ~ does integral promotion. * _MAX: () (U_MAX >> 1) * _MIN: -_MAX - . * The latter is a hack which happens to work on some machines but * does *not* catch any random system, or things like integer types * with NaN if that is possible. * * All of the types are explicitly cast to prevent accidental loss of * numeric range, and in the hope that they will be less likely to confuse * over-eager optimizers. * */ #define PERL_UCHAR_MIN ((unsigned char)0) #ifdef UCHAR_MAX # define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX) #else # ifdef MAXUCHAR # define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR) # else # define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0) # endif #endif /* * CHAR_MIN and CHAR_MAX are not included here, as the (char) type may be * ambiguous. It may be equivalent to (signed char) or (unsigned char) * depending on local options. Until Configure detects this (or at least * detects whether the "signed" keyword is available) the CHAR ranges * will not be included. UCHAR functions normally. * - kja */ #define PERL_USHORT_MIN ((unsigned short)0) #ifdef USHORT_MAX # define PERL_USHORT_MAX ((unsigned short)USHORT_MAX) #else # ifdef MAXUSHORT # define PERL_USHORT_MAX ((unsigned short)MAXUSHORT) # else # ifdef USHRT_MAX # define PERL_USHORT_MAX ((unsigned short)USHRT_MAX) # else # define PERL_USHORT_MAX ((unsigned short)~(unsigned)0) # endif # endif #endif #ifdef SHORT_MAX # define PERL_SHORT_MAX ((short)SHORT_MAX) #else # ifdef MAXSHORT /* Often used in */ # define PERL_SHORT_MAX ((short)MAXSHORT) # else # ifdef SHRT_MAX # define PERL_SHORT_MAX ((short)SHRT_MAX) # else # define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1)) # endif # endif #endif #ifdef SHORT_MIN # define PERL_SHORT_MIN ((short)SHORT_MIN) #else # ifdef MINSHORT # define PERL_SHORT_MIN ((short)MINSHORT) # else # ifdef SHRT_MIN # define PERL_SHORT_MIN ((short)SHRT_MIN) # else # define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3)) # endif # endif #endif #ifdef UINT_MAX # define PERL_UINT_MAX ((unsigned int)UINT_MAX) #else # ifdef MAXUINT # define PERL_UINT_MAX ((unsigned int)MAXUINT) # else # define PERL_UINT_MAX (~(unsigned int)0) # endif #endif #define PERL_UINT_MIN ((unsigned int)0) #ifdef INT_MAX # define PERL_INT_MAX ((int)INT_MAX) #else # ifdef MAXINT /* Often used in */ # define PERL_INT_MAX ((int)MAXINT) # else # define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1)) # endif #endif #ifdef INT_MIN # define PERL_INT_MIN ((int)INT_MIN) #else # ifdef MININT # define PERL_INT_MIN ((int)MININT) # else # define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3)) # endif #endif #ifdef ULONG_MAX # define PERL_ULONG_MAX ((unsigned long)ULONG_MAX) #else # ifdef MAXULONG # define PERL_ULONG_MAX ((unsigned long)MAXULONG) # else # define PERL_ULONG_MAX (~(unsigned long)0) # endif #endif #define PERL_ULONG_MIN ((unsigned long)0L) #ifdef LONG_MAX # define PERL_LONG_MAX ((long)LONG_MAX) #else # ifdef MAXLONG /* Often used in */ # define PERL_LONG_MAX ((long)MAXLONG) # else # define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1)) # endif #endif #ifdef LONG_MIN # define PERL_LONG_MIN ((long)LONG_MIN) #else # ifdef MINLONG # define PERL_LONG_MIN ((long)MINLONG) # else # define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3)) # endif #endif #ifdef UV_IS_QUAD # define PERL_UQUAD_MAX (~(UV)0) # define PERL_UQUAD_MIN ((UV)0) # define PERL_QUAD_MAX ((IV) (PERL_UQUAD_MAX >> 1)) # define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3)) #endif #ifdef MYMALLOC # include "malloc_ctl.h" #endif struct RExC_state_t; struct _reg_trie_data; typedef MEM_SIZE STRLEN; #ifdef PERL_MAD typedef struct token TOKEN; typedef struct madprop MADPROP; typedef struct nexttoken NEXTTOKE; #endif typedef struct op OP; typedef struct cop COP; typedef struct unop UNOP; typedef struct binop BINOP; typedef struct listop LISTOP; typedef struct logop LOGOP; typedef struct pmop PMOP; typedef struct svop SVOP; typedef struct padop PADOP; typedef struct pvop PVOP; typedef struct loop LOOP; typedef struct interpreter PerlInterpreter; /* Amdahl's has struct sv */ /* SGI's has struct sv */ #if defined(UTS) || defined(__sgi) # define STRUCT_SV perl_sv #else # define STRUCT_SV sv #endif typedef struct STRUCT_SV SV; typedef struct av AV; typedef struct hv HV; typedef struct cv CV; typedef struct regexp ORANGE; /* This is the body structure. */ typedef struct p5rx REGEXP; typedef struct gp GP; typedef struct gv GV; typedef struct io IO; typedef struct context PERL_CONTEXT; typedef struct block BLOCK; typedef struct magic MAGIC; typedef struct xpv XPV; typedef struct xpviv XPVIV; typedef struct xpvuv XPVUV; typedef struct xpvnv XPVNV; typedef struct xpvmg XPVMG; typedef struct xpvlv XPVLV; typedef struct xpvav XPVAV; typedef struct xpvhv XPVHV; typedef struct xpvgv XPVGV; typedef struct xpvcv XPVCV; typedef struct xpvbm XPVBM; typedef struct xpvfm XPVFM; typedef struct xpvio XPVIO; typedef struct mgvtbl MGVTBL; typedef union any ANY; typedef struct ptr_tbl_ent PTR_TBL_ENT_t; typedef struct ptr_tbl PTR_TBL_t; typedef struct clone_params CLONE_PARAMS; #include "handy.h" #if defined(USE_LARGE_FILES) && !defined(NO_64_BIT_RAWIO) # if LSEEKSIZE == 8 && !defined(USE_64_BIT_RAWIO) # define USE_64_BIT_RAWIO /* implicit */ # endif #endif /* Notice the use of HAS_FSEEKO: now we are obligated to always use * fseeko/ftello if possible. Don't go #defining ftell to ftello yourself, * however, because operating systems like to do that themself. */ #ifndef FSEEKSIZE # ifdef HAS_FSEEKO # define FSEEKSIZE LSEEKSIZE # else # define FSEEKSIZE LONGSIZE # endif #endif #if defined(USE_LARGE_FILES) && !defined(NO_64_BIT_STDIO) # if FSEEKSIZE == 8 && !defined(USE_64_BIT_STDIO) # define USE_64_BIT_STDIO /* implicit */ # endif #endif #ifdef USE_64_BIT_RAWIO # ifdef HAS_OFF64_T # undef Off_t # define Off_t off64_t # undef LSEEKSIZE # define LSEEKSIZE 8 # endif /* Most 64-bit environments have defines like _LARGEFILE_SOURCE that * will trigger defines like the ones below. Some 64-bit environments, * however, do not. Therefore we have to explicitly mix and match. */ # if defined(USE_OPEN64) # define open open64 # endif # if defined(USE_LSEEK64) # define lseek lseek64 # else # if defined(USE_LLSEEK) # define lseek llseek # endif # endif # if defined(USE_STAT64) # define stat stat64 # endif # if defined(USE_FSTAT64) # define fstat fstat64 # endif # if defined(USE_LSTAT64) # define lstat lstat64 # endif # if defined(USE_FLOCK64) # define flock flock64 # endif # if defined(USE_LOCKF64) # define lockf lockf64 # endif # if defined(USE_FCNTL64) # define fcntl fcntl64 # endif # if defined(USE_TRUNCATE64) # define truncate truncate64 # endif # if defined(USE_FTRUNCATE64) # define ftruncate ftruncate64 # endif #endif #ifdef USE_64_BIT_STDIO # ifdef HAS_FPOS64_T # undef Fpos_t # define Fpos_t fpos64_t # endif /* Most 64-bit environments have defines like _LARGEFILE_SOURCE that * will trigger defines like the ones below. Some 64-bit environments, * however, do not. */ # if defined(USE_FOPEN64) # define fopen fopen64 # endif # if defined(USE_FSEEK64) # define fseek fseek64 /* don't do fseeko here, see perlio.c */ # endif # if defined(USE_FTELL64) # define ftell ftell64 /* don't do ftello here, see perlio.c */ # endif # if defined(USE_FSETPOS64) # define fsetpos fsetpos64 # endif # if defined(USE_FGETPOS64) # define fgetpos fgetpos64 # endif # if defined(USE_TMPFILE64) # define tmpfile tmpfile64 # endif # if defined(USE_FREOPEN64) # define freopen freopen64 # endif #endif #if defined(OS2) # include "iperlsys.h" #endif #if defined(__OPEN_VM) # include "vmesa/vmesaish.h" # define ISHISH "vmesa" #endif #ifdef DOSISH # if defined(OS2) # include "os2ish.h" # else # include "dosish.h" # endif # define ISHISH "dos" #endif #if defined(VMS) # include "vmsish.h" # include "embed.h" # ifndef PERL_MAD # undef op_getmad # define op_getmad(arg,pegop,slot) NOOP # endif # define ISHISH "vms" #endif #if defined(PLAN9) # include "./plan9/plan9ish.h" # define ISHISH "plan9" #endif #if defined(MPE) # include "mpeix/mpeixish.h" # define ISHISH "mpeix" #endif #if defined(__VOS__) # ifdef __GNUC__ # include "./vos/vosish.h" # else # include "vos/vosish.h" # endif # define ISHISH "vos" #endif #if defined(EPOC) # include "epocish.h" # define ISHISH "epoc" #endif #ifdef __SYMBIAN32__ # include "symbian/symbianish.h" # include "embed.h" # ifndef PERL_MAD # undef op_getmad # define op_getmad(arg,pegop,slot) NOOP # endif # define ISHISH "symbian" #endif #if defined(__HAIKU__) # include "haiku/haikuish.h" # define ISHISH "haiku" #elif defined(__BEOS__) # include "beos/beosish.h" # define ISHISH "beos" #endif #ifndef ISHISH # include "unixish.h" # define ISHISH "unix" #endif /* NSIG logic from Configure --> */ /* Strange style to avoid deeply-nested #if/#else/#endif */ #ifndef NSIG # ifdef _NSIG # define NSIG (_NSIG) # endif #endif #ifndef NSIG # ifdef SIGMAX # define NSIG (SIGMAX+1) # endif #endif #ifndef NSIG # ifdef SIG_MAX # define NSIG (SIG_MAX+1) # endif #endif #ifndef NSIG # ifdef _SIG_MAX # define NSIG (_SIG_MAX+1) # endif #endif #ifndef NSIG # ifdef MAXSIG # define NSIG (MAXSIG+1) # endif #endif #ifndef NSIG # ifdef MAX_SIG # define NSIG (MAX_SIG+1) # endif #endif #ifndef NSIG # ifdef SIGARRAYSIZE # define NSIG SIGARRAYSIZE /* Assume ary[SIGARRAYSIZE] */ # endif #endif #ifndef NSIG # ifdef _sys_nsig # define NSIG (_sys_nsig) /* Solaris 2.5 */ # endif #endif /* Default to some arbitrary number that's big enough to get most of the common signals. */ #ifndef NSIG # define NSIG 50 #endif /* <-- NSIG logic from Configure */ #ifndef NO_ENVIRON_ARRAY # define USE_ENVIRON_ARRAY #endif /* * initialise to avoid floating-point exceptions from overflow, etc */ #ifndef PERL_FPU_INIT # ifdef HAS_FPSETMASK # if HAS_FLOATINGPOINT_H # include # endif /* Some operating systems have this as a macro, which in turn expands to a comma expression, and the last sub-expression is something that gets calculated, and then they have the gall to warn that a value computed is not used. Hence cast to void. */ # define PERL_FPU_INIT (void)fpsetmask(0) # else # if defined(SIGFPE) && defined(SIG_IGN) && !defined(PERL_MICRO) # define PERL_FPU_INIT PL_sigfpe_saved = (Sighandler_t) signal(SIGFPE, SIG_IGN) # define PERL_FPU_PRE_EXEC { Sigsave_t xfpe; rsignal_save(SIGFPE, PL_sigfpe_saved, &xfpe); # define PERL_FPU_POST_EXEC rsignal_restore(SIGFPE, &xfpe); } # else # define PERL_FPU_INIT # endif # endif #endif #ifndef PERL_FPU_PRE_EXEC # define PERL_FPU_PRE_EXEC { # define PERL_FPU_POST_EXEC } #endif #ifndef PERL_SYS_INIT3_BODY # define PERL_SYS_INIT3_BODY(argvp,argcp,envp) PERL_SYS_INIT_BODY(argvp,argcp) #endif /* =for apidoc Am|void|PERL_SYS_INIT|int argc|char** argv Provides system-specific tune up of the C runtime environment necessary to run Perl interpreters. This should be called only once, before creating any Perl interpreters. =for apidoc Am|void|PERL_SYS_INIT3|int argc|char** argv|char** env Provides system-specific tune up of the C runtime environment necessary to run Perl interpreters. This should be called only once, before creating any Perl interpreters. =for apidoc Am|void|PERL_SYS_TERM| Provides system-specific clean up of the C runtime environment after running Perl interpreters. This should be called only once, after freeing any remaining Perl interpreters. =cut */ #define PERL_SYS_INIT(argc, argv) Perl_sys_init(argc, argv) #define PERL_SYS_INIT3(argc, argv, env) Perl_sys_init3(argc, argv, env) #define PERL_SYS_TERM() Perl_sys_term() #ifndef PERL_WRITE_MSG_TO_CONSOLE # define PERL_WRITE_MSG_TO_CONSOLE(io, msg, len) PerlIO_write(io, msg, len) #endif #ifndef MAXPATHLEN # ifdef PATH_MAX # ifdef _POSIX_PATH_MAX # if PATH_MAX > _POSIX_PATH_MAX /* POSIX 1990 (and pre) was ambiguous about whether PATH_MAX * included the null byte or not. Later amendments of POSIX, * XPG4, the Austin Group, and the Single UNIX Specification * all explicitly include the null byte in the PATH_MAX. * Ditto for _POSIX_PATH_MAX. */ # define MAXPATHLEN PATH_MAX # else # define MAXPATHLEN _POSIX_PATH_MAX # endif # else # define MAXPATHLEN (PATH_MAX+1) # endif # else # ifdef _POSIX_PATH_MAX # define MAXPATHLEN _POSIX_PATH_MAX # else # define MAXPATHLEN 1024 /* Err on the large side. */ # endif # endif #endif /* In case Configure was not used (we are using a "canned config" * such as Win32, or a cross-compilation setup, for example) try going * by the gcc major and minor versions. One useful URL is * http://www.ohse.de/uwe/articles/gcc-attributes.html, * but contrary to this information warn_unused_result seems * not to be in gcc 3.3.5, at least. --jhi * Also, when building extensions with an installed perl, this allows * the user to upgrade gcc and get the right attributes, rather than * relying on the list generated at Configure time. --AD * Set these up now otherwise we get confused when some of the <*thread.h> * includes below indirectly pull in (which needs to know if we * have HASATTRIBUTE_FORMAT). */ #ifndef PERL_MICRO #if defined __GNUC__ && !defined(__INTEL_COMPILER) # if __GNUC__ == 3 && __GNUC_MINOR__ >= 1 || __GNUC__ > 3 /* 3.1 -> */ # define HASATTRIBUTE_DEPRECATED # endif # if __GNUC__ >= 3 /* 3.0 -> */ /* XXX Verify this version */ # define HASATTRIBUTE_FORMAT # if defined __MINGW32__ # define PRINTF_FORMAT_NULL_OK # endif # endif # if __GNUC__ >= 3 /* 3.0 -> */ # define HASATTRIBUTE_MALLOC # endif # if __GNUC__ == 3 && __GNUC_MINOR__ >= 3 || __GNUC__ > 3 /* 3.3 -> */ # define HASATTRIBUTE_NONNULL # endif # if __GNUC__ == 2 && __GNUC_MINOR__ >= 5 || __GNUC__ > 2 /* 2.5 -> */ # define HASATTRIBUTE_NORETURN # endif # if __GNUC__ >= 3 /* gcc 3.0 -> */ # define HASATTRIBUTE_PURE # endif # if __GNUC__ == 3 && __GNUC_MINOR__ >= 4 || __GNUC__ > 3 /* 3.4 -> */ # define HASATTRIBUTE_UNUSED # endif # if __GNUC__ == 3 && __GNUC_MINOR__ == 3 && !defined(__cplusplus) # define HASATTRIBUTE_UNUSED /* gcc-3.3, but not g++-3.3. */ # endif # if __GNUC__ == 3 && __GNUC_MINOR__ >= 4 || __GNUC__ > 3 /* 3.4 -> */ # define HASATTRIBUTE_WARN_UNUSED_RESULT # endif #endif #endif /* #ifndef PERL_MICRO */ /* USE_5005THREADS needs to be after unixish.h as includes * which defines NSIG - which will stop inclusion of * this results in many functions being undeclared which bothers C++ * May make sense to have threads after "*ish.h" anyway */ #if defined(USE_ITHREADS) # ifdef NETWARE # include # else # ifdef FAKE_THREADS # include "fakethr.h" # else # ifdef WIN32 # include # else # ifdef OS2 # include "os2thread.h" # else # ifdef I_MACH_CTHREADS # include # if (defined(NeXT) || defined(__NeXT__)) && defined(PERL_POLLUTE_MALLOC) # define MUTEX_INIT_CALLS_MALLOC # endif typedef cthread_t perl_os_thread; typedef mutex_t perl_mutex; typedef condition_t perl_cond; typedef void * perl_key; # else /* Posix threads */ # ifdef I_PTHREAD # include # endif typedef pthread_t perl_os_thread; typedef pthread_mutex_t perl_mutex; typedef pthread_cond_t perl_cond; typedef pthread_key_t perl_key; # endif /* I_MACH_CTHREADS */ # endif /* OS2 */ # endif /* WIN32 */ # endif /* FAKE_THREADS */ #endif /* NETWARE */ #endif /* USE_ITHREADS */ #if defined(WIN32) # include "win32.h" #endif #ifdef NETWARE # include "netware.h" #endif #define STATUS_UNIX PL_statusvalue #ifdef VMS # define STATUS_NATIVE PL_statusvalue_vms /* * vaxc$errno is only guaranteed to be valid if errno == EVMSERR, otherwise * its contents can not be trusted. Unfortunately, Perl seems to check * it on exit, so it when PL_statusvalue_vms is updated, vaxc$errno should * be updated also. */ # include # include /* Presume this because if VMS changes it, it will require a new * set of APIs for waiting on children for binary compatibility. */ # define child_offset_bits (8) # ifndef C_FAC_POSIX # define C_FAC_POSIX 0x35A000 # endif /* STATUS_EXIT - validates and returns a NATIVE exit status code for the * platform from the existing UNIX or Native status values. */ # define STATUS_EXIT \ (((I32)PL_statusvalue_vms == -1 ? SS$_ABORT : PL_statusvalue_vms) | \ (VMSISH_HUSHED ? STS$M_INHIB_MSG : 0)) /* STATUS_NATIVE_CHILD_SET - Calculate UNIX status that matches the child * exit code and shifts the UNIX value over the correct number of bits to * be a child status. Usually the number of bits is 8, but that could be * platform dependent. The NATIVE status code is presumed to have either * from a child process. */ /* This is complicated. The child processes return a true native VMS status which must be saved. But there is an assumption in Perl that the UNIX child status has some relationship to errno values, so Perl tries to translate it to text in some of the tests. In order to get the string translation correct, for the error, errno must be EVMSERR, but that generates a different text message than what the test programs are expecting. So an errno value must be derived from the native status value when an error occurs. That will hide the true native status message. With this version of perl, the true native child status can always be retrieved so that is not a problem. But in this case, Pl_statusvalue and errno may have different values in them. */ # define STATUS_NATIVE_CHILD_SET(n) \ STMT_START { \ I32 evalue = (I32)n; \ if (evalue == EVMSERR) { \ PL_statusvalue_vms = vaxc$errno; \ PL_statusvalue = evalue; \ } else { \ PL_statusvalue_vms = evalue; \ if (evalue == -1) { \ PL_statusvalue = -1; \ PL_statusvalue_vms = SS$_ABORT; /* Should not happen */ \ } else \ PL_statusvalue = Perl_vms_status_to_unix(evalue, 1); \ set_vaxc_errno(evalue); \ if ((PL_statusvalue_vms & C_FAC_POSIX) == C_FAC_POSIX) \ set_errno(EVMSERR); \ else set_errno(Perl_vms_status_to_unix(evalue, 0)); \ PL_statusvalue = PL_statusvalue << child_offset_bits; \ } \ } STMT_END # ifdef VMSISH_STATUS # define STATUS_CURRENT (VMSISH_STATUS ? STATUS_NATIVE : STATUS_UNIX) # else # define STATUS_CURRENT STATUS_UNIX # endif /* STATUS_UNIX_SET - takes a UNIX/POSIX errno value and attempts to update * the NATIVE status to an equivalent value. Can not be used to translate * exit code values as exit code values are not guaranteed to have any * relationship at all to errno values. * This is used when Perl is forcing errno to have a specific value. */ # define STATUS_UNIX_SET(n) \ STMT_START { \ I32 evalue = (I32)n; \ PL_statusvalue = evalue; \ if (PL_statusvalue != -1) { \ if (PL_statusvalue != EVMSERR) { \ PL_statusvalue &= 0xFFFF; \ if (MY_POSIX_EXIT) \ PL_statusvalue_vms=PL_statusvalue ? SS$_ABORT : SS$_NORMAL;\ else PL_statusvalue_vms = Perl_unix_status_to_vms(evalue); \ } \ else { \ PL_statusvalue_vms = vaxc$errno; \ } \ } \ else PL_statusvalue_vms = SS$_ABORT; \ set_vaxc_errno(PL_statusvalue_vms); \ } STMT_END /* STATUS_UNIX_EXIT_SET - Takes a UNIX/POSIX exit code and sets * the NATIVE error status based on it. * * When in the default mode to comply with the Perl VMS documentation, * 0 is a success and any other code sets the NATIVE status to a failure * code of SS$_ABORT. * * In the new POSIX EXIT mode, native status will be set so that the * actual exit code will can be retrieved by the calling program or * shell. * * If the exit code is not clearly a UNIX parent or child exit status, * it will be passed through as a VMS status. */ # define STATUS_UNIX_EXIT_SET(n) \ STMT_START { \ I32 evalue = (I32)n; \ PL_statusvalue = evalue; \ if (MY_POSIX_EXIT) { \ if (evalue <= 0xFF00) { \ if (evalue > 0xFF) \ evalue = (evalue >> child_offset_bits) & 0xFF; \ PL_statusvalue_vms = \ (C_FAC_POSIX | (evalue << 3 ) | \ ((evalue == 1) ? (STS$K_ERROR | STS$M_INHIB_MSG) : 1)); \ } else /* forgive them Perl, for they have sinned */ \ PL_statusvalue_vms = evalue; \ } else { \ if (evalue == 0) \ PL_statusvalue_vms = SS$_NORMAL; \ else if (evalue <= 0xFF00) \ PL_statusvalue_vms = SS$_ABORT; \ else { /* forgive them Perl, for they have sinned */ \ if (evalue != EVMSERR) PL_statusvalue_vms = evalue; \ else PL_statusvalue_vms = vaxc$errno; \ /* And obviously used a VMS status value instead of UNIX */ \ PL_statusvalue = EVMSERR; \ } \ set_vaxc_errno(PL_statusvalue_vms); \ } \ } STMT_END /* STATUS_EXIT_SET - Takes a NATIVE/UNIX/POSIX exit code * and sets the NATIVE error status based on it. This special case * is needed to maintain compatibility with past VMS behavior. * * In the default mode on VMS, this number is passed through as * both the NATIVE and UNIX status. Which makes it different * that the STATUS_UNIX_EXIT_SET. * * In the new POSIX EXIT mode, native status will be set so that the * actual exit code will can be retrieved by the calling program or * shell. * * A POSIX exit code is from 0 to 255. If the exit code is higher * than this, it needs to be assumed that it is a VMS exit code and * passed through. */ # define STATUS_EXIT_SET(n) \ STMT_START { \ I32 evalue = (I32)n; \ PL_statusvalue = evalue; \ if (MY_POSIX_EXIT) \ if (evalue > 255) PL_statusvalue_vms = evalue; else { \ PL_statusvalue_vms = \ (C_FAC_POSIX | (evalue << 3 ) | \ ((evalue == 1) ? (STS$K_ERROR | STS$M_INHIB_MSG) : 1));} \ else \ PL_statusvalue_vms = evalue ? evalue : SS$_NORMAL; \ set_vaxc_errno(PL_statusvalue_vms); \ } STMT_END /* This macro forces a success status */ # define STATUS_ALL_SUCCESS \ (PL_statusvalue = 0, PL_statusvalue_vms = SS$_NORMAL) /* This macro forces a failure status */ # define STATUS_ALL_FAILURE (PL_statusvalue = 1, \ vaxc$errno = PL_statusvalue_vms = MY_POSIX_EXIT ? \ (C_FAC_POSIX | (1 << 3) | STS$K_ERROR | STS$M_INHIB_MSG) : SS$_ABORT) #else # define STATUS_NATIVE PL_statusvalue_posix # if defined(WCOREDUMP) # define STATUS_NATIVE_CHILD_SET(n) \ STMT_START { \ PL_statusvalue_posix = (n); \ if (PL_statusvalue_posix == -1) \ PL_statusvalue = -1; \ else { \ PL_statusvalue = \ (WIFEXITED(PL_statusvalue_posix) ? (WEXITSTATUS(PL_statusvalue_posix) << 8) : 0) | \ (WIFSIGNALED(PL_statusvalue_posix) ? (WTERMSIG(PL_statusvalue_posix) & 0x7F) : 0) | \ (WIFSIGNALED(PL_statusvalue_posix) && WCOREDUMP(PL_statusvalue_posix) ? 0x80 : 0); \ } \ } STMT_END # elif defined(WIFEXITED) # define STATUS_NATIVE_CHILD_SET(n) \ STMT_START { \ PL_statusvalue_posix = (n); \ if (PL_statusvalue_posix == -1) \ PL_statusvalue = -1; \ else { \ PL_statusvalue = \ (WIFEXITED(PL_statusvalue_posix) ? (WEXITSTATUS(PL_statusvalue_posix) << 8) : 0) | \ (WIFSIGNALED(PL_statusvalue_posix) ? (WTERMSIG(PL_statusvalue_posix) & 0x7F) : 0); \ } \ } STMT_END # else # define STATUS_NATIVE_CHILD_SET(n) \ STMT_START { \ PL_statusvalue_posix = (n); \ if (PL_statusvalue_posix == -1) \ PL_statusvalue = -1; \ else { \ PL_statusvalue = \ PL_statusvalue_posix & 0xFFFF; \ } \ } STMT_END # endif # define STATUS_UNIX_SET(n) \ STMT_START { \ PL_statusvalue = (n); \ if (PL_statusvalue != -1) \ PL_statusvalue &= 0xFFFF; \ } STMT_END # define STATUS_UNIX_EXIT_SET(n) STATUS_UNIX_SET(n) # define STATUS_EXIT_SET(n) STATUS_UNIX_SET(n) # define STATUS_CURRENT STATUS_UNIX # define STATUS_EXIT STATUS_UNIX # define STATUS_ALL_SUCCESS (PL_statusvalue = 0, PL_statusvalue_posix = 0) # define STATUS_ALL_FAILURE (PL_statusvalue = 1, PL_statusvalue_posix = 1) #endif /* flags in PL_exit_flags for nature of exit() */ #define PERL_EXIT_EXPECTED 0x01 #define PERL_EXIT_DESTRUCT_END 0x02 /* Run END in perl_destruct */ #ifndef MEMBER_TO_FPTR # define MEMBER_TO_FPTR(name) name #endif #ifndef PERL_CORE /* format to use for version numbers in file/directory names */ /* XXX move to Configure? */ /* This was only ever used for the current version, and that can be done at compile time, as PERL_FS_VERSION, so should we just delete it? */ # ifndef PERL_FS_VER_FMT # define PERL_FS_VER_FMT "%d.%d.%d" # endif #endif #ifndef PERL_FS_VERSION # define PERL_FS_VERSION PERL_VERSION_STRING #endif /* This defines a way to flush all output buffers. This may be a * performance issue, so we allow people to disable it. Also, if * we are using stdio, there are broken implementations of fflush(NULL) * out there, Solaris being the most prominent. */ #ifndef PERL_FLUSHALL_FOR_CHILD # if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO) # define PERL_FLUSHALL_FOR_CHILD PerlIO_flush((PerlIO*)NULL) # else # ifdef FFLUSH_ALL # define PERL_FLUSHALL_FOR_CHILD my_fflush_all() # else # define PERL_FLUSHALL_FOR_CHILD NOOP # endif # endif #endif #ifndef PERL_WAIT_FOR_CHILDREN # define PERL_WAIT_FOR_CHILDREN NOOP #endif /* the traditional thread-unsafe notion of "current interpreter". */ #ifndef PERL_SET_INTERP # define PERL_SET_INTERP(i) (PL_curinterp = (PerlInterpreter*)(i)) #endif #ifndef PERL_GET_INTERP # define PERL_GET_INTERP (PL_curinterp) #endif #if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_GET_THX) # ifdef MULTIPLICITY # define PERL_GET_THX ((PerlInterpreter *)PERL_GET_CONTEXT) # endif # define PERL_SET_THX(t) PERL_SET_CONTEXT(t) #endif /* This replaces the previous %_ "hack" by the "%p" hacks. All that is required is that the perl source does not use "%-p" or "%-p" or "%p" formats. These formats will still work in perl code. See comments in sv.c for futher details. Robin Barker 2005-07-14 No longer use %1p for VDf = %vd. RMB 2007-10-19 */ #ifndef SVf_ # define SVf_(n) "-" STRINGIFY(n) "p" #endif #ifndef SVf # define SVf "-p" #endif #ifndef SVf32 # define SVf32 SVf_(32) #endif #ifndef SVf256 # define SVf256 SVf_(256) #endif #define SVfARG(p) ((void*)(p)) #ifdef PERL_CORE /* not used; but needed for backward compatibilty with XS code? - RMB */ # undef VDf #else # ifndef VDf # define VDf "vd" # endif #endif #ifdef PERL_CORE /* not used; but needed for backward compatibilty with XS code? - RMB */ # undef UVf #else # ifndef UVf # define UVf UVuf # endif #endif #if !defined(PERL_CORE) && !defined(PERL_NO_SHORT_NAMES) # if defined(PERL_IMPLICIT_CONTEXT) # define pmflag(a,b) Perl_pmflag(aTHX_ a,b) # else # define pmflag Perl_pmflag # endif #endif #ifdef HASATTRIBUTE_DEPRECATED # define __attribute__deprecated__ __attribute__((deprecated)) #endif #ifdef HASATTRIBUTE_FORMAT # define __attribute__format__(x,y,z) __attribute__((format(x,y,z))) #endif #ifdef HASATTRIBUTE_MALLOC # define __attribute__malloc__ __attribute__((__malloc__)) #endif #ifdef HASATTRIBUTE_NONNULL # define __attribute__nonnull__(a) __attribute__((nonnull(a))) #endif #ifdef HASATTRIBUTE_NORETURN # define __attribute__noreturn__ __attribute__((noreturn)) #endif #ifdef HASATTRIBUTE_PURE # define __attribute__pure__ __attribute__((pure)) #endif #ifdef HASATTRIBUTE_UNUSED # define __attribute__unused__ __attribute__((unused)) #endif #ifdef HASATTRIBUTE_WARN_UNUSED_RESULT # define __attribute__warn_unused_result__ __attribute__((warn_unused_result)) #endif /* If we haven't defined the attributes yet, define them to blank. */ #ifndef __attribute__deprecated__ # define __attribute__deprecated__ #endif #ifndef __attribute__format__ # define __attribute__format__(x,y,z) #endif #ifndef __attribute__malloc__ # define __attribute__malloc__ #endif #ifndef __attribute__nonnull__ # define __attribute__nonnull__(a) #endif #ifndef __attribute__noreturn__ # define __attribute__noreturn__ #endif #ifndef __attribute__pure__ # define __attribute__pure__ #endif #ifndef __attribute__unused__ # define __attribute__unused__ #endif #ifndef __attribute__warn_unused_result__ # define __attribute__warn_unused_result__ #endif /* For functions that are marked as __attribute__noreturn__, it's not appropriate to call return. In either case, include the lint directive. */ #ifdef HASATTRIBUTE_NORETURN # define NORETURN_FUNCTION_END /* NOTREACHED */ #else # define NORETURN_FUNCTION_END /* NOTREACHED */ return 0 #endif /* Some OS warn on NULL format to printf */ #ifdef PRINTF_FORMAT_NULL_OK # define __attribute__format__null_ok__(x,y,z) __attribute__format__(x,y,z) #else # define __attribute__format__null_ok__(x,y,z) #endif #ifdef HAS_BUILTIN_EXPECT # define EXPECT(expr,val) __builtin_expect(expr,val) #else # define EXPECT(expr,val) (expr) #endif #define LIKELY(cond) EXPECT(cond,1) #define UNLIKELY(cond) EXPECT(cond,0) #ifdef HAS_BUILTIN_CHOOSE_EXPR /* placeholder */ #endif /* Some unistd.h's give a prototype for pause() even though HAS_PAUSE ends up undefined. This causes the #define below to be rejected by the compiler. Sigh. */ #ifdef HAS_PAUSE #define Pause pause #else #define Pause() sleep((32767<<16)+32767) #endif #ifndef IOCPARM_LEN # ifdef IOCPARM_MASK /* on BSDish systems we're safe */ # define IOCPARM_LEN(x) (((x) >> 16) & IOCPARM_MASK) # else # if defined(_IOC_SIZE) && defined(__GLIBC__) /* on Linux systems we're safe; except when we're not [perl #38223] */ # define IOCPARM_LEN(x) (_IOC_SIZE(x) < 256 ? 256 : _IOC_SIZE(x)) # else /* otherwise guess at what's safe */ # define IOCPARM_LEN(x) 256 # endif # endif #endif #if defined(__CYGWIN__) /* USEMYBINMODE * This symbol, if defined, indicates that the program should * use the routine my_binmode(FILE *fp, char iotype, int mode) to insure * that a file is in "binary" mode -- that is, that no translation * of bytes occurs on read or write operations. */ # define USEMYBINMODE /**/ # include /* for setmode() prototype */ # define my_binmode(fp, iotype, mode) \ (PerlLIO_setmode(fileno(fp), mode) != -1 ? TRUE : FALSE) #endif #ifdef __CYGWIN__ void init_os_extras(void); #endif #ifdef UNION_ANY_DEFINITION UNION_ANY_DEFINITION; #else union any { void* any_ptr; I32 any_i32; IV any_iv; long any_long; bool any_bool; void (*any_dptr) (void*); void (*any_dxptr) (pTHX_ void*); }; #endif typedef I32 (*filter_t) (pTHX_ int, SV *, int); #define FILTER_READ(idx, sv, len) filter_read(idx, sv, len) #define FILTER_DATA(idx) \ (PL_parser ? AvARRAY(PL_parser->rsfp_filters)[idx] : NULL) #define FILTER_ISREADER(idx) \ (PL_parser && PL_parser->rsfp_filters \ && idx >= AvFILLp(PL_parser->rsfp_filters)) #define PERL_FILTER_EXISTS(i) \ (PL_parser && PL_parser->rsfp_filters \ && (i) <= av_len(PL_parser->rsfp_filters)) #if defined(_AIX) && !defined(_AIX43) #if defined(USE_REENTRANT) || defined(_REENTRANT) || defined(_THREAD_SAFE) /* We cannot include to get the struct crypt_data * because of setkey prototype problems when threading */ typedef struct crypt_data { /* straight from /usr/include/crypt.h */ /* From OSF, Not needed in AIX char C[28], D[28]; */ char E[48]; char KS[16][48]; char block[66]; char iobuf[16]; } CRYPTD; #endif /* threading */ #endif /* AIX */ #if !defined(OS2) # include "iperlsys.h" #endif #ifdef __LIBCATAMOUNT__ #undef HAS_PASSWD /* unixish.h but not unixish enough. */ #undef HAS_GROUP #define FAKE_BIT_BUCKET #endif /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0. * Note that the USE_HASH_SEED and USE_HASH_SEED_EXPLICIT are *NOT* * defined by Configure, despite their names being similar to the * other defines like USE_ITHREADS. Configure in fact knows nothing * about the randomised hashes. Therefore to enable/disable the hash * randomisation defines use the Configure -Accflags=... instead. */ #if !defined(NO_HASH_SEED) && !defined(USE_HASH_SEED) && !defined(USE_HASH_SEED_EXPLICIT) # define USE_HASH_SEED #endif /* Win32 defines a type 'WORD' in windef.h. This conflicts with the enumerator * 'WORD' defined in perly.h. The yytokentype enum is only a debugging aid, so * it's not really needed. */ #if defined(WIN32) # define YYTOKENTYPE #endif #include "perly.h" #ifdef PERL_MAD struct nexttoken { YYSTYPE next_val; /* value of next token, if any */ I32 next_type; /* type of next token */ MADPROP *next_mad; /* everything else about that token */ }; #endif /* macros to define bit-fields in structs. */ #ifndef PERL_BITFIELD8 # define PERL_BITFIELD8 unsigned #endif #ifndef PERL_BITFIELD16 # define PERL_BITFIELD16 unsigned #endif #ifndef PERL_BITFIELD32 # define PERL_BITFIELD32 unsigned #endif #include "sv.h" #include "regexp.h" #include "util.h" #include "form.h" #include "gv.h" #include "pad.h" #include "cv.h" #include "opnames.h" #include "op.h" #include "hv.h" #include "cop.h" #include "av.h" #include "mg.h" #include "scope.h" #include "warnings.h" #include "utf8.h" /* defined in sv.c, but also used in [ach]v.c */ #undef _XPV_HEAD #undef _XPVMG_HEAD #undef _XPVCV_COMMON typedef struct _sublex_info SUBLEXINFO; struct _sublex_info { U8 super_state; /* lexer state to save */ U16 sub_inwhat; /* "lex_inwhat" to use */ OP *sub_op; /* "lex_op" to use */ char *super_bufptr; /* PL_parser->bufptr that was */ char *super_bufend; /* PL_parser->bufend that was */ }; #include "parser.h" typedef struct magic_state MGS; /* struct magic_state defined in mg.c */ struct scan_data_t; /* Used in S_* functions in regcomp.c */ struct regnode_charclass_class; /* Used in S_* functions in regcomp.c */ /* Keep next first in this structure, because sv_free_arenas take advantage of this to share code between the pte arenas and the SV body arenas */ struct ptr_tbl_ent { struct ptr_tbl_ent* next; const void* oldval; void* newval; }; struct ptr_tbl { struct ptr_tbl_ent** tbl_ary; UV tbl_max; UV tbl_items; }; #if defined(iAPX286) || defined(M_I286) || defined(I80286) # define I286 #endif #if defined(htonl) && !defined(HAS_HTONL) #define HAS_HTONL #endif #if defined(htons) && !defined(HAS_HTONS) #define HAS_HTONS #endif #if defined(ntohl) && !defined(HAS_NTOHL) #define HAS_NTOHL #endif #if defined(ntohs) && !defined(HAS_NTOHS) #define HAS_NTOHS #endif #ifndef HAS_HTONL #if (BYTEORDER & 0xffff) != 0x4321 #define HAS_HTONS #define HAS_HTONL #define HAS_NTOHS #define HAS_NTOHL #define MYSWAP #define htons my_swap #define htonl my_htonl #define ntohs my_swap #define ntohl my_ntohl #endif #else #if (BYTEORDER & 0xffff) == 0x4321 #undef HAS_HTONS #undef HAS_HTONL #undef HAS_NTOHS #undef HAS_NTOHL #endif #endif /* * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'. * -DWS */ #if BYTEORDER != 0x1234 # define HAS_VTOHL # define HAS_VTOHS # define HAS_HTOVL # define HAS_HTOVS # if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321 # define vtohl(x) ((((x)&0xFF)<<24) \ +(((x)>>24)&0xFF) \ +(((x)&0x0000FF00)<<8) \ +(((x)&0x00FF0000)>>8) ) # define vtohs(x) ((((x)&0xFF)<<8) + (((x)>>8)&0xFF)) # define htovl(x) vtohl(x) # define htovs(x) vtohs(x) # endif /* otherwise default to functions in util.c */ #ifndef htovs short htovs(short n); short vtohs(short n); long htovl(long n); long vtohl(long n); #endif #endif /* *MAX Plus 1. A floating point value. Hopefully expressed in a way that dodgy floating point can't mess up. >> 2 rather than 1, so that value is safely less than I32_MAX after 1 is added to it May find that some broken compiler will want the value cast to I32. [after the shift, as signed >> may not be as secure as unsigned >>] */ #define I32_MAX_P1 (2.0 * (1 + (((U32)I32_MAX) >> 1))) #define U32_MAX_P1 (4.0 * (1 + ((U32_MAX) >> 2))) /* For compilers that can't correctly cast NVs over 0x7FFFFFFF (or 0x7FFFFFFFFFFFFFFF) to an unsigned integer. In the future, sizeof(UV) may be greater than sizeof(IV), so don't assume that half max UV is max IV. */ #define U32_MAX_P1_HALF (2.0 * (1 + ((U32_MAX) >> 2))) #define UV_MAX_P1 (4.0 * (1 + ((UV_MAX) >> 2))) #define IV_MAX_P1 (2.0 * (1 + (((UV)IV_MAX) >> 1))) #define UV_MAX_P1_HALF (2.0 * (1 + ((UV_MAX) >> 2))) /* This may look like unnecessary jumping through hoops, but converting out of range floating point values to integers *is* undefined behaviour, and it is starting to bite. */ #ifndef CAST_INLINE #define I_32(what) (cast_i32((NV)(what))) #define U_32(what) (cast_ulong((NV)(what))) #define I_V(what) (cast_iv((NV)(what))) #define U_V(what) (cast_uv((NV)(what))) #else #define I_32(n) ((n) < I32_MAX_P1 ? ((n) < I32_MIN ? I32_MIN : (I32) (n)) \ : ((n) < U32_MAX_P1 ? (I32)(U32) (n) \ : ((n) > 0 ? (I32) U32_MAX : 0 /* NaN */))) #define U_32(n) ((n) < 0.0 ? ((n) < I32_MIN ? (UV) I32_MIN : (U32)(I32) (n)) \ : ((n) < U32_MAX_P1 ? (U32) (n) \ : ((n) > 0 ? U32_MAX : 0 /* NaN */))) #define I_V(n) ((n) < IV_MAX_P1 ? ((n) < IV_MIN ? IV_MIN : (IV) (n)) \ : ((n) < UV_MAX_P1 ? (IV)(UV) (n) \ : ((n) > 0 ? (IV)UV_MAX : 0 /* NaN */))) #define U_V(n) ((n) < 0.0 ? ((n) < IV_MIN ? (UV) IV_MIN : (UV)(IV) (n)) \ : ((n) < UV_MAX_P1 ? (UV) (n) \ : ((n) > 0 ? UV_MAX : 0 /* NaN */))) #endif #define U_S(what) ((U16)U_32(what)) #define U_I(what) ((unsigned int)U_32(what)) #define U_L(what) U_32(what) #ifdef HAS_SIGNBIT # define Perl_signbit signbit #endif /* These do not care about the fractional part, only about the range. */ #define NV_WITHIN_IV(nv) (I_V(nv) >= IV_MIN && I_V(nv) <= IV_MAX) #define NV_WITHIN_UV(nv) ((nv)>=0.0 && U_V(nv) >= UV_MIN && U_V(nv) <= UV_MAX) /* Used with UV/IV arguments: */ /* XXXX: need to speed it up */ #define CLUMP_2UV(iv) ((iv) < 0 ? 0 : (UV)(iv)) #define CLUMP_2IV(uv) ((uv) > (UV)IV_MAX ? IV_MAX : (IV)(uv)) #ifndef MAXSYSFD # define MAXSYSFD 2 #endif #ifndef __cplusplus #if !(defined(UNDER_CE) || defined(SYMBIAN)) Uid_t getuid (void); Uid_t geteuid (void); Gid_t getgid (void); Gid_t getegid (void); #endif #endif #ifndef Perl_debug_log # define Perl_debug_log PerlIO_stderr() #endif #ifndef Perl_error_log # define Perl_error_log (PL_stderrgv \ && isGV(PL_stderrgv) \ && GvIOp(PL_stderrgv) \ && IoOFP(GvIOp(PL_stderrgv)) \ ? IoOFP(GvIOp(PL_stderrgv)) \ : PerlIO_stderr()) #endif #define DEBUG_p_FLAG 0x00000001 /* 1 */ #define DEBUG_s_FLAG 0x00000002 /* 2 */ #define DEBUG_l_FLAG 0x00000004 /* 4 */ #define DEBUG_t_FLAG 0x00000008 /* 8 */ #define DEBUG_o_FLAG 0x00000010 /* 16 */ #define DEBUG_c_FLAG 0x00000020 /* 32 */ #define DEBUG_P_FLAG 0x00000040 /* 64 */ #define DEBUG_m_FLAG 0x00000080 /* 128 */ #define DEBUG_f_FLAG 0x00000100 /* 256 */ #define DEBUG_r_FLAG 0x00000200 /* 512 */ #define DEBUG_x_FLAG 0x00000400 /* 1024 */ #define DEBUG_u_FLAG 0x00000800 /* 2048 */ /* U is reserved for Unofficial, exploratory hacking */ #define DEBUG_U_FLAG 0x00001000 /* 4096 */ #define DEBUG_H_FLAG 0x00002000 /* 8192 */ #define DEBUG_X_FLAG 0x00004000 /* 16384 */ #define DEBUG_D_FLAG 0x00008000 /* 32768 */ /* 0x00010000 is unused, used to be S */ #define DEBUG_T_FLAG 0x00020000 /* 131072 */ #define DEBUG_R_FLAG 0x00040000 /* 262144 */ #define DEBUG_J_FLAG 0x00080000 /* 524288 */ #define DEBUG_v_FLAG 0x00100000 /*1048576 */ #define DEBUG_C_FLAG 0x00200000 /*2097152 */ #define DEBUG_A_FLAG 0x00400000 /*4194304 */ #define DEBUG_q_FLAG 0x00800000 /*8388608 */ #define DEBUG_M_FLAG 0x01000000 /*16777216*/ #define DEBUG_B_FLAG 0x02000000 /*33554432*/ #define DEBUG_MASK 0x03FEEFFF /* mask of all the standard flags */ #define DEBUG_DB_RECURSE_FLAG 0x40000000 #define DEBUG_TOP_FLAG 0x80000000 /* XXX what's this for ??? Signal that something was done? */ # define DEBUG_p_TEST_ (PL_debug & DEBUG_p_FLAG) # define DEBUG_s_TEST_ (PL_debug & DEBUG_s_FLAG) # define DEBUG_l_TEST_ (PL_debug & DEBUG_l_FLAG) # define DEBUG_t_TEST_ (PL_debug & DEBUG_t_FLAG) # define DEBUG_o_TEST_ (PL_debug & DEBUG_o_FLAG) # define DEBUG_c_TEST_ (PL_debug & DEBUG_c_FLAG) # define DEBUG_P_TEST_ (PL_debug & DEBUG_P_FLAG) # define DEBUG_m_TEST_ (PL_debug & DEBUG_m_FLAG) # define DEBUG_f_TEST_ (PL_debug & DEBUG_f_FLAG) # define DEBUG_r_TEST_ (PL_debug & DEBUG_r_FLAG) # define DEBUG_x_TEST_ (PL_debug & DEBUG_x_FLAG) # define DEBUG_u_TEST_ (PL_debug & DEBUG_u_FLAG) # define DEBUG_U_TEST_ (PL_debug & DEBUG_U_FLAG) # define DEBUG_H_TEST_ (PL_debug & DEBUG_H_FLAG) # define DEBUG_X_TEST_ (PL_debug & DEBUG_X_FLAG) # define DEBUG_D_TEST_ (PL_debug & DEBUG_D_FLAG) # define DEBUG_T_TEST_ (PL_debug & DEBUG_T_FLAG) # define DEBUG_R_TEST_ (PL_debug & DEBUG_R_FLAG) # define DEBUG_J_TEST_ (PL_debug & DEBUG_J_FLAG) # define DEBUG_v_TEST_ (PL_debug & DEBUG_v_FLAG) # define DEBUG_C_TEST_ (PL_debug & DEBUG_C_FLAG) # define DEBUG_A_TEST_ (PL_debug & DEBUG_A_FLAG) # define DEBUG_q_TEST_ (PL_debug & DEBUG_q_FLAG) # define DEBUG_M_TEST_ (PL_debug & DEBUG_M_FLAG) # define DEBUG_B_TEST_ (PL_debug & DEBUG_B_FLAG) # define DEBUG_Xv_TEST_ (DEBUG_X_TEST_ && DEBUG_v_TEST_) # define DEBUG_Uv_TEST_ (DEBUG_U_TEST_ && DEBUG_v_TEST_) #ifdef DEBUGGING # define DEBUG_p_TEST DEBUG_p_TEST_ # define DEBUG_s_TEST DEBUG_s_TEST_ # define DEBUG_l_TEST DEBUG_l_TEST_ # define DEBUG_t_TEST DEBUG_t_TEST_ # define DEBUG_o_TEST DEBUG_o_TEST_ # define DEBUG_c_TEST DEBUG_c_TEST_ # define DEBUG_P_TEST DEBUG_P_TEST_ # define DEBUG_m_TEST DEBUG_m_TEST_ # define DEBUG_f_TEST DEBUG_f_TEST_ # define DEBUG_r_TEST DEBUG_r_TEST_ # define DEBUG_x_TEST DEBUG_x_TEST_ # define DEBUG_u_TEST DEBUG_u_TEST_ # define DEBUG_U_TEST DEBUG_U_TEST_ # define DEBUG_H_TEST DEBUG_H_TEST_ # define DEBUG_X_TEST DEBUG_X_TEST_ # define DEBUG_D_TEST DEBUG_D_TEST_ # define DEBUG_T_TEST DEBUG_T_TEST_ # define DEBUG_R_TEST DEBUG_R_TEST_ # define DEBUG_J_TEST DEBUG_J_TEST_ # define DEBUG_v_TEST DEBUG_v_TEST_ # define DEBUG_C_TEST DEBUG_C_TEST_ # define DEBUG_A_TEST DEBUG_A_TEST_ # define DEBUG_q_TEST DEBUG_q_TEST_ # define DEBUG_M_TEST DEBUG_M_TEST_ # define DEBUG_B_TEST DEBUG_B_TEST_ # define DEBUG_Xv_TEST DEBUG_Xv_TEST_ # define DEBUG_Uv_TEST DEBUG_Uv_TEST_ # define PERL_DEB(a) a # define PERL_DEBUG(a) if (PL_debug) a # define DEBUG_p(a) if (DEBUG_p_TEST) a # define DEBUG_s(a) if (DEBUG_s_TEST) a # define DEBUG_l(a) if (DEBUG_l_TEST) a # define DEBUG_t(a) if (DEBUG_t_TEST) a # define DEBUG_o(a) if (DEBUG_o_TEST) a # define DEBUG_c(a) if (DEBUG_c_TEST) a # define DEBUG_P(a) if (DEBUG_P_TEST) a /* Temporarily turn off memory debugging in case the a * does memory allocation, either directly or indirectly. */ # define DEBUG_m(a) \ STMT_START { \ if (PERL_GET_INTERP) { dTHX; if (DEBUG_m_TEST) {PL_debug&=~DEBUG_m_FLAG; a; PL_debug|=DEBUG_m_FLAG;} } \ } STMT_END # define DEBUG__(t, a) \ STMT_START { \ if (t) STMT_START {a;} STMT_END; \ } STMT_END # define DEBUG_f(a) DEBUG__(DEBUG_f_TEST, a) #ifndef PERL_EXT_RE_BUILD # define DEBUG_r(a) DEBUG__(DEBUG_r_TEST, a) #else # define DEBUG_r(a) STMT_START {a;} STMT_END #endif /* PERL_EXT_RE_BUILD */ # define DEBUG_x(a) DEBUG__(DEBUG_x_TEST, a) # define DEBUG_u(a) DEBUG__(DEBUG_u_TEST, a) # define DEBUG_U(a) DEBUG__(DEBUG_U_TEST, a) # define DEBUG_H(a) DEBUG__(DEBUG_H_TEST, a) # define DEBUG_X(a) DEBUG__(DEBUG_X_TEST, a) # define DEBUG_D(a) DEBUG__(DEBUG_D_TEST, a) # define DEBUG_Xv(a) DEBUG__(DEBUG_Xv_TEST, a) # define DEBUG_Uv(a) DEBUG__(DEBUG_Uv_TEST, a) # define DEBUG_T(a) DEBUG__(DEBUG_T_TEST, a) # define DEBUG_R(a) DEBUG__(DEBUG_R_TEST, a) # define DEBUG_v(a) DEBUG__(DEBUG_v_TEST, a) # define DEBUG_C(a) DEBUG__(DEBUG_C_TEST, a) # define DEBUG_A(a) DEBUG__(DEBUG_A_TEST, a) # define DEBUG_q(a) DEBUG__(DEBUG_q_TEST, a) # define DEBUG_M(a) DEBUG__(DEBUG_M_TEST, a) # define DEBUG_B(a) DEBUG__(DEBUG_B_TEST, a) #else /* DEBUGGING */ # define DEBUG_p_TEST (0) # define DEBUG_s_TEST (0) # define DEBUG_l_TEST (0) # define DEBUG_t_TEST (0) # define DEBUG_o_TEST (0) # define DEBUG_c_TEST (0) # define DEBUG_P_TEST (0) # define DEBUG_m_TEST (0) # define DEBUG_f_TEST (0) # define DEBUG_r_TEST (0) # define DEBUG_x_TEST (0) # define DEBUG_u_TEST (0) # define DEBUG_U_TEST (0) # define DEBUG_H_TEST (0) # define DEBUG_X_TEST (0) # define DEBUG_D_TEST (0) # define DEBUG_T_TEST (0) # define DEBUG_R_TEST (0) # define DEBUG_J_TEST (0) # define DEBUG_v_TEST (0) # define DEBUG_C_TEST (0) # define DEBUG_A_TEST (0) # define DEBUG_q_TEST (0) # define DEBUG_M_TEST (0) # define DEBUG_B_TEST (0) # define DEBUG_Xv_TEST (0) # define DEBUG_Uv_TEST (0) # define PERL_DEB(a) # define PERL_DEBUG(a) # define DEBUG_p(a) # define DEBUG_s(a) # define DEBUG_l(a) # define DEBUG_t(a) # define DEBUG_o(a) # define DEBUG_c(a) # define DEBUG_P(a) # define DEBUG_m(a) # define DEBUG_f(a) # define DEBUG_r(a) # define DEBUG_x(a) # define DEBUG_u(a) # define DEBUG_U(a) # define DEBUG_H(a) # define DEBUG_X(a) # define DEBUG_D(a) # define DEBUG_T(a) # define DEBUG_R(a) # define DEBUG_v(a) # define DEBUG_C(a) # define DEBUG_A(a) # define DEBUG_q(a) # define DEBUG_M(a) # define DEBUG_B(a) # define DEBUG_Xv(a) # define DEBUG_Uv(a) #endif /* DEBUGGING */ #define DEBUG_SCOPE(where) \ DEBUG_l(WITH_THR(Perl_deb(aTHX_ "%s scope %ld at %s:%d\n", \ where, (long)PL_scopestack_ix, __FILE__, __LINE__))); /* These constants should be used in preference to raw characters * when using magic. Note that some perl guts still assume * certain character properties of these constants, namely that * isUPPER() and toLOWER() may do useful mappings. * * Update the magic_names table in dump.c when adding/amending these */ #define PERL_MAGIC_sv '\0' /* Special scalar variable */ #define PERL_MAGIC_overload 'A' /* %OVERLOAD hash */ #define PERL_MAGIC_overload_elem 'a' /* %OVERLOAD hash element */ #define PERL_MAGIC_overload_table 'c' /* Holds overload table (AMT) on stash */ #define PERL_MAGIC_bm 'B' /* Boyer-Moore (fast string search) */ #define PERL_MAGIC_regdata 'D' /* Regex match position data (@+ and @- vars) */ #define PERL_MAGIC_regdatum 'd' /* Regex match position data element */ #define PERL_MAGIC_env 'E' /* %ENV hash */ #define PERL_MAGIC_envelem 'e' /* %ENV hash element */ #define PERL_MAGIC_fm 'f' /* Formline ('compiled' format) */ #define PERL_MAGIC_regex_global 'g' /* m//g target / study()ed string */ #define PERL_MAGIC_hints 'H' /* %^H hash */ #define PERL_MAGIC_hintselem 'h' /* %^H hash element */ #define PERL_MAGIC_isa 'I' /* @ISA array */ #define PERL_MAGIC_isaelem 'i' /* @ISA array element */ #define PERL_MAGIC_nkeys 'k' /* scalar(keys()) lvalue */ #define PERL_MAGIC_dbfile 'L' /* Debugger %_ #endif /* Keep the old croak based assert for those who want it, and as a fallback if the platform is so heretically non-ANSI that it can't assert. */ #define Perl_assert(what) PERL_DEB( \ ((what) ? ((void) 0) : \ (Perl_croak_nocontext("Assertion %s failed: file \"" __FILE__ \ "\", line %d", STRINGIFY(what), __LINE__), \ (void) 0))) #ifndef assert # define assert(what) Perl_assert(what) #endif struct ufuncs { I32 (*uf_val)(pTHX_ IV, SV*); I32 (*uf_set)(pTHX_ IV, SV*); IV uf_index; }; /* In pre-5.7-Perls the PERL_MAGIC_uvar magic didn't get the thread context. * XS code wanting to be backward compatible can do something * like the following: #ifndef PERL_MG_UFUNC #define PERL_MG_UFUNC(name,ix,sv) I32 name(IV ix, SV *sv) #endif static PERL_MG_UFUNC(foo_get, index, val) { sv_setsv(val, ...); return TRUE; } -- Doug MacEachern */ #ifndef PERL_MG_UFUNC #define PERL_MG_UFUNC(name,ix,sv) I32 name(pTHX_ IV ix, SV *sv) #endif /* Fix these up for __STDC__ */ #ifndef DONT_DECLARE_STD char *mktemp (char*); #ifndef atof double atof (const char*); #endif #endif #ifndef STANDARD_C /* All of these are in stdlib.h or time.h for ANSI C */ Time_t time(); struct tm *gmtime(), *localtime(); #if defined(OEMVS) || defined(__OPEN_VM) char *(strchr)(), *(strrchr)(); char *(strcpy)(), *(strcat)(); #else char *strchr(), *strrchr(); char *strcpy(), *strcat(); #endif #endif /* ! STANDARD_C */ #ifdef I_MATH # include #else START_EXTERN_C double exp (double); double log (double); double log10 (double); double sqrt (double); double frexp (double,int*); double ldexp (double,int); double modf (double,double*); double sin (double); double cos (double); double atan2 (double,double); double pow (double,double); END_EXTERN_C #endif #if !defined(NV_INF) && defined(USE_LONG_DOUBLE) && defined(LDBL_INFINITY) # define NV_INF LDBL_INFINITY #endif #if !defined(NV_INF) && defined(DBL_INFINITY) # define NV_INF (NV)DBL_INFINITY #endif #if !defined(NV_INF) && defined(INFINITY) # define NV_INF (NV)INFINITY #endif #if !defined(NV_INF) && defined(INF) # define NV_INF (NV)INF #endif #if !defined(NV_INF) && defined(USE_LONG_DOUBLE) && defined(HUGE_VALL) # define NV_INF (NV)HUGE_VALL #endif #if !defined(NV_INF) && defined(HUGE_VAL) # define NV_INF (NV)HUGE_VAL #endif #if !defined(NV_NAN) && defined(USE_LONG_DOUBLE) # if !defined(NV_NAN) && defined(LDBL_NAN) # define NV_NAN LDBL_NAN # endif # if !defined(NV_NAN) && defined(LDBL_QNAN) # define NV_NAN LDBL_QNAN # endif # if !defined(NV_NAN) && defined(LDBL_SNAN) # define NV_NAN LDBL_SNAN # endif #endif #if !defined(NV_NAN) && defined(DBL_NAN) # define NV_NAN (NV)DBL_NAN #endif #if !defined(NV_NAN) && defined(DBL_QNAN) # define NV_NAN (NV)DBL_QNAN #endif #if !defined(NV_NAN) && defined(DBL_SNAN) # define NV_NAN (NV)DBL_SNAN #endif #if !defined(NV_NAN) && defined(QNAN) # define NV_NAN (NV)QNAN #endif #if !defined(NV_NAN) && defined(SNAN) # define NV_NAN (NV)SNAN #endif #if !defined(NV_NAN) && defined(NAN) # define NV_NAN (NV)NAN #endif #ifndef __cplusplus # if defined(NeXT) || defined(__NeXT__) /* or whatever catches all NeXTs */ char *crypt (); /* Maybe more hosts will need the unprototyped version */ # else # if !defined(WIN32) && !defined(VMS) #ifndef crypt char *crypt (const char*, const char*); #endif # endif /* !WIN32 */ # endif /* !NeXT && !__NeXT__ */ # ifndef DONT_DECLARE_STD # ifndef getenv char *getenv (const char*); # endif /* !getenv */ # if !defined(HAS_LSEEK_PROTO) && !defined(EPOC) && !defined(__hpux) # ifdef _FILE_OFFSET_BITS # if _FILE_OFFSET_BITS == 64 Off_t lseek (int,Off_t,int); # endif # endif # endif # endif /* !DONT_DECLARE_STD */ #ifndef getlogin char *getlogin (void); #endif #endif /* !__cplusplus */ /* Fixme on VMS. This needs to be a run-time, not build time options */ /* Also rename() is affected by this */ #ifdef UNLINK_ALL_VERSIONS /* Currently only makes sense for VMS */ #define UNLINK unlnk I32 unlnk (pTHX_ const char*); #else #define UNLINK PerlLIO_unlink #endif /* some versions of glibc are missing the setresuid() proto */ #if defined(HAS_SETRESUID) && !defined(HAS_SETRESUID_PROTO) int setresuid(uid_t ruid, uid_t euid, uid_t suid); #endif /* some versions of glibc are missing the setresgid() proto */ #if defined(HAS_SETRESGID) && !defined(HAS_SETRESGID_PROTO) int setresgid(gid_t rgid, gid_t egid, gid_t sgid); #endif #ifndef HAS_SETREUID # ifdef HAS_SETRESUID # define setreuid(r,e) setresuid(r,e,(Uid_t)-1) # define HAS_SETREUID # endif #endif #ifndef HAS_SETREGID # ifdef HAS_SETRESGID # define setregid(r,e) setresgid(r,e,(Gid_t)-1) # define HAS_SETREGID # endif #endif /* Sighandler_t defined in iperlsys.h */ #ifdef HAS_SIGACTION typedef struct sigaction Sigsave_t; #else typedef Sighandler_t Sigsave_t; #endif #define SCAN_DEF 0 #define SCAN_TR 1 #define SCAN_REPL 2 #ifdef DEBUGGING # ifndef register # define register # endif # define RUNOPS_DEFAULT Perl_runops_debug #else # define RUNOPS_DEFAULT Perl_runops_standard #endif #ifdef USE_PERLIO EXTERN_C void PerlIO_teardown(void); # ifdef USE_ITHREADS # define PERLIO_INIT MUTEX_INIT(&PL_perlio_mutex) # define PERLIO_TERM \ STMT_START { \ PerlIO_teardown(); \ MUTEX_DESTROY(&PL_perlio_mutex);\ } STMT_END # else # define PERLIO_INIT # define PERLIO_TERM PerlIO_teardown() # endif #else # define PERLIO_INIT # define PERLIO_TERM #endif #ifdef MYMALLOC # ifdef MUTEX_INIT_CALLS_MALLOC # define MALLOC_INIT \ STMT_START { \ PL_malloc_mutex = NULL; \ MUTEX_INIT(&PL_malloc_mutex); \ } STMT_END # define MALLOC_TERM \ STMT_START { \ perl_mutex tmp = PL_malloc_mutex; \ PL_malloc_mutex = NULL; \ MUTEX_DESTROY(&tmp); \ } STMT_END # else # define MALLOC_INIT MUTEX_INIT(&PL_malloc_mutex) # define MALLOC_TERM MUTEX_DESTROY(&PL_malloc_mutex) # endif #else # define MALLOC_INIT # define MALLOC_TERM #endif #if defined(PERL_IMPLICIT_CONTEXT) struct perl_memory_debug_header; struct perl_memory_debug_header { tTHX interpreter; # ifdef PERL_POISON MEM_SIZE size; # endif struct perl_memory_debug_header *prev; struct perl_memory_debug_header *next; }; # define sTHX (sizeof(struct perl_memory_debug_header) + \ (MEM_ALIGNBYTES - sizeof(struct perl_memory_debug_header) \ %MEM_ALIGNBYTES) % MEM_ALIGNBYTES) #else # define sTHX 0 #endif #ifdef PERL_TRACK_MEMPOOL # define INIT_TRACK_MEMPOOL(header, interp) \ STMT_START { \ (header).interpreter = (interp); \ (header).prev = (header).next = &(header); \ } STMT_END # else # define INIT_TRACK_MEMPOOL(header, interp) #endif #ifdef I_MALLOCMALLOC /* Needed for malloc_size(), malloc_good_size() on some systems */ # include #endif #ifdef MYMALLOC # define Perl_safesysmalloc_size(where) Perl_malloced_size(where) #else # ifdef HAS_MALLOC_SIZE # ifdef PERL_TRACK_MEMPOOL # define Perl_safesysmalloc_size(where) \ (malloc_size(((char *)(where)) - sTHX) - sTHX) # else # define Perl_safesysmalloc_size(where) malloc_size(where) # endif # endif # ifdef HAS_MALLOC_GOOD_SIZE # ifdef PERL_TRACK_MEMPOOL # define Perl_malloc_good_size(how_much) \ (malloc_good_size((how_much) + sTHX) - sTHX) # else # define Perl_malloc_good_size(how_much) malloc_good_size(how_much) # endif # else /* Having this as the identity operation makes some code simpler. */ # define Perl_malloc_good_size(how_much) (how_much) # endif #endif typedef int (CPERLscope(*runops_proc_t)) (pTHX); typedef void (CPERLscope(*share_proc_t)) (pTHX_ SV *sv); typedef int (CPERLscope(*thrhook_proc_t)) (pTHX); typedef OP* (CPERLscope(*PPADDR_t)[]) (pTHX); typedef bool (CPERLscope(*destroyable_proc_t)) (pTHX_ SV *sv); /* _ (for $_) must be first in the following list (DEFSV requires it) */ #define THREADSV_NAMES "_123456789&`'+/.,\\\";^-%=|~:\001\005!@" /* NeXT has problems with crt0.o globals */ #if defined(__DYNAMIC__) && \ (defined(NeXT) || defined(__NeXT__) || defined(PERL_DARWIN)) # if defined(NeXT) || defined(__NeXT) # include # define environ (*environ_pointer) EXT char *** environ_pointer; # else # if defined(PERL_DARWIN) && defined(PERL_CORE) # include /* for the env array */ # define environ (*_NSGetEnviron()) # endif # endif #else /* VMS and some other platforms don't use the environ array */ # ifdef USE_ENVIRON_ARRAY # if !defined(DONT_DECLARE_STD) || \ (defined(__svr4__) && defined(__GNUC__) && defined(sun)) || \ defined(__sgi) || \ defined(__DGUX) extern char ** environ; /* environment variables supplied via exec */ # endif # endif #endif START_EXTERN_C /* handy constants */ EXTCONST char PL_warn_uninit[] INIT("Use of uninitialized value%s%s%s"); EXTCONST char PL_warn_nosemi[] INIT("Semicolon seems to be missing"); EXTCONST char PL_warn_reserved[] INIT("Unquoted string \"%s\" may clash with future reserved word"); EXTCONST char PL_warn_nl[] INIT("Unsuccessful %s on filename containing newline"); EXTCONST char PL_no_wrongref[] INIT("Can't use %s ref as %s ref"); /* The core no longer needs these here. If you require the string constant, please inline a copy into your own code. */ EXTCONST char PL_no_symref[] __attribute__deprecated__ INIT("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use"); EXTCONST char PL_no_symref_sv[] __attribute__deprecated__ INIT("Can't use string (\"%" SVf32 "\") as %s ref while \"strict refs\" in use"); EXTCONST char PL_no_usym[] INIT("Can't use an undefined value as %s reference"); EXTCONST char PL_no_aelem[] INIT("Modification of non-creatable array value attempted, subscript %d"); EXTCONST char PL_no_helem_sv[] INIT("Modification of non-creatable hash value attempted, subscript \"%"SVf"\""); EXTCONST char PL_no_modify[] INIT("Modification of a read-only value attempted"); EXTCONST char PL_no_mem[] INIT("Out of memory!\n"); EXTCONST char PL_no_security[] INIT("Insecure dependency in %s%s"); EXTCONST char PL_no_sock_func[] INIT("Unsupported socket function \"%s\" called"); EXTCONST char PL_no_dir_func[] INIT("Unsupported directory function \"%s\" called"); EXTCONST char PL_no_func[] INIT("The %s function is unimplemented"); EXTCONST char PL_no_myglob[] INIT("\"%s\" variable %s can't be in a package"); EXTCONST char PL_no_localize_ref[] INIT("Can't localize through a reference"); EXTCONST char PL_memory_wrap[] INIT("panic: memory wrap"); #ifdef CSH EXTCONST char PL_cshname[] INIT(CSH); # define PL_cshlen (sizeof(CSH "") - 1) #endif EXTCONST char PL_uuemap[65] INIT("`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_"); #ifdef DOINIT EXTCONST char PL_uudmap[256] = #include "uudmap.h" ; EXTCONST char PL_bitcount[256] = # include "bitcount.h" ; EXTCONST char* const PL_sig_name[] = { SIG_NAME }; EXTCONST int PL_sig_num[] = { SIG_NUM }; #else EXTCONST char PL_uudmap[256]; EXTCONST char PL_bitcount[256]; EXTCONST char* const PL_sig_name[]; EXTCONST int PL_sig_num[]; #endif /* fast conversion and case folding tables */ #ifdef DOINIT #ifdef EBCDIC EXTCONST unsigned char PL_fold[] = { /* fast EBCDIC case folding table */ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 123, 124, 125, 126, 127, 128, 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 138, 139, 140, 141, 142, 143, 144, 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 154, 155, 156, 157, 158, 159, 160, 161, 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', 170, 171, 172, 173, 174, 175, 176, 177, 178, 179, 180, 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, 191, 192, 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 202, 203, 204, 205, 206, 207, 208, 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 218, 219, 220, 221, 222, 223, 224, 225, 's', 't', 'u', 'v', 'w', 'x', 'y', 'z', 234, 235, 236, 237, 238, 239, 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 255 }; #else /* ascii rather than ebcdic */ EXTCONST unsigned char PL_fold[] = { 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z', 91, 92, 93, 94, 95, 96, 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', 123, 124, 125, 126, 127, 128, 129, 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, 168, 169, 170, 171, 172, 173, 174, 175, 176, 177, 178, 179, 180, 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 208, 209, 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, 221, 222, 223, 224, 225, 226, 227, 228, 229, 230, 231, 232, 233, 234, 235, 236, 237, 238, 239, 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 255 }; #endif /* !EBCDIC, but still in DOINIT */ /* If these tables are accessed through ebcdic, the access will be converted to * latin1 first */ EXTCONST unsigned char PL_latin1_lc[] = { /* lowercasing */ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z', 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 123, 124, 125, 126, 127, 128, 129, 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, 168, 169, 170, 171, 172, 173, 174, 175, 176, 177, 178, 179, 180, 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, 191, 192+32, 193+32, 194+32, 195+32, 196+32, 197+32, 198+32, 199+32, 200+32, 201+32, 202+32, 203+32, 204+32, 205+32, 206+32, 207+32, 208+32, 209+32, 210+32, 211+32, 212+32, 213+32, 214+32, 215, 216+32, 217+32, 218+32, 219+32, 220+32, 221+32, 222+32, 223, 224, 225, 226, 227, 228, 229, 230, 231, 232, 233, 234, 235, 236, 237, 238, 239, 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 255 }; /* upper and title case of latin1 characters, modified so that the three tricky * ones are mapped to 255 (which is one of the three) */ EXTCONST unsigned char PL_mod_latin1_uc[] = { 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', 123, 124, 125, 126, 127, 128, 129, 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, 168, 169, 170, 171, 172, 173, 174, 175, 176, 177, 178, 179, 180, 255 /*micro*/, 182, 183, 184, 185, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 208, 209, 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, 221, 222, 255 /*sharp s*/, 224-32, 225-32, 226-32, 227-32, 228-32, 229-32, 230-32, 231-32, 232-32, 233-32, 234-32, 235-32, 236-32, 237-32, 238-32, 239-32, 240-32, 241-32, 242-32, 243-32, 244-32, 245-32, 246-32, 247, 248-32, 249-32, 250-32, 251-32, 252-32, 253-32, 254-32, 255 }; #else /* ! DOINIT */ EXTCONST unsigned char PL_fold[]; EXTCONST unsigned char PL_mod_latin1_uc[]; EXTCONST unsigned char PL_latin1_lc[]; #endif #ifndef PERL_GLOBAL_STRUCT /* or perlvars.h */ #ifdef DOINIT EXT unsigned char PL_fold_locale[] = { /* Unfortunately not EXTCONST. */ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z', 91, 92, 93, 94, 95, 96, 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', 123, 124, 125, 126, 127, 128, 129, 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, 168, 169, 170, 171, 172, 173, 174, 175, 176, 177, 178, 179, 180, 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 208, 209, 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, 221, 222, 223, 224, 225, 226, 227, 228, 229, 230, 231, 232, 233, 234, 235, 236, 237, 238, 239, 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 255 }; #else EXT unsigned char PL_fold_locale[]; /* Unfortunately not EXTCONST. */ #endif #endif /* !PERL_GLOBAL_STRUCT */ #ifdef DOINIT #ifdef EBCDIC EXTCONST unsigned char PL_freq[] = {/* EBCDIC frequencies for mixed English/C */ 1, 2, 84, 151, 154, 155, 156, 157, 165, 246, 250, 3, 158, 7, 18, 29, 40, 51, 62, 73, 85, 96, 107, 118, 129, 140, 147, 148, 149, 150, 152, 153, 255, 6, 8, 9, 10, 11, 12, 13, 14, 15, 24, 25, 26, 27, 28, 226, 29, 30, 31, 32, 33, 43, 44, 45, 46, 47, 48, 49, 50, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 94, 95, 234, 181, 233, 187, 190, 180, 96, 97, 98, 99, 100, 101, 102, 104, 112, 182, 174, 236, 232, 229, 103, 228, 226, 114, 115, 116, 117, 118, 119, 120, 121, 122, 235, 176, 230, 194, 162, 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 201, 205, 163, 217, 220, 224, 5, 248, 227, 244, 242, 255, 241, 231, 240, 253, 16, 197, 19, 20, 21, 187, 23, 169, 210, 245, 237, 249, 247, 239, 168, 252, 34, 196, 36, 37, 38, 39, 41, 42, 251, 254, 238, 223, 221, 213, 225, 177, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 74, 75, 205, 208, 186, 202, 200, 218, 198, 179, 178, 214, 88, 89, 90, 91, 92, 93, 217, 166, 170, 207, 199, 209, 206, 204, 160, 212, 105, 106, 108, 109, 110, 111, 203, 113, 216, 215, 192, 175, 193, 243, 172, 161, 123, 124, 125, 126, 127, 128, 222, 219, 211, 195, 188, 193, 185, 184, 191, 183, 141, 142, 143, 144, 145, 146 }; #else /* ascii rather than ebcdic */ EXTCONST unsigned char PL_freq[] = { /* letter frequencies for mixed English/C */ 1, 2, 84, 151, 154, 155, 156, 157, 165, 246, 250, 3, 158, 7, 18, 29, 40, 51, 62, 73, 85, 96, 107, 118, 129, 140, 147, 148, 149, 150, 152, 153, 255, 182, 224, 205, 174, 176, 180, 217, 233, 232, 236, 187, 235, 228, 234, 226, 222, 219, 211, 195, 188, 193, 185, 184, 191, 183, 201, 229, 181, 220, 194, 162, 163, 208, 186, 202, 200, 218, 198, 179, 178, 214, 166, 170, 207, 199, 209, 206, 204, 160, 212, 216, 215, 192, 175, 173, 243, 172, 161, 190, 203, 189, 164, 230, 167, 248, 227, 244, 242, 255, 241, 231, 240, 253, 169, 210, 245, 237, 249, 247, 239, 168, 252, 251, 254, 238, 223, 221, 213, 225, 177, 197, 171, 196, 159, 4, 5, 6, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 108, 109, 110, 111, 112, 113, 114, 115, 116, 117, 119, 120, 121, 122, 123, 124, 125, 126, 127, 128, 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 141, 142, 143, 144, 145, 146 }; #endif #else EXTCONST unsigned char PL_freq[]; #endif #ifdef DEBUGGING #ifdef DOINIT EXTCONST char* const PL_block_type[] = { "NULL", "WHEN", "BLOCK", "GIVEN", "LOOP_FOR", "LOOP_PLAIN", "LOOP_LAZYSV", "LOOP_LAZYIV", "SUB", "FORMAT", "EVAL", "SUBST" }; #else EXTCONST char* PL_block_type[]; #endif #endif /* These are all the compile time options that affect binary compatibility. Other compile time options that are binary compatible are in perl.c Both are combined for the output of perl -V However, this string will be embedded in any shared perl library, which will allow us add a comparison check in perlmain.c in the near future. */ #ifdef DOINIT EXTCONST char PL_bincompat_options[] = # ifdef DEBUG_LEAKING_SCALARS " DEBUG_LEAKING_SCALARS" # endif # ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP " DEBUG_LEAKING_SCALARS_FORK_DUMP" # endif # ifdef FAKE_THREADS " FAKE_THREADS" # endif # ifdef MULTIPLICITY " MULTIPLICITY" # endif # ifdef MYMALLOC " MYMALLOC" # endif # ifdef PERL_DEBUG_READONLY_OPS " PERL_DEBUG_READONLY_OPS" # endif # ifdef PERL_GLOBAL_STRUCT " PERL_GLOBAL_STRUCT" # endif # ifdef PERL_IMPLICIT_CONTEXT " PERL_IMPLICIT_CONTEXT" # endif # ifdef PERL_IMPLICIT_SYS " PERL_IMPLICIT_SYS" # endif # ifdef PERL_MAD " PERL_MAD" # endif # ifdef PERL_NEED_APPCTX " PERL_NEED_APPCTX" # endif # ifdef PERL_NEED_TIMESBASE " PERL_NEED_TIMESBASE" # endif # ifdef PERL_OLD_COPY_ON_WRITE " PERL_OLD_COPY_ON_WRITE" # endif # ifdef PERL_POISON " PERL_POISON" # endif # ifdef PERL_TRACK_MEMPOOL " PERL_TRACK_MEMPOOL" # endif # ifdef PERL_USES_PL_PIDSTATUS " PERL_USES_PL_PIDSTATUS" # endif # ifdef PL_OP_SLAB_ALLOC " PL_OP_SLAB_ALLOC" # endif # ifdef THREADS_HAVE_PIDS " THREADS_HAVE_PIDS" # endif # ifdef USE_64_BIT_ALL " USE_64_BIT_ALL" # endif # ifdef USE_64_BIT_INT " USE_64_BIT_INT" # endif # ifdef USE_IEEE " USE_IEEE" # endif # ifdef USE_ITHREADS " USE_ITHREADS" # endif # ifdef USE_LARGE_FILES " USE_LARGE_FILES" # endif # ifdef USE_LONG_DOUBLE " USE_LONG_DOUBLE" # endif # ifdef USE_PERLIO " USE_PERLIO" # endif # ifdef USE_REENTRANT_API " USE_REENTRANT_API" # endif # ifdef USE_SFIO " USE_SFIO" # endif # ifdef USE_SOCKS " USE_SOCKS" # endif # ifdef VMS_DO_SOCKETS " VMS_DO_SOCKETS" # ifdef DECCRTL_SOCKETS " DECCRTL_SOCKETS" # endif # endif # ifdef VMS_WE_ARE_CASE_SENSITIVE " VMS_SYMBOL_CASE_AS_IS" # endif ""; #else EXTCONST char PL_bincompat_options[]; #endif END_EXTERN_C /*****************************************************************************/ /* This lexer/parser stuff is currently global since yacc is hard to reenter */ /*****************************************************************************/ /* XXX This needs to be revisited, since BEGIN makes yacc re-enter... */ #ifdef __Lynx__ /* LynxOS defines these in scsi.h which is included via ioctl.h */ #ifdef FORMAT #undef FORMAT #endif #ifdef SPACE #undef SPACE #endif #endif #define LEX_NOTPARSING 11 /* borrowed from toke.c */ typedef enum { XOPERATOR, XTERM, XREF, XSTATE, XBLOCK, XATTRBLOCK, XATTRTERM, XTERMBLOCK, XTERMORDORDOR /* evil hack */ /* update exp_name[] in toke.c if adding to this enum */ } expectation; enum { /* pass one of these to get_vtbl */ want_vtbl_sv, want_vtbl_env, want_vtbl_envelem, want_vtbl_sig, want_vtbl_sigelem, want_vtbl_pack, want_vtbl_packelem, want_vtbl_dbline, want_vtbl_isa, want_vtbl_isaelem, want_vtbl_arylen, want_vtbl_glob, want_vtbl_mglob, want_vtbl_nkeys, want_vtbl_taint, want_vtbl_substr, want_vtbl_vec, want_vtbl_pos, want_vtbl_bm, want_vtbl_fm, want_vtbl_uvar, want_vtbl_defelem, want_vtbl_regexp, want_vtbl_collxfrm, want_vtbl_amagic, want_vtbl_amagicelem, want_vtbl_regdata, want_vtbl_regdatum, want_vtbl_backref, want_vtbl_utf8, want_vtbl_symtab, want_vtbl_arylen_p, want_vtbl_hintselem, want_vtbl_hints }; /* Hints are now stored in a dedicated U32, so the bottom 8 bits are no longer special and there is no need for HINT_PRIVATE_MASK for COPs However, bitops store HINT_INTEGER in their op_private. */ #define HINT_INTEGER 0x00000001 /* integer pragma */ #define HINT_STRICT_REFS 0x00000002 /* strict pragma */ #define HINT_LOCALE 0x00000004 /* locale pragma */ #define HINT_BYTES 0x00000008 /* bytes pragma */ #define HINT_ARYBASE 0x00000010 /* $[ is non-zero */ /* Note: 20,40,80 used for NATIVE_HINTS */ /* currently defined by vms/vmsish.h */ #define HINT_BLOCK_SCOPE 0x00000100 #define HINT_STRICT_SUBS 0x00000200 /* strict pragma */ #define HINT_STRICT_VARS 0x00000400 /* strict pragma */ #define HINT_UNI_8_BIT 0x00000800 /* unicode_strings feature */ /* The HINT_NEW_* constants are used by the overload pragma */ #define HINT_NEW_INTEGER 0x00001000 #define HINT_NEW_FLOAT 0x00002000 #define HINT_NEW_BINARY 0x00004000 #define HINT_NEW_STRING 0x00008000 #define HINT_NEW_RE 0x00010000 #define HINT_LOCALIZE_HH 0x00020000 /* %^H needs to be copied */ #define HINT_LEXICAL_IO_IN 0x00040000 /* ${^OPEN} is set for input */ #define HINT_LEXICAL_IO_OUT 0x00080000 /* ${^OPEN} is set for output */ #define HINT_RE_TAINT 0x00100000 /* re pragma */ #define HINT_RE_EVAL 0x00200000 /* re pragma */ #define HINT_FILETEST_ACCESS 0x00400000 /* filetest pragma */ #define HINT_UTF8 0x00800000 /* utf8 pragma */ #define HINT_NO_AMAGIC 0x01000000 /* overloading pragma */ /* The following are stored in $^H{sort}, not in PL_hints */ #define HINT_SORT_SORT_BITS 0x000000FF /* allow 256 different ones */ #define HINT_SORT_QUICKSORT 0x00000001 #define HINT_SORT_MERGESORT 0x00000002 #define HINT_SORT_STABLE 0x00000100 /* sort styles (currently one) */ /* Various states of the input record separator SV (rs) */ #define RsSNARF(sv) (! SvOK(sv)) #define RsSIMPLE(sv) (SvOK(sv) && (! SvPOK(sv) || SvCUR(sv))) #define RsPARA(sv) (SvPOK(sv) && ! SvCUR(sv)) #define RsRECORD(sv) (SvROK(sv) && (SvIV(SvRV(sv)) > 0)) /* A struct for keeping various DEBUGGING related stuff, * neatly packed. Currently only scratch variables for * constructing debug output are included. Needed always, * not just when DEBUGGING, though, because of the re extension. c*/ struct perl_debug_pad { SV pad[3]; }; #define PERL_DEBUG_PAD(i) &(PL_debug_pad.pad[i]) #define PERL_DEBUG_PAD_ZERO(i) (SvPVX(PERL_DEBUG_PAD(i))[0] = 0, \ (((XPV*) SvANY(PERL_DEBUG_PAD(i)))->xpv_cur = 0), \ PERL_DEBUG_PAD(i)) /* Enable variables which are pointers to functions */ typedef void (CPERLscope(*peep_t))(pTHX_ OP* o); typedef regexp*(CPERLscope(*regcomp_t)) (pTHX_ char* exp, char* xend, PMOP* pm); typedef I32 (CPERLscope(*regexec_t)) (pTHX_ regexp* prog, char* stringarg, char* strend, char* strbeg, I32 minend, SV* screamer, void* data, U32 flags); typedef char* (CPERLscope(*re_intuit_start_t)) (pTHX_ regexp *prog, SV *sv, char *strpos, char *strend, U32 flags, re_scream_pos_data *d); typedef SV* (CPERLscope(*re_intuit_string_t)) (pTHX_ regexp *prog); typedef void (CPERLscope(*regfree_t)) (pTHX_ struct regexp* r); typedef regexp*(CPERLscope(*regdupe_t)) (pTHX_ const regexp* r, CLONE_PARAMS *param); typedef void (*DESTRUCTORFUNC_NOCONTEXT_t) (void*); typedef void (*DESTRUCTORFUNC_t) (pTHX_ void*); typedef void (*SVFUNC_t) (pTHX_ SV* const); typedef I32 (*SVCOMPARE_t) (pTHX_ SV* const, SV* const); typedef void (*XSINIT_t) (pTHX); typedef void (*ATEXIT_t) (pTHX_ void*); typedef void (*XSUBADDR_t) (pTHX_ CV *); /* Set up PERLVAR macros for populating structs */ #define PERLVAR(var,type) type var; #define PERLVARA(var,n,type) type var[n]; #define PERLVARI(var,type,init) type var; #define PERLVARIC(var,type,init) type var; #define PERLVARISC(var,init) const char var[sizeof(init)]; typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX); typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*); typedef void(CPERLscope(*Perl_ophook_t))(pTHX_ OP*); typedef int (CPERLscope(*Perl_keyword_plugin_t))(pTHX_ char*, STRLEN, OP**); #define KEYWORD_PLUGIN_DECLINE 0 #define KEYWORD_PLUGIN_STMT 1 #define KEYWORD_PLUGIN_EXPR 2 /* Interpreter exitlist entry */ typedef struct exitlistentry { void (*fn) (pTHX_ void*); void *ptr; } PerlExitListEntry; /* if you only have signal() and it resets on each signal, FAKE_PERSISTENT_SIGNAL_HANDLERS fixes */ /* These have to be before perlvars.h */ #if !defined(HAS_SIGACTION) && defined(VMS) # define FAKE_PERSISTENT_SIGNAL_HANDLERS #endif /* if we're doing kill() with sys$sigprc on VMS, FAKE_DEFAULT_SIGNAL_HANDLERS */ #if defined(KILL_BY_SIGPRC) # define FAKE_DEFAULT_SIGNAL_HANDLERS #endif #define PERL_PATCHLEVEL_H_IMPLICIT #include "patchlevel.h" #undef PERL_PATCHLEVEL_H_IMPLICIT #define PERL_VERSION_STRING STRINGIFY(PERL_REVISION) "." \ STRINGIFY(PERL_VERSION) "." \ STRINGIFY(PERL_SUBVERSION) #ifdef PERL_GLOBAL_STRUCT struct perl_vars { # include "perlvars.h" }; # ifdef PERL_CORE # ifndef PERL_GLOBAL_STRUCT_PRIVATE EXT struct perl_vars PL_Vars; EXT struct perl_vars *PL_VarsPtr INIT(&PL_Vars); # undef PERL_GET_VARS # define PERL_GET_VARS() PL_VarsPtr # endif /* !PERL_GLOBAL_STRUCT_PRIVATE */ # else /* PERL_CORE */ # if !defined(__GNUC__) || !defined(WIN32) EXT # endif /* WIN32 */ struct perl_vars *PL_VarsPtr; # define PL_Vars (*((PL_VarsPtr) \ ? PL_VarsPtr : (PL_VarsPtr = Perl_GetVars(aTHX)))) # endif /* PERL_CORE */ #endif /* PERL_GLOBAL_STRUCT */ #if defined(MULTIPLICITY) /* If we have multiple interpreters define a struct holding variables which must be per-interpreter If we don't have threads anything that would have be per-thread is per-interpreter. */ struct interpreter { # include "intrpvar.h" }; #else struct interpreter { char broiled; }; #endif /* MULTIPLICITY */ /* Done with PERLVAR macros for now ... */ #undef PERLVAR #undef PERLVARA #undef PERLVARI #undef PERLVARIC #undef PERLVARISC struct tempsym; /* defined in pp_pack.c */ #include "thread.h" #include "pp.h" #ifndef PERL_CALLCONV # ifdef __cplusplus # define PERL_CALLCONV extern "C" # else # define PERL_CALLCONV # endif #endif #undef PERL_CKDEF #undef PERL_PPDEF #define PERL_CKDEF(s) PERL_CALLCONV OP *s (pTHX_ OP *o); #define PERL_PPDEF(s) PERL_CALLCONV OP *s (pTHX); #include "proto.h" /* this has structure inits, so it cannot be included before here */ #include "opcode.h" /* The following must follow proto.h as #defines mess up syntax */ #if !defined(PERL_FOR_X2P) # include "embedvar.h" #endif #ifndef PERL_MAD # undef PL_madskills # undef PL_xmlfp # define PL_madskills 0 # define PL_xmlfp 0 #endif /* Now include all the 'global' variables * If we don't have threads or multiple interpreters * these include variables that would have been their struct-s */ #define PERLVAR(var,type) EXT type PL_##var; #define PERLVARA(var,n,type) EXT type PL_##var[n]; #define PERLVARI(var,type,init) EXT type PL_##var INIT(init); #define PERLVARIC(var,type,init) EXTCONST type PL_##var INIT(init); #define PERLVARISC(var,init) EXTCONST char PL_##var[sizeof(init)] INIT(init); #if !defined(MULTIPLICITY) START_EXTERN_C # include "intrpvar.h" END_EXTERN_C #endif #ifdef PERL_CORE /* All core uses now exterminated. Ensure no zombies can return: */ # undef PL_na #endif #if defined(WIN32) /* Now all the config stuff is setup we can include embed.h */ # include "embed.h" # ifndef PERL_MAD # undef op_getmad # define op_getmad(arg,pegop,slot) NOOP # endif #endif #ifndef PERL_GLOBAL_STRUCT START_EXTERN_C # include "perlvars.h" END_EXTERN_C #endif #undef PERLVAR #undef PERLVARA #undef PERLVARI #undef PERLVARIC START_EXTERN_C /* PERL_GLOBAL_STRUCT_PRIVATE wants to keep global data like the * magic vtables const, but this is incompatible with SWIG which * does want to modify the vtables. */ #ifdef PERL_GLOBAL_STRUCT_PRIVATE # define EXT_MGVTBL EXTCONST MGVTBL #else # define EXT_MGVTBL EXT MGVTBL #endif #ifdef DOINIT # define MGVTBL_SET(var,a,b,c,d,e,f,g,h) EXT_MGVTBL var = {a,b,c,d,e,f,g,h} /* Like MGVTBL_SET but with the get magic having a const MG* */ # define MGVTBL_SET_CONST_MAGIC_GET(var,a,b,c,d,e,f,g,h) EXT_MGVTBL var \ = {(int (*)(pTHX_ SV *, MAGIC *))a,b,c,d,e,f,g,h} #else # define MGVTBL_SET(var,a,b,c,d,e,f,g,h) EXT_MGVTBL var # define MGVTBL_SET_CONST_MAGIC_GET(var,a,b,c,d,e,f,g,h) EXT_MGVTBL var #endif /* These all need to be 0, not NULL, as NULL can be (void*)0, which is a * pointer to data, whereas we're assigning pointers to functions, which are * not the same beast. ANSI doesn't allow the assignment from one to the other. * (although most, but not all, compilers are prepared to do it) */ MGVTBL_SET( PL_vtbl_sv, MEMBER_TO_FPTR(Perl_magic_get), MEMBER_TO_FPTR(Perl_magic_set), MEMBER_TO_FPTR(Perl_magic_len), 0, 0, 0, 0, 0 ); MGVTBL_SET( PL_vtbl_env, 0, MEMBER_TO_FPTR(Perl_magic_set_all_env), 0, MEMBER_TO_FPTR(Perl_magic_clear_all_env), 0, 0, 0, 0 ); MGVTBL_SET( PL_vtbl_envelem, 0, MEMBER_TO_FPTR(Perl_magic_setenv), 0, MEMBER_TO_FPTR(Perl_magic_clearenv), 0, 0, 0, 0 ); MGVTBL_SET( PL_vtbl_sig, 0, 0, 0, 0, 0, 0, 0, 0 ); #ifdef PERL_MICRO MGVTBL_SET( PL_vtbl_sigelem, 0, 0, 0, 0, 0, 0, 0, 0 ); #else MGVTBL_SET( PL_vtbl_sigelem, MEMBER_TO_FPTR(Perl_magic_getsig), MEMBER_TO_FPTR(Perl_magic_setsig), 0, MEMBER_TO_FPTR(Perl_magic_clearsig), 0, 0, 0, 0 ); #endif MGVTBL_SET( PL_vtbl_pack, 0, 0, MEMBER_TO_FPTR(Perl_magic_sizepack), MEMBER_TO_FPTR(Perl_magic_wipepack), 0, 0, 0, 0 ); MGVTBL_SET( PL_vtbl_packelem, MEMBER_TO_FPTR(Perl_magic_getpack), MEMBER_TO_FPTR(Perl_magic_setpack), 0, MEMBER_TO_FPTR(Perl_magic_clearpack), 0, 0, 0, 0 ); MGVTBL_SET( PL_vtbl_dbline, 0, MEMBER_TO_FPTR(Perl_magic_setdbline), 0, 0, 0, 0, 0, 0 ); MGVTBL_SET( PL_vtbl_isa, 0, MEMBER_TO_FPTR(Perl_magic_setisa), 0, MEMBER_TO_FPTR(Perl_magic_clearisa), 0, 0, 0, 0 ); MGVTBL_SET( PL_vtbl_isaelem, 0, MEMBER_TO_FPTR(Perl_magic_setisa), 0, 0, 0, 0, 0, 0 ); MGVTBL_SET_CONST_MAGIC_GET( PL_vtbl_arylen, MEMBER_TO_FPTR(Perl_magic_getarylen), MEMBER_TO_FPTR(Perl_magic_setarylen), 0, 0, 0, 0, 0, 0 ); MGVTBL_SET( PL_vtbl_arylen_p, 0, 0, 0, 0, MEMBER_TO_FPTR(Perl_magic_freearylen_p), 0, 0, 0 ); MGVTBL_SET( PL_vtbl_mglob, 0, MEMBER_TO_FPTR(Perl_magic_setmglob), 0, 0, 0, 0, 0, 0 ); MGVTBL_SET( PL_vtbl_nkeys, MEMBER_TO_FPTR(Perl_magic_getnkeys), MEMBER_TO_FPTR(Perl_magic_setnkeys), 0, 0, 0, 0, 0, 0 ); MGVTBL_SET( PL_vtbl_taint, MEMBER_TO_FPTR(Perl_magic_gettaint), MEMBER_TO_FPTR(Perl_magic_settaint), 0, 0, 0, 0, 0, 0 ); MGVTBL_SET( PL_vtbl_substr, MEMBER_TO_FPTR(Perl_magic_getsubstr), MEMBER_TO_FPTR(Perl_magic_setsubstr), 0, 0, 0, 0, 0, 0 ); MGVTBL_SET( PL_vtbl_vec, MEMBER_TO_FPTR(Perl_magic_getvec), MEMBER_TO_FPTR(Perl_magic_setvec), 0, 0, 0, 0, 0, 0 ); MGVTBL_SET( PL_vtbl_pos, MEMBER_TO_FPTR(Perl_magic_getpos), MEMBER_TO_FPTR(Perl_magic_setpos), 0, 0, 0, 0, 0, 0 ); MGVTBL_SET( PL_vtbl_bm, 0, MEMBER_TO_FPTR(Perl_magic_setregexp), 0, 0, 0, 0, 0, 0 ); MGVTBL_SET( PL_vtbl_fm, 0, MEMBER_TO_FPTR(Perl_magic_setregexp), 0, 0, 0, 0, 0, 0 ); MGVTBL_SET( PL_vtbl_uvar, MEMBER_TO_FPTR(Perl_magic_getuvar), MEMBER_TO_FPTR(Perl_magic_setuvar), 0, 0, 0, 0, 0, 0 ); MGVTBL_SET( PL_vtbl_defelem, MEMBER_TO_FPTR(Perl_magic_getdefelem), MEMBER_TO_FPTR(Perl_magic_setdefelem), 0, 0, 0, 0, 0, 0 ); MGVTBL_SET( PL_vtbl_regexp, 0, MEMBER_TO_FPTR(Perl_magic_setregexp), 0, 0, 0, 0, 0, 0 ); MGVTBL_SET( PL_vtbl_regdata, 0, 0, MEMBER_TO_FPTR(Perl_magic_regdata_cnt), 0, 0, 0, 0, 0 ); MGVTBL_SET( PL_vtbl_regdatum, MEMBER_TO_FPTR(Perl_magic_regdatum_get), MEMBER_TO_FPTR(Perl_magic_regdatum_set), 0, 0, 0, 0, 0, 0 ); MGVTBL_SET( PL_vtbl_amagic, 0, MEMBER_TO_FPTR(Perl_magic_setamagic), 0, 0, MEMBER_TO_FPTR(Perl_magic_setamagic), 0, 0, 0 ); MGVTBL_SET( PL_vtbl_amagicelem, 0, MEMBER_TO_FPTR(Perl_magic_setamagic), 0, 0, MEMBER_TO_FPTR(Perl_magic_setamagic), 0, 0, 0 ); MGVTBL_SET( PL_vtbl_backref, 0, 0, 0, 0, MEMBER_TO_FPTR(Perl_magic_killbackrefs), 0, 0, 0 ); MGVTBL_SET( PL_vtbl_ovrld, 0, 0, 0, 0, MEMBER_TO_FPTR(Perl_magic_freeovrld), 0, 0, 0 ); MGVTBL_SET( PL_vtbl_utf8, 0, MEMBER_TO_FPTR(Perl_magic_setutf8), 0, 0, 0, 0, 0, 0 ); #ifdef USE_LOCALE_COLLATE MGVTBL_SET( PL_vtbl_collxfrm, 0, MEMBER_TO_FPTR(Perl_magic_setcollxfrm), 0, 0, 0, 0, 0, 0 ); #endif MGVTBL_SET( PL_vtbl_hintselem, 0, MEMBER_TO_FPTR(Perl_magic_sethint), 0, MEMBER_TO_FPTR(Perl_magic_clearhint), 0, 0, 0, 0 ); MGVTBL_SET( PL_vtbl_hints, 0, 0, 0, MEMBER_TO_FPTR(Perl_magic_clearhints), 0, 0, 0, 0 ); #include "overload.h" END_EXTERN_C struct am_table { U32 flags; U32 was_ok_sub; long was_ok_am; long fallback; CV* table[NofAMmeth]; }; struct am_table_short { U32 flags; U32 was_ok_sub; long was_ok_am; }; typedef struct am_table AMT; typedef struct am_table_short AMTS; #define AMGfallNEVER 1 #define AMGfallNO 2 #define AMGfallYES 3 #define AMTf_AMAGIC 1 #define AMTf_OVERLOADED 2 #define AMT_AMAGIC(amt) ((amt)->flags & AMTf_AMAGIC) #define AMT_AMAGIC_on(amt) ((amt)->flags |= AMTf_AMAGIC) #define AMT_AMAGIC_off(amt) ((amt)->flags &= ~AMTf_AMAGIC) #define AMT_OVERLOADED(amt) ((amt)->flags & AMTf_OVERLOADED) #define AMT_OVERLOADED_on(amt) ((amt)->flags |= AMTf_OVERLOADED) #define AMT_OVERLOADED_off(amt) ((amt)->flags &= ~AMTf_OVERLOADED) #define StashHANDLER(stash,meth) gv_handler((stash),CAT2(meth,_amg)) /* * some compilers like to redefine cos et alia as faster * (and less accurate?) versions called F_cos et cetera (Quidquid * latine dictum sit, altum viditur.) This trick collides with * the Perl overloading (amg). The following #defines fool both. */ #ifdef _FASTMATH # ifdef atan2 # define F_atan2_amg atan2_amg # endif # ifdef cos # define F_cos_amg cos_amg # endif # ifdef exp # define F_exp_amg exp_amg # endif # ifdef log # define F_log_amg log_amg # endif # ifdef pow # define F_pow_amg pow_amg # endif # ifdef sin # define F_sin_amg sin_amg # endif # ifdef sqrt # define F_sqrt_amg sqrt_amg # endif #endif /* _FASTMATH */ #define PERLDB_ALL (PERLDBf_SUB | PERLDBf_LINE | \ PERLDBf_NOOPT | PERLDBf_INTER | \ PERLDBf_SUBLINE| PERLDBf_SINGLE| \ PERLDBf_NAMEEVAL| PERLDBf_NAMEANON | \ PERLDBf_SAVESRC) /* No _NONAME, _GOTO */ #define PERLDBf_SUB 0x01 /* Debug sub enter/exit */ #define PERLDBf_LINE 0x02 /* Keep line # */ #define PERLDBf_NOOPT 0x04 /* Switch off optimizations */ #define PERLDBf_INTER 0x08 /* Preserve more data for later inspections */ #define PERLDBf_SUBLINE 0x10 /* Keep subr source lines */ #define PERLDBf_SINGLE 0x20 /* Start with single-step on */ #define PERLDBf_NONAME 0x40 /* For _SUB: no name of the subr */ #define PERLDBf_GOTO 0x80 /* Report goto: call DB::goto */ #define PERLDBf_NAMEEVAL 0x100 /* Informative names for evals */ #define PERLDBf_NAMEANON 0x200 /* Informative names for anon subs */ #define PERLDBf_SAVESRC 0x400 /* Save source lines into @{"_<$filename"} */ #define PERLDBf_SAVESRC_NOSUBS 0x800 /* Including evals that generate no subrouties */ #define PERLDBf_SAVESRC_INVALID 0x1000 /* Save source that did not compile */ #define PERLDB_SUB (PL_perldb && (PL_perldb & PERLDBf_SUB)) #define PERLDB_LINE (PL_perldb && (PL_perldb & PERLDBf_LINE)) #define PERLDB_NOOPT (PL_perldb && (PL_perldb & PERLDBf_NOOPT)) #define PERLDB_INTER (PL_perldb && (PL_perldb & PERLDBf_INTER)) #define PERLDB_SUBLINE (PL_perldb && (PL_perldb & PERLDBf_SUBLINE)) #define PERLDB_SINGLE (PL_perldb && (PL_perldb & PERLDBf_SINGLE)) #define PERLDB_SUB_NN (PL_perldb && (PL_perldb & (PERLDBf_NONAME))) #define PERLDB_GOTO (PL_perldb && (PL_perldb & PERLDBf_GOTO)) #define PERLDB_NAMEEVAL (PL_perldb && (PL_perldb & PERLDBf_NAMEEVAL)) #define PERLDB_NAMEANON (PL_perldb && (PL_perldb & PERLDBf_NAMEANON)) #define PERLDB_SAVESRC (PL_perldb && (PL_perldb & PERLDBf_SAVESRC)) #define PERLDB_SAVESRC_NOSUBS (PL_perldb && (PL_perldb & PERLDBf_SAVESRC_NOSUBS)) #define PERLDB_SAVESRC_INVALID (PL_perldb && (PL_perldb & PERLDBf_SAVESRC_INVALID)) #ifdef USE_LOCALE_NUMERIC #define SET_NUMERIC_STANDARD() \ set_numeric_standard(); #define SET_NUMERIC_LOCAL() \ set_numeric_local(); #define IN_LOCALE_RUNTIME (CopHINTS_get(PL_curcop) & HINT_LOCALE) #define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE) #define IN_LOCALE \ (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) #define STORE_NUMERIC_LOCAL_SET_STANDARD() \ bool was_local = PL_numeric_local && IN_LOCALE; \ if (was_local) SET_NUMERIC_STANDARD(); #define STORE_NUMERIC_STANDARD_SET_LOCAL() \ bool was_standard = PL_numeric_standard && IN_LOCALE; \ if (was_standard) SET_NUMERIC_LOCAL(); #define RESTORE_NUMERIC_LOCAL() \ if (was_local) SET_NUMERIC_LOCAL(); #define RESTORE_NUMERIC_STANDARD() \ if (was_standard) SET_NUMERIC_STANDARD(); #define Atof my_atof #else /* !USE_LOCALE_NUMERIC */ #define SET_NUMERIC_STANDARD() /**/ #define SET_NUMERIC_LOCAL() /**/ #define IS_NUMERIC_RADIX(a, b) (0) #define STORE_NUMERIC_LOCAL_SET_STANDARD() /**/ #define STORE_NUMERIC_STANDARD_SET_LOCAL() /**/ #define RESTORE_NUMERIC_LOCAL() /**/ #define RESTORE_NUMERIC_STANDARD() /**/ #define Atof my_atof #define IN_LOCALE_RUNTIME 0 #endif /* !USE_LOCALE_NUMERIC */ #if !defined(Strtol) && defined(USE_64_BIT_INT) && defined(IV_IS_QUAD) && QUADKIND == QUAD_IS_LONG_LONG # ifdef __hpux # define strtoll __strtoll /* secret handshake */ # endif # ifdef WIN64 # define strtoll _strtoi64 /* secret handshake */ # endif # if !defined(Strtol) && defined(HAS_STRTOLL) # define Strtol strtoll # endif # if !defined(Strtol) && defined(HAS_STRTOQ) # define Strtol strtoq # endif /* is there atoq() anywhere? */ #endif #if !defined(Strtol) && defined(HAS_STRTOL) # define Strtol strtol #endif #ifndef Atol /* It would be more fashionable to use Strtol() to define atol() * (as is done for Atoul(), see below) but for backward compatibility * we just assume atol(). */ # if defined(USE_64_BIT_INT) && defined(IV_IS_QUAD) && QUADKIND == QUAD_IS_LONG_LONG && defined(HAS_ATOLL) # ifdef WIN64 # define atoll _atoi64 /* secret handshake */ # endif # define Atol atoll # else # define Atol atol # endif #endif #if !defined(Strtoul) && defined(USE_64_BIT_INT) && defined(UV_IS_QUAD) && QUADKIND == QUAD_IS_LONG_LONG # ifdef __hpux # define strtoull __strtoull /* secret handshake */ # endif # ifdef WIN64 # define strtoull _strtoui64 /* secret handshake */ # endif # if !defined(Strtoul) && defined(HAS_STRTOULL) # define Strtoul strtoull # endif # if !defined(Strtoul) && defined(HAS_STRTOUQ) # define Strtoul strtouq # endif /* is there atouq() anywhere? */ #endif #if !defined(Strtoul) && defined(HAS_STRTOUL) # define Strtoul strtoul #endif #if !defined(Strtoul) && defined(HAS_STRTOL) /* Last resort. */ # define Strtoul(s, e, b) strchr((s), '-') ? ULONG_MAX : (unsigned long)strtol((s), (e), (b)) #endif #ifndef Atoul # define Atoul(s) Strtoul(s, NULL, 10) #endif /* if these never got defined, they need defaults */ #ifndef PERL_SET_CONTEXT # define PERL_SET_CONTEXT(i) PERL_SET_INTERP(i) #endif #ifndef PERL_GET_CONTEXT # define PERL_GET_CONTEXT PERL_GET_INTERP #endif #ifndef PERL_GET_THX # define PERL_GET_THX ((void*)NULL) #endif #ifndef PERL_SET_THX # define PERL_SET_THX(t) NOOP #endif #ifndef PERL_SCRIPT_MODE #define PERL_SCRIPT_MODE "r" #endif /* * Some operating systems are stingy with stack allocation, * so perl may have to guard against stack overflow. */ #ifndef PERL_STACK_OVERFLOW_CHECK #define PERL_STACK_OVERFLOW_CHECK() NOOP #endif /* * Some nonpreemptive operating systems find it convenient to * check for asynchronous conditions after each op execution. * Keep this check simple, or it may slow down execution * massively. */ #ifndef PERL_MICRO # ifndef PERL_ASYNC_CHECK # define PERL_ASYNC_CHECK() if (PL_sig_pending) despatch_signals() # endif #endif #ifndef PERL_ASYNC_CHECK # define PERL_ASYNC_CHECK() NOOP #endif /* * On some operating systems, a memory allocation may succeed, * but put the process too close to the system's comfort limit. * In this case, PERL_ALLOC_CHECK frees the pointer and sets * it to NULL. */ #ifndef PERL_ALLOC_CHECK #define PERL_ALLOC_CHECK(p) NOOP #endif #ifdef HAS_SEM # include # include # ifndef HAS_UNION_SEMUN /* Provide the union semun. */ union semun { int val; struct semid_ds *buf; unsigned short *array; }; # endif # ifdef USE_SEMCTL_SEMUN # ifdef IRIX32_SEMUN_BROKEN_BY_GCC union gccbug_semun { int val; struct semid_ds *buf; unsigned short *array; char __dummy[5]; }; # define semun gccbug_semun # endif # define Semctl(id, num, cmd, semun) semctl(id, num, cmd, semun) # else # ifdef USE_SEMCTL_SEMID_DS # ifdef EXTRA_F_IN_SEMUN_BUF # define Semctl(id, num, cmd, semun) semctl(id, num, cmd, semun.buff) # else # define Semctl(id, num, cmd, semun) semctl(id, num, cmd, semun.buf) # endif # endif # endif #endif /* * Boilerplate macros for initializing and accessing interpreter-local * data from C. All statics in extensions should be reworked to use * this, if you want to make the extension thread-safe. See * ext/XS/APItest/APItest.xs for an example of the use of these macros, * and perlxs.pod for more. * * Code that uses these macros is responsible for the following: * 1. #define MY_CXT_KEY to a unique string, e.g. * "DynaLoader::_guts" XS_VERSION * XXX in the current implementation, this string is ignored. * 2. Declare a typedef named my_cxt_t that is a structure that contains * all the data that needs to be interpreter-local. * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t. * 4. Use the MY_CXT_INIT macro such that it is called exactly once * (typically put in the BOOT: section). * 5. Use the members of the my_cxt_t structure everywhere as * MY_CXT.member. * 6. Use the dMY_CXT macro (a declaration) in all the functions that * access MY_CXT. */ #if defined(PERL_IMPLICIT_CONTEXT) #ifdef PERL_GLOBAL_STRUCT_PRIVATE /* This must appear in all extensions that define a my_cxt_t structure, * right after the definition (i.e. at file scope). The non-threads * case below uses it to declare the data as static. */ #define START_MY_CXT #define MY_CXT_INDEX Perl_my_cxt_index(aTHX_ MY_CXT_KEY) /* Creates and zeroes the per-interpreter data. * (We allocate my_cxtp in a Perl SV so that it will be released when * the interpreter goes away.) */ #define MY_CXT_INIT \ my_cxt_t *my_cxtp = \ (my_cxt_t*)Perl_my_cxt_init(aTHX_ MY_CXT_KEY, sizeof(my_cxt_t)) #define MY_CXT_INIT_INTERP(my_perl) \ my_cxt_t *my_cxtp = \ (my_cxt_t*)Perl_my_cxt_init(my_perl, MY_CXT_KEY, sizeof(my_cxt_t)) /* This declaration should be used within all functions that use the * interpreter-local data. */ #define dMY_CXT \ my_cxt_t *my_cxtp = (my_cxt_t *)PL_my_cxt_list[MY_CXT_INDEX] #define dMY_CXT_INTERP(my_perl) \ my_cxt_t *my_cxtp = (my_cxt_t *)(my_perl)->Imy_cxt_list[MY_CXT_INDEX] /* Clones the per-interpreter data. */ #define MY_CXT_CLONE \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ Copy(PL_my_cxt_list[MY_CXT_INDEX], my_cxtp, 1, my_cxt_t);\ PL_my_cxt_list[MY_CXT_INDEX] = my_cxtp \ #else /* #ifdef PERL_GLOBAL_STRUCT_PRIVATE */ /* This must appear in all extensions that define a my_cxt_t structure, * right after the definition (i.e. at file scope). The non-threads * case below uses it to declare the data as static. */ #define START_MY_CXT static int my_cxt_index = -1; /* This declaration should be used within all functions that use the * interpreter-local data. */ #define dMY_CXT \ my_cxt_t *my_cxtp = (my_cxt_t *)PL_my_cxt_list[my_cxt_index] #define dMY_CXT_INTERP(my_perl) \ my_cxt_t *my_cxtp = (my_cxt_t *)(my_perl)->Imy_cxt_list[my_cxt_index] /* Creates and zeroes the per-interpreter data. * (We allocate my_cxtp in a Perl SV so that it will be released when * the interpreter goes away.) */ #define MY_CXT_INIT \ my_cxt_t *my_cxtp = \ (my_cxt_t*)Perl_my_cxt_init(aTHX_ &my_cxt_index, sizeof(my_cxt_t)) #define MY_CXT_INIT_INTERP(my_perl) \ my_cxt_t *my_cxtp = \ (my_cxt_t*)Perl_my_cxt_init(my_perl, &my_cxt_index, sizeof(my_cxt_t)) /* Clones the per-interpreter data. */ #define MY_CXT_CLONE \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ Copy(PL_my_cxt_list[my_cxt_index], my_cxtp, 1, my_cxt_t);\ PL_my_cxt_list[my_cxt_index] = my_cxtp \ #endif /* #ifdef PERL_GLOBAL_STRUCT_PRIVATE */ /* This macro must be used to access members of the my_cxt_t structure. * e.g. MYCXT.some_data */ #define MY_CXT (*my_cxtp) /* Judicious use of these macros can reduce the number of times dMY_CXT * is used. Use is similar to pTHX, aTHX etc. */ #define pMY_CXT my_cxt_t *my_cxtp #define pMY_CXT_ pMY_CXT, #define _pMY_CXT ,pMY_CXT #define aMY_CXT my_cxtp #define aMY_CXT_ aMY_CXT, #define _aMY_CXT ,aMY_CXT #else /* PERL_IMPLICIT_CONTEXT */ #define START_MY_CXT static my_cxt_t my_cxt; #define dMY_CXT_SV dNOOP #define dMY_CXT dNOOP #define dMY_CXT_INTERP(my_perl) dNOOP #define MY_CXT_INIT NOOP #define MY_CXT_CLONE NOOP #define MY_CXT my_cxt #define pMY_CXT void #define pMY_CXT_ #define _pMY_CXT #define aMY_CXT #define aMY_CXT_ #define _aMY_CXT #endif /* !defined(PERL_IMPLICIT_CONTEXT) */ #ifdef I_FCNTL # include #endif #ifdef __Lynx__ # include #endif #ifdef I_SYS_FILE # include #endif #if defined(HAS_FLOCK) && !defined(HAS_FLOCK_PROTO) int flock(int fd, int op); #endif #ifndef O_RDONLY /* Assume UNIX defaults */ # define O_RDONLY 0000 # define O_WRONLY 0001 # define O_RDWR 0002 # define O_CREAT 0100 #endif #ifndef O_BINARY # define O_BINARY 0 #endif #ifndef O_TEXT # define O_TEXT 0 #endif #if O_TEXT != O_BINARY /* If you have different O_TEXT and O_BINARY and you are a CLRF shop, * that is, you are somehow DOSish. */ # if defined(__BEOS__) || defined(__HAIKU__) || defined(__VOS__) || \ defined(__CYGWIN__) /* BeOS/Haiku has O_TEXT != O_BINARY but O_TEXT and O_BINARY have no effect; * BeOS/Haiku is always UNIXoid (LF), not DOSish (CRLF). */ /* VOS has O_TEXT != O_BINARY, and they have effect, * but VOS always uses LF, never CRLF. */ /* If you have O_TEXT different from your O_BINARY but you still are * not a CRLF shop. */ # undef PERLIO_USING_CRLF # else /* If you really are DOSish. */ # define PERLIO_USING_CRLF 1 # endif #endif #ifdef I_LIBUTIL # include /* setproctitle() in some FreeBSDs */ #endif #ifndef EXEC_ARGV_CAST #define EXEC_ARGV_CAST(x) (char **)x #endif #define IS_NUMBER_IN_UV 0x01 /* number within UV range (maybe not int). value returned in pointed- to UV */ #define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 /* pointed to UV undefined */ #define IS_NUMBER_NOT_INT 0x04 /* saw . or E notation */ #define IS_NUMBER_NEG 0x08 /* leading minus sign */ #define IS_NUMBER_INFINITY 0x10 /* this is big */ #define IS_NUMBER_NAN 0x20 /* this is not */ #define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send) /* Input flags: */ #define PERL_SCAN_ALLOW_UNDERSCORES 0x01 /* grok_??? accept _ in numbers */ #define PERL_SCAN_DISALLOW_PREFIX 0x02 /* grok_??? reject 0x in hex etc */ #define PERL_SCAN_SILENT_ILLDIGIT 0x04 /* grok_??? not warn about illegal digits */ /* Output flags: */ #define PERL_SCAN_GREATER_THAN_UV_MAX 0x02 /* should this merge with above? */ /* to let user control profiling */ #ifdef PERL_GPROF_CONTROL extern void moncontrol(int); #define PERL_GPROF_MONCONTROL(x) moncontrol(x) #else #define PERL_GPROF_MONCONTROL(x) #endif #ifdef UNDER_CE #include "wince.h" #endif /* ISO 6429 NEL - C1 control NExt Line */ /* See http://www.unicode.org/unicode/reports/tr13/ */ #ifdef EBCDIC /* In EBCDIC NEL is just an alias for LF */ # if '^' == 95 /* CP 1047: MVS OpenEdition - OS/390 - z/OS */ # define NEXT_LINE_CHAR 0x15 # else /* CDRA */ # define NEXT_LINE_CHAR 0x25 # endif #else # define NEXT_LINE_CHAR 0x85 #endif /* The UTF-8 bytes of the Unicode LS and PS, U+2028 and U+2029 */ #define UNICODE_LINE_SEPA_0 0xE2 #define UNICODE_LINE_SEPA_1 0x80 #define UNICODE_LINE_SEPA_2 0xA8 #define UNICODE_PARA_SEPA_0 0xE2 #define UNICODE_PARA_SEPA_1 0x80 #define UNICODE_PARA_SEPA_2 0xA9 #ifndef PIPESOCK_MODE # define PIPESOCK_MODE #endif #ifndef SOCKET_OPEN_MODE # define SOCKET_OPEN_MODE PIPESOCK_MODE #endif #ifndef PIPE_OPEN_MODE # define PIPE_OPEN_MODE PIPESOCK_MODE #endif #define PERL_MAGIC_UTF8_CACHESIZE 2 #define PERL_UNICODE_STDIN_FLAG 0x0001 #define PERL_UNICODE_STDOUT_FLAG 0x0002 #define PERL_UNICODE_STDERR_FLAG 0x0004 #define PERL_UNICODE_IN_FLAG 0x0008 #define PERL_UNICODE_OUT_FLAG 0x0010 #define PERL_UNICODE_ARGV_FLAG 0x0020 #define PERL_UNICODE_LOCALE_FLAG 0x0040 #define PERL_UNICODE_WIDESYSCALLS_FLAG 0x0080 /* for Sarathy */ #define PERL_UNICODE_UTF8CACHEASSERT_FLAG 0x0100 #define PERL_UNICODE_STD_FLAG \ (PERL_UNICODE_STDIN_FLAG | \ PERL_UNICODE_STDOUT_FLAG | \ PERL_UNICODE_STDERR_FLAG) #define PERL_UNICODE_INOUT_FLAG \ (PERL_UNICODE_IN_FLAG | \ PERL_UNICODE_OUT_FLAG) #define PERL_UNICODE_DEFAULT_FLAGS \ (PERL_UNICODE_STD_FLAG | \ PERL_UNICODE_INOUT_FLAG | \ PERL_UNICODE_LOCALE_FLAG) #define PERL_UNICODE_ALL_FLAGS 0x01ff #define PERL_UNICODE_STDIN 'I' #define PERL_UNICODE_STDOUT 'O' #define PERL_UNICODE_STDERR 'E' #define PERL_UNICODE_STD 'S' #define PERL_UNICODE_IN 'i' #define PERL_UNICODE_OUT 'o' #define PERL_UNICODE_INOUT 'D' #define PERL_UNICODE_ARGV 'A' #define PERL_UNICODE_LOCALE 'L' #define PERL_UNICODE_WIDESYSCALLS 'W' #define PERL_UNICODE_UTF8CACHEASSERT 'a' #define PERL_SIGNALS_UNSAFE_FLAG 0x0001 /* 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 * by defining PERL_BLOCK_SIGNALS. */ #define PERL_BLOCK_SIGNALS #if defined(HAS_SIGPROCMASK) && defined(PERL_BLOCK_SIGNALS) # define PERL_BLOCKSIG_ADD(set,sig) \ sigset_t set; sigemptyset(&(set)); sigaddset(&(set), sig) # define PERL_BLOCKSIG_BLOCK(set) \ sigprocmask(SIG_BLOCK, &(set), NULL) # define PERL_BLOCKSIG_UNBLOCK(set) \ sigprocmask(SIG_UNBLOCK, &(set), NULL) #endif /* HAS_SIGPROCMASK && PERL_BLOCK_SIGNALS */ /* How about the old style of sigblock()? */ #ifndef PERL_BLOCKSIG_ADD # define PERL_BLOCKSIG_ADD(set, sig) NOOP #endif #ifndef PERL_BLOCKSIG_BLOCK # define PERL_BLOCKSIG_BLOCK(set) NOOP #endif #ifndef PERL_BLOCKSIG_UNBLOCK # define PERL_BLOCKSIG_UNBLOCK(set) NOOP #endif /* Use instead of abs() since abs() forces its argument to be an int, * but also beware since this evaluates its argument twice, so no x++. */ #define PERL_ABS(x) ((x) < 0 ? -(x) : (x)) #if defined(__DECC) && defined(__osf__) #pragma message disable (mainparm) /* Perl uses the envp in main(). */ #endif #define do_open(g, n, l, a, rm, rp, sf) \ do_openn(g, n, l, a, rm, rp, sf, (SV **) NULL, 0) #ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION # define do_exec(cmd) do_exec3(cmd,0,0) #endif #ifdef OS2 # define do_aexec Perl_do_aexec #else # define do_aexec(really, mark,sp) do_aexec5(really, mark, sp, 0, 0) #endif #if defined(OEMVS) #define NO_ENV_ARRAY_IN_MAIN #endif /* These are used by Perl_pv_escape() and Perl_pv_pretty() * are here so that they are available throughout the core * NOTE that even though some are for _escape and some for _pretty * there must not be any clashes as the flags from _pretty are * passed straight through to _escape. */ #define PERL_PV_ESCAPE_QUOTE 0x0001 #define PERL_PV_PRETTY_QUOTE PERL_PV_ESCAPE_QUOTE #define PERL_PV_PRETTY_ELLIPSES 0x0002 #define PERL_PV_PRETTY_LTGT 0x0004 #define PERL_PV_ESCAPE_FIRSTCHAR 0x0008 #define PERL_PV_ESCAPE_UNI 0x0100 #define PERL_PV_ESCAPE_UNI_DETECT 0x0200 #define PERL_PV_ESCAPE_ALL 0x1000 #define PERL_PV_ESCAPE_NOBACKSLASH 0x2000 #define PERL_PV_ESCAPE_NOCLEAR 0x4000 #define PERL_PV_ESCAPE_RE 0x8000 #define PERL_PV_PRETTY_NOCLEAR PERL_PV_ESCAPE_NOCLEAR /* used by pv_display in dump.c*/ #define PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE #define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE /* (KEEP THIS LAST IN perl.h!) Mention NV_PRESERVES_UV HAS_MKSTEMP HAS_MKSTEMPS HAS_MKDTEMP HAS_GETCWD HAS_MMAP HAS_MPROTECT HAS_MSYNC HAS_MADVISE HAS_MUNMAP I_SYSMMAN Mmap_t NVef NVff NVgf HAS_UALARM HAS_USLEEP HAS_SETITIMER HAS_GETITIMER HAS_SENDMSG HAS_RECVMSG HAS_READV HAS_WRITEV I_SYSUIO HAS_STRUCT_MSGHDR HAS_STRUCT_CMSGHDR HAS_NL_LANGINFO HAS_DIRFD so that Configure picks them up. (KEEP THIS LAST IN perl.h!) */ #endif /* Include guard */ /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */ perl-5.12.0-RC0/utf8.h0000444000175000017500000003225211325127002013161 0ustar jessejesse/* utf8.h * * Copyright (C) 2000, 2001, 2002, 2005, 2006, 2007, 2009 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* Use UTF-8 as the default script encoding? * Turning this on will break scripts having non-UTF-8 binary * data (such as Latin-1) in string literals. */ #ifdef USE_UTF8_SCRIPTS # define USE_UTF8_IN_NAMES (!IN_BYTES) #else # define USE_UTF8_IN_NAMES (PL_hints & HINT_UTF8) #endif /* Source backward compatibility. */ #define uvuni_to_utf8(d, uv) uvuni_to_utf8_flags(d, uv, 0) #define is_utf8_string_loc(s, len, ep) is_utf8_string_loclen(s, len, ep, 0) #ifdef EBCDIC /* The equivalent of these macros but implementing UTF-EBCDIC are in the following header file: */ #include "utfebcdic.h" #else /* ! EBCDIC */ START_EXTERN_C #ifdef DOINIT EXTCONST unsigned char PL_utf8skip[] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* ascii */ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* ascii */ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* ascii */ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* ascii */ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* bogus */ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* bogus */ 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, /* scripts */ 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,4,4,4,4,4,4,4,4,5,5,5,5,6,6, /* cjk etc. */ 7,13, /* Perl extended (not UTF-8). Up to 72bit allowed (64-bit + reserved). */ }; #else EXTCONST unsigned char PL_utf8skip[]; #endif END_EXTERN_C /* Native character to iso-8859-1 */ #define NATIVE_TO_ASCII(ch) (ch) #define ASCII_TO_NATIVE(ch) (ch) /* Transform after encoding */ #define NATIVE_TO_UTF(ch) (ch) #define UTF_TO_NATIVE(ch) (ch) /* Transforms in wide UV chars */ #define UNI_TO_NATIVE(ch) (ch) #define NATIVE_TO_UNI(ch) (ch) /* Transforms in invariant space */ #define NATIVE_TO_NEED(enc,ch) (ch) #define ASCII_TO_NEED(enc,ch) (ch) /* As there are no translations, avoid the function wrapper */ #define utf8n_to_uvchr utf8n_to_uvuni #define uvchr_to_utf8 uvuni_to_utf8 /* The following table is from Unicode 3.2. Code Points 1st Byte 2nd Byte 3rd Byte 4th Byte U+0000..U+007F 00..7F U+0080..U+07FF * C2..DF 80..BF U+0800..U+0FFF E0 * A0..BF 80..BF U+1000..U+CFFF E1..EC 80..BF 80..BF U+D000..U+D7FF ED 80..9F 80..BF U+D800..U+DFFF +++++++ utf16 surrogates, not legal utf8 +++++++ U+E000..U+FFFF EE..EF 80..BF 80..BF U+10000..U+3FFFF F0 * 90..BF 80..BF 80..BF U+40000..U+FFFFF F1..F3 80..BF 80..BF 80..BF U+100000..U+10FFFF F4 80..8F 80..BF 80..BF Note the gaps before several of the byte entries above marked by '*'. These are caused by legal UTF-8 avoiding non-shortest encodings: it is technically possible to UTF-8-encode a single code point in different ways, but that is explicitly forbidden, and the shortest possible encoding should always be used (and that is what Perl does). */ /* Another way to look at it, as bits: Code Points 1st Byte 2nd Byte 3rd Byte 4th Byte 0aaaaaaa 0aaaaaaa 00000bbbbbaaaaaa 110bbbbb 10aaaaaa ccccbbbbbbaaaaaa 1110cccc 10bbbbbb 10aaaaaa 00000dddccccccbbbbbbaaaaaa 11110ddd 10cccccc 10bbbbbb 10aaaaaa As you can see, the continuation bytes all begin with C<10>, and the leading bits of the start byte tell how many bytes there are in the encoded character. */ #define UNI_IS_INVARIANT(c) (((UV)c) < 0x80) /* Note that C0 and C1 are invalid in legal UTF8, so the lower bound of the * below might ought to be C2 */ #define UTF8_IS_START(c) (((U8)c) >= 0xc0 && (((U8)c) <= 0xfd)) #define UTF8_IS_CONTINUATION(c) (((U8)c) >= 0x80 && (((U8)c) <= 0xbf)) #define UTF8_IS_CONTINUED(c) (((U8)c) & 0x80) #define UTF8_IS_DOWNGRADEABLE_START(c) (((U8)c & 0xfc) == 0xc0) #define UTF_START_MARK(len) (((len) > 7) ? 0xFF : (0xFE << (7-(len)))) #define UTF_START_MASK(len) (((len) >= 7) ? 0x00 : (0x1F >> ((len)-2))) #define UTF_CONTINUATION_MARK 0x80 #define UTF_ACCUMULATION_SHIFT 6 #define UTF_CONTINUATION_MASK ((U8)0x3f) #ifdef HAS_QUAD #define UNISKIP(uv) ( (uv) < 0x80 ? 1 : \ (uv) < 0x800 ? 2 : \ (uv) < 0x10000 ? 3 : \ (uv) < 0x200000 ? 4 : \ (uv) < 0x4000000 ? 5 : \ (uv) < 0x80000000 ? 6 : \ (uv) < UTF8_QUAD_MAX ? 7 : 13 ) #else /* No, I'm not even going to *TRY* putting #ifdef inside a #define */ #define UNISKIP(uv) ( (uv) < 0x80 ? 1 : \ (uv) < 0x800 ? 2 : \ (uv) < 0x10000 ? 3 : \ (uv) < 0x200000 ? 4 : \ (uv) < 0x4000000 ? 5 : \ (uv) < 0x80000000 ? 6 : 7 ) #endif #endif /* EBCDIC vs ASCII */ /* Rest of these are attributes of Unicode and perl's internals rather than the * encoding, or happen to be the same in both ASCII and EBCDIC (at least at * this level; the macros that some of these call may have different * definitions in the two encodings */ #define NATIVE8_TO_UNI(ch) NATIVE_TO_ASCII(ch) /* a clearer synonym */ #define UTF8_ACCUMULATE(old, new) (((old) << UTF_ACCUMULATION_SHIFT) | (((U8)new) & UTF_CONTINUATION_MASK)) #define UTF8SKIP(s) PL_utf8skip[*(const U8*)(s)] #define UTF8_IS_INVARIANT(c) UNI_IS_INVARIANT(NATIVE_TO_UTF(c)) #define NATIVE_IS_INVARIANT(c) UNI_IS_INVARIANT(NATIVE8_TO_UNI(c)) #define MAX_PORTABLE_UTF8_TWO_BYTE 0x3FF /* constrained by EBCDIC */ /* The macros in the next sets are used to generate the two utf8 or utfebcdic * bytes from an ordinal that is known to fit into two bytes; it must be less * than 0x3FF to work across both encodings. */ /* Nocast allows these to be used in the case label of a switch statement */ #define UTF8_TWO_BYTE_HI_nocast(c) UTF_TO_NATIVE(((c)>>UTF_ACCUMULATION_SHIFT)|UTF_START_MARK(2)) #define UTF8_TWO_BYTE_LO_nocast(c) UTF_TO_NATIVE(((c)&UTF_CONTINUATION_MASK)|UTF_CONTINUATION_MARK) #define UTF8_TWO_BYTE_HI(c) ((U8) (UTF8_TWO_BYTE_HI_nocast(c))) #define UTF8_TWO_BYTE_LO(c) ((U8) (UTF8_TWO_BYTE_LO_nocast(c))) /* This name is used when the source is a single byte */ #define UTF8_EIGHT_BIT_HI(c) UTF8_TWO_BYTE_HI((U8)(c)) #define UTF8_EIGHT_BIT_LO(c) UTF8_TWO_BYTE_LO((U8)(c)) /* * Note: we try to be careful never to call the isXXX_utf8() functions * unless we're pretty sure we've seen the beginning of a UTF-8 or UTFEBCDIC * character. Otherwise we risk loading in the heavy-duty swash_init and * swash_fetch routines unnecessarily. */ #define isIDFIRST_lazy_if(p,c) ((IN_BYTES || (!c || ! UTF8_IS_START(*((const U8*)p)))) \ ? isIDFIRST(*(p)) \ : isIDFIRST_utf8((const U8*)p)) #define isALNUM_lazy_if(p,c) ((IN_BYTES || (!c || ! UTF8_IS_START(*((const U8*)p)))) \ ? isALNUM(*(p)) \ : isALNUM_utf8((const U8*)p)) #define isIDFIRST_lazy(p) isIDFIRST_lazy_if(p,1) #define isALNUM_lazy(p) isALNUM_lazy_if(p,1) #define UTF8_MAXBYTES 13 /* How wide can a single UTF-8 encoded character become in bytes. * NOTE: Strictly speaking Perl's UTF-8 should not be called UTF-8 * since UTF-8 is an encoding of Unicode and given Unicode's current * upper limit only four bytes is possible. Perl thinks of UTF-8 * as a way to encode non-negative integers in a binary format. */ #define UTF8_MAXLEN UTF8_MAXBYTES /* The maximum number of UTF-8 bytes a single Unicode character can * uppercase/lowercase/fold into; this number depends on the Unicode * version. An example of maximal expansion is the U+03B0 which * uppercases to U+03C5 U+0308 U+0301. The Unicode databases that * tell these things are UnicodeData.txt, CaseFolding.txt, and * SpecialCasing.txt. */ #define UTF8_MAXBYTES_CASE 6 #define IN_BYTES (CopHINTS_get(PL_curcop) & HINT_BYTES) #define DO_UTF8(sv) (SvUTF8(sv) && !IN_BYTES) #define IN_UNI_8_BIT ( (CopHINTS_get(PL_curcop) & HINT_UNI_8_BIT) \ && ! IN_LOCALE_RUNTIME && ! IN_BYTES) #define UTF8_ALLOW_EMPTY 0x0001 #define UTF8_ALLOW_CONTINUATION 0x0002 #define UTF8_ALLOW_NON_CONTINUATION 0x0004 #define UTF8_ALLOW_FE_FF 0x0008 /* Allow FE or FF start bytes, \ yields above 0x7fffFFFF */ #define UTF8_ALLOW_SHORT 0x0010 /* expecting more bytes */ #define UTF8_ALLOW_SURROGATE 0x0020 #define UTF8_ALLOW_FFFF 0x0040 /* Allow UNICODE_ILLEGAL */ #define UTF8_ALLOW_LONG 0x0080 /* expecting fewer bytes */ #define UTF8_ALLOW_ANYUV (UTF8_ALLOW_EMPTY|UTF8_ALLOW_FE_FF|\ UTF8_ALLOW_SURROGATE|UTF8_ALLOW_FFFF) #define UTF8_ALLOW_ANY 0x00FF #define UTF8_CHECK_ONLY 0x0200 #define UTF8_ALLOW_DEFAULT (ckWARN(WARN_UTF8) ? 0 : \ UTF8_ALLOW_ANYUV) #define UNICODE_SURROGATE_FIRST 0xD800 #define UNICODE_SURROGATE_LAST 0xDFFF #define UNICODE_REPLACEMENT 0xFFFD #define UNICODE_BYTE_ORDER_MARK 0xFEFF #define UNICODE_ILLEGAL 0xFFFF /* Though our UTF-8 encoding can go beyond this, * let's be conservative and do as Unicode 5.1 says. */ #define PERL_UNICODE_MAX 0x10FFFF #define UNICODE_ALLOW_SURROGATE 0x0001 /* Allow UTF-16 surrogates (EVIL) */ #define UNICODE_ALLOW_FDD0 0x0002 /* Allow the U+FDD0...U+FDEF */ #define UNICODE_ALLOW_FFFF 0x0004 /* Allow U+FFF[EF], U+1FFF[EF], ... */ #define UNICODE_ALLOW_SUPER 0x0008 /* Allow past 0x10FFFF */ #define UNICODE_ALLOW_ANY 0x000F #define UNICODE_IS_SURROGATE(c) ((c) >= UNICODE_SURROGATE_FIRST && \ (c) <= UNICODE_SURROGATE_LAST) #define UNICODE_IS_REPLACEMENT(c) ((c) == UNICODE_REPLACEMENT) #define UNICODE_IS_BYTE_ORDER_MARK(c) ((c) == UNICODE_BYTE_ORDER_MARK) #define UNICODE_IS_ILLEGAL(c) ((c) == UNICODE_ILLEGAL) #ifdef HAS_QUAD # define UTF8_QUAD_MAX UINT64_C(0x1000000000) #endif #define UTF8_IS_ASCII(c) UTF8_IS_INVARIANT(c) #define UNICODE_GREEK_CAPITAL_LETTER_SIGMA 0x03A3 #define UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA 0x03C2 #define UNICODE_GREEK_SMALL_LETTER_SIGMA 0x03C3 #define UNI_DISPLAY_ISPRINT 0x0001 #define UNI_DISPLAY_BACKSLASH 0x0002 #define UNI_DISPLAY_QQ (UNI_DISPLAY_ISPRINT|UNI_DISPLAY_BACKSLASH) #define UNI_DISPLAY_REGEX (UNI_DISPLAY_ISPRINT|UNI_DISPLAY_BACKSLASH) #ifndef EBCDIC # define LATIN_SMALL_LETTER_SHARP_S 0x00DF # define LATIN_SMALL_LETTER_Y_WITH_DIAERESIS 0x00FF # define MICRO_SIGN 0x00B5 #endif #define ANYOF_FOLD_SHARP_S(node, input, end) \ (ANYOF_BITMAP_TEST(node, LATIN_SMALL_LETTER_SHARP_S) && \ (ANYOF_FLAGS(node) & ANYOF_UNICODE) && \ (ANYOF_FLAGS(node) & ANYOF_FOLD) && \ ((end) > (input) + 1) && \ toLOWER((input)[0]) == 's' && \ toLOWER((input)[1]) == 's') #define SHARP_S_SKIP 2 #ifdef EBCDIC /* IS_UTF8_CHAR() is not ported to EBCDIC */ #else #define IS_UTF8_CHAR_1(p) \ ((p)[0] <= 0x7F) #define IS_UTF8_CHAR_2(p) \ ((p)[0] >= 0xC2 && (p)[0] <= 0xDF && \ (p)[1] >= 0x80 && (p)[1] <= 0xBF) #define IS_UTF8_CHAR_3a(p) \ ((p)[0] == 0xE0 && \ (p)[1] >= 0xA0 && (p)[1] <= 0xBF && \ (p)[2] >= 0x80 && (p)[2] <= 0xBF) #define IS_UTF8_CHAR_3b(p) \ ((p)[0] >= 0xE1 && (p)[0] <= 0xEC && \ (p)[1] >= 0x80 && (p)[1] <= 0xBF && \ (p)[2] >= 0x80 && (p)[2] <= 0xBF) #define IS_UTF8_CHAR_3c(p) \ ((p)[0] == 0xED && \ (p)[1] >= 0x80 && (p)[1] <= 0xBF && \ (p)[2] >= 0x80 && (p)[2] <= 0xBF) /* In IS_UTF8_CHAR_3c(p) one could use * (p)[1] >= 0x80 && (p)[1] <= 0x9F * if one wanted to exclude surrogates. */ #define IS_UTF8_CHAR_3d(p) \ ((p)[0] >= 0xEE && (p)[0] <= 0xEF && \ (p)[1] >= 0x80 && (p)[1] <= 0xBF && \ (p)[2] >= 0x80 && (p)[2] <= 0xBF) #define IS_UTF8_CHAR_4a(p) \ ((p)[0] == 0xF0 && \ (p)[1] >= 0x90 && (p)[1] <= 0xBF && \ (p)[2] >= 0x80 && (p)[2] <= 0xBF && \ (p)[3] >= 0x80 && (p)[3] <= 0xBF) #define IS_UTF8_CHAR_4b(p) \ ((p)[0] >= 0xF1 && (p)[0] <= 0xF3 && \ (p)[1] >= 0x80 && (p)[1] <= 0xBF && \ (p)[2] >= 0x80 && (p)[2] <= 0xBF && \ (p)[3] >= 0x80 && (p)[3] <= 0xBF) /* In IS_UTF8_CHAR_4c(p) one could use * (p)[0] == 0xF4 * if one wanted to stop at the Unicode limit U+10FFFF. * The 0xF7 allows us to go to 0x1fffff (0x200000 would * require five bytes). Not doing any further code points * since that is not needed (and that would not be strict * UTF-8, anyway). The "slow path" in Perl_is_utf8_char() * will take care of the "extended UTF-8". */ #define IS_UTF8_CHAR_4c(p) \ ((p)[0] == 0xF4 && (p)[0] <= 0xF7 && \ (p)[1] >= 0x80 && (p)[1] <= 0xBF && \ (p)[2] >= 0x80 && (p)[2] <= 0xBF && \ (p)[3] >= 0x80 && (p)[3] <= 0xBF) #define IS_UTF8_CHAR_3(p) \ (IS_UTF8_CHAR_3a(p) || \ IS_UTF8_CHAR_3b(p) || \ IS_UTF8_CHAR_3c(p) || \ IS_UTF8_CHAR_3d(p)) #define IS_UTF8_CHAR_4(p) \ (IS_UTF8_CHAR_4a(p) || \ IS_UTF8_CHAR_4b(p) || \ IS_UTF8_CHAR_4c(p)) /* IS_UTF8_CHAR(p) is strictly speaking wrong (not UTF-8) because it * (1) allows UTF-8 encoded UTF-16 surrogates * (2) it allows code points past U+10FFFF. * The Perl_is_utf8_char() full "slow" code will handle the Perl * "extended UTF-8". */ #define IS_UTF8_CHAR(p, n) \ ((n) == 1 ? IS_UTF8_CHAR_1(p) : \ (n) == 2 ? IS_UTF8_CHAR_2(p) : \ (n) == 3 ? IS_UTF8_CHAR_3(p) : \ (n) == 4 ? IS_UTF8_CHAR_4(p) : 0) #define IS_UTF8_CHAR_FAST(n) ((n) <= 4) #endif /* IS_UTF8_CHAR() for UTF-8 */ /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */ perl-5.12.0-RC0/fakesdio.h0000444000175000017500000000636411325125741014075 0ustar jessejesse/* fakestdio.h * * Copyright (C) 2000, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * This is "source level" stdio compatibility mode. * We try and #define stdio functions in terms of PerlIO. */ #define _CANNOT "CANNOT" #undef FILE #define FILE PerlIO #undef clearerr #undef fclose #undef fdopen #undef feof #undef ferror #undef fflush #undef fgetc #undef fgetpos #undef fgets #undef fileno #undef flockfile #undef fopen #undef fprintf #undef fputc #undef fputs #undef fread #undef freopen #undef fscanf #undef fseek #undef fsetpos #undef ftell #undef ftrylockfile #undef funlockfile #undef fwrite #undef getc #undef getc_unlocked #undef getw #undef pclose #undef popen #undef putc #undef putc_unlocked #undef putw #undef rewind #undef setbuf #undef setvbuf #undef stderr #undef stdin #undef stdout #undef tmpfile #undef ungetc #undef vfprintf #undef printf /* printf used to live in perl.h like this - more sophisticated than the rest */ #if defined(__GNUC__) && !defined(__STRICT_ANSI__) && !defined(PERL_GCC_PEDANTIC) #define printf(fmt,args...) PerlIO_stdoutf(fmt,##args) #else #define printf PerlIO_stdoutf #endif #define fprintf PerlIO_printf #define stdin PerlIO_stdin() #define stdout PerlIO_stdout() #define stderr PerlIO_stderr() #define tmpfile() PerlIO_tmpfile() #define fclose(f) PerlIO_close(f) #define fflush(f) PerlIO_flush(f) #define fopen(p,m) PerlIO_open(p,m) #define vfprintf(f,fmt,a) PerlIO_vprintf(f,fmt,a) #define fgetc(f) PerlIO_getc(f) #define fputc(c,f) PerlIO_putc(f,c) #define fputs(s,f) PerlIO_puts(f,s) #define getc(f) PerlIO_getc(f) #define getc_unlocked(f) PerlIO_getc(f) #define putc(c,f) PerlIO_putc(f,c) #define putc_unlocked(c,f) PerlIO_putc(c,f) #define ungetc(c,f) PerlIO_ungetc(f,c) #if 0 /* return values of read/write need work */ #define fread(b,s,c,f) PerlIO_read(f,b,(s*c)) #define fwrite(b,s,c,f) PerlIO_write(f,b,(s*c)) #else #define fread(b,s,c,f) _CANNOT fread #define fwrite(b,s,c,f) _CANNOT fwrite #endif #define fseek(f,o,w) PerlIO_seek(f,o,w) #define ftell(f) PerlIO_tell(f) #define rewind(f) PerlIO_rewind(f) #define clearerr(f) PerlIO_clearerr(f) #define feof(f) PerlIO_eof(f) #define ferror(f) PerlIO_error(f) #define fdopen(fd,p) PerlIO_fdopen(fd,p) #define fileno(f) PerlIO_fileno(f) #define popen(c,m) my_popen(c,m) #define pclose(f) my_pclose(f) #define fsetpos(f,p) _CANNOT _fsetpos_ #define fgetpos(f,p) _CANNOT _fgetpos_ #define __filbuf(f) _CANNOT __filbuf_ #define _filbuf(f) _CANNOT _filbuf_ #define __flsbuf(c,f) _CANNOT __flsbuf_ #define _flsbuf(c,f) _CANNOT _flsbuf_ #define getw(f) _CANNOT _getw_ #define putw(v,f) _CANNOT _putw_ #if SFIO_VERSION < 20000101L #define flockfile(f) _CANNOT _flockfile_ #define ftrylockfile(f) _CANNOT _ftrylockfile_ #define funlockfile(f) _CANNOT _funlockfile_ #endif #define freopen(p,m,f) _CANNOT _freopen_ #define setbuf(f,b) _CANNOT _setbuf_ #define setvbuf(f,b,x,s) _CANNOT _setvbuf_ #define fscanf _CANNOT _fscanf_ #define fgets(s,n,f) _CANNOT _fgets_ /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */ perl-5.12.0-RC0/README.bs20000000444000175000017500000001737111143650473013727 0ustar jessejesseThis document is written in pod format hence there are punctuation characters in odd places. Do not worry, you've apparently got the ASCII->EBCDIC translation worked out correctly. You can read more about pod in pod/perlpod.pod or the short summary in the INSTALL file. =head1 NAME README.BS2000 - building and installing Perl for BS2000. =head1 SYNOPSIS This document will help you Configure, build, test and install Perl on BS2000 in the POSIX subsystem. =head1 DESCRIPTION This is a ported perl for the POSIX subsystem in BS2000 VERSION OSD V3.1A or later. It may work on other versions, but we started porting and testing it with 3.1A and are currently using Version V4.0A. You may need the following GNU programs in order to install perl: =head2 gzip on BS2000 We used version 1.2.4, which could be installed out of the box with one failure during 'make check'. =head2 bison on BS2000 The yacc coming with BS2000 POSIX didn't work for us. So we had to use bison. We had to make a few changes to perl in order to use the pure (reentrant) parser of bison. We used version 1.25, but we had to add a few changes due to EBCDIC. See below for more details concerning yacc. =head2 Unpacking Perl Distribution on BS2000 To extract an ASCII tar archive on BS2000 POSIX you need an ASCII filesystem (we used the mountpoint /usr/local/ascii for this). Now you extract the archive in the ASCII filesystem without I/O-conversion: cd /usr/local/ascii export IO_CONVERSION=NO gunzip < /usr/local/src/perl.tar.gz | pax -r You may ignore the error message for the first element of the archive (this doesn't look like a tar archive / skipping to next file...), it's only the directory which will be created automatically anyway. After extracting the archive you copy the whole directory tree to your EBCDIC filesystem. B: cd /usr/local/src IO_CONVERSION=YES cp -r /usr/local/ascii/perl5.005_02 ./ =head2 Compiling Perl on BS2000 There is a "hints" file for BS2000 called hints.posix-bc (because posix-bc is the OS name given by `uname`) that specifies the correct values for most things. The major problem is (of course) the EBCDIC character set. We have german EBCDIC version. Because of our problems with the native yacc we used GNU bison to generate a pure (=reentrant) parser for perly.y. So our yacc is really the following script: -----8<-----/usr/local/bin/yacc-----8<----- #! /usr/bin/sh # Bison as a reentrant yacc: # save parameters: params="" while [[ $# -gt 1 ]]; do params="$params $1" shift done # add flag %pure_parser: tmpfile=/tmp/bison.$$.y echo %pure_parser > $tmpfile cat $1 >> $tmpfile # call bison: echo "/usr/local/bin/bison --yacc $params $1\t\t\t(Pure Parser)" /usr/local/bin/bison --yacc $params $tmpfile # cleanup: rm -f $tmpfile -----8<----------8<----- We still use the normal yacc for a2p.y though!!! We made a softlink called byacc to distinguish between the two versions: ln -s /usr/bin/yacc /usr/local/bin/byacc We build perl using GNU make. We tried the native make once and it worked too. =head2 Testing Perl on BS2000 We still got a few errors during C. Some of them are the result of using bison. Bison prints I instead of I, so we may ignore them. The following list shows our errors, your results may differ: op/numconvert.......FAILED tests 1409-1440 op/regexp...........FAILED tests 483, 496 op/regexp_noamp.....FAILED tests 483, 496 pragma/overload.....FAILED tests 152-153, 170-171 pragma/warnings.....FAILED tests 14, 82, 129, 155, 192, 205, 207 lib/bigfloat........FAILED tests 351-352, 355 lib/bigfltpm........FAILED tests 354-355, 358 lib/complex.........FAILED tests 267, 487 lib/dumper..........FAILED tests 43, 45 Failed 11/231 test scripts, 95.24% okay. 57/10595 subtests failed, 99.46% okay. =head2 Installing Perl on BS2000 We have no nroff on BS2000 POSIX (yet), so we ignored any errors while installing the documentation. =head2 Using Perl in the Posix-Shell of BS2000 BS2000 POSIX doesn't support the shebang notation (C<#!/usr/local/bin/perl>), so you have to use the following lines instead: : # use perl eval 'exec /usr/local/bin/perl -S $0 ${1+"$@"}' if $running_under_some_shell; =head2 Using Perl in "native" BS2000 We don't have much experience with this yet, but try the following: Copy your Perl executable to a BS2000 LLM using bs2cp: C Now you can start it with the following (SDF) command: C First you get the BS2000 commandline prompt ('*'). Here you may enter your parameters, e.g. C<-e 'print "Hello World!\\n";'> (note the double backslash!) or C<-w> and the name of your Perl script. Filenames starting with C are searched in the Posix filesystem, others are searched in the BS2000 filesystem. You may even use wildcards if you put a C<%> in front of your filename (e.g. C<-w checkfiles.pl %*.c>). Read your C/C++ manual for additional possibilities of the commandline prompt (look for PARAMETER-PROMPTING). =head2 Floating point anomalies on BS2000 There appears to be a bug in the floating point implementation on BS2000 POSIX systems such that calling int() on the product of a number and a small magnitude number is not the same as calling int() on the quotient of that number and a large magnitude number. For example, in the following Perl code: my $x = 100000.0; my $y = int($x * 1e-5) * 1e5; # '0' my $z = int($x / 1e+5) * 1e5; # '100000' print "\$y is $y and \$z is $z\n"; # $y is 0 and $z is 100000 Although one would expect the quantities $y and $z to be the same and equal to 100000 they will differ and instead will be 0 and 100000 respectively. =head2 Using PerlIO and different encodings on ASCII and EBCDIC partitions Since version 5.8 Perl uses the new PerlIO on BS2000. This enables you using different encodings per IO channel. For example you may use use Encode; open($f, ">:encoding(ascii)", "test.ascii"); print $f "Hello World!\n"; open($f, ">:encoding(posix-bc)", "test.ebcdic"); print $f "Hello World!\n"; open($f, ">:encoding(latin1)", "test.latin1"); print $f "Hello World!\n"; open($f, ">:encoding(utf8)", "test.utf8"); print $f "Hello World!\n"; to get two files containing "Hello World!\n" in ASCII, EBCDIC, ISO Latin-1 (in this example identical to ASCII) respective UTF-EBCDIC (in this example identical to normal EBCDIC). See the documentation of Encode::PerlIO for details. As the PerlIO layer uses raw IO internally, all this totally ignores the type of your filesystem (ASCII or EBCDIC) and the IO_CONVERSION environment variable. If you want to get the old behavior, that the BS2000 IO functions determine conversion depending on the filesystem PerlIO still is your friend. You use IO_CONVERSION as usual and tell Perl, that it should use the native IO layer: export IO_CONVERSION=YES export PERLIO=stdio Now your IO would be ASCII on ASCII partitions and EBCDIC on EBCDIC partitions. See the documentation of PerlIO (without C!) for further posibilities. =head1 AUTHORS Thomas Dorner =head1 SEE ALSO L, L. =head2 Mailing list If you are interested in the VM/ESA, z/OS (formerly known as OS/390) and POSIX-BC (BS2000) ports of Perl then see the perl-mvs mailing list. To subscribe, send an empty message to perl-mvs-subscribe@perl.org. See also: http://lists.perl.org/showlist.cgi?name=perl-mvs There are web archives of the mailing list at: http://www.xray.mpe.mpg.de/mailing-lists/perl-mvs/ http://archive.develooper.com/perl-mvs@perl.org/ =head1 HISTORY This document was originally written by Thomas Dorner for the 5.005 release of Perl. This document was podified for the 5.6 release of perl 11 July 2000. =cut perl-5.12.0-RC0/regcharclass.h0000644000175000017500000006323711325125742014756 0ustar jessejesse/* -*- buffer-read-only: t -*- * * regcharclass.h * * Copyright (C) 2007, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * * !!!!!!! DO NOT EDIT THIS FILE !!!!!!! * This file is built by Porting/regcharclass.pl. * * Any changes made here will be lost! * */ /* LNBREAK: Line Break: \R "\x0D\x0A" # CRLF - Network (Windows) line ending 0x0A # LF | LINE FEED 0x0B # VT | VERTICAL TAB 0x0C # FF | FORM FEED 0x0D # CR | CARRIAGE RETURN 0x85 # NEL | NEXT LINE 0x2028 # LINE SEPARATOR 0x2029 # PARAGRAPH SEPARATOR */ /*** GENERATED CODE ***/ #define is_LNBREAK(s,is_utf8) \ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0C ) ? 1 \ : ( 0x0D == ((U8*)s)[0] ) ? \ ( ( 0x0A == ((U8*)s)[1] ) ? 2 : 1 ) \ : ( is_utf8 ) ? \ ( ( 0xC2 == ((U8*)s)[0] ) ? \ ( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \ : ( 0xE2 == ((U8*)s)[0] ) ? \ ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0xA8 == ((U8*)s)[2] || 0xA9 == ((U8*)s)[2] ) ) ? 3 : 0 )\ : 0 ) \ : ( 0x85 == ((U8*)s)[0] ) ) /*** GENERATED CODE ***/ #define is_LNBREAK_safe(s,e,is_utf8) \ ( ((e)-(s) > 2) ? \ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0C ) ? 1 \ : ( 0x0D == ((U8*)s)[0] ) ? \ ( ( 0x0A == ((U8*)s)[1] ) ? 2 : 1 ) \ : ( is_utf8 ) ? \ ( ( 0xC2 == ((U8*)s)[0] ) ? \ ( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \ : ( 0xE2 == ((U8*)s)[0] ) ? \ ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0xA8 == ((U8*)s)[2] || 0xA9 == ((U8*)s)[2] ) ) ? 3 : 0 )\ : 0 ) \ : ( 0x85 == ((U8*)s)[0] ) ) \ : ((e)-(s) > 1) ? \ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0C ) ? 1 \ : ( 0x0D == ((U8*)s)[0] ) ? \ ( ( 0x0A == ((U8*)s)[1] ) ? 2 : 1 ) \ : ( is_utf8 ) ? \ ( ( ( 0xC2 == ((U8*)s)[0] ) && ( 0x85 == ((U8*)s)[1] ) ) ? 2 : 0 ) \ : ( 0x85 == ((U8*)s)[0] ) ) \ : ((e)-(s) > 0) ? \ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) ? 1 \ : ( !( is_utf8 ) ) ? \ ( 0x85 == ((U8*)s)[0] ) \ : 0 ) \ : 0 ) /*** GENERATED CODE ***/ #define is_LNBREAK_utf8(s) \ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0C ) ? 1 \ : ( 0x0D == ((U8*)s)[0] ) ? \ ( ( 0x0A == ((U8*)s)[1] ) ? 2 : 1 ) \ : ( 0xC2 == ((U8*)s)[0] ) ? \ ( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \ : ( 0xE2 == ((U8*)s)[0] ) ? \ ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0xA8 == ((U8*)s)[2] || 0xA9 == ((U8*)s)[2] ) ) ? 3 : 0 )\ : 0 ) /*** GENERATED CODE ***/ #define is_LNBREAK_utf8_safe(s,e) \ ( ((e)-(s) > 2) ? \ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0C ) ? 1 \ : ( 0x0D == ((U8*)s)[0] ) ? \ ( ( 0x0A == ((U8*)s)[1] ) ? 2 : 1 ) \ : ( 0xC2 == ((U8*)s)[0] ) ? \ ( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \ : ( 0xE2 == ((U8*)s)[0] ) ? \ ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0xA8 == ((U8*)s)[2] || 0xA9 == ((U8*)s)[2] ) ) ? 3 : 0 )\ : 0 ) \ : ((e)-(s) > 1) ? \ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0C ) ? 1 \ : ( 0x0D == ((U8*)s)[0] ) ? \ ( ( 0x0A == ((U8*)s)[1] ) ? 2 : 1 ) \ : ( 0xC2 == ((U8*)s)[0] ) ? \ ( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \ : 0 ) \ : ((e)-(s) > 0) ? \ ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) \ : 0 ) /*** GENERATED CODE ***/ #define is_LNBREAK_latin1(s) \ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0C ) ? 1 \ : ( 0x0D == ((U8*)s)[0] ) ? \ ( ( 0x0A == ((U8*)s)[1] ) ? 2 : 1 ) \ : ( 0x85 == ((U8*)s)[0] ) ) /*** GENERATED CODE ***/ #define is_LNBREAK_latin1_safe(s,e) \ ( ((e)-(s) > 1) ? \ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0C ) ? 1 \ : ( 0x0D == ((U8*)s)[0] ) ? \ ( ( 0x0A == ((U8*)s)[1] ) ? 2 : 1 ) \ : ( 0x85 == ((U8*)s)[0] ) ) \ : ((e)-(s) > 0) ? \ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) || 0x85 == ((U8*)s)[0] )\ : 0 ) /* HORIZWS: Horizontal Whitespace: \h \H 0x09 # HT 0x20 # SPACE 0xa0 # NBSP 0x1680 # OGHAM SPACE MARK 0x180e # MONGOLIAN VOWEL SEPARATOR 0x2000 # EN QUAD 0x2001 # EM QUAD 0x2002 # EN SPACE 0x2003 # EM SPACE 0x2004 # THREE-PER-EM SPACE 0x2005 # FOUR-PER-EM SPACE 0x2006 # SIX-PER-EM SPACE 0x2007 # FIGURE SPACE 0x2008 # PUNCTUATION SPACE 0x2009 # THIN SPACE 0x200A # HAIR SPACE 0x202f # NARROW NO-BREAK SPACE 0x205f # MEDIUM MATHEMATICAL SPACE 0x3000 # IDEOGRAPHIC SPACE */ /*** GENERATED CODE ***/ #define is_HORIZWS(s,is_utf8) \ ( ( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] ) ? 1 \ : ( is_utf8 ) ? \ ( ( 0xC2 == ((U8*)s)[0] ) ? \ ( ( 0xA0 == ((U8*)s)[1] ) ? 2 : 0 ) \ : ( 0xE1 == ((U8*)s)[0] ) ? \ ( ( 0x9A == ((U8*)s)[1] ) ? \ ( ( 0x80 == ((U8*)s)[2] ) ? 3 : 0 ) \ : ( 0xA0 == ((U8*)s)[1] ) ? \ ( ( 0x8E == ((U8*)s)[2] ) ? 3 : 0 ) \ : 0 ) \ : ( 0xE2 == ((U8*)s)[0] ) ? \ ( ( 0x80 == ((U8*)s)[1] ) ? \ ( ( ( 0x80 <= ((U8*)s)[2] && ((U8*)s)[2] <= 0x8A ) || 0xAF == ((U8*)s)[2] ) ? 3 : 0 )\ : ( 0x81 == ((U8*)s)[1] ) ? \ ( ( 0x9F == ((U8*)s)[2] ) ? 3 : 0 ) \ : 0 ) \ : ( 0xE3 == ((U8*)s)[0] ) ? \ ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0x80 == ((U8*)s)[2] ) ) ? 3 : 0 ) \ : 0 ) \ : ( 0xA0 == ((U8*)s)[0] ) ) /*** GENERATED CODE ***/ #define is_HORIZWS_safe(s,e,is_utf8) \ ( ((e)-(s) > 2) ? \ ( ( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] ) ? 1 \ : ( is_utf8 ) ? \ ( ( 0xC2 == ((U8*)s)[0] ) ? \ ( ( 0xA0 == ((U8*)s)[1] ) ? 2 : 0 ) \ : ( 0xE1 == ((U8*)s)[0] ) ? \ ( ( 0x9A == ((U8*)s)[1] ) ? \ ( ( 0x80 == ((U8*)s)[2] ) ? 3 : 0 ) \ : ( 0xA0 == ((U8*)s)[1] ) ? \ ( ( 0x8E == ((U8*)s)[2] ) ? 3 : 0 ) \ : 0 ) \ : ( 0xE2 == ((U8*)s)[0] ) ? \ ( ( 0x80 == ((U8*)s)[1] ) ? \ ( ( ( 0x80 <= ((U8*)s)[2] && ((U8*)s)[2] <= 0x8A ) || 0xAF == ((U8*)s)[2] ) ? 3 : 0 )\ : ( 0x81 == ((U8*)s)[1] ) ? \ ( ( 0x9F == ((U8*)s)[2] ) ? 3 : 0 ) \ : 0 ) \ : ( 0xE3 == ((U8*)s)[0] ) ? \ ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0x80 == ((U8*)s)[2] ) ) ? 3 : 0 )\ : 0 ) \ : ( 0xA0 == ((U8*)s)[0] ) ) \ : ((e)-(s) > 1) ? \ ( ( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] ) ? 1 \ : ( is_utf8 ) ? \ ( ( ( 0xC2 == ((U8*)s)[0] ) && ( 0xA0 == ((U8*)s)[1] ) ) ? 2 : 0 ) \ : ( 0xA0 == ((U8*)s)[0] ) ) \ : ((e)-(s) > 0) ? \ ( ( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] ) ? 1 \ : ( !( is_utf8 ) ) ? \ ( 0xA0 == ((U8*)s)[0] ) \ : 0 ) \ : 0 ) /*** GENERATED CODE ***/ #define is_HORIZWS_utf8(s) \ ( ( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] ) ? 1 \ : ( 0xC2 == ((U8*)s)[0] ) ? \ ( ( 0xA0 == ((U8*)s)[1] ) ? 2 : 0 ) \ : ( 0xE1 == ((U8*)s)[0] ) ? \ ( ( 0x9A == ((U8*)s)[1] ) ? \ ( ( 0x80 == ((U8*)s)[2] ) ? 3 : 0 ) \ : ( 0xA0 == ((U8*)s)[1] ) ? \ ( ( 0x8E == ((U8*)s)[2] ) ? 3 : 0 ) \ : 0 ) \ : ( 0xE2 == ((U8*)s)[0] ) ? \ ( ( 0x80 == ((U8*)s)[1] ) ? \ ( ( ( 0x80 <= ((U8*)s)[2] && ((U8*)s)[2] <= 0x8A ) || 0xAF == ((U8*)s)[2] ) ? 3 : 0 )\ : ( 0x81 == ((U8*)s)[1] ) ? \ ( ( 0x9F == ((U8*)s)[2] ) ? 3 : 0 ) \ : 0 ) \ : ( 0xE3 == ((U8*)s)[0] ) ? \ ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0x80 == ((U8*)s)[2] ) ) ? 3 : 0 ) \ : 0 ) /*** GENERATED CODE ***/ #define is_HORIZWS_utf8_safe(s,e) \ ( ((e)-(s) > 2) ? \ ( ( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] ) ? 1 \ : ( 0xC2 == ((U8*)s)[0] ) ? \ ( ( 0xA0 == ((U8*)s)[1] ) ? 2 : 0 ) \ : ( 0xE1 == ((U8*)s)[0] ) ? \ ( ( 0x9A == ((U8*)s)[1] ) ? \ ( ( 0x80 == ((U8*)s)[2] ) ? 3 : 0 ) \ : ( 0xA0 == ((U8*)s)[1] ) ? \ ( ( 0x8E == ((U8*)s)[2] ) ? 3 : 0 ) \ : 0 ) \ : ( 0xE2 == ((U8*)s)[0] ) ? \ ( ( 0x80 == ((U8*)s)[1] ) ? \ ( ( ( 0x80 <= ((U8*)s)[2] && ((U8*)s)[2] <= 0x8A ) || 0xAF == ((U8*)s)[2] ) ? 3 : 0 )\ : ( 0x81 == ((U8*)s)[1] ) ? \ ( ( 0x9F == ((U8*)s)[2] ) ? 3 : 0 ) \ : 0 ) \ : ( 0xE3 == ((U8*)s)[0] ) ? \ ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0x80 == ((U8*)s)[2] ) ) ? 3 : 0 ) \ : 0 ) \ : ((e)-(s) > 1) ? \ ( ( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] ) ? 1 \ : ( 0xC2 == ((U8*)s)[0] ) ? \ ( ( 0xA0 == ((U8*)s)[1] ) ? 2 : 0 ) \ : 0 ) \ : ((e)-(s) > 0) ? \ ( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] ) \ : 0 ) /*** GENERATED CODE ***/ #define is_HORIZWS_latin1(s) \ ( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] || 0xA0 == ((U8*)s)[0] ) /*** GENERATED CODE ***/ #define is_HORIZWS_latin1_safe(s,e) \ ( ((e)-(s) > 0) ? \ ( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] || 0xA0 == ((U8*)s)[0] ) \ : 0 ) /*** GENERATED CODE ***/ #define is_HORIZWS_cp(cp) \ ( 0x09 == cp || ( 0x09 < cp && \ ( 0x20 == cp || ( 0x20 < cp && \ ( 0xA0 == cp || ( 0xA0 < cp && \ ( 0x1680 == cp || ( 0x1680 < cp && \ ( 0x180E == cp || ( 0x180E < cp && \ ( ( 0x2000 <= cp && cp <= 0x200A ) || ( 0x200A < cp && \ ( 0x202F == cp || ( 0x202F < cp && \ ( 0x205F == cp || ( 0x205F < cp && \ 0x3000 == cp ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) /* VERTWS: Vertical Whitespace: \v \V 0x0A # LF 0x0B # VT 0x0C # FF 0x0D # CR 0x85 # NEL 0x2028 # LINE SEPARATOR 0x2029 # PARAGRAPH SEPARATOR */ /*** GENERATED CODE ***/ #define is_VERTWS(s,is_utf8) \ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) ? 1 \ : ( is_utf8 ) ? \ ( ( 0xC2 == ((U8*)s)[0] ) ? \ ( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \ : ( 0xE2 == ((U8*)s)[0] ) ? \ ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0xA8 == ((U8*)s)[2] || 0xA9 == ((U8*)s)[2] ) ) ? 3 : 0 )\ : 0 ) \ : ( 0x85 == ((U8*)s)[0] ) ) /*** GENERATED CODE ***/ #define is_VERTWS_safe(s,e,is_utf8) \ ( ((e)-(s) > 2) ? \ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) ? 1 \ : ( is_utf8 ) ? \ ( ( 0xC2 == ((U8*)s)[0] ) ? \ ( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \ : ( 0xE2 == ((U8*)s)[0] ) ? \ ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0xA8 == ((U8*)s)[2] || 0xA9 == ((U8*)s)[2] ) ) ? 3 : 0 )\ : 0 ) \ : ( 0x85 == ((U8*)s)[0] ) ) \ : ((e)-(s) > 1) ? \ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) ? 1 \ : ( is_utf8 ) ? \ ( ( ( 0xC2 == ((U8*)s)[0] ) && ( 0x85 == ((U8*)s)[1] ) ) ? 2 : 0 ) \ : ( 0x85 == ((U8*)s)[0] ) ) \ : ((e)-(s) > 0) ? \ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) ? 1 \ : ( !( is_utf8 ) ) ? \ ( 0x85 == ((U8*)s)[0] ) \ : 0 ) \ : 0 ) /*** GENERATED CODE ***/ #define is_VERTWS_utf8(s) \ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) ? 1 \ : ( 0xC2 == ((U8*)s)[0] ) ? \ ( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \ : ( 0xE2 == ((U8*)s)[0] ) ? \ ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0xA8 == ((U8*)s)[2] || 0xA9 == ((U8*)s)[2] ) ) ? 3 : 0 )\ : 0 ) /*** GENERATED CODE ***/ #define is_VERTWS_utf8_safe(s,e) \ ( ((e)-(s) > 2) ? \ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) ? 1 \ : ( 0xC2 == ((U8*)s)[0] ) ? \ ( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \ : ( 0xE2 == ((U8*)s)[0] ) ? \ ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0xA8 == ((U8*)s)[2] || 0xA9 == ((U8*)s)[2] ) ) ? 3 : 0 )\ : 0 ) \ : ((e)-(s) > 1) ? \ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) ? 1 \ : ( 0xC2 == ((U8*)s)[0] ) ? \ ( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \ : 0 ) \ : ((e)-(s) > 0) ? \ ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) \ : 0 ) /*** GENERATED CODE ***/ #define is_VERTWS_latin1(s) \ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) || 0x85 == ((U8*)s)[0] ) /*** GENERATED CODE ***/ #define is_VERTWS_latin1_safe(s,e) \ ( ((e)-(s) > 0) ? \ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) || 0x85 == ((U8*)s)[0] )\ : 0 ) /*** GENERATED CODE ***/ #define is_VERTWS_cp(cp) \ ( ( 0x0A <= cp && cp <= 0x0D ) || ( 0x0D < cp && \ ( 0x85 == cp || ( 0x85 < cp && \ ( 0x2028 == cp || ( 0x2028 < cp && \ 0x2029 == cp ) ) ) ) ) ) /* TRICKYFOLD: Problematic fold case letters. 0x00DF # LATIN1 SMALL LETTER SHARP S 0x0390 # GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS 0x03B0 # GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS */ /*** GENERATED CODE ***/ #define is_TRICKYFOLD(s,is_utf8) \ ( ( is_utf8 ) ? \ ( ( 0xC3 == ((U8*)s)[0] ) ? \ ( ( 0x9F == ((U8*)s)[1] ) ? 2 : 0 ) \ : ( 0xCE == ((U8*)s)[0] ) ? \ ( ( 0x90 == ((U8*)s)[1] || 0xB0 == ((U8*)s)[1] ) ? 2 : 0 ) \ : 0 ) \ : ( 0xDF == ((U8*)s)[0] ) ) /*** GENERATED CODE ***/ #define is_TRICKYFOLD_safe(s,e,is_utf8) \ ( ((e)-(s) > 1) ? \ ( ( is_utf8 ) ? \ ( ( 0xC3 == ((U8*)s)[0] ) ? \ ( ( 0x9F == ((U8*)s)[1] ) ? 2 : 0 ) \ : ( 0xCE == ((U8*)s)[0] ) ? \ ( ( 0x90 == ((U8*)s)[1] || 0xB0 == ((U8*)s)[1] ) ? 2 : 0 ) \ : 0 ) \ : ( 0xDF == ((U8*)s)[0] ) ) \ : ((e)-(s) > 0) ? \ ( ( !( is_utf8 ) ) ? \ ( 0xDF == ((U8*)s)[0] ) \ : 0 ) \ : 0 ) /*** GENERATED CODE ***/ #define is_TRICKYFOLD_cp(cp) \ ( 0xDF == cp || ( 0xDF < cp && \ ( 0x390 == cp || ( 0x390 < cp && \ 0x3B0 == cp ) ) ) ) /*** GENERATED CODE ***/ #define what_TRICKYFOLD(s,is_utf8) \ ( ( is_utf8 ) ? \ ( ( 0xC3 == ((U8*)s)[0] ) ? \ ( ( 0x9F == ((U8*)s)[1] ) ? 0xDF : 0 ) \ : ( 0xCE == ((U8*)s)[0] ) ? \ ( ( 0x90 == ((U8*)s)[1] ) ? 0x390 \ : ( 0xB0 == ((U8*)s)[1] ) ? 0x3B0 : 0 ) \ : 0 ) \ : ( 0xDF == ((U8*)s)[0] ) ? 0xDF : 0 ) /*** GENERATED CODE ***/ #define what_TRICKYFOLD_safe(s,e,is_utf8) \ ( ((e)-(s) > 1) ? \ ( ( is_utf8 ) ? \ ( ( 0xC3 == ((U8*)s)[0] ) ? \ ( ( 0x9F == ((U8*)s)[1] ) ? 0xDF : 0 ) \ : ( 0xCE == ((U8*)s)[0] ) ? \ ( ( 0x90 == ((U8*)s)[1] ) ? 0x390 \ : ( 0xB0 == ((U8*)s)[1] ) ? 0x3B0 : 0 ) \ : 0 ) \ : ( 0xDF == ((U8*)s)[0] ) ? 0xDF : 0 ) \ : ((e)-(s) > 0) ? \ ( ( ( !( is_utf8 ) ) && ( 0xDF == ((U8*)s)[0] ) ) ? 0xDF : 0 ) \ : 0 ) /*** GENERATED CODE ***/ #define what_len_TRICKYFOLD(s,is_utf8,len) \ ( ( is_utf8 ) ? \ ( ( 0xC3 == ((U8*)s)[0] ) ? \ ( ( 0x9F == ((U8*)s)[1] ) ? len=2, 0xDF : 0 ) \ : ( 0xCE == ((U8*)s)[0] ) ? \ ( ( 0x90 == ((U8*)s)[1] ) ? len=2, 0x390 \ : ( 0xB0 == ((U8*)s)[1] ) ? len=2, 0x3B0 : 0 ) \ : 0 ) \ : ( 0xDF == ((U8*)s)[0] ) ? len=1, 0xDF : 0 ) /*** GENERATED CODE ***/ #define what_len_TRICKYFOLD_safe(s,e,is_utf8,len) \ ( ((e)-(s) > 1) ? \ ( ( is_utf8 ) ? \ ( ( 0xC3 == ((U8*)s)[0] ) ? \ ( ( 0x9F == ((U8*)s)[1] ) ? len=2, 0xDF : 0 ) \ : ( 0xCE == ((U8*)s)[0] ) ? \ ( ( 0x90 == ((U8*)s)[1] ) ? len=2, 0x390 \ : ( 0xB0 == ((U8*)s)[1] ) ? len=2, 0x3B0 : 0 ) \ : 0 ) \ : ( 0xDF == ((U8*)s)[0] ) ? len=1, 0xDF : 0 ) \ : ((e)-(s) > 0) ? \ ( ( ( !( is_utf8 ) ) && ( 0xDF == ((U8*)s)[0] ) ) ? len=1, 0xDF : 0 ) \ : 0 ) /* ex: set ro: */ perl-5.12.0-RC0/intrpvar.h0000444000175000017500000005642011325127001014142 0ustar jessejesse/* intrpvar.h * * Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, * 2006, 2007, 2008 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* =head1 Per-Interpreter Variables */ /* These variables are per-interpreter in threaded/multiplicity builds, * global otherwise. * Don't forget to re-run embed.pl to propagate changes! */ /* New variables must be added to the very end for binary compatibility. * XSUB.h provides wrapper functions via perlapi.h that make this * irrelevant, but not all code may be expected to #include XSUB.h. */ /* Don't forget to add your variable also to perl_clone()! */ /* The 'I' prefix is only needed for vars that need appropriate #defines * generated when built with or without MULTIPLICITY. It is also used * to generate the appropriate export list for win32. * * When building without MULTIPLICITY, these variables will be truly global. * * Important ones in the first cache line (if alignment is done right) */ PERLVAR(Istack_sp, SV **) /* top of the stack */ #ifdef OP_IN_REGISTER PERLVAR(Iopsave, OP *) #else PERLVAR(Iop, OP *) /* currently executing op */ #endif PERLVAR(Icurpad, SV **) /* active pad (lexicals+tmps) */ PERLVAR(Istack_base, SV **) PERLVAR(Istack_max, SV **) PERLVAR(Iscopestack, I32 *) /* scopes we've ENTERed */ /* name of the scopes we've ENTERed. Only used with -DDEBUGGING, but needs to be present always, as -DDEUBGGING must be binary compatible with non. */ PERLVARI(Iscopestack_name, const char * *, NULL) PERLVAR(Iscopestack_ix, I32) PERLVAR(Iscopestack_max,I32) PERLVAR(Isavestack, ANY *) /* items that need to be restored when LEAVEing scopes we've ENTERed */ PERLVAR(Isavestack_ix, I32) PERLVAR(Isavestack_max, I32) PERLVAR(Itmps_stack, SV **) /* mortals we've made */ PERLVARI(Itmps_ix, I32, -1) PERLVARI(Itmps_floor, I32, -1) PERLVAR(Itmps_max, I32) PERLVAR(Imodcount, I32) /* how much mod()ification in assignment? */ PERLVAR(Imarkstack, I32 *) /* stack_sp locations we're remembering */ PERLVAR(Imarkstack_ptr, I32 *) PERLVAR(Imarkstack_max, I32 *) PERLVAR(ISv, SV *) /* used to hold temporary values */ PERLVAR(IXpv, XPV *) /* used to hold temporary values */ /* =for apidoc Amn|STRLEN|PL_na A convenience variable which is typically used with C when one doesn't care about the length of the string. It is usually more efficient to either declare a local variable and use that instead or to use the C macro. =cut */ PERLVAR(Ina, STRLEN) /* for use in SvPV when length is Not Applicable */ /* stat stuff */ PERLVAR(Istatbuf, Stat_t) PERLVAR(Istatcache, Stat_t) /* _ */ PERLVAR(Istatgv, GV *) PERLVARI(Istatname, SV *, NULL) #ifdef HAS_TIMES PERLVAR(Itimesbuf, struct tms) #endif /* Fields used by magic variables such as $@, $/ and so on */ PERLVAR(Icurpm, PMOP *) /* what to do \ interps in REs from */ /* =for apidoc mn|SV*|PL_rs The input record separator - C<$/> in Perl space. =for apidoc mn|GV*|PL_last_in_gv The GV which was last used for a filehandle input operation. (C<< >>) =for apidoc mn|GV*|PL_ofsgv The glob containing the output field separator - C<*,> in Perl space. =cut */ PERLVAR(Irs, SV *) /* input record separator $/ */ PERLVAR(Ilast_in_gv, GV *) /* GV used in last */ PERLVAR(Iofsgv, GV *) /* GV of output field separator *, */ PERLVAR(Idefoutgv, GV *) /* default FH for output */ PERLVARI(Ichopset, const char *, " \n-") /* $: */ PERLVAR(Iformtarget, SV *) PERLVAR(Ibodytarget, SV *) PERLVAR(Itoptarget, SV *) /* Stashes */ PERLVAR(Idefstash, HV *) /* main symbol table */ PERLVAR(Icurstash, HV *) /* symbol table for current package */ PERLVAR(Irestartop, OP *) /* propagating an error from croak? */ PERLVAR(Icurcop, COP *) PERLVAR(Icurstack, AV *) /* THE STACK */ PERLVAR(Icurstackinfo, PERL_SI *) /* current stack + context */ PERLVAR(Imainstack, AV *) /* the stack when nothing funny is happening */ PERLVAR(Itop_env, JMPENV *) /* ptr to current sigjmp environment */ PERLVAR(Istart_env, JMPENV) /* empty startup sigjmp environment */ PERLVARI(Ierrors, SV *, NULL) /* outstanding queued errors */ /* statics "owned" by various functions */ PERLVAR(Ihv_fetch_ent_mh, HE*) /* owned by hv_fetch_ent() */ PERLVAR(Ilastgotoprobe, OP*) /* from pp_ctl.c */ /* sort stuff */ PERLVAR(Isortcop, OP *) /* user defined sort routine */ PERLVAR(Isortstash, HV *) /* which is in some package or other */ PERLVAR(Ifirstgv, GV *) /* $a */ PERLVAR(Isecondgv, GV *) /* $b */ /* float buffer */ PERLVAR(Iefloatbuf, char *) PERLVAR(Iefloatsize, STRLEN) /* regex stuff */ PERLVAR(Iscreamfirst, I32 *) PERLVAR(Iscreamnext, I32 *) PERLVAR(Ilastscream, SV *) PERLVAR(Ireg_state, struct re_save_state) PERLVAR(Iregdummy, regnode) /* from regcomp.c */ PERLVARI(Idumpindent, U16, 4) /* number of blanks per dump indentation level */ PERLVAR(Iutf8locale, bool) /* utf8 locale detected */ PERLVARI(Irehash_seed_set, bool, FALSE) /* 582 hash initialized? */ PERLVARA(Icolors,6, char *) /* from regcomp.c */ PERLVARI(Ipeepp, peep_t, MEMBER_TO_FPTR(Perl_peep)) /* Pointer to peephole optimizer */ /* =for apidoc Amn|Perl_ophook_t|PL_opfreehook When non-C, the function pointed by this variable will be called each time an OP is freed with the corresponding OP as the argument. This allows extensions to free any extra attribute they have locally attached to an OP. It is also assured to first fire for the parent OP and then for its kids. When you replace this variable, it is considered a good practice to store the possibly previously installed hook and that you recall it inside your own. =cut */ PERLVARI(Iopfreehook, Perl_ophook_t, 0) /* op_free() hook */ PERLVARI(Imaxscream, I32, -1) PERLVARI(Ireginterp_cnt,I32, 0) /* Whether "Regexp" was interpolated. */ PERLVARI(Iwatchaddr, char **, 0) PERLVAR(Iwatchok, char *) /* the currently active slab in a chain of slabs of regmatch states, * and the currently active state within that slab */ PERLVARI(Iregmatch_slab, regmatch_slab *, NULL) PERLVAR(Iregmatch_state, regmatch_state *) /* Put anything new that is pointer aligned here. */ PERLVAR(Idelaymagic, U16) /* ($<,$>) = ... */ PERLVAR(Ilocalizing, U8) /* are we processing a local() list? */ PERLVAR(Icolorset, bool) /* from regcomp.c */ PERLVARI(Idirty, bool, FALSE) /* in the middle of tearing things down? */ PERLVAR(Iin_eval, U8) /* trap "fatal" errors? */ PERLVAR(Itainted, bool) /* using variables controlled by $< */ /* This value may be set when embedding for full cleanup */ /* 0=none, 1=full, 2=full with checks */ /* mod_perl is special, and also assigns a meaning -1 */ PERLVARI(Iperl_destruct_level, signed char, 0) PERLVAR(Iperldb, U32) /* pseudo environmental stuff */ PERLVAR(Iorigargc, int) PERLVAR(Iorigargv, char **) PERLVAR(Ienvgv, GV *) PERLVAR(Iincgv, GV *) PERLVAR(Ihintgv, GV *) PERLVAR(Iorigfilename, char *) PERLVAR(Idiehook, SV *) PERLVAR(Iwarnhook, SV *) /* switches */ PERLVAR(Ipatchlevel, SV *) PERLVAR(Ilocalpatches, const char * const *) PERLVARI(Isplitstr, const char *, " ") PERLVAR(Iminus_c, bool) PERLVAR(Iminus_n, bool) PERLVAR(Iminus_p, bool) PERLVAR(Iminus_l, bool) PERLVAR(Iminus_a, bool) PERLVAR(Iminus_F, bool) PERLVAR(Idoswitches, bool) PERLVAR(Iminus_E, bool) /* =for apidoc mn|bool|PL_dowarn The C variable which corresponds to Perl's $^W warning variable. =cut */ PERLVAR(Idowarn, U8) PERLVAR(Idoextract, bool) PERLVAR(Isawampersand, bool) /* must save all match strings */ PERLVAR(Iunsafe, bool) PERLVAR(Iexit_flags, U8) /* was exit() unexpected, etc. */ PERLVAR(Isrand_called, bool) /* Part of internal state, but makes the 16th 1 byte variable in a row. */ PERLVAR(Itainting, bool) /* doing taint checks */ /* Space for a U8 */ PERLVAR(Iinplace, char *) PERLVAR(Ie_script, SV *) /* magical thingies */ PERLVAR(Ibasetime, Time_t) /* $^T */ PERLVAR(Iformfeed, SV *) /* $^L */ PERLVARI(Imaxsysfd, I32, MAXSYSFD) /* top fd to pass to subprocesses */ PERLVAR(Istatusvalue, I32) /* $? */ #ifdef VMS PERLVAR(Istatusvalue_vms,U32) #else PERLVAR(Istatusvalue_posix,I32) #endif PERLVARI(Isig_pending, int,0) /* Number if highest signal pending */ PERLVAR(Ipsig_pend, int *) /* per-signal "count" of pending */ /* shortcuts to various I/O objects */ PERLVAR(Istdingv, GV *) PERLVAR(Istderrgv, GV *) PERLVAR(Idefgv, GV *) PERLVAR(Iargvgv, GV *) PERLVAR(Iargvoutgv, GV *) PERLVAR(Iargvout_stack, AV *) /* shortcuts to regexp stuff */ PERLVAR(Ireplgv, GV *) /* shortcuts to misc objects */ PERLVAR(Ierrgv, GV *) /* shortcuts to debugging objects */ PERLVAR(IDBgv, GV *) PERLVAR(IDBline, GV *) /* =for apidoc mn|GV *|PL_DBsub When Perl is run in debugging mode, with the B<-d> switch, this GV contains the SV which holds the name of the sub being debugged. This is the C variable which corresponds to Perl's $DB::sub variable. See C. =for apidoc mn|SV *|PL_DBsingle When Perl is run in debugging mode, with the B<-d> switch, this SV is a boolean which indicates whether subs are being single-stepped. Single-stepping is automatically turned on after every step. This is the C variable which corresponds to Perl's $DB::single variable. See C. =for apidoc mn|SV *|PL_DBtrace Trace variable used when Perl is run in debugging mode, with the B<-d> switch. This is the C variable which corresponds to Perl's $DB::trace variable. See C. =cut */ PERLVAR(IDBsub, GV *) PERLVAR(IDBsingle, SV *) PERLVAR(IDBtrace, SV *) PERLVAR(IDBsignal, SV *) PERLVAR(Idbargs, AV *) /* args to call listed by caller function */ /* symbol tables */ PERLVAR(Idebstash, HV *) /* symbol table for perldb package */ PERLVAR(Iglobalstash, HV *) /* global keyword overrides imported here */ PERLVAR(Icurstname, SV *) /* name of current package */ PERLVAR(Ibeginav, AV *) /* names of BEGIN subroutines */ PERLVAR(Iendav, AV *) /* names of END subroutines */ PERLVAR(Iunitcheckav, AV *) /* names of UNITCHECK subroutines */ PERLVAR(Icheckav, AV *) /* names of CHECK subroutines */ PERLVAR(Iinitav, AV *) /* names of INIT subroutines */ PERLVAR(Istrtab, HV *) /* shared string table */ PERLVARI(Isub_generation,U32,1) /* incr to invalidate method cache */ /* funky return mechanisms */ PERLVAR(Iforkprocess, int) /* so do_open |- can return proc# */ /* memory management */ PERLVAR(Isv_count, I32) /* how many SV* are currently allocated */ PERLVAR(Isv_objcount, I32) /* how many objects are currently allocated */ PERLVAR(Isv_root, SV*) /* storage for SVs belonging to interp */ PERLVAR(Isv_arenaroot, SV*) /* list of areas for garbage collection */ /* subprocess state */ PERLVAR(Ifdpid, AV *) /* keep fd-to-pid mappings for my_popen */ /* internal state */ PERLVARI(Iop_mask, char *, NULL) /* masked operations for safe evals */ /* current interpreter roots */ PERLVAR(Imain_cv, CV *) PERLVAR(Imain_root, OP *) PERLVAR(Imain_start, OP *) PERLVAR(Ieval_root, OP *) PERLVAR(Ieval_start, OP *) /* runtime control stuff */ PERLVARI(Icurcopdb, COP *, NULL) PERLVAR(Ifilemode, int) /* so nextargv() can preserve mode */ PERLVAR(Ilastfd, int) /* what to preserve mode on */ PERLVAR(Ioldname, char *) /* what to preserve mode on */ PERLVAR(IArgv, const char **) /* stuff to free from do_aexec, vfork safe */ PERLVAR(ICmd, char *) /* stuff to free from do_aexec, vfork safe */ /* Elements in this array have ';' appended and are injected as a single line into the tokeniser. You can't put any (literal) newlines into any program you stuff in into this array, as the point where it's injected is expecting a single physical line. */ PERLVAR(Ipreambleav, AV *) PERLVAR(Imess_sv, SV *) PERLVAR(Iors_sv, SV *) /* output record separator $\ */ /* statics moved here for shared library purposes */ PERLVARI(Igensym, I32, 0) /* next symbol for getsym() to define */ PERLVARI(Icv_has_eval, bool, FALSE) /* PL_compcv includes an entereval or similar */ PERLVAR(Itaint_warn, bool) /* taint warns instead of dying */ PERLVARI(Ilaststype, U16, OP_STAT) PERLVARI(Ilaststatval, int, -1) /* interpreter atexit processing */ PERLVARI(Iexitlistlen, I32, 0) /* length of same */ PERLVARI(Iexitlist, PerlExitListEntry *, NULL) /* list of exit functions */ /* =for apidoc Amn|HV*|PL_modglobal C is a general purpose, interpreter global HV for use by extensions that need to keep information on a per-interpreter basis. In a pinch, it can also be used as a symbol table for extensions to share data among each other. It is a good idea to use keys prefixed by the package name of the extension that owns the data. =cut */ PERLVAR(Imodglobal, HV *) /* per-interp module data */ /* these used to be in global before 5.004_68 */ PERLVARI(Iprofiledata, U32 *, NULL) /* table of ops, counts */ PERLVAR(Icompiling, COP) /* compiling/done executing marker */ PERLVAR(Icompcv, CV *) /* currently compiling subroutine */ PERLVAR(Icomppad, AV *) /* storage for lexically scoped temporaries */ PERLVAR(Icomppad_name, AV *) /* variable names for "my" variables */ PERLVAR(Icomppad_name_fill, I32) /* last "introduced" variable offset */ PERLVAR(Icomppad_name_floor, I32) /* start of vars in innermost block */ #ifdef HAVE_INTERP_INTERN PERLVAR(Isys_intern, struct interp_intern) /* platform internals */ #endif /* more statics moved here */ PERLVAR(IDBcv, CV *) /* from perl.c */ PERLVARI(Igeneration, int, 100) /* from op.c */ PERLVARI(Iin_clean_objs,bool, FALSE) /* from sv.c */ PERLVARI(Iin_clean_all, bool, FALSE) /* from sv.c */ PERLVAR(Inomemok, bool) /* let malloc context handle nomem */ PERLVARI(Isavebegin, bool, FALSE) /* save BEGINs for compiler */ PERLVAR(Iuid, Uid_t) /* current real user id */ PERLVAR(Ieuid, Uid_t) /* current effective user id */ PERLVAR(Igid, Gid_t) /* current real group id */ PERLVAR(Iegid, Gid_t) /* current effective group id */ PERLVARI(Ian, U32, 0) /* malloc sequence number */ PERLVARI(Icop_seqmax, U32, 0) /* statement sequence number */ PERLVARI(Ievalseq, U32, 0) /* eval sequence number */ PERLVAR(Iorigalen, U32) PERLVAR(Iorigenviron, char **) #ifdef PERL_USES_PL_PIDSTATUS PERLVAR(Ipidstatus, HV *) /* pid-to-status mappings for waitpid */ #endif PERLVAR(Iosname, char *) /* operating system */ PERLVAR(Isighandlerp, Sighandler_t) PERLVARA(Ibody_roots, PERL_ARENA_ROOTS_SIZE, void*) /* array of body roots */ PERLVAR(Inice_chunk, char *) /* a nice chunk of memory to reuse */ PERLVAR(Inice_chunk_size, U32) /* how nice the chunk of memory is */ PERLVARI(Imaxo, int, MAXO) /* maximum number of ops */ PERLVARI(Irunops, runops_proc_t, MEMBER_TO_FPTR(RUNOPS_DEFAULT)) /* =for apidoc Amn|SV|PL_sv_undef This is the C SV. Always refer to this as C<&PL_sv_undef>. =for apidoc Amn|SV|PL_sv_no This is the C SV. See C. Always refer to this as C<&PL_sv_no>. =for apidoc Amn|SV|PL_sv_yes This is the C SV. See C. Always refer to this as C<&PL_sv_yes>. =cut */ PERLVAR(Isv_undef, SV) PERLVAR(Isv_no, SV) PERLVAR(Isv_yes, SV) PERLVAR(Isubname, SV *) /* name of current subroutine */ PERLVAR(Isubline, I32) /* line this subroutine began on */ PERLVAR(Imin_intro_pending, I32) /* start of vars to introduce */ PERLVAR(Imax_intro_pending, I32) /* end of vars to introduce */ PERLVAR(Ipadix, I32) /* max used index in current "register" pad */ PERLVAR(Ipadix_floor, I32) /* how low may inner block reset padix */ PERLVAR(Ihints, U32) /* pragma-tic compile-time flags */ PERLVAR(Idebug, VOL U32) /* flags given to -D switch */ /* Perl_Ibreakable_sub_generation_ptr was too long for VMS, hence "gen" */ PERLVARI(Ibreakable_sub_gen, U32, 0) PERLVARI(Iamagic_generation, long, 0) #ifdef USE_LOCALE_COLLATE PERLVAR(Icollation_name,char *) /* Name of current collation */ PERLVAR(Icollxfrm_base, Size_t) /* Basic overhead in *xfrm() */ PERLVARI(Icollxfrm_mult,Size_t, 2) /* Expansion factor in *xfrm() */ PERLVARI(Icollation_ix, U32, 0) /* Collation generation index */ PERLVARI(Icollation_standard, bool, TRUE) /* Assume simple collation */ #endif /* USE_LOCALE_COLLATE */ #if defined (PERL_UTF8_CACHE_ASSERT) || defined (DEBUGGING) # define PERL___I -1 #else # define PERL___I 1 #endif PERLVARI(Iutf8cache, I8, PERL___I) /* Is the utf8 caching code enabled? */ #undef PERL___I #ifdef USE_LOCALE_NUMERIC PERLVARI(Inumeric_standard, bool, TRUE) /* Assume simple numerics */ PERLVARI(Inumeric_local, bool, TRUE) /* Assume local numerics */ PERLVAR(Inumeric_name, char *) /* Name of current numeric locale */ #endif /* !USE_LOCALE_NUMERIC */ /* utf8 character classes */ PERLVAR(Iutf8_alnum, SV *) PERLVAR(Iutf8_ascii, SV *) PERLVAR(Iutf8_alpha, SV *) PERLVAR(Iutf8_space, SV *) PERLVAR(Iutf8_perl_space, SV *) PERLVAR(Iutf8_perl_word, SV *) PERLVAR(Iutf8_posix_digit, SV *) PERLVAR(Iutf8_cntrl, SV *) PERLVAR(Iutf8_graph, SV *) PERLVAR(Iutf8_digit, SV *) PERLVAR(Iutf8_upper, SV *) PERLVAR(Iutf8_lower, SV *) PERLVAR(Iutf8_print, SV *) PERLVAR(Iutf8_punct, SV *) PERLVAR(Iutf8_xdigit, SV *) PERLVAR(Iutf8_mark, SV *) PERLVAR(Iutf8_X_begin, SV *) PERLVAR(Iutf8_X_extend, SV *) PERLVAR(Iutf8_X_prepend, SV *) PERLVAR(Iutf8_X_non_hangul, SV *) PERLVAR(Iutf8_X_L, SV *) PERLVAR(Iutf8_X_LV, SV *) PERLVAR(Iutf8_X_LVT, SV *) PERLVAR(Iutf8_X_T, SV *) PERLVAR(Iutf8_X_V, SV *) PERLVAR(Iutf8_X_LV_LVT_V, SV *) PERLVAR(Iutf8_toupper, SV *) PERLVAR(Iutf8_totitle, SV *) PERLVAR(Iutf8_tolower, SV *) PERLVAR(Iutf8_tofold, SV *) PERLVAR(Ilast_swash_hv, HV *) PERLVAR(Ilast_swash_tmps, U8 *) PERLVAR(Ilast_swash_slen, STRLEN) PERLVARA(Ilast_swash_key,10, U8) PERLVAR(Ilast_swash_klen, U8) /* Only needs to store 0-10 */ #ifdef FCRYPT PERLVARI(Icryptseen, bool, FALSE) /* has fast crypt() been initialized? */ #endif PERLVAR(Ipad_reset_pending, bool) /* reset pad on next attempted alloc */ PERLVARI(Iglob_index, int, 0) PERLVAR(Iparser, yy_parser *) /* current parser state */ /* Array of signal handlers, indexed by signal number, through which the C signal handler dispatches. */ PERLVAR(Ipsig_ptr, SV**) /* Array of names of signals, indexed by signal number, for (re)use as the first argument to a signal handler. Only one block of memory is allocated for both psig_name and psig_ptr. */ PERLVAR(Ipsig_name, SV**) #if defined(PERL_IMPLICIT_SYS) PERLVAR(IMem, struct IPerlMem*) PERLVAR(IMemShared, struct IPerlMem*) PERLVAR(IMemParse, struct IPerlMem*) PERLVAR(IEnv, struct IPerlEnv*) PERLVAR(IStdIO, struct IPerlStdIO*) PERLVAR(ILIO, struct IPerlLIO*) PERLVAR(IDir, struct IPerlDir*) PERLVAR(ISock, struct IPerlSock*) PERLVAR(IProc, struct IPerlProc*) #endif PERLVAR(Iptr_table, PTR_TBL_t*) PERLVARI(Ibeginav_save, AV*, NULL) /* save BEGIN{}s when compiling */ PERLVAR(Ibody_arenas, void*) /* pointer to list of body-arenas */ #ifdef USE_LOCALE_NUMERIC PERLVAR(Inumeric_radix_sv, SV *) /* The radix separator if not '.' */ #endif #if defined(USE_ITHREADS) PERLVAR(Iregex_pad, SV**) /* Shortcut into the array of regex_padav */ PERLVAR(Iregex_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 */ #endif #ifdef USE_REENTRANT_API PERLVAR(Ireentrant_buffer, REENTR*) /* here we store the _r buffers */ #endif PERLVAR(Icustom_op_names, HV*) /* Names of user defined ops */ PERLVAR(Icustom_op_descs, HV*) /* Descriptions of user defined ops */ #ifdef PERLIO_LAYERS PERLVARI(Iperlio, PerlIO *,NULL) PERLVARI(Iknown_layers, PerlIO_list_t *,NULL) PERLVARI(Idef_layerlist, PerlIO_list_t *,NULL) #endif PERLVARI(Iencoding, SV*, NULL) /* character encoding */ PERLVAR(Idebug_pad, struct perl_debug_pad) /* always needed because of the re extension */ PERLVAR(Iutf8_idstart, SV *) PERLVAR(Iutf8_idcont, SV *) PERLVAR(Isort_RealCmp, SVCOMPARE_t) PERLVARI(Icheckav_save, AV*, NULL) /* save CHECK{}s when compiling */ PERLVARI(Iunitcheckav_save, AV*, NULL) /* save UNITCHECK{}s when compiling */ PERLVARI(Iclocktick, long, 0) /* this many times() ticks in a second */ PERLVARI(Iin_load_module, int, 0) /* to prevent recursions in PerlIO_find_layer */ PERLVAR(Iunicode, U32) /* Unicode features: $ENV{PERL_UNICODE} or -C */ PERLVAR(Isignals, U32) /* Using which pre-5.8 signals */ PERLVAR(Ireentrant_retint, int) /* Integer return value from reentrant functions */ PERLVAR(Istashcache, HV *) /* Cache to speed up S_method_common */ /* Hooks to shared SVs and locks. */ PERLVARI(Isharehook, share_proc_t, MEMBER_TO_FPTR(Perl_sv_nosharing)) PERLVARI(Ilockhook, share_proc_t, MEMBER_TO_FPTR(Perl_sv_nosharing)) #ifdef NO_MATHOMS # define PERL_UNLOCK_HOOK Perl_sv_nosharing #else /* This reference ensures that the mathoms are linked with perl */ # define PERL_UNLOCK_HOOK Perl_sv_nounlocking #endif PERLVARI(Iunlockhook, share_proc_t, MEMBER_TO_FPTR(PERL_UNLOCK_HOOK)) PERLVARI(Ithreadhook, thrhook_proc_t, MEMBER_TO_FPTR(Perl_nothreadhook)) PERLVARI(Ihash_seed, UV, 0) /* Hash initializer */ PERLVARI(Irehash_seed, UV, 0) /* 582 hash initializer */ PERLVARI(Iisarev, HV*, NULL) /* Reverse map of @ISA dependencies */ /* The last unconditional member of the interpreter structure when 5.10.0 was released. The offset of the end of this is baked into a global variable in any shared perl library which will allow a sanity test in future perl releases. */ #define PERL_LAST_5_10_0_INTERP_MEMBER Iisarev #ifdef PERL_IMPLICIT_CONTEXT PERLVARI(Imy_cxt_size, int, 0) /* size of PL_my_cxt_list */ PERLVARI(Imy_cxt_list, void **, NULL) /* per-module array of MY_CXT pointers */ # ifdef PERL_GLOBAL_STRUCT_PRIVATE PERLVARI(Imy_cxt_keys, const char **, NULL) /* per-module array of pointers to MY_CXT_KEY constants */ # endif #endif #ifdef PERL_TRACK_MEMPOOL /* For use with the memory debugging code in util.c */ PERLVAR(Imemory_debug_header, struct perl_memory_debug_header) #endif #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP /* File descriptor to talk to the child which dumps scalars. */ PERLVARI(Idumper_fd, int, -1) #endif /* Stores the PPID */ #ifdef THREADS_HAVE_PIDS PERLVARI(Ippid, IV, 0) #endif #ifdef PERL_MAD PERLVARI(Imadskills, bool, FALSE) /* preserve all syntactic info */ /* (MAD = Misc Attribute Decoration) */ PERLVARI(Ixmlfp, PerlIO *,NULL) #endif #ifdef PL_OP_SLAB_ALLOC PERLVAR(IOpPtr,I32 **) PERLVARI(IOpSpace,I32,0) PERLVAR(IOpSlab,I32 *) #endif #ifdef PERL_DEBUG_READONLY_OPS PERLVARI(Islabs, I32**, NULL) /* Array of slabs that have been allocated */ PERLVARI(Islab_count, U32, 0) /* Size of the array */ #endif /* Can shared object be destroyed */ PERLVARI(Idestroyhook, destroyable_proc_t, MEMBER_TO_FPTR(Perl_sv_destroyable)) #ifdef DEBUG_LEAKING_SCALARS PERLVARI(Isv_serial, U32, 0) /* SV serial number, used in sv.c */ #endif /* Register of known Method Resolution Orders. What this actually points to is an implementation detail (it may change to a structure incorporating a reference count - use mro_get_from_name to retrieve a C */ PERLVAR(Iregistered_mros, HV *) /* If you are adding a U8 or U16, check to see if there are 'Space' comments * above on where there are gaps which currently will be structure padding. */ /* Within a stable branch, new variables must be added to the very end, before * this comment, for binary compatibility (the offsets of the old members must * not change). * (Don't forget to add your variable also to perl_clone()!) * XSUB.h provides wrapper functions via perlapi.h that make this * irrelevant, but not all code may be expected to #include XSUB.h. */ perl-5.12.0-RC0/gv.c0000444000175000017500000020131611346121271012706 0ustar jessejesse/* gv.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * 'Mercy!' cried Gandalf. 'If the giving of information is to be the cure * of your inquisitiveness, I shall spend all the rest of my days in answering * you. What more do you want to know?' * 'The names of all the stars, and of all living things, and the whole * history of Middle-earth and Over-heaven and of the Sundering Seas,' * laughed Pippin. * * [p.599 of _The Lord of the Rings_, III/xi: "The Palantír"] */ /* =head1 GV Functions A GV is a structure which corresponds to to a Perl typeglob, ie *foo. It is a structure that holds a pointer to a scalar, an array, a hash etc, corresponding to $foo, @foo, %foo. GVs are usually found as values in stashes (symbol table hashes) where Perl stores its global variables. =cut */ #include "EXTERN.h" #define PERL_IN_GV_C #include "perl.h" #include "overload.c" static const char S_autoload[] = "AUTOLOAD"; static const STRLEN S_autolen = sizeof(S_autoload)-1; GV * Perl_gv_add_by_type(pTHX_ GV *gv, svtype type) { SV **where; if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV) { const char *what; if (type == SVt_PVIO) { /* * if it walks like a dirhandle, then let's assume that * this is a dirhandle. */ what = PL_op->op_type == OP_READDIR || PL_op->op_type == OP_TELLDIR || PL_op->op_type == OP_SEEKDIR || PL_op->op_type == OP_REWINDDIR || PL_op->op_type == OP_CLOSEDIR ? "dirhandle" : "filehandle"; /* diag_listed_as: Bad symbol for filehandle */ } else if (type == SVt_PVHV) { what = "hash"; } else { what = type == SVt_PVAV ? "array" : "scalar"; } Perl_croak(aTHX_ "Bad symbol for %s", what); } if (type == SVt_PVHV) { where = (SV **)&GvHV(gv); } else if (type == SVt_PVAV) { where = (SV **)&GvAV(gv); } else if (type == SVt_PVIO) { where = (SV **)&GvIOp(gv); } else { where = &GvSV(gv); } if (!*where) *where = newSV_type(type); return gv; } GV * Perl_gv_fetchfile(pTHX_ const char *name) { PERL_ARGS_ASSERT_GV_FETCHFILE; return gv_fetchfile_flags(name, strlen(name), 0); } GV * Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen, const U32 flags) { dVAR; char smallbuf[128]; char *tmpbuf; const STRLEN tmplen = namelen + 2; GV *gv; PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS; PERL_UNUSED_ARG(flags); if (!PL_defstash) return NULL; if (tmplen <= sizeof smallbuf) tmpbuf = smallbuf; else 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); #ifdef PERL_DONT_CREATE_GVSV GvSV(gv) = newSVpvn(name, namelen); #else sv_setpvn(GvSV(gv), name, namelen); #endif if (PERLDB_LINE || PERLDB_SAVESRC) hv_magic(GvHVn(gv_AVadd(gv)), NULL, PERL_MAGIC_dbfile); } if (tmpbuf != smallbuf) Safefree(tmpbuf); return gv; } /* =for apidoc gv_const_sv If C is a typeglob whose subroutine entry is a constant sub eligible for inlining, or C is a placeholder reference that would be promoted to such a typeglob, then returns the value returned by the sub. Otherwise, returns NULL. =cut */ SV * Perl_gv_const_sv(pTHX_ GV *gv) { PERL_ARGS_ASSERT_GV_CONST_SV; if (SvTYPE(gv) == SVt_PVGV) return cv_const_sv(GvCVu(gv)); return SvROK(gv) ? SvRV(gv) : NULL; } GP * Perl_newGP(pTHX_ GV *const gv) { GP *gp; U32 hash; #ifdef USE_ITHREADS const char *const file = (PL_curcop && CopFILE(PL_curcop)) ? CopFILE(PL_curcop) : ""; const STRLEN len = strlen(file); #else SV *const temp_sv = CopFILESV(PL_curcop); const char *file; STRLEN len; PERL_ARGS_ASSERT_NEWGP; if (temp_sv) { file = SvPVX(temp_sv); len = SvCUR(temp_sv); } else { file = ""; len = 0; } #endif PERL_HASH(hash, file, len); Newxz(gp, 1, GP); #ifndef PERL_DONT_CREATE_GVSV gp->gp_sv = newSV(0); #endif gp->gp_line = PL_curcop ? CopLINE(PL_curcop) : 0; /* XXX Ideally this cast would be replaced with a change to const char* in the struct. */ gp->gp_file_hek = share_hek(file, len, hash); gp->gp_egv = gv; gp->gp_refcnt = 1; return gp; } void Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) { dVAR; const U32 old_type = SvTYPE(gv); const bool doproto = old_type > SVt_NULL; char * const proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL; const STRLEN protolen = proto ? SvCUR(gv) : 0; SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL; const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0; PERL_ARGS_ASSERT_GV_INIT; assert (!(proto && has_constant)); if (has_constant) { /* The constant has to be a simple scalar type. */ switch (SvTYPE(has_constant)) { case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: case SVt_PVFM: case SVt_PVIO: Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob", sv_reftype(has_constant, 0)); 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 (SvLEN(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); GvGP(gv) = Perl_newGP(aTHX_ gv); GvSTASH(gv) = stash; if (stash) Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv)); gv_name_set(gv, name, len, GV_ADD); if (multi || doproto) /* doproto means it _was_ mentioned */ GvMULTI_on(gv); if (doproto) { /* Replicate part of newSUB here. */ ENTER; if (has_constant) { /* newCONSTSUB takes ownership of the reference from us. */ GvCV(gv) = newCONSTSUB(stash, name, has_constant); /* 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); } else { (void) start_subparse(0,0); /* Create empty CV in compcv. */ GvCV(gv) = PL_compcv; } LEAVE; mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar($) { (shift) } sub ASDF::baz($); *ASDF::baz = \&Foo::bar */ CvGV(GvCV(gv)) = gv; CvFILE_set_from_cop(GvCV(gv), PL_curcop); CvSTASH(GvCV(gv)) = PL_curstash; if (proto) { sv_usepvn_flags(MUTABLE_SV(GvCV(gv)), proto, protolen, SV_HAS_TRAILING_NUL); } } } STATIC void S_gv_init_sv(pTHX_ GV *gv, const svtype sv_type) { PERL_ARGS_ASSERT_GV_INIT_SV; switch (sv_type) { case SVt_PVIO: (void)GvIOn(gv); break; case SVt_PVAV: (void)GvAVn(gv); break; case SVt_PVHV: (void)GvHVn(gv); break; #ifdef PERL_DONT_CREATE_GVSV case SVt_NULL: case SVt_PVCV: case SVt_PVFM: case SVt_PVGV: 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 */ } #endif } } /* =for apidoc gv_fetchmeth Returns the glob with the given C and a defined subroutine or C. The glob lives in the given C, or in the stashes accessible via @ISA and UNIVERSAL::. The argument C should be either 0 or -1. If C, as a side-effect creates a glob with the given C in the given C which in the case of success contains an alias for the subroutine, and sets up caching info for this glob. This function grants C<"SUPER"> token as a postfix of the stash name. The GV returned from C may be a method cache entry, which is not visible to Perl code. So when calling C, you should not use the GV directly; instead, you should use the method's CV, which can be obtained from the GV with the C macro. =cut */ /* NOTE: No support for tied ISA */ GV * Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) { dVAR; GV** gvp; AV* linear_av; SV** linear_svp; SV* linear_sv; HV* cstash; GV* candidate = NULL; CV* cand_cv = NULL; CV* old_cv; GV* topgv = NULL; const char *hvname; I32 create = (level >= 0) ? 1 : 0; I32 items; STRLEN packlen; U32 topgen_cmp; PERL_ARGS_ASSERT_GV_FETCHMETH; /* UNIVERSAL methods should be callable without a stash */ if (!stash) { create = 0; /* probably appropriate */ if(!(stash = gv_stashpvs("UNIVERSAL", 0))) return 0; } assert(stash); hvname = HvNAME_get(stash); if (!hvname) Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); assert(hvname); assert(name); DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) ); topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation; /* check locally for a real method or a cache entry */ gvp = (GV**)hv_fetch(stash, name, len, create); if(gvp) { topgv = *gvp; assert(topgv); if (SvTYPE(topgv) != SVt_PVGV) gv_init(topgv, stash, name, len, TRUE); if ((cand_cv = GvCV(topgv))) { /* If genuine method or valid cache entry, use it */ if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) { return topgv; } else { /* stale cache entry, junk it and move on */ SvREFCNT_dec(cand_cv); GvCV(topgv) = cand_cv = NULL; GvCVGEN(topgv) = 0; } } else if (GvCVGEN(topgv) == topgen_cmp) { /* cache indicates no such method definitively */ return 0; } } packlen = HvNAMELEN_get(stash); if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) { HV* basestash; packlen -= 7; basestash = gv_stashpvn(hvname, packlen, GV_ADD); linear_av = mro_get_linear_isa(basestash); } else { linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */ } linear_svp = AvARRAY(linear_av) + 1; /* skip over self */ items = AvFILLp(linear_av); /* no +1, to skip over self */ while (items--) { linear_sv = *linear_svp++; assert(linear_sv); cstash = gv_stashsv(linear_sv, 0); if (!cstash) { Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA", SVfARG(linear_sv), hvname); continue; } assert(cstash); gvp = (GV**)hv_fetch(cstash, name, len, 0); if (!gvp) continue; candidate = *gvp; assert(candidate); if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, cstash, name, len, TRUE); if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) { /* * Found real method, cache method in topgv if: * 1. topgv has no synonyms (else inheritance crosses wires) * 2. method isn't a stub (else AUTOLOAD fails spectacularly) */ if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) { if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv); SvREFCNT_inc_simple_void_NN(cand_cv); GvCV(topgv) = cand_cv; GvCVGEN(topgv) = topgen_cmp; } return candidate; } } /* Check UNIVERSAL without caching */ if(level == 0 || level == -1) { candidate = gv_fetchmeth(NULL, name, len, 1); if(candidate) { cand_cv = GvCV(candidate); if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) { if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv); SvREFCNT_inc_simple_void_NN(cand_cv); GvCV(topgv) = cand_cv; GvCVGEN(topgv) = topgen_cmp; } return candidate; } } if (topgv && GvREFCNT(topgv) == 1) { /* cache the fact that the method is not defined */ GvCVGEN(topgv) = topgen_cmp; } return 0; } /* =for apidoc gv_fetchmeth_autoload Same as gv_fetchmeth(), but looks for autoloaded subroutines too. Returns a glob for the subroutine. For an autoloaded subroutine without a GV, will create a GV even if C. For an autoloaded subroutine without a stub, GvCV() of the result may be zero. =cut */ GV * Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) { GV *gv = gv_fetchmeth(stash, name, len, level); PERL_ARGS_ASSERT_GV_FETCHMETH_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(stash, S_autoload, S_autolen, FALSE))) 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(stash, name, len, 0); gvp = (GV**)hv_fetch(stash, name, len, (level >= 0)); if (!gvp) return NULL; return *gvp; } return gv; } /* =for apidoc gv_fetchmethod_autoload Returns the glob which contains the subroutine to call to invoke the method on the C. In fact in the presence of autoloading this may be the glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is already setup. The third parameter of C determines whether AUTOLOAD lookup is performed if the given method is not present: non-zero means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD. Calling C is equivalent to calling C with a non-zero C parameter. These functions grant C<"SUPER"> token as a prefix of the method name. Note that if you want to keep the returned glob for a long time, you need to check for it being "AUTOLOAD", since at the later time the call may load a different subroutine due to $AUTOLOAD changing its value. Use the glob created via a side effect to do this. These functions have the same side-effects and as C with C. C should be writable if contains C<':'> or C<' ''>. The warning against passing the GV returned by C to C apply equally to these functions. =cut */ STATIC HV* S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen) { AV* superisa; GV** gvp; GV* gv; HV* stash; PERL_ARGS_ASSERT_GV_GET_SUPER_PKG; stash = gv_stashpvn(name, namelen, 0); if(stash) return stash; /* If we must create it, give it an @ISA array containing the real package this SUPER is for, so that it's tied into the cache invalidation code correctly */ stash = gv_stashpvn(name, namelen, GV_ADD); gvp = (GV**)hv_fetchs(stash, "ISA", TRUE); gv = *gvp; gv_init(gv, stash, "ISA", 3, TRUE); superisa = GvAVn(gv); GvMULTI_on(gv); sv_magic(MUTABLE_SV(superisa), MUTABLE_SV(gv), PERL_MAGIC_isa, NULL, 0); #ifdef USE_ITHREADS av_push(superisa, newSVpv(CopSTASHPV(PL_curcop), 0)); #else av_push(superisa, newSVhek(CopSTASH(PL_curcop) ? HvNAME_HEK(CopSTASH(PL_curcop)) : NULL)); #endif return stash; } GV * Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) { PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD; return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0); } /* Don't merge this yet, as it's likely to get a len parameter, and possibly even a U32 hash */ GV * Perl_gv_fetchmethod_flags(pTHX_ HV *stash, const char *name, U32 flags) { dVAR; register const char *nend; const char *nsplit = NULL; GV* gv; HV* ostash = stash; const char * const origname = name; SV *const error_report = MUTABLE_SV(stash); const U32 autoload = flags & GV_AUTOLOAD; const U32 do_croak = flags & GV_CROAK; PERL_ARGS_ASSERT_GV_FETCHMETHOD_FLAGS; if (SvTYPE(stash) < SVt_PVHV) stash = NULL; else { /* The only way stash can become NULL later on is if nsplit is set, which in turn means that there is no need for a SVt_PVHV case the error reporting code. */ } for (nend = name; *nend; nend++) { if (*nend == '\'') { nsplit = nend; name = nend + 1; } else if (*nend == ':' && *(nend + 1) == ':') { nsplit = nend++; name = nend + 1; } } if (nsplit) { if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) { /* ->SUPER::method should really be looked up in original stash */ SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER", CopSTASHPV(PL_curcop))); /* __PACKAGE__::SUPER stash should be autovivified */ stash = gv_get_super_pkg(SvPVX_const(tmpstr), SvCUR(tmpstr)); DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", origname, HvNAME_get(stash), name) ); } else { /* don't autovifify if ->NoSuchStash::method */ stash = gv_stashpvn(origname, nsplit - origname, 0); /* however, explicit calls to Pkg::SUPER::method may happen, and may require autovivification to work */ if (!stash && (nsplit - origname) >= 7 && strnEQ(nsplit - 7, "::SUPER", 7) && gv_stashpvn(origname, nsplit - origname - 7, 0)) stash = gv_get_super_pkg(origname, nsplit - origname); } ostash = stash; } gv = gv_fetchmeth(stash, name, nend - name, 0); if (!gv) { if (strEQ(name,"import") || strEQ(name,"unimport")) gv = MUTABLE_GV(&PL_sv_yes); else if (autoload) gv = gv_autoload4(ostash, name, nend - name, TRUE); if (!gv && do_croak) { /* Right now this is exclusively for the benefit of S_method_common in pp_hot.c */ if (stash) { Perl_croak(aTHX_ "Can't locate object method \"%s\" via package \"%.*s\"", name, (int)HvNAMELEN_get(stash), HvNAME_get(stash)); } else { STRLEN packlen; const char *packname; if (nsplit) { packlen = nsplit - origname; packname = origname; } else { packname = SvPV_const(error_report, packlen); } Perl_croak(aTHX_ "Can't locate object method \"%s\" via package \"%.*s\"" " (perhaps you forgot to load \"%.*s\"?)", name, (int)packlen, packname, (int)packlen, packname); } } } else if (autoload) { CV* const cv = GvCV(gv); if (!CvROOT(cv) && !CvXSUB(cv)) { GV* stubgv; GV* autogv; if (CvANON(cv)) stubgv = gv; else { stubgv = CvGV(cv); if (GvCV(stubgv) != cv) /* orphaned import */ stubgv = gv; } autogv = gv_autoload4(GvSTASH(stubgv), GvNAME(stubgv), GvNAMELEN(stubgv), TRUE); if (autogv) gv = autogv; } } return gv; } GV* Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) { dVAR; GV* gv; CV* cv; HV* varstash; GV* vargv; SV* varsv; const char *packname = ""; STRLEN packname_len = 0; PERL_ARGS_ASSERT_GV_AUTOLOAD4; if (len == S_autolen && memEQ(name, S_autoload, S_autolen)) return NULL; if (stash) { if (SvTYPE(stash) < SVt_PVHV) { packname = SvPV_const(MUTABLE_SV(stash), packname_len); stash = NULL; } else { packname = HvNAME_get(stash); packname_len = HvNAMELEN_get(stash); } } if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE))) return NULL; cv = GvCV(gv); if (!(CvROOT(cv) || CvXSUB(cv))) return NULL; /* * Inheriting AUTOLOAD for non-methods works ... for now. */ if (!method && (GvCVGEN(gv) || GvSTASH(gv) != stash) ) Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated", packname, (int)len, name); if (CvISXSUB(cv)) { /* rather than lookup/init $AUTOLOAD here * only to have the XSUB do another lookup for $AUTOLOAD * and split that value on the last '::', * pass along the same data via some unused fields in the CV */ CvSTASH(cv) = stash; SvPV_set(cv, (char *)name); /* cast to lose constness warning */ SvCUR_set(cv, len); return gv; } /* * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name. * The subroutine's original name may not be "AUTOLOAD", so we don't * use that, but for lack of anything better we will use the sub's * original package to look up $AUTOLOAD. */ varstash = GvSTASH(CvGV(cv)); vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE); ENTER; if (!isGV(vargv)) { gv_init(vargv, varstash, S_autoload, S_autolen, FALSE); #ifdef PERL_DONT_CREATE_GVSV GvSV(vargv) = newSV(0); #endif } LEAVE; varsv = GvSVn(vargv); sv_setpvn(varsv, packname, packname_len); sv_catpvs(varsv, "::"); sv_catpvn(varsv, name, len); return gv; } /* require_tie_mod() internal routine for requiring a module * that implements the logic of automatical ties like %! and %- * * The "gv" parameter should be the glob. * "varpv" holds the name of the var, used for error messages. * "namesv" holds the module name. Its refcount will be decremented. * "methpv" holds the method name to test for to check that things * are working reasonably close to as expected. * "flags": if flag & 1 then save the scalar before loading. * For the protection of $! to work (it is set by this routine) * the sv slot must already be magicalized. */ STATIC HV* S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags) { dVAR; HV* stash = gv_stashsv(namesv, 0); PERL_ARGS_ASSERT_REQUIRE_TIE_MOD; if (!stash || !(gv_fetchmethod(stash, methpv))) { SV *module = newSVsv(namesv); char varname = *varpv; /* varpv might be clobbered by load_module, so save it. For the moment it's always a single char. */ dSP; ENTER; if ( flags & 1 ) save_scalar(gv); PUSHSTACKi(PERLSI_MAGIC); Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL); POPSTACK; LEAVE; SPAGAIN; stash = gv_stashsv(namesv, 0); if (!stash) Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" is not available", varname, SVfARG(namesv)); else if (!gv_fetchmethod(stash, methpv)) Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" does not support method %s", varname, SVfARG(namesv), methpv); } SvREFCNT_dec(namesv); return stash; } /* =for apidoc gv_stashpv Returns a pointer to the stash for a specified package. Uses C to determine the length of C, then calls C. =cut */ HV* Perl_gv_stashpv(pTHX_ const char *name, I32 create) { PERL_ARGS_ASSERT_GV_STASHPV; return gv_stashpvn(name, strlen(name), create); } /* =for apidoc gv_stashpvn Returns a pointer to the stash for a specified package. The C parameter indicates the length of the C, in bytes. C is passed to C, so if set to C then the package will be created if it does not already exist. If the package does not exist and C is 0 (or any other setting that does not create packages) then NULL is returned. =cut */ HV* Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags) { char smallbuf[128]; char *tmpbuf; HV *stash; GV *tmpgv; U32 tmplen = namelen + 2; PERL_ARGS_ASSERT_GV_STASHPVN; if (tmplen <= sizeof smallbuf) tmpbuf = smallbuf; else 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); if (!tmpgv) return NULL; if (!GvHV(tmpgv)) GvHV(tmpgv) = newHV(); stash = GvHV(tmpgv); if (!HvNAME_get(stash)) hv_name_set(stash, name, namelen, 0); return stash; } /* =for apidoc gv_stashsv Returns a pointer to the stash for a specified package. See C. =cut */ HV* Perl_gv_stashsv(pTHX_ SV *sv, I32 flags) { STRLEN len; const char * const ptr = SvPV_const(sv,len); PERL_ARGS_ASSERT_GV_STASHSV; return gv_stashpvn(ptr, len, flags); } GV * Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) { PERL_ARGS_ASSERT_GV_FETCHPV; return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type); } GV * Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) { STRLEN len; const char * const nambeg = SvPV_const(name, len); PERL_ARGS_ASSERT_GV_FETCHSV; return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type); } GV * Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, const svtype sv_type) { dVAR; register const char *name = nambeg; register GV *gv = NULL; GV**gvp; I32 len; register const char *name_cursor; HV *stash = NULL; const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT); const I32 no_expand = flags & GV_NOEXPAND; const I32 add = flags & ~GV_NOADD_MASK; const char *const name_end = nambeg + full_len; const char *const name_em1 = name_end - 1; U32 faking_it; PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS; if (flags & GV_NOTQUAL) { /* Caller promised that there is no stash, so we can skip the check. */ len = full_len; goto no_stash; } if (full_len > 2 && *name == '*' && isALPHA(name[1])) { /* accidental stringify on a GV? */ name++; } for (name_cursor = name; name_cursor < name_end; name_cursor++) { if ((*name_cursor == ':' && name_cursor < name_em1 && name_cursor[1] == ':') || (*name_cursor == '\'' && name_cursor[1])) { if (!stash) stash = PL_defstash; if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */ return NULL; len = name_cursor - name; if (len > 0) { char smallbuf[128]; char *tmpbuf; if (len + 2 <= (I32)sizeof (smallbuf)) tmpbuf = smallbuf; else Newx(tmpbuf, len+2, char); Copy(name, tmpbuf, len, char); tmpbuf[len++] = ':'; tmpbuf[len++] = ':'; gvp = (GV**)hv_fetch(stash,tmpbuf,len,add); gv = gvp ? *gvp : NULL; if (gv && gv != (const GV *)&PL_sv_undef) { if (SvTYPE(gv) != SVt_PVGV) gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI)); else GvMULTI_on(gv); } if (tmpbuf != smallbuf) Safefree(tmpbuf); if (!gv || gv == (const GV *)&PL_sv_undef) return NULL; if (!(stash = GvHV(gv))) stash = GvHV(gv) = newHV(); if (!HvNAME_get(stash)) hv_name_set(stash, nambeg, name_cursor - nambeg, 0); } if (*name_cursor == ':') name_cursor++; name_cursor++; name = name_cursor; if (name == name_end) return gv ? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE)); } } len = name_cursor - name; /* No stash in name, so see how we can default */ if (!stash) { no_stash: if (len && isIDFIRST_lazy(name)) { bool global = FALSE; switch (len) { case 1: if (*name == '_') global = TRUE; break; case 3: if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C') || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V') || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G')) global = TRUE; break; case 4: if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G' && name[3] == 'V') global = TRUE; break; case 5: if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D' && name[3] == 'I' && name[4] == 'N') global = TRUE; break; case 6: if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D') &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T') ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R'))) global = TRUE; break; case 7: if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G' && name[3] == 'V' && name[4] == 'O' && name[5] == 'U' && name[6] == 'T') global = TRUE; break; } if (global) stash = PL_defstash; else if (IN_PERL_COMPILETIME) { stash = PL_curstash; if (add && (PL_hints & HINT_STRICT_VARS) && sv_type != SVt_PVCV && sv_type != SVt_PVGV && sv_type != SVt_PVFM && sv_type != SVt_PVIO && !(len == 1 && sv_type == SVt_PV && (*name == 'a' || *name == 'b')) ) { gvp = (GV**)hv_fetch(stash,name,len,0); if (!gvp || *gvp == (const GV *)&PL_sv_undef || SvTYPE(*gvp) != SVt_PVGV) { stash = NULL; } else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) || (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) || (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) ) { /* diag_listed_as: Variable "%s" is not imported%s */ Perl_warn(aTHX_ "Variable \"%c%s\" is not imported", sv_type == SVt_PVAV ? '@' : sv_type == SVt_PVHV ? '%' : '$', name); if (GvCVu(*gvp)) Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name); stash = NULL; } } } else stash = CopSTASH(PL_curcop); } else stash = PL_defstash; } /* By this point we should have a stash and a name */ if (!stash) { if (add) { SV * const err = Perl_mess(aTHX_ "Global symbol \"%s%s\" requires explicit package name", (sv_type == SVt_PV ? "$" : sv_type == SVt_PVAV ? "@" : sv_type == SVt_PVHV ? "%" : ""), name); GV *gv; if (USE_UTF8_IN_NAMES) SvUTF8_on(err); qerror(err); gv = gv_fetchpvs("::", GV_ADDMULTI, SVt_PVHV); if(!gv) { /* symbol table under destruction */ return NULL; } stash = GvHV(gv); } else return NULL; } if (!SvREFCNT(stash)) /* symbol table under destruction */ return NULL; gvp = (GV**)hv_fetch(stash,name,len,add); if (!gvp || *gvp == (const GV *)&PL_sv_undef) return NULL; gv = *gvp; if (SvTYPE(gv) == SVt_PVGV) { if (add) { GvMULTI_on(gv); gv_init_sv(gv, sv_type); if (len == 1 && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) { if (*name == '!') require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1); else if (*name == '-' || *name == '+') require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0); } } return gv; } else if (no_init) { return gv; } else if (no_expand && SvROK(gv)) { return gv; } /* Adding a new symbol. Unless of course there was already something non-GV here, in which case we want to behave as if there was always a GV here, containing some sort of subroutine. Otherwise we run the risk of creating things like GvIO, which can cause subtle bugs. eg the one that tripped up SQL::Translator */ faking_it = SvOK(gv); if (add & GV_ADDWARN) Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg); gv_init(gv, stash, name, len, add & GV_ADDMULTI); gv_init_sv(gv, faking_it ? SVt_PVCV : sv_type); if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) : (PL_dowarn & G_WARN_ON ) ) ) GvMULTI_on(gv) ; /* set up magic where warranted */ 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 the common case of lower case variable names. */ } else #endif { const char * const name2 = name + 1; switch (*name) { case 'A': if (strEQ(name2, "RGV")) { IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START; } else if (strEQ(name2, "RGVOUT")) { GvMULTI_on(gv); } break; case 'E': if (strnEQ(name2, "XPORT", 5)) GvMULTI_on(gv); break; case 'I': if (strEQ(name2, "SA")) { AV* const av = GvAVn(gv); GvMULTI_on(gv); sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa, NULL, 0); /* NOTE: No support for tied ISA */ if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA") && AvFILLp(av) == -1) { av_push(av, newSVpvs("NDBM_File")); gv_stashpvs("NDBM_File", GV_ADD); av_push(av, newSVpvs("DB_File")); gv_stashpvs("DB_File", GV_ADD); av_push(av, newSVpvs("GDBM_File")); gv_stashpvs("GDBM_File", GV_ADD); av_push(av, newSVpvs("SDBM_File")); gv_stashpvs("SDBM_File", GV_ADD); av_push(av, newSVpvs("ODBM_File")); gv_stashpvs("ODBM_File", GV_ADD); } } break; case 'O': if (strEQ(name2, "VERLOAD")) { HV* const hv = GvHVn(gv); GvMULTI_on(gv); hv_magic(hv, NULL, PERL_MAGIC_overload); } break; case 'S': if (strEQ(name2, "IG")) { 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 (strEQ(name2, "ERSION")) GvMULTI_on(gv); break; case '\003': /* $^CHILD_ERROR_NATIVE */ if (strEQ(name2, "HILD_ERROR_NATIVE")) goto magicalize; break; case '\005': /* $^ENCODING */ if (strEQ(name2, "NCODING")) goto magicalize; break; case '\015': /* $^MATCH */ if (strEQ(name2, "ATCH")) goto magicalize; case '\017': /* $^OPEN */ if (strEQ(name2, "PEN")) goto magicalize; break; case '\020': /* $^PREMATCH $^POSTMATCH */ if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH")) goto magicalize; case '\024': /* ${^TAINT} */ if (strEQ(name2, "AINT")) goto ro_magicalize; break; case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */ if (strEQ(name2, "NICODE")) goto ro_magicalize; if (strEQ(name2, "TF8LOCALE")) goto ro_magicalize; if (strEQ(name2, "TF8CACHE")) goto magicalize; break; case '\027': /* $^WARNING_BITS */ if (strEQ(name2, "ARNING_BITS")) goto magicalize; 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 */ /* This snippet is taken from is_gv_magical */ const char *end = name + len; while (--end > name) { if (!isDIGIT(*end)) return gv; } goto magicalize; } } } } 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 '&': /* $& */ case '`': /* $` */ case '\'': /* $' */ if ( sv_type == SVt_PVAV || sv_type == SVt_PVHV || sv_type == SVt_PVCV || sv_type == SVt_PVFM || sv_type == SVt_PVIO ) { break; } PL_sawampersand = TRUE; goto magicalize; case ':': /* $: */ sv_setpv(GvSVn(gv),PL_chopset); goto magicalize; case '?': /* $? */ #ifdef COMPLEX_STATUS SvUPGRADE(GvSVn(gv), SVt_PVLV); #endif goto magicalize; case '!': /* $! */ GvMULTI_on(gv); /* If %! has been used, automatically load Errno.pm. */ sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); /* magicalization must be done before require_tie_mod is called */ if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1); break; case '-': /* $- */ case '+': /* $+ */ GvMULTI_on(gv); /* no used once warnings here */ { AV* const av = GvAVn(gv); SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL; sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0); sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); if (avc) SvREADONLY_on(GvSVn(gv)); SvREADONLY_on(av); if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0); break; } case '*': /* $* */ case '#': /* $# */ if (sv_type == SVt_PV) Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "$%c is no longer supported", *name); break; case '|': /* $| */ sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0); goto magicalize; 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)); /* FALL THROUGH */ case '0': /* $0 */ case '1': /* $1 */ case '2': /* $2 */ case '3': /* $3 */ case '4': /* $4 */ case '5': /* $5 */ case '6': /* $6 */ case '7': /* $7 */ case '8': /* $8 */ case '9': /* $9 */ 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"); PL_formfeed = GvSVn(gv); break; case ';': /* $; */ sv_setpvs(GvSVn(gv),"\034"); break; case ']': /* $] */ { SV * const sv = GvSVn(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 = GvSVn(gv); GvSV(gv) = new_version(PL_patchlevel); SvREADONLY_on(GvSV(gv)); SvREFCNT_dec(sv); } break; } } return gv; } void Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain) { const char *name; STRLEN namelen; const HV * const hv = GvSTASH(gv); PERL_ARGS_ASSERT_GV_FULLNAME4; if (!hv) { SvOK_off(sv); return; } sv_setpv(sv, prefix ? prefix : ""); name = HvNAME_get(hv); if (name) { namelen = HvNAMELEN_get(hv); } else { name = "__ANON__"; namelen = 8; } if (keepmain || strNE(name, "main")) { sv_catpvn(sv,name,namelen); sv_catpvs(sv,"::"); } sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv)); } void Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain) { const GV * const egv = GvEGV(gv); PERL_ARGS_ASSERT_GV_EFULLNAME4; gv_fullname4(sv, egv ? egv : gv, prefix, keepmain); } void Perl_gv_check(pTHX_ const HV *stash) { dVAR; register I32 i; PERL_ARGS_ASSERT_GV_CHECK; if (!HvARRAY(stash)) return; for (i = 0; i <= (I32) HvMAX(stash); i++) { const HE *entry; for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { register GV *gv; HV *hv; if (HeKEY(entry)[HeKLEN(entry)-1] == ':' && (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv))) { if (hv != PL_defstash && hv != stash) gv_check(hv); /* nested package */ } else if (isALPHA(*HeKEY(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)); #ifdef USE_ITHREADS CopFILE(PL_curcop) = (char *)file; /* set for warning */ #else CopFILEGV(PL_curcop) = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0); #endif Perl_warner(aTHX_ packWARN(WARN_ONCE), "Name \"%s::%s\" used only once: possible typo", HvNAME_get(stash), GvNAME(gv)); } } } } GV * Perl_newGVgen(pTHX_ const char *pack) { dVAR; PERL_ARGS_ASSERT_NEWGVGEN; return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++), GV_ADD, SVt_PVGV); } /* hopefully this is only called on local symbol table entries */ GP* Perl_gp_ref(pTHX_ GP *gp) { dVAR; if (!gp) return NULL; gp->gp_refcnt++; if (gp->gp_cv) { 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(gp->gp_cv); gp->gp_cv = NULL; gp->gp_cvgen = 0; } } return gp; } void Perl_gp_free(pTHX_ GV *gv) { dVAR; GP* gp; if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv))) return; if (gp->gp_refcnt == 0) { Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Attempt to free unreferenced glob pointers" pTHX__FORMAT pTHX__VALUE); return; } if (--gp->gp_refcnt > 0) { if (gp->gp_egv == gv) gp->gp_egv = 0; GvGP(gv) = 0; return; } if (gp->gp_file_hek) unshare_hek(gp->gp_file_hek); SvREFCNT_dec(gp->gp_sv); SvREFCNT_dec(gp->gp_av); /* FIXME - another reference loop GV -> symtab -> GV ? Somehow gp->gp_hv can end up pointing at freed garbage. */ if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) { const char *hvname = HvNAME_get(gp->gp_hv); if (PL_stashcache && hvname) (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv), G_DISCARD); SvREFCNT_dec(gp->gp_hv); } SvREFCNT_dec(gp->gp_io); SvREFCNT_dec(gp->gp_cv); SvREFCNT_dec(gp->gp_form); Safefree(gp); GvGP(gv) = 0; } int Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg) { AMT * const amtp = (AMT*)mg->mg_ptr; PERL_UNUSED_ARG(sv); 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(MUTABLE_SV(cv)); amtp->table[i] = NULL; } } } return 0; } /* Updates and caches the CV's */ /* Returns: * 1 on success and there is some overload * 0 if there is no overload * -1 if some error occurred and it couldn't croak */ int Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) { dVAR; MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); AMT amt; const struct mro_meta* stash_meta = HvMROMETA(stash); U32 newgen; PERL_ARGS_ASSERT_GV_AMUPDATE; newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen; if (mg) { const AMT * const amtp = (AMT*)mg->mg_ptr; if (amtp->was_ok_am == PL_amagic_generation && amtp->was_ok_sub == newgen) { return AMT_OVERLOADED(amtp) ? 1 : 0; } sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table); } DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) ); Zero(&amt,1,AMT); amt.was_ok_am = PL_amagic_generation; amt.was_ok_sub = newgen; amt.fallback = AMGfallNO; amt.flags = 0; { int filled = 0, have_ovl = 0; int i, lim = 1; /* Work with "fallback" key, which we assume to be first in PL_AMG_names */ /* Try to find via inheritance. */ GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1); SV * const sv = gv ? GvSV(gv) : NULL; CV* cv; if (!gv) lim = DESTROY_amg; /* Skip overloading entries. */ #ifdef PERL_DONT_CREATE_GVSV else if (!sv) { NOOP; /* Equivalent to !SvTRUE and !SvOK */ } #endif else if (SvTRUE(sv)) amt.fallback=AMGfallYES; else if (SvOK(sv)) amt.fallback=AMGfallNEVER; for (i = 1; i < lim; i++) amt.table[i] = NULL; for (; i < NofAMmeth; i++) { const char * const cooky = PL_AMG_names[i]; /* Human-readable form, for debugging: */ const char * const cp = (i >= DESTROY_amg ? cooky : 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". */ if (i >= DESTROY_amg) gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0); else /* Autoload taken care of below */ gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1); cv = 0; if (gv && (cv = GvCV(gv))) { const char *hvname; if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil") && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "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) ); if (!gvsv || !SvPOK(gvsv) || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv), FALSE))) { /* Can be an import stub (created by "can"). */ if (destructing) { return -1; } else { const char * const name = (gvsv && SvPOK(gvsv)) ? SvPVX_const(gvsv) : "???"; Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\ "in package \"%.256s\"", (GvCVGEN(gv) ? "Stub found while resolving" : "Can't resolve"), name, cp, hvname); } } 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; if (i < DESTROY_amg) have_ovl = 1; } else if (gv) { /* Autoloaded... */ cv = MUTABLE_CV(gv); filled = 1; } amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv)); } if (filled) { AMT_AMAGIC_on(&amt); if (have_ovl) AMT_OVERLOADED_on(&amt); sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table, (char*)&amt, sizeof(AMT)); return have_ovl; } } /* Here we have no table: */ /* no_table: */ AMT_AMAGIC_off(&amt); sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table, (char*)&amt, sizeof(AMTS)); return 0; } CV* Perl_gv_handler(pTHX_ HV *stash, I32 id) { dVAR; MAGIC *mg; AMT *amtp; U32 newgen; struct mro_meta* stash_meta; if (!stash || !HvNAME_get(stash)) return NULL; stash_meta = HvMROMETA(stash); newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen; mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); if (!mg) { do_update: /* If we're looking up a destructor to invoke, we must avoid * that Gv_AMupdate croaks, because we might be dying already */ if (Gv_AMupdate(stash, id == DESTROY_amg) == -1) { /* and if it didn't found a destructor, we fall back * to a simpler method that will only look for the * destructor instead of the whole magic */ if (id == DESTROY_amg) { GV * const gv = gv_fetchmethod(stash, "DESTROY"); if (gv) return GvCV(gv); } return NULL; } mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); } assert(mg); amtp = (AMT*)mg->mg_ptr; if ( amtp->was_ok_am != PL_amagic_generation || amtp->was_ok_sub != newgen ) 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; } return NULL; } SV* Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) { dVAR; MAGIC *mg; CV *cv=NULL; CV **cvp=NULL, **ocvp=NULL; AMT *amtp=NULL, *oamtp=NULL; int off = 0, off1, lr = 0, notfound = 0; int postpr = 0, force_cpy = 0; int assign = AMGf_assign & flags; const int assignshift = assign ? 1 : 0; #ifdef DEBUGGING int fl=0; #endif HV* stash=NULL; PERL_ARGS_ASSERT_AMAGIC_CALL; if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) { SV *lex_mask = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0, "overloading", 11, 0, 0); if ( !lex_mask || !SvOK(lex_mask) ) /* overloading lexically disabled */ return NULL; 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 NULL; } } if (!(AMGf_noleft & flags) && SvAMAGIC(left) && (stash = SvSTASH(SvRV(left))) && (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)) && ((cv = cvp[off=method+assignshift]) || (assign && amtp->fallback > AMGfallNEVER && /* fallback to * usual method */ ( #ifdef DEBUGGING fl = 1, #endif cv = cvp[off=method])))) { lr = -1; /* Call method for left argument */ } else { if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) { int logic; /* 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; case not_amg: (void)((cv = cvp[off=bool__amg]) || (cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg])); 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); /* As a bit of a source compatibility hack, SvAMAGIC() and friends dereference an RV, to behave the same was as when overloading was stored on the reference, not the referant. Hence we can't use SvAMAGIC_on() */ SvFLAGS(newref) |= SVf_AMAGIC; 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=sv_2mortal(newSViv(0)); if (off1==lt_amg) { SV* const lessp = amagic_call(left,nullsv, lt_amg,AMGf_noright); logic = SvTRUE(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 = sv_2mortal(newSViv(0)); 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. */ break; 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. */ break; default: goto not_found; } if (!cv) goto not_found; } else if (!(AMGf_noright & flags) && SvAMAGIC(right) && (stash = SvSTASH(SvRV(right))) && (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 (((ocvp && oamtp->fallback > AMGfallNEVER && (cvp=ocvp) && (lr = -1)) || (cvp && amtp->fallback > AMGfallNEVER && (lr=1))) && !(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 */ } off = -1; switch (method) { 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: off = scmp_amg; break; } if ((off != -1) && (cv = cvp[off])) postpr = 1; else goto not_found; } 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. */ break; } if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */ notfound = 1; lr = -1; } else if (cvp && (cv=cvp[nomethod_amg])) { notfound = 1; lr = 1; } else if ((amtp && amtp->fallback >= AMGfallYES) && !DEBUG_o_TEST) { /* 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%s%s%s", AMG_id2name(method + assignshift), (flags & AMGf_unary ? " " : "\n\tleft "), SvAMAGIC(left)? "in overloaded package ": "has no overloaded magic", SvAMAGIC(left)? HvNAME_get(SvSTASH(SvRV(left))): "", SvAMAGIC(right)? ",\n\tright argument in overloaded package ": (flags & AMGf_unary ? "" : ",\n\tright argument has no overloaded magic"), SvAMAGIC(right)? HvNAME_get(SvSTASH(SvRV(right))): "")); if (amtp && amtp->fallback >= AMGfallYES) { DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) ); } else { Perl_croak(aTHX_ "%"SVf, SVfARG(msg)); } return NULL; } force_cpy = force_cpy || assign; } } #ifdef DEBUGGING if (!notfound) { DEBUG_o(Perl_deb(aTHX_ "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%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 ? HvNAME_get(stash) : "null", fl? ",\n\tassignment variant used": "") ); } #endif /* Since we use shallow copy during assignment, we need * to dublicate the contents, probably calling user-supplied * version of copy operator */ /* We need to copy in following cases: * a) Assignment form was called. * assignshift==1, assign==T, method + 1 == off * b) Increment or decrement, called directly. * assignshift==0, assign==0, method + 0 == off * c) Increment or decrement, translated to assignment add/subtr. * assignshift==0, assign==T, * force_cpy == T * d) Increment or decrement, translated to nomethod. * assignshift==0, assign==0, * force_cpy == T * e) Assignment form translated to nomethod. * assignshift==1, assign==T, method + 1 != off * force_cpy == T */ /* off is method, method+assignshift, or a result of opcode substitution. * In the latter case assignshift==0, so only notfound case is important. */ if (( (method + assignshift == off) && (assign || (method == inc_amg) || (method == dec_amg))) || force_cpy) RvDEEPCP(left); { dSP; BINOP myop; SV* res; const bool oldcatch = CATCH_GET; CATCH_SET(TRUE); Zero(&myop, 1, BINOP); myop.op_last = (OP *) &myop; myop.op_next = NULL; myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED; PUSHSTACKi(PERLSI_OVERLOAD); ENTER; SAVEOP(); PL_op = (OP *) &myop; if (PERLDB_SUB && PL_curstash != PL_debstash) PL_op->op_private |= OPpENTERSUB_DB; PUTBACK; pp_pushmark(); EXTEND(SP, notfound + 5); PUSHs(lr>0? right: left); PUSHs(lr>0? left: right); 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)); } PUSHs(MUTABLE_SV(cv)); PUTBACK; if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX))) CALLRUNOPS(aTHX); LEAVE; SPAGAIN; res=POPs; PUTBACK; POPSTACK; CATCH_SET(oldcatch); if (postpr) { int ans; switch (method) { case le_amg: case sle_amg: ans=SvIV(res)<=0; break; case lt_amg: case slt_amg: ans=SvIV(res)<0; break; case ge_amg: case sge_amg: ans=SvIV(res)>=0; break; case gt_amg: case sgt_amg: ans=SvIV(res)>0; break; case eq_amg: case seq_amg: ans=SvIV(res)==0; break; case ne_amg: case sne_amg: ans=SvIV(res)!=0; break; case inc_amg: case dec_amg: SvSetSV(left,res); return left; case not_amg: ans=!SvTRUE(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"); } return SvREFCNT_inc(SvRV(res)); } else { return res; } } } /* =for apidoc is_gv_magical_sv Returns C if given the name of a magical GV. Currently only useful internally when determining if a GV should be created even in rvalue contexts. C is not used at present but available for future extension to allow selecting particular classes of magical variable. Currently assumes that C is NUL terminated (as well as len being valid). This assumption is met by all callers within the perl core, which all pass pointers returned by SvPV. =cut */ bool Perl_is_gv_magical_sv(pTHX_ SV *const name_sv, U32 flags) { STRLEN len; const char *const name = SvPV_const(name_sv, len); PERL_UNUSED_ARG(flags); PERL_ARGS_ASSERT_IS_GV_MAGICAL_SV; if (len > 1) { const char * const name1 = name + 1; switch (*name) { case 'I': if (len == 3 && name[1] == 'S' && name[2] == 'A') goto yes; break; case 'O': if (len == 8 && strEQ(name1, "VERLOAD")) goto yes; break; case 'S': if (len == 3 && name[1] == 'I' && name[2] == 'G') goto yes; break; /* Using ${^...} variables is likely to be sufficiently rare that it seems sensible to avoid the space hit of also checking the length. */ case '\017': /* ${^OPEN} */ if (strEQ(name1, "PEN")) goto yes; break; case '\024': /* ${^TAINT} */ if (strEQ(name1, "AINT")) goto yes; break; case '\025': /* ${^UNICODE} */ if (strEQ(name1, "NICODE")) goto yes; if (strEQ(name1, "TF8LOCALE")) goto yes; break; case '\027': /* ${^WARNING_BITS} */ if (strEQ(name1, "ARNING_BITS")) goto yes; break; case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': { const char *end = name + len; while (--end > name) { if (!isDIGIT(*end)) return FALSE; } goto yes; } } } else { /* Because we're already assuming that name is NUL terminated below, we can treat an empty name as "\0" */ switch (*name) { case '&': case '`': case '\'': case ':': case '?': case '!': case '-': case '#': case '[': case '^': 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 '\010': /* $^H */ case '\011': /* $^I, NOT \t in EBCDIC */ case '\014': /* $^L */ case '\016': /* $^N */ case '\017': /* $^O */ case '\020': /* $^P */ case '\023': /* $^S */ case '\024': /* $^T */ case '\026': /* $^V */ case '\027': /* $^W */ case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': yes: return TRUE; default: break; } } return FALSE; } void Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags) { dVAR; U32 hash; PERL_ARGS_ASSERT_GV_NAME_SET; PERL_UNUSED_ARG(flags); if (len > I32_MAX) Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len); if (!(flags & GV_ADD) && GvNAME_HEK(gv)) { unshare_hek(GvNAME_HEK(gv)); } PERL_HASH(hash, name, len); GvNAME_HEK(gv) = share_hek(name, len, hash); } /* =for apidoc gv_try_downgrade If the typeglob C can be expressed more succinctly, by having something other than a real GV in its place in the stash, replace it with the optimised form. Basic requirements for this are that C is a real typeglob, is sufficiently ordinary, and is only referenced from its package. This function is meant to be used when a GV has been looked up in part to see what was there, causing upgrading, but based on what was found it turns out that the real GV isn't required after all. If C is a completely empty typeglob, it is deleted from the stash. If C is a typeglob containing only a sufficiently-ordinary constant sub, the typeglob is replaced with a scalar-reference placeholder that more compactly represents the same thing. =cut */ void Perl_gv_try_downgrade(pTHX_ GV *gv) { HV *stash; CV *cv; HEK *namehek; SV **gvp; PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE; if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) && !SvOBJECT(gv) && !SvMAGICAL(gv) && !SvREADONLY(gv) && isGV_with_GP(gv) && GvGP(gv) && !GvINTRO(gv) && GvREFCNT(gv) == 1 && !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) && GvEGV(gv) == gv && (stash = GvSTASH(gv)))) return; cv = GvCV(gv); if (!cv) { HEK *gvnhek = GvNAME_HEK(gv); (void)hv_delete(stash, HEK_KEY(gvnhek), HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD); } else if (GvMULTI(gv) && cv && !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) && CvSTASH(cv) == stash && 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_fetch(stash, HEK_KEY(namehek), HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) && *gvp == (SV*)gv) { SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr); SvREFCNT(gv) = 0; sv_clear((SV*)gv); SvREFCNT(gv) = 1; SvFLAGS(gv) = SVt_IV|SVf_ROK; SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv)); SvRV_set(gv, value); } } /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */ perl-5.12.0-RC0/scope.c0000444000175000017500000007315511325127001013405 0ustar jessejesse/* scope.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * For the fashion of Minas Tirith was such that it was built on seven * levels... * * [p.751 of _The Lord of the Rings_, V/i: "Minas Tirith"] */ /* This file contains functions to manipulate several of Perl's stacks; * in particular it contains code to push various types of things onto * the savestack, then to pop them off and perform the correct restorative * action for each one. This corresponds to the cleanup Perl does at * each scope exit. */ #include "EXTERN.h" #define PERL_IN_SCOPE_C #include "perl.h" SV** Perl_stack_grow(pTHX_ SV **sp, SV **p, int n) { dVAR; PERL_ARGS_ASSERT_STACK_GROW; PL_stack_sp = sp; #ifndef STRESS_REALLOC av_extend(PL_curstack, (p - PL_stack_base) + (n) + 128); #else av_extend(PL_curstack, (p - PL_stack_base) + (n) + 1); #endif return PL_stack_sp; } #ifndef STRESS_REALLOC #define GROW(old) ((old) * 3 / 2) #else #define GROW(old) ((old) + 1) #endif PERL_SI * Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems) { dVAR; PERL_SI *si; Newx(si, 1, PERL_SI); si->si_stack = newAV(); AvREAL_off(si->si_stack); av_extend(si->si_stack, stitems > 0 ? stitems-1 : 0); AvALLOC(si->si_stack)[0] = &PL_sv_undef; AvFILLp(si->si_stack) = 0; si->si_prev = 0; si->si_next = 0; si->si_cxmax = cxitems - 1; si->si_cxix = -1; si->si_type = PERLSI_UNDEF; Newx(si->si_cxstack, cxitems, PERL_CONTEXT); /* Without any kind of initialising PUSHSUBST() * in pp_subst() will read uninitialised heap. */ PoisonNew(si->si_cxstack, cxitems, PERL_CONTEXT); return si; } I32 Perl_cxinc(pTHX) { dVAR; const IV old_max = cxstack_max; cxstack_max = GROW(cxstack_max); Renew(cxstack, cxstack_max + 1, PERL_CONTEXT); /* XXX should fix CXINC macro */ /* Without any kind of initialising deep enough recursion * will end up reading uninitialised PERL_CONTEXTs. */ PoisonNew(cxstack + old_max + 1, cxstack_max - old_max, PERL_CONTEXT); return cxstack_ix + 1; } void Perl_push_scope(pTHX) { dVAR; if (PL_scopestack_ix == PL_scopestack_max) { PL_scopestack_max = GROW(PL_scopestack_max); Renew(PL_scopestack, PL_scopestack_max, I32); #ifdef DEBUGGING Renew(PL_scopestack_name, PL_scopestack_max, const char*); #endif } #ifdef DEBUGGING PL_scopestack_name[PL_scopestack_ix] = "unknown"; #endif PL_scopestack[PL_scopestack_ix++] = PL_savestack_ix; } void Perl_pop_scope(pTHX) { dVAR; const I32 oldsave = PL_scopestack[--PL_scopestack_ix]; LEAVE_SCOPE(oldsave); } void Perl_markstack_grow(pTHX) { dVAR; const I32 oldmax = PL_markstack_max - PL_markstack; const I32 newmax = GROW(oldmax); Renew(PL_markstack, newmax, I32); PL_markstack_ptr = PL_markstack + oldmax; PL_markstack_max = PL_markstack + newmax; } void Perl_savestack_grow(pTHX) { dVAR; PL_savestack_max = GROW(PL_savestack_max) + 4; Renew(PL_savestack, PL_savestack_max, ANY); } void Perl_savestack_grow_cnt(pTHX_ I32 need) { dVAR; PL_savestack_max = PL_savestack_ix + need; Renew(PL_savestack, PL_savestack_max, ANY); } #undef GROW void Perl_tmps_grow(pTHX_ I32 n) { dVAR; #ifndef STRESS_REALLOC if (n < 128) n = (PL_tmps_max < 512) ? 128 : 512; #endif PL_tmps_max = PL_tmps_ix + n + 1; Renew(PL_tmps_stack, PL_tmps_max, SV*); } void Perl_free_tmps(pTHX) { dVAR; /* XXX should tmps_floor live in cxstack? */ const I32 myfloor = PL_tmps_floor; while (PL_tmps_ix > myfloor) { /* clean up after last statement */ SV* const sv = PL_tmps_stack[PL_tmps_ix]; PL_tmps_stack[PL_tmps_ix--] = NULL; if (sv && sv != &PL_sv_undef) { SvTEMP_off(sv); SvREFCNT_dec(sv); /* note, can modify tmps_ix!!! */ } } } STATIC SV * S_save_scalar_at(pTHX_ SV **sptr, const U32 flags) { dVAR; SV * osv; register SV *sv; PERL_ARGS_ASSERT_SAVE_SCALAR_AT; osv = *sptr; sv = (flags & SAVEf_KEEPOLDELEM) ? osv : (*sptr = newSV(0)); if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv) && SvTYPE(osv) != SVt_PVGV) { if (SvGMAGICAL(osv)) { const bool oldtainted = PL_tainted; SvFLAGS(osv) |= (SvFLAGS(osv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; PL_tainted = oldtainted; } if (!(flags & SAVEf_KEEPOLDELEM)) mg_localize(osv, sv, (flags & SAVEf_SETMAGIC) != 0); } return sv; } void Perl_save_pushptrptr(pTHX_ void *const ptr1, void *const ptr2, const int type) { dVAR; SSCHECK(3); SSPUSHPTR(ptr1); SSPUSHPTR(ptr2); SSPUSHINT(type); } SV * Perl_save_scalar(pTHX_ GV *gv) { dVAR; SV ** const sptr = &GvSVn(gv); PERL_ARGS_ASSERT_SAVE_SCALAR; PL_localizing = 1; SvGETMAGIC(*sptr); PL_localizing = 0; save_pushptrptr(SvREFCNT_inc_simple(gv), SvREFCNT_inc(*sptr), SAVEt_SV); return save_scalar_at(sptr, SAVEf_SETMAGIC); /* XXX - FIXME - see #60360 */ } /* Like save_sptr(), but also SvREFCNT_dec()s the new value. Can be used to * restore a global SV to its prior contents, freeing new value. */ void Perl_save_generic_svref(pTHX_ SV **sptr) { dVAR; PERL_ARGS_ASSERT_SAVE_GENERIC_SVREF; save_pushptrptr(sptr, SvREFCNT_inc(*sptr), SAVEt_GENERIC_SVREF); } /* Like save_pptr(), but also Safefree()s the new value if it is different * from the old one. Can be used to restore a global char* to its prior * contents, freeing new value. */ void Perl_save_generic_pvref(pTHX_ char **str) { dVAR; PERL_ARGS_ASSERT_SAVE_GENERIC_PVREF; save_pushptrptr(*str, str, SAVEt_GENERIC_PVREF); } /* Like save_generic_pvref(), but uses PerlMemShared_free() rather than Safefree(). * Can be used to restore a shared global char* to its prior * contents, freeing new value. */ void Perl_save_shared_pvref(pTHX_ char **str) { dVAR; PERL_ARGS_ASSERT_SAVE_SHARED_PVREF; save_pushptrptr(str, *str, SAVEt_SHARED_PVREF); } /* set the SvFLAGS specified by mask to the values in val */ void Perl_save_set_svflags(pTHX_ SV* sv, U32 mask, U32 val) { dVAR; PERL_ARGS_ASSERT_SAVE_SET_SVFLAGS; SSCHECK(4); SSPUSHPTR(sv); SSPUSHINT(mask); SSPUSHINT(val); SSPUSHINT(SAVEt_SET_SVFLAGS); } void Perl_save_gp(pTHX_ GV *gv, I32 empty) { dVAR; PERL_ARGS_ASSERT_SAVE_GP; save_pushptrptr(SvREFCNT_inc(gv), GvGP(gv), SAVEt_GP); if (empty) { GP *gp = Perl_newGP(aTHX_ gv); if (GvCVu(gv)) mro_method_changed_in(GvSTASH(gv)); /* taking a method out of circulation ("local")*/ if (GvIOp(gv) && (IoFLAGS(GvIOp(gv)) & IOf_ARGV)) { gp->gp_io = newIO(); IoFLAGS(gp->gp_io) |= IOf_ARGV|IOf_START; } #ifdef PERL_DONT_CREATE_GVSV if (gv == PL_errgv) { /* We could scatter this logic everywhere by changing the definition of ERRSV from GvSV() to GvSVn(), but it seems more efficient to do this check once here. */ gp->gp_sv = newSV(0); } #endif GvGP(gv) = gp; } else { gp_ref(GvGP(gv)); GvINTRO_on(gv); } } AV * Perl_save_ary(pTHX_ GV *gv) { dVAR; AV * const oav = GvAVn(gv); AV *av; PERL_ARGS_ASSERT_SAVE_ARY; if (!AvREAL(oav) && AvREIFY(oav)) av_reify(oav); save_pushptrptr(gv, oav, SAVEt_AV); GvAV(gv) = NULL; av = GvAVn(gv); if (SvMAGIC(oav)) mg_localize(MUTABLE_SV(oav), MUTABLE_SV(av), TRUE); return av; } HV * Perl_save_hash(pTHX_ GV *gv) { dVAR; HV *ohv, *hv; PERL_ARGS_ASSERT_SAVE_HASH; save_pushptrptr(gv, (ohv = GvHVn(gv)), SAVEt_HV); GvHV(gv) = NULL; hv = GvHVn(gv); if (SvMAGIC(ohv)) mg_localize(MUTABLE_SV(ohv), MUTABLE_SV(hv), TRUE); return hv; } void Perl_save_item(pTHX_ register SV *item) { dVAR; register SV * const sv = newSVsv(item); PERL_ARGS_ASSERT_SAVE_ITEM; save_pushptrptr(item, /* remember the pointer */ sv, /* remember the value */ SAVEt_ITEM); } void Perl_save_bool(pTHX_ bool *boolp) { dVAR; PERL_ARGS_ASSERT_SAVE_BOOL; SSCHECK(3); SSPUSHBOOL(*boolp); SSPUSHPTR(boolp); SSPUSHINT(SAVEt_BOOL); } void Perl_save_pushi32ptr(pTHX_ const I32 i, void *const ptr, const int type) { dVAR; SSCHECK(3); SSPUSHINT(i); SSPUSHPTR(ptr); SSPUSHINT(type); } void Perl_save_int(pTHX_ int *intp) { dVAR; PERL_ARGS_ASSERT_SAVE_INT; save_pushi32ptr(*intp, intp, SAVEt_INT); } void Perl_save_I8(pTHX_ I8 *bytep) { dVAR; PERL_ARGS_ASSERT_SAVE_I8; save_pushi32ptr(*bytep, bytep, SAVEt_I8); } void Perl_save_I16(pTHX_ I16 *intp) { dVAR; PERL_ARGS_ASSERT_SAVE_I16; save_pushi32ptr(*intp, intp, SAVEt_I16); } void Perl_save_I32(pTHX_ I32 *intp) { dVAR; PERL_ARGS_ASSERT_SAVE_I32; save_pushi32ptr(*intp, intp, SAVEt_I32); } /* Cannot use save_sptr() to store a char* since the SV** cast will * force word-alignment and we'll miss the pointer. */ void Perl_save_pptr(pTHX_ char **pptr) { dVAR; PERL_ARGS_ASSERT_SAVE_PPTR; save_pushptrptr(*pptr, pptr, SAVEt_PPTR); } void Perl_save_vptr(pTHX_ void *ptr) { dVAR; PERL_ARGS_ASSERT_SAVE_VPTR; save_pushptrptr(*(char**)ptr, ptr, SAVEt_VPTR); } void Perl_save_sptr(pTHX_ SV **sptr) { dVAR; PERL_ARGS_ASSERT_SAVE_SPTR; save_pushptrptr(*sptr, sptr, SAVEt_SPTR); } void Perl_save_padsv_and_mortalize(pTHX_ PADOFFSET off) { dVAR; SSCHECK(4); ASSERT_CURPAD_ACTIVE("save_padsv"); SSPUSHPTR(SvREFCNT_inc_simple_NN(PL_curpad[off])); SSPUSHPTR(PL_comppad); SSPUSHLONG((long)off); SSPUSHINT(SAVEt_PADSV_AND_MORTALIZE); } void Perl_save_hptr(pTHX_ HV **hptr) { dVAR; PERL_ARGS_ASSERT_SAVE_HPTR; save_pushptrptr(*hptr, hptr, SAVEt_HPTR); } void Perl_save_aptr(pTHX_ AV **aptr) { dVAR; PERL_ARGS_ASSERT_SAVE_APTR; save_pushptrptr(*aptr, aptr, SAVEt_APTR); } void Perl_save_pushptr(pTHX_ void *const ptr, const int type) { dVAR; SSCHECK(2); SSPUSHPTR(ptr); SSPUSHINT(type); } void Perl_save_clearsv(pTHX_ SV **svp) { dVAR; PERL_ARGS_ASSERT_SAVE_CLEARSV; ASSERT_CURPAD_ACTIVE("save_clearsv"); SSCHECK(2); SSPUSHLONG((long)(svp-PL_curpad)); SSPUSHINT(SAVEt_CLEARSV); SvPADSTALE_off(*svp); /* mark lexical as active */ } void Perl_save_delete(pTHX_ HV *hv, char *key, I32 klen) { dVAR; PERL_ARGS_ASSERT_SAVE_DELETE; save_pushptri32ptr(key, klen, SvREFCNT_inc_simple(hv), SAVEt_DELETE); } void Perl_save_hdelete(pTHX_ HV *hv, SV *keysv) { STRLEN len; I32 klen; const char *key; PERL_ARGS_ASSERT_SAVE_HDELETE; key = SvPV_const(keysv, len); klen = SvUTF8(keysv) ? -(I32)len : (I32)len; SvREFCNT_inc_simple_void_NN(hv); save_pushptri32ptr(savepvn(key, len), klen, hv, SAVEt_DELETE); } void Perl_save_adelete(pTHX_ AV *av, I32 key) { dVAR; PERL_ARGS_ASSERT_SAVE_ADELETE; SvREFCNT_inc_void(av); save_pushi32ptr(key, av, SAVEt_ADELETE); } void Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p) { dVAR; PERL_ARGS_ASSERT_SAVE_DESTRUCTOR; SSCHECK(3); SSPUSHDPTR(f); SSPUSHPTR(p); SSPUSHINT(SAVEt_DESTRUCTOR); } void Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p) { dVAR; SSCHECK(3); SSPUSHDXPTR(f); SSPUSHPTR(p); SSPUSHINT(SAVEt_DESTRUCTOR_X); } void Perl_save_hints(pTHX) { dVAR; if (PL_compiling.cop_hints_hash) { HINTS_REFCNT_LOCK; PL_compiling.cop_hints_hash->refcounted_he_refcnt++; HINTS_REFCNT_UNLOCK; } if (PL_hints & HINT_LOCALIZE_HH) { save_pushptri32ptr(GvHV(PL_hintgv), PL_hints, PL_compiling.cop_hints_hash, SAVEt_HINTS); GvHV(PL_hintgv) = Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)); } else { save_pushi32ptr(PL_hints, PL_compiling.cop_hints_hash, SAVEt_HINTS); } } static void S_save_pushptri32ptr(pTHX_ void *const ptr1, const I32 i, void *const ptr2, const int type) { SSCHECK(4); SSPUSHPTR(ptr1); SSPUSHINT(i); SSPUSHPTR(ptr2); SSPUSHINT(type); } void Perl_save_aelem_flags(pTHX_ AV *av, I32 idx, SV **sptr, const U32 flags) { dVAR; SV *sv; PERL_ARGS_ASSERT_SAVE_AELEM_FLAGS; SvGETMAGIC(*sptr); save_pushptri32ptr(SvREFCNT_inc_simple(av), idx, SvREFCNT_inc(*sptr), SAVEt_AELEM); /* if it gets reified later, the restore will have the wrong refcnt */ if (!AvREAL(av) && AvREIFY(av)) SvREFCNT_inc_void(*sptr); save_scalar_at(sptr, flags); /* XXX - FIXME - see #60360 */ if (flags & SAVEf_KEEPOLDELEM) 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 (SvTIED_mg(sv, PERL_MAGIC_tiedelem)) sv_2mortal(sv); } void Perl_save_helem_flags(pTHX_ HV *hv, SV *key, SV **sptr, const U32 flags) { dVAR; SV *sv; PERL_ARGS_ASSERT_SAVE_HELEM_FLAGS; SvGETMAGIC(*sptr); SSCHECK(4); SSPUSHPTR(SvREFCNT_inc_simple(hv)); SSPUSHPTR(newSVsv(key)); SSPUSHPTR(SvREFCNT_inc(*sptr)); SSPUSHINT(SAVEt_HELEM); save_scalar_at(sptr, flags); if (flags & SAVEf_KEEPOLDELEM) 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 (SvTIED_mg(sv, PERL_MAGIC_tiedelem)) sv_2mortal(sv); } SV* Perl_save_svref(pTHX_ SV **sptr) { dVAR; PERL_ARGS_ASSERT_SAVE_SVREF; SvGETMAGIC(*sptr); save_pushptrptr(sptr, SvREFCNT_inc(*sptr), SAVEt_SVREF); return save_scalar_at(sptr, SAVEf_SETMAGIC); /* XXX - FIXME - see #60360 */ } I32 Perl_save_alloc(pTHX_ I32 size, I32 pad) { dVAR; register const I32 start = pad + ((char*)&PL_savestack[PL_savestack_ix] - (char*)PL_savestack); register const I32 elems = 1 + ((size + pad - 1) / sizeof(*PL_savestack)); SSGROW(elems + 2); PL_savestack_ix += elems; SSPUSHINT(elems); SSPUSHINT(SAVEt_ALLOC); return start; } void Perl_leave_scope(pTHX_ I32 base) { dVAR; register SV *sv; register SV *value; register GV *gv; register AV *av; register HV *hv; void* ptr; register char* str; I32 i; /* Localise the effects of the TAINT_NOT inside the loop. */ const bool was = PL_tainted; if (base < -1) Perl_croak(aTHX_ "panic: corrupt saved stack index"); while (PL_savestack_ix > base) { TAINT_NOT; switch (SSPOPINT) { case SAVEt_ITEM: /* normal string */ value = MUTABLE_SV(SSPOPPTR); sv = MUTABLE_SV(SSPOPPTR); sv_replace(sv,value); PL_localizing = 2; SvSETMAGIC(sv); PL_localizing = 0; break; case SAVEt_SV: /* scalar reference */ value = MUTABLE_SV(SSPOPPTR); gv = MUTABLE_GV(SSPOPPTR); ptr = &GvSV(gv); av = MUTABLE_AV(gv); /* what to refcnt_dec */ restore_sv: sv = *(SV**)ptr; *(SV**)ptr = value; SvREFCNT_dec(sv); PL_localizing = 2; SvSETMAGIC(value); PL_localizing = 0; SvREFCNT_dec(value); if (av) /* actually an av, hv or gv */ SvREFCNT_dec(av); break; case SAVEt_GENERIC_PVREF: /* generic pv */ ptr = SSPOPPTR; str = (char*)SSPOPPTR; if (*(char**)ptr != str) { Safefree(*(char**)ptr); *(char**)ptr = str; } break; case SAVEt_SHARED_PVREF: /* shared pv */ str = (char*)SSPOPPTR; ptr = SSPOPPTR; if (*(char**)ptr != str) { #ifdef NETWARE PerlMem_free(*(char**)ptr); #else PerlMemShared_free(*(char**)ptr); #endif *(char**)ptr = str; } break; case SAVEt_GENERIC_SVREF: /* generic sv */ value = MUTABLE_SV(SSPOPPTR); ptr = SSPOPPTR; sv = *(SV**)ptr; *(SV**)ptr = value; SvREFCNT_dec(sv); SvREFCNT_dec(value); break; case SAVEt_AV: /* array reference */ av = MUTABLE_AV(SSPOPPTR); gv = MUTABLE_GV(SSPOPPTR); SvREFCNT_dec(GvAV(gv)); GvAV(gv) = av; if (SvMAGICAL(av)) { PL_localizing = 2; SvSETMAGIC(MUTABLE_SV(av)); PL_localizing = 0; } break; case SAVEt_HV: /* hash reference */ hv = MUTABLE_HV(SSPOPPTR); gv = MUTABLE_GV(SSPOPPTR); SvREFCNT_dec(GvHV(gv)); GvHV(gv) = hv; if (SvMAGICAL(hv)) { PL_localizing = 2; SvSETMAGIC(MUTABLE_SV(hv)); PL_localizing = 0; } break; case SAVEt_INT: /* int reference */ ptr = SSPOPPTR; *(int*)ptr = (int)SSPOPINT; break; case SAVEt_BOOL: /* bool reference */ ptr = SSPOPPTR; *(bool*)ptr = (bool)SSPOPBOOL; break; case SAVEt_I32: /* I32 reference */ ptr = SSPOPPTR; #ifdef PERL_DEBUG_READONLY_OPS { const I32 val = SSPOPINT; if (*(I32*)ptr != val) *(I32*)ptr = val; } #else *(I32*)ptr = (I32)SSPOPINT; #endif break; case SAVEt_SPTR: /* SV* reference */ ptr = SSPOPPTR; *(SV**)ptr = MUTABLE_SV(SSPOPPTR); break; case SAVEt_VPTR: /* random* reference */ case SAVEt_PPTR: /* char* reference */ ptr = SSPOPPTR; *(char**)ptr = (char*)SSPOPPTR; break; case SAVEt_HPTR: /* HV* reference */ ptr = SSPOPPTR; *(HV**)ptr = MUTABLE_HV(SSPOPPTR); break; case SAVEt_APTR: /* AV* reference */ ptr = SSPOPPTR; *(AV**)ptr = MUTABLE_AV(SSPOPPTR); break; case SAVEt_GP: /* scalar reference */ ptr = SSPOPPTR; gv = MUTABLE_GV(SSPOPPTR); gp_free(gv); GvGP(gv) = (GP*)ptr; /* putting a method back into circulation ("local")*/ if (GvCVu(gv) && (hv=GvSTASH(gv)) && HvNAME_get(hv)) mro_method_changed_in(hv); SvREFCNT_dec(gv); break; case SAVEt_FREESV: ptr = SSPOPPTR; SvREFCNT_dec(MUTABLE_SV(ptr)); break; case SAVEt_MORTALIZESV: ptr = SSPOPPTR; sv_2mortal(MUTABLE_SV(ptr)); break; case SAVEt_FREEOP: ptr = SSPOPPTR; ASSERT_CURPAD_LEGAL("SAVEt_FREEOP"); /* XXX DAPM tmp */ op_free((OP*)ptr); break; case SAVEt_FREEPV: ptr = SSPOPPTR; Safefree(ptr); break; case SAVEt_CLEARSV: ptr = (void*)&PL_curpad[SSPOPLONG]; sv = *(SV**)ptr; DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf"[0x%"UVxf"] clearsv: %ld sv=0x%"UVxf"<%"IVdf"> %s\n", PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)((SV **)ptr-PL_curpad), PTR2UV(sv), (IV)SvREFCNT(sv), (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) ? "clear" : "abandon" )); /* Can clear pad variable in place? */ if (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) { /* * if a my variable that was made readonly is going out of * scope, we want to remove the readonlyness so that it can * go out of scope quietly */ if (SvPADMY(sv) && !SvFAKE(sv)) SvREADONLY_off(sv); if (SvTHINKFIRST(sv)) sv_force_normal_flags(sv, SV_IMMEDIATE_UNREF); if (SvMAGICAL(sv)) mg_free(sv); switch (SvTYPE(sv)) { case SVt_NULL: break; case SVt_PVAV: av_clear(MUTABLE_AV(sv)); break; case SVt_PVHV: hv_clear(MUTABLE_HV(sv)); break; case SVt_PVCV: Perl_croak(aTHX_ "panic: leave_scope pad code"); default: SvOK_off(sv); break; } SvPADSTALE_on(sv); /* mark as no longer live */ } else { /* Someone has a claim on this, so abandon it. */ const U32 padflags = SvFLAGS(sv) & (SVs_PADMY|SVs_PADTMP); switch (SvTYPE(sv)) { /* Console ourselves with a new value */ case SVt_PVAV: *(SV**)ptr = MUTABLE_SV(newAV()); break; case SVt_PVHV: *(SV**)ptr = MUTABLE_SV(newHV()); break; default: *(SV**)ptr = newSV(0); break; } SvREFCNT_dec(sv); /* Cast current value to the winds. */ /* preserve pad nature, but also mark as not live * for any closure capturing */ SvFLAGS(*(SV**)ptr) |= padflags | SVs_PADSTALE; } break; case SAVEt_DELETE: ptr = SSPOPPTR; hv = MUTABLE_HV(ptr); i = SSPOPINT; ptr = SSPOPPTR; (void)hv_delete(hv, (char*)ptr, i, G_DISCARD); SvREFCNT_dec(hv); Safefree(ptr); break; case SAVEt_ADELETE: ptr = SSPOPPTR; av = MUTABLE_AV(ptr); i = SSPOPINT; (void)av_delete(av, i, G_DISCARD); SvREFCNT_dec(av); break; case SAVEt_DESTRUCTOR_X: ptr = SSPOPPTR; (*SSPOPDXPTR)(aTHX_ ptr); break; case SAVEt_REGCONTEXT: case SAVEt_ALLOC: i = SSPOPINT; PL_savestack_ix -= i; /* regexp must have croaked */ break; case SAVEt_STACK_POS: /* Position on Perl stack */ i = SSPOPINT; PL_stack_sp = PL_stack_base + i; break; case SAVEt_STACK_CXPOS: /* blk_oldsp on context stack */ i = SSPOPINT; cxstack[i].blk_oldsp = SSPOPINT; break; case SAVEt_AELEM: /* array element */ value = MUTABLE_SV(SSPOPPTR); i = SSPOPINT; av = MUTABLE_AV(SSPOPPTR); ptr = av_fetch(av,i,1); if (!AvREAL(av) && AvREIFY(av)) /* undo reify guard */ SvREFCNT_dec(value); if (ptr) { sv = *(SV**)ptr; if (sv && sv != &PL_sv_undef) { if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied)) SvREFCNT_inc_void_NN(sv); goto restore_sv; } } SvREFCNT_dec(av); SvREFCNT_dec(value); break; case SAVEt_HELEM: /* hash element */ value = MUTABLE_SV(SSPOPPTR); sv = MUTABLE_SV(SSPOPPTR); hv = MUTABLE_HV(SSPOPPTR); ptr = hv_fetch_ent(hv, sv, 1, 0); SvREFCNT_dec(sv); if (ptr) { const SV * const oval = HeVAL((HE*)ptr); if (oval && oval != &PL_sv_undef) { ptr = &HeVAL((HE*)ptr); if (SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) SvREFCNT_inc_void(*(SV**)ptr); av = MUTABLE_AV(hv); /* what to refcnt_dec */ goto restore_sv; } } SvREFCNT_dec(hv); SvREFCNT_dec(value); break; case SAVEt_OP: PL_op = (OP*)SSPOPPTR; break; case SAVEt_HINTS: if ((PL_hints & HINT_LOCALIZE_HH) && GvHV(PL_hintgv)) { SvREFCNT_dec(MUTABLE_SV(GvHV(PL_hintgv))); GvHV(PL_hintgv) = NULL; } Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash); PL_compiling.cop_hints_hash = (struct refcounted_he *) SSPOPPTR; *(I32*)&PL_hints = (I32)SSPOPINT; if (PL_hints & HINT_LOCALIZE_HH) { SvREFCNT_dec(MUTABLE_SV(GvHV(PL_hintgv))); GvHV(PL_hintgv) = MUTABLE_HV(SSPOPPTR); assert(GvHV(PL_hintgv)); } else if (!GvHV(PL_hintgv)) { /* Need to add a new one manually, else gv_fetchpv() can add one in this code: if (SvTYPE(gv) == SVt_PVGV) { if (add) { GvMULTI_on(gv); gv_init_sv(gv, sv_type); if (*name=='!' && sv_type == SVt_PVHV && len==1) require_errno(gv); } return gv; } 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: PL_comppad = (PAD*)SSPOPPTR; if (PL_comppad) PL_curpad = AvARRAY(PL_comppad); else PL_curpad = NULL; break; case SAVEt_PADSV_AND_MORTALIZE: { const PADOFFSET off = (PADOFFSET)SSPOPLONG; SV **svp; ptr = SSPOPPTR; assert (ptr); svp = AvARRAY((PAD*)ptr) + off; /* This mortalizing used to be done by POPLOOP() 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 = MUTABLE_SV(SSPOPPTR); } break; case SAVEt_SAVESWITCHSTACK: { dSP; AV *const t = MUTABLE_AV(SSPOPPTR); AV *const f = MUTABLE_AV(SSPOPPTR); SWITCHSTACK(t,f); PL_curstackinfo->si_stack = f; } break; case SAVEt_SET_SVFLAGS: { const U32 val = (U32)SSPOPINT; const U32 mask = (U32)SSPOPINT; sv = MUTABLE_SV(SSPOPPTR); SvFLAGS(sv) &= ~mask; SvFLAGS(sv) |= val; } 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 */ value = MUTABLE_SV(SSPOPPTR); ptr = SSPOPPTR; av = NULL; /* what to refcnt_dec */ goto restore_sv; /* These are only saved in mathoms.c */ case SAVEt_NSTAB: gv = MUTABLE_GV(SSPOPPTR); (void)sv_clear(MUTABLE_SV(gv)); break; case SAVEt_LONG: /* long reference */ ptr = SSPOPPTR; *(long*)ptr = (long)SSPOPLONG; break; case SAVEt_IV: /* IV reference */ ptr = SSPOPPTR; *(IV*)ptr = (IV)SSPOPIV; break; case SAVEt_I16: /* I16 reference */ ptr = SSPOPPTR; *(I16*)ptr = (I16)SSPOPINT; break; case SAVEt_I8: /* I8 reference */ ptr = SSPOPPTR; *(I8*)ptr = (I8)SSPOPINT; break; case SAVEt_DESTRUCTOR: ptr = SSPOPPTR; (*SSPOPDPTR)(ptr); break; case SAVEt_COP_ARYBASE: ptr = SSPOPPTR; i = SSPOPINT; CopARYBASE_set((COP *)ptr, i); break; case SAVEt_COMPILE_WARNINGS: ptr = SSPOPPTR; if (!specialWARN(PL_compiling.cop_warnings)) PerlMemShared_free(PL_compiling.cop_warnings); PL_compiling.cop_warnings = (STRLEN*)ptr; break; case SAVEt_RE_STATE: { const struct re_save_state *const state = (struct re_save_state *) (PL_savestack + PL_savestack_ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE); PL_savestack_ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE; if (PL_reg_start_tmp != state->re_state_reg_start_tmp) { Safefree(PL_reg_start_tmp); } if (PL_reg_poscache != state->re_state_reg_poscache) { Safefree(PL_reg_poscache); } Copy(state, &PL_reg_state, 1, struct re_save_state); } break; case SAVEt_PARSER: ptr = SSPOPPTR; parser_free((yy_parser *) ptr); break; default: Perl_croak(aTHX_ "panic: leave_scope inconsistency"); } } PL_tainted = was; } void Perl_cx_dump(pTHX_ PERL_CONTEXT *cx) { dVAR; PERL_ARGS_ASSERT_CX_DUMP; #ifdef DEBUGGING PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), PL_block_type[CxTYPE(cx)]); if (CxTYPE(cx) != CXt_SUBST) { 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_OLDPM = 0x%"UVxf"\n", PTR2UV(cx->blk_oldpm)); PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", cx->blk_gimme ? "LIST" : "SCALAR"); } switch (CxTYPE(cx)) { case CXt_NULL: case CXt_BLOCK: 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; 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; 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; case CXt_LOOP_LAZYIV: case CXt_LOOP_LAZYSV: case CXt_LOOP_FOR: case CXt_LOOP_PLAIN: PerlIO_printf(Perl_debug_log, "BLK_LOOP.LABEL = %s\n", CxLABEL(cx)); PerlIO_printf(Perl_debug_log, "BLK_LOOP.RESETSP = %ld\n", (long)cx->blk_loop.resetsp); 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.NEXT_OP = 0x%"UVxf"\n", PTR2UV(CX_LOOP_NEXTOP_GET(cx))); /* XXX: not accurate for LAZYSV/IV */ 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); PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERVAR = 0x%"UVxf"\n", PTR2UV(CxITERVAR(cx))); 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; } #else PERL_UNUSED_CONTEXT; PERL_UNUSED_ARG(cx); #endif /* DEBUGGING */ } /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */ perl-5.12.0-RC0/epoc/0000755000175000017500000000000011351321566013060 5ustar jessejesseperl-5.12.0-RC0/epoc/epocish.h0000444000175000017500000001071011325125741014656 0ustar jessejesse/* * The following symbols are defined if your operating system supports * functions by that name. All Unixes I know of support them, thus they * are not checked by the configuration script, but are directly defined * here. */ /* HAS_IOCTL: * This symbol, if defined, indicates that the ioctl() routine is * available to set I/O characteristics */ #define HAS_IOCTL /**/ /* HAS_UTIME: * This symbol, if defined, indicates that the routine utime() is * available to update the access and modification times of files. */ /* #define HAS_UTIME / **/ /* HAS_GROUP * This symbol, if defined, indicates that the getgrnam() and * getgrgid() routines are available to get group entries. * The getgrent() has a separate definition, HAS_GETGRENT. */ /* #define HAS_GROUP / **/ /* HAS_PASSWD * This symbol, if defined, indicates that the getpwnam() and * getpwuid() routines are available to get password entries. * The getpwent() has a separate definition, HAS_GETPWENT. */ /* #define HAS_PASSWD / **/ /* #define HAS_KILL */ #define HAS_WAIT /* USEMYBINMODE * This symbol, if defined, indicates that the program should * use the routine my_binmode(FILE *fp, char iotype, int mode) to insure * that a file is in "binary" mode -- that is, that no translation * of bytes occurs on read or write operations. */ #undef USEMYBINMODE /* Stat_t: * This symbol holds the type used to declare buffers for information * returned by stat(). It's usually just struct stat. It may be necessary * to include and to get any typedef'ed * information. */ #define Stat_t struct stat /* USE_STAT_RDEV: * This symbol is defined if this system has a stat structure declaring * st_rdev */ #define USE_STAT_RDEV /**/ /* ACME_MESS: * This symbol, if defined, indicates that error messages should be * should be generated in a format that allows the use of the Acme * GUI/editor's autofind feature. */ #undef ACME_MESS /**/ /* UNLINK_ALL_VERSIONS: * This symbol, if defined, indicates that the program should arrange * to remove all versions of a file if unlink() is called. This is * probably only relevant for VMS. */ /* #define UNLINK_ALL_VERSIONS / **/ /* VMS: * This symbol, if defined, indicates that the program is running under * VMS. It is currently automatically set by cpps running under VMS, * and is included here for completeness only. */ /* #define VMS / **/ /* ALTERNATE_SHEBANG: * This symbol, if defined, contains a "magic" string which may be used * as the first line of a Perl program designed to be executed directly * by name, instead of the standard Unix #!. If ALTERNATE_SHEBANG * begins with a character other then #, then Perl will only treat * it as a command line if if finds the string "perl" in the first * word; otherwise it's treated as the first line of code in the script. * (IOW, Perl won't hand off to another interpreter via an alternate * shebang sequence that might be legal Perl code.) */ /* #define ALTERNATE_SHEBANG "#!" / **/ #define ABORT() abort(); /* * fwrite1() should be a routine with the same calling sequence as fwrite(), * but which outputs all of the bytes requested as a single stream (unlike * fwrite() itself, which on some systems outputs several distinct records * if the number_of_items parameter is >1). */ #define fwrite1 fwrite #define Stat(fname,bufptr) stat((fname),(bufptr)) #define Fstat(fd,bufptr) fstat((fd),(bufptr)) #define Fflush(fp) fflush(fp) #define Mkdir(path,mode) mkdir((path),(mode)) /* epocemx setenv bug workaround */ #ifndef PERL_SYS_INIT_BODY # define PERL_SYS_INIT_BODY(c,v) \ MALLOC_CHECK_TAINT2(*c,*v) putenv(".dummy=foo"); putenv(".dummy"); \ PERLIO_INIT; MALLOC_INIT #endif #ifndef PERL_SYS_TERM_BODY #define PERL_SYS_TERM_BODY() PERLIO_TERM; MALLOC_TERM #endif #define BIT_BUCKET "/dev/null" #define dXSUB_SYS /* getsockname returns the size of struct sockaddr_in *without* padding */ #define BOGUS_GETNAME_RETURN 8 /* read() on a socket is unimplemented in current epocemx use recv() instead */ #define PERL_SOCK_SYSREAD_IS_RECV /* write ditto, use send */ #define PERL_SOCK_SYSWRITE_IS_SEND /* No /dev/random available*/ #define PERL_NO_DEV_RANDOM /* work around for buggy atof(): atof() in ER5 stdlib depends on locale. */ #define strtoul(a,b,c) epoc_strtoul(a,b,c) #define init_os_extras Perl_init_os_extras #define ARG_MAX 4096 #define ECONNABORTED 0xdead /* For environ */ #include #define PERL_USE_SAFE_PUTENV perl-5.12.0-RC0/epoc/config.sh0000444000175000017500000005300411347250766014671 0ustar jessejesse#!/bin/sh # # This file is manually maintained. # # It is NOT produced by running the Configure script. # # Package name : perl5 # Source directory : . # Configuration time: # Configured by : Olaf Flebbe # Target system : EPOC Author='' Date='$Date' Header='' Id='$Id' Locker='' Log='$Log' RCSfile='$RCSfile' Revision='$Revision' Source='' State='' _a='.a' _exe='.exe' _o='.o' afs='false' afsroot='/afs' alignbytes='8' ansi2knr='' aphostname='' apirevision='' apisubversion='' apiversion='' ar='arm-epoc-pe-ar' archlib='/usr/lib/perl/5.12.0/epoc' archlibexp='/usr/lib/perl/5.12.0/epoc' archname64='' archname='epoc' archobjs='epoc.o epocish.o epoc_stubs.o' asctime_r_proto='0' awk='awk' baserev='5.0' bash='' bin='' binexp='' bison='bison' byacc='' byteorder='1234' c='' castflags='0' cat='cat' cc='arm-epoc-pe-gcc -DEPOC' cccdlflags='' ccdlflags='' ccflags='' ccsymbols='' cf_by='olaf' cf_email='o.flebbe@gmx.de' cf_time='Dec 2001' charbits='8' chgrp='' chmod='' chown='' clocktype='' comm='' compress='' contains='grep' cp='cp' cpio='' cpp='arm-epoc-pe-cpp' cpp_stuff='42' cppccsymbols='EPOC=1' cppflags='' cpplast='-' cppminus='-' cpprun='arm-epoc-pe-gcc -E' cppstdin='arm-epoc-pe-gcc -E' cppsymbols='' crypt_r_proto='0' cryptlib='' csh='csh' ctermid_r_proto='0' ctime_r_proto='0' d_Gconvert='epoc_gcvt((x),(n),(b))' d_PRIEUldbl='undef' d_PRIFUldbl='undef' d_PRIGUldbl='undef' d_PRIXU64='undef' d_PRId64='undef' d_PRIeldbl='undef' d_PRIfldbl='define' d_PRIgldbl='define' d_PRIi64='undef' d_PRIo64='undef' d_PRIu64='undef' d_PRIx64='undef' d__fwalk='undef' d_access='undef' d_accessx='undef' d_aintl='undef' d_alarm='undef' d_archlib='define' d_asctime64='undef' d_asctime_r='undef' d_atolf='undef' d_atoll='undef' d_attribute_deprecated='undef' d_attribute_format='undef' d_attribute_malloc='undef' d_attribute_nonnull='undef' d_attribute_noreturn='undef' d_attribute_pure='undef' d_attribute_unused='undef' d_attribute_warn_unused_result='undef' d_bcmp='define' d_bcopy='define' d_bsdgetpgrp='undef' d_bsdsetpgrp='undef' d_bsd='undef' d_bzero='define' d_c99_variadic_macros='undef' d_casti32='undef' d_castneg='undef' d_charvspr='undef' d_chown='undef' d_chroot='undef' d_chsize='undef' d_class='undef' d_clearenv='define' d_closedir='undef' d_cmsghdr_s='undef' d_cmsghdr_s='undef' d_const='define' d_copysignl='undef' d_cplusplus='undef' d_crypt_r='undef' d_crypt='undef' d_csh='undef' d_ctermid_r='undef' d_ctime64='undef' d_ctime_r='undef' d_cuserid='undef' d_dbl_dig='undef' d_dbminitproto='undef' d_difftime64='undef' d_difftime='define' d_dir_dd_fd='undef' d_dirfd='undef' d_dirnamlen='undef' d_dlerror='undef' d_dlopen='undef' d_dlsymun='undef' d_dosuid='undef' d_drand48proto='define' d_drand48_r='undef' d_dup2='undef' d_eaccess='undef' d_endgrent_r='undef' d_endgrent='undef' d_endhent='undef' d_endhostent_r='undef' d_endnent='undef' d_endnetent_r='undef' d_endpent='undef' d_endprotoent_r='undef' d_endpwent_r='undef' d_endpwent='undef' d_endsent='undef' d_endservent_r='undef' d_eofnblk='define' d_eunice='undef' d_faststdio='undef' d_fchdir='undef' d_fchmod='undef' d_fchown='undef' d_fcntl_can_lock='undef' d_fcntl='undef' d_fd_macros='undef' d_fds_bits='undef' d_fd_set='define' d_fgetpos='define' d_finitel='undef' d_finite='undef' d_flexfnam='define' d_flockproto='undef' d_flock='undef' d_fork='undef' d_fpathconf='undef' d_fpclassify='undef' d_fpclassl='undef' d_fp_class='undef' d_fpclass='undef' d_fpos64_t='undef' d_frexpl='undef' d_fseeko='undef' d_fsetpos='define' d_fstatfs='define' d_fstatvfs='undef' d_fsync='undef' d_ftello='undef' d_ftime='undef' d_futimes='undef' d_gdbm_ndbm_h_uses_prototypes='undef' d_gdbmndbm_h_uses_prototypes='undef' d_getaddrinfo='undef' d_getespwnam='undef' d_getfsstat='undef' d_getgrent_r='undef' d_getgrent='undef' d_getgrgid_r='undef' d_getgrnam_r='undef' d_getgrps='undef' d_gethbyaddr='define' d_gethbyname='define' d_gethent='undef' d_gethname='undef' d_gethostbyaddr_r='undef' d_gethostbyname_r='undef' d_gethostent_r='undef' d_gethostprotos='define' d_getitimer='undef' d_getlogin_r='undef' d_getlogin='undef' d_getmntent='undef' d_getnameinfo='undef' d_getnbyaddr='undef' d_getnbyname='undef' d_getnent='undef' d_getnetbyaddr_r='undef' d_getnetbyname_r='undef' d_getnetent_r='undef' d_getnetprotos='define' d_getpagsz='undef' d_getpbyname='define' d_getpbynumber='define' d_getpent='undef' d_getpgid='undef' d_getpgrp2='undef' d_getpgrp='undef' d_getppid='undef' d_getprior='undef' d_getprotobyname_r='undef' d_getprotobynumber_r='undef' d_getprotoent_r='undef' d_getprotoprotos='define' d_getprpwnam='undef' d_getpwent_r='undef' d_getpwent='undef' d_getpwnam_r='undef' d_getpwuid_r='undef' d_getsbyname='undef' d_getsbyport='undef' d_getsent='undef' d_getservbyname_r='undef' d_getservbyport_r='undef' d_getservent_r='undef' d_getservprotos='define' d_getspnam_r='undef' d_getspnam='undef' d_gettimeod='define' d_gmtime64='undef' d_gmtime_r='undef' d_gnulibc='undef' d_grpasswd='undef' d_hasmntopt='undef' d_htonl='define' d_ilogbl='undef' d_index='undef' d_inetaton='define' d_inetntop='undef' d_inetpton='undef' d_int64_t='undef' d_iovec_s='undef' d_isascii='define' d_isfinite='undef' d_isinf='undef' d_isnan='define' d_isnanl='undef' d_killpg='undef' d_lchown='undef' d_ldbl_dig='undef' d_link='undef' d_llseek='undef' d_localtime64='undef' d_localtime_r_needs_tzset='undef' d_localtime_r='undef' d_locconv='undef' d_lockf='undef' d_longdbl='undef' d_longlong='define' d_lseekproto='define' d_lstat='undef' d_madvise='undef' d_malloc_good_size='undef' d_malloc_size='undef' d_mblen='undef' d_mbstowcs='undef' d_mbtowc='undef' d_memchr='define' d_memcmp='define' d_memcpy='define' d_memmove='define' d_memset='define' d_mkdir='define' d_mkfifo='undef' d_mktime64='undef' d_mktime='define' d_mmap='undef' d_modfl_pow32_bug='undef' d_modflproto='undef' d_modfl='undef' d_mprotect='undef' d_msgctl='undef' d_msg_ctrunc='undef' d_msg_dontroute='undef' d_msgget='undef' d_msghdr_s='undef' d_msghdr_s='undef' d_msg_oob='undef' d_msg_peek='undef' d_msg_proxy='undef' d_msgrcv='undef' d_msgsnd='undef' d_msg='undef' d_msync='undef' d_munmap='undef' d_mymalloc='undef' d_ndbm_h_uses_prototypes='undef' d_nice='undef' d_nl_langinfo='undef' d_off64_t='undef' d_old_pthread_create_joinable='undef' d_oldpthreads='undef' d_oldsock='undef' d_open3='define' d_pathconf='undef' d_pause='undef' d_perl_otherlibdirs='undef' d_phostname='undef' d_pipe='undef' d_poll='undef' d_portable='undef' d_procselfexe='undef' d_pthread_atfork='undef' d_pthread_attr_setscope='undef' d_pthread_yield='undef' d_pwage='undef' d_pwchange='undef' d_pwclass='undef' d_pwcomment='undef' d_pwexpire='undef' d_pwgecos='undef' d_pwpasswd='undef' d_pwquota='undef' d_qgcvt='undef' d_random_r='undef' d_readdir64_r='undef' d_readdir='define' d_readdir_r='undef' d_readlink='undef' d_readv='undef' d_readv='undef' d_recvmsg='undef' d_recvmsg='undef' d_rename='define' d_rewinddir='define' d_rmdir='define' d_safebcpy='undef' d_safemcpy='undef' d_sanemcmp='define' d_sbrkproto='undef' d_scalbnl='undef' d_sched_yield='undef' d_scm_rights='undef' d_seekdir='define' d_select='undef' d_sem='undef' d_semctl='undef' d_semctl_semid_ds='define' d_semctl_semun='define' d_semget='undef' d_semop='undef' d_sendmsg='undef' d_setegid='undef' d_seteuid='undef' d_setgrent='undef' d_setgrent_r='undef' d_setgrps='undef' d_sethent='undef' d_sethostent_r='undef' d_setitimer='undef' d_setlinebuf='undef' d_setlocale='undef' d_setlocale_r='undef' d_setnent='undef' d_setnetent_r='undef' d_setpent='undef' d_setpgid='undef' d_setpgrp2='undef' d_setpgrp='undef' d_setprior='undef' d_setproctitle='undef' d_setprotoent_r='undef' d_setpwent='undef' d_setpwent_r='undef' d_setregid='undef' d_setresgid='undef' d_setresuid='undef' d_setreuid='undef' d_setrgid='undef' d_setruid='undef' d_setsent='undef' d_setservent_r='undef' d_setsid='undef' d_setvbuf='undef' d_sfio='undef' d_shm='undef' d_shmat='undef' d_shmatprototype='undef' d_shmctl='undef' d_shmdt='undef' d_shmget='undef' d_sigaction='undef' d_sigprocmask='undef' d_sigsetjmp='undef' d_snprintf='undef' d_sockatmark='undef' d_sockatmarkproto='undef' d_socket='define' d_sockpair='undef' d_socks5_init='undef' d_srand48_r='undef' d_srandom_r='undef' d_sresgproto='undef' d_sresuproto='undef' d_statblks='define' d_statfs='undef' d_statfsflags='define' d_statvfs='undef' d_stdio_cnt_lval='define' d_stdio_ptr_lval='define' d_stdio_ptr_lval_nochange_cnt='undef' d_stdio_ptr_lval_sets_cnt='undef' d_stdio_stream_array='undef' d_stdiobase='undef' d_stdstdio='undef' d_strchr='define' d_strcoll='define' d_strctcpy='define' d_strerrm='strerror(e)' d_strerror='define' d_strerror_r='undef' d_strftime='define' d_strlcat='undef' d_strlcpy='undef' d_strtod='define' d_strtol='define' d_strtoq='undef' d_strtoul='define' d_strtoull='undef' d_strtouq='undef' d_strxfrm='define' d_suidsafe='undef' d_symlink='undef' d_syscall='undef' d_syscallproto='undef' d_sysconf='define' d_sysernlst='undef' d_syserrlst='undef' d_system='define' d_tcgetpgrp='undef' d_tcsetpgrp='undef' d_telldir='define' d_telldirproto='define' d_time='undef' d_timegm='undef' d_times='undef' d_tm_tm_gmtoff='undef' d_tm_tm_zone='undef' d_tmpnam_r='undef' d_truncate='undef' d_ttyname_r='undef' d_tzname='undef' d_u32align='define' d_ualarm='undef' d_umask='undef' d_uname='undef' d_union_semun='undef' d_unordered='undef' d_unsetenv='undef' d_usleepproto='undef' d_vendorlib='undef' d_vfork='undef' d_void_closedir='undef' d_voidsig='undef' d_voidtty='undef' d_volatile='define' d_vprintf='define' d_vsnprintf='undef' d_wait4='undef' d_waitpid='undef' d_wcstombs='undef' d_wctomb='undef' d_writev='undef' d_xenix='undef' date='date' db_hashtype='undef' db_prefixtype='undef' defvoidused='15' direntrytype='struct dirent' dlext='none' dlsrc='dl_none.xs' doublesize='8' drand01='(rand()/(double)(1U< #include #include #include extern "C" { /* Workaround for defect strtoul(). Values with leading + are zero */ unsigned long int epoc_strtoul(const char *nptr, char **endptr, int base) { if (nptr && *nptr == '+') nptr++; return strtoul( nptr, endptr, base); } void epoc_gcvt( double x, int digits, unsigned char *buf) { TRealFormat trel; trel.iPlaces = digits; trel.iPoint = TChar( '.'); TPtr result( buf, 80); result.Num( x, trel); result.Append( TChar( 0)); } } perl-5.12.0-RC0/epoc/createpkg.pl0000444000175000017500000000144011347250766015367 0ustar jessejesse#!/usr/bin/perl use File::Find; use Cwd; $VERSION="5.12.0"; $EPOC_VERSION=1; sub filefound { my $f = $File::Find::name; return if ( $f =~ /CVS|Unicode|unicore|CPAN|ExtUtils|IPC|User|DB.pm|\.a$|\.ld$|\.exists$|\.pod$|\.t$/i); my $back = $f; my $psiback = $back; $psiback =~ s|.*/lib/|\\emx\\lib\\perl\\$VERSION\\|; $psiback =~ s|/|\\|g; print OUT "\"$back\"-\"!:$psiback\"\n" if ( -f $f ); } open OUT,">perl.pkg"; print OUT "#{\"perl$VERSION\"},(0x100051d8),0,$EPOC_VERSION,0\n"; print OUT "\"" . cwd . "/Artistic.txt\"-\"\",FT,TC\n"; print OUT "\"" . cwd . "/perl\"-\"!:\\emx\\bin\\perl.exe\"\n"; find(\&filefound, cwd.'/lib'); open IN, "Artistic.txt"; while (my $line = ) { chomp $line; print OUT "$line\r\n"; } close IN; close OUT; perl-5.12.0-RC0/epoc/epoc.c0000444000175000017500000000415711325125741014155 0ustar jessejesse/* * Copyright (c) 1999 Olaf Flebbe o.flebbe@gmx.de * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ #include #include #include #include #include #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int do_spawn( char *cmd) { dTHX; return system( cmd); } int do_aspawn ( void *vreally, void **vmark, void **vsp) { dTHX; SV *really = (SV*)vreally; SV **mark = (SV**)vmark; SV **sp = (SV**)vsp; char **argv; char *str; char *p2, **ptr; char *cmd; int rc; int index = 0; if (sp<=mark) return -1; ptr = argv =(char**) malloc ((sp-mark+3)*sizeof (char*)); while (++mark <= sp) { if (*mark && (str = SvPV_nolen(*mark))) argv[index] = str; else argv[index] = ""; } argv[index++] = 0; cmd = strdup((const char*)(really ? SvPV_nolen(really) : argv[0])); rc = spawnvp( P_WAIT, cmd, argv); free( argv); free( cmd); return rc; } static XS(epoc_getcwd) /* more or less stolen from win32.c */ { dXSARGS; /* Make the host for current directory */ char *buffer; int buflen = 256; char *ptr; buffer = (char *) malloc( buflen); if (buffer == NULL) { XSRETURN_UNDEF; } while ((NULL == ( ptr = getcwd( buffer, buflen))) && (errno == ERANGE)) { buflen *= 2; if (NULL == realloc( buffer, buflen)) { XSRETURN_UNDEF; } } /* * If ptr != NULL * then it worked, set PV valid, * else return 'undef' */ if (ptr) { SV *sv = sv_newmortal(); char *tptr; for (tptr = ptr; *tptr != '\0'; tptr++) { if (*tptr == '\\') { *tptr = '/'; } } sv_setpv(sv, ptr); free( buffer); EXTEND(SP,1); SvPOK_on(sv); ST(0) = sv; #ifndef INCOMPLETE_TAINTS SvTAINTED_on(ST(0)); #endif XSRETURN(1); } free( buffer); XSRETURN_UNDEF; } void Perl_init_os_extras(void) { dTHX; char *file = __FILE__; newXS("EPOC::getcwd", epoc_getcwd, file); } perl-5.12.0-RC0/epoc/epoc_stubs.c0000444000175000017500000000053611143650473015375 0ustar jessejesse/* * Copyright (c) 1999 Olaf Flebbe o.flebbe@gmx.de * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ int setgid() {return -1;} int setuid() {return -1;} int execv() { return -1;} int execvp() { return -1;} void Perl_do_exec() {} perl-5.12.0-RC0/cc_runtime.h0000444000175000017500000000422611325127001014422 0ustar jessejesse/* cc_runtime.h * * Copyright (C) 1999, 2000, 2001, 2004, 2006, 2008 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ #define DOOP(ppname) PUTBACK; PL_op = ppname(aTHX); SPAGAIN #define CCPP(s) OP * s(pTHX) #define PP_LIST(g) do { \ dMARK; \ if (g != G_ARRAY) { \ if (++MARK <= SP) \ *MARK = *SP; \ else \ *MARK = &PL_sv_undef; \ SP = MARK; \ } \ } while (0) #define MAYBE_TAINT_SASSIGN_SRC(sv) \ if (PL_tainting && PL_tainted && (!SvGMAGICAL(left) || !SvSMAGICAL(left) || \ !((mg=mg_find(left, PERL_MAGIC_taint)) && mg->mg_len & 1)))\ TAINT_NOT #define PP_PREINC(sv) do { \ if (SvIOK(sv)) { \ ++SvIVX(sv); \ SvFLAGS(sv) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK); \ } \ else \ sv_inc(sv); \ SvSETMAGIC(sv); \ } while (0) #define PP_UNSTACK do { \ TAINT_NOT; \ PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; \ FREETMPS; \ oldsave = PL_scopestack[PL_scopestack_ix - 1]; \ LEAVE_SCOPE(oldsave); \ SPAGAIN; \ } while(0) /* Anyone using eval "" deserves this mess */ #define PP_EVAL(ppaddr, nxt) do { \ dJMPENV; \ int ret; \ PUTBACK; \ JMPENV_PUSH(ret); \ switch (ret) { \ case 0: \ PL_op = ppaddr(aTHX); \ cxstack[cxstack_ix].blk_eval.retop = Nullop; \ if (PL_op != nxt) CALLRUNOPS(aTHX); \ JMPENV_POP; \ break; \ case 1: JMPENV_POP; JMPENV_JUMP(1); \ case 2: JMPENV_POP; JMPENV_JUMP(2); \ case 3: \ JMPENV_POP; \ if (PL_restartop && PL_restartop != nxt) \ JMPENV_JUMP(3); \ } \ PL_op = nxt; \ SPAGAIN; \ } while (0) #define PP_ENTERTRY(label) \ STMT_START { \ dJMPENV; \ int ret; \ JMPENV_PUSH(ret); \ switch (ret) { \ case 1: JMPENV_POP; JMPENV_JUMP(1);\ case 2: JMPENV_POP; JMPENV_JUMP(2);\ case 3: JMPENV_POP; SPAGAIN; goto label;\ } \ } STMT_END #define PP_LEAVETRY \ STMT_START{ PL_top_env=PL_top_env->je_prev; }STMT_END perl-5.12.0-RC0/pp_proto.h0000644000175000017500000002551111325127001014136 0ustar jessejesse/* -*- buffer-read-only: t -*- !!!!!!! DO NOT EDIT THIS FILE !!!!!!! This file is built by opcode.pl from its data. Any changes made here will be lost! */ PERL_CKDEF(Perl_ck_anoncode) PERL_CKDEF(Perl_ck_bitop) PERL_CKDEF(Perl_ck_chdir) PERL_CKDEF(Perl_ck_concat) PERL_CKDEF(Perl_ck_defined) PERL_CKDEF(Perl_ck_delete) PERL_CKDEF(Perl_ck_die) PERL_CKDEF(Perl_ck_each) PERL_CKDEF(Perl_ck_eof) PERL_CKDEF(Perl_ck_eval) PERL_CKDEF(Perl_ck_exec) PERL_CKDEF(Perl_ck_exists) PERL_CKDEF(Perl_ck_exit) PERL_CKDEF(Perl_ck_ftst) PERL_CKDEF(Perl_ck_fun) PERL_CKDEF(Perl_ck_glob) PERL_CKDEF(Perl_ck_grep) PERL_CKDEF(Perl_ck_index) PERL_CKDEF(Perl_ck_join) PERL_CKDEF(Perl_ck_lfun) PERL_CKDEF(Perl_ck_listiob) PERL_CKDEF(Perl_ck_match) PERL_CKDEF(Perl_ck_method) PERL_CKDEF(Perl_ck_null) PERL_CKDEF(Perl_ck_open) PERL_CKDEF(Perl_ck_readline) PERL_CKDEF(Perl_ck_repeat) PERL_CKDEF(Perl_ck_require) PERL_CKDEF(Perl_ck_return) PERL_CKDEF(Perl_ck_rfun) PERL_CKDEF(Perl_ck_rvconst) PERL_CKDEF(Perl_ck_sassign) PERL_CKDEF(Perl_ck_select) PERL_CKDEF(Perl_ck_shift) PERL_CKDEF(Perl_ck_smartmatch) PERL_CKDEF(Perl_ck_sort) PERL_CKDEF(Perl_ck_spair) PERL_CKDEF(Perl_ck_split) PERL_CKDEF(Perl_ck_subr) PERL_CKDEF(Perl_ck_substr) PERL_CKDEF(Perl_ck_svconst) PERL_CKDEF(Perl_ck_trunc) PERL_CKDEF(Perl_ck_unpack) PERL_PPDEF(Perl_pp_null) PERL_PPDEF(Perl_pp_stub) PERL_PPDEF(Perl_pp_scalar) PERL_PPDEF(Perl_pp_pushmark) PERL_PPDEF(Perl_pp_wantarray) PERL_PPDEF(Perl_pp_const) PERL_PPDEF(Perl_pp_gvsv) PERL_PPDEF(Perl_pp_gv) PERL_PPDEF(Perl_pp_gelem) PERL_PPDEF(Perl_pp_padsv) PERL_PPDEF(Perl_pp_padav) PERL_PPDEF(Perl_pp_padhv) PERL_PPDEF(Perl_pp_padany) PERL_PPDEF(Perl_pp_pushre) PERL_PPDEF(Perl_pp_rv2gv) PERL_PPDEF(Perl_pp_rv2sv) PERL_PPDEF(Perl_pp_av2arylen) PERL_PPDEF(Perl_pp_rv2cv) PERL_PPDEF(Perl_pp_anoncode) PERL_PPDEF(Perl_pp_prototype) PERL_PPDEF(Perl_pp_refgen) PERL_PPDEF(Perl_pp_srefgen) PERL_PPDEF(Perl_pp_ref) PERL_PPDEF(Perl_pp_bless) PERL_PPDEF(Perl_pp_backtick) PERL_PPDEF(Perl_pp_glob) PERL_PPDEF(Perl_pp_readline) PERL_PPDEF(Perl_pp_rcatline) PERL_PPDEF(Perl_pp_regcmaybe) PERL_PPDEF(Perl_pp_regcreset) PERL_PPDEF(Perl_pp_regcomp) PERL_PPDEF(Perl_pp_match) PERL_PPDEF(Perl_pp_qr) PERL_PPDEF(Perl_pp_subst) PERL_PPDEF(Perl_pp_substcont) PERL_PPDEF(Perl_pp_trans) PERL_PPDEF(Perl_pp_sassign) PERL_PPDEF(Perl_pp_aassign) PERL_PPDEF(Perl_pp_chop) PERL_PPDEF(Perl_pp_schop) PERL_PPDEF(Perl_pp_chomp) PERL_PPDEF(Perl_pp_schomp) PERL_PPDEF(Perl_pp_defined) PERL_PPDEF(Perl_pp_undef) PERL_PPDEF(Perl_pp_study) PERL_PPDEF(Perl_pp_pos) PERL_PPDEF(Perl_pp_preinc) PERL_PPDEF(Perl_pp_predec) PERL_PPDEF(Perl_pp_postinc) PERL_PPDEF(Perl_pp_postdec) PERL_PPDEF(Perl_pp_pow) PERL_PPDEF(Perl_pp_multiply) PERL_PPDEF(Perl_pp_i_multiply) PERL_PPDEF(Perl_pp_divide) PERL_PPDEF(Perl_pp_i_divide) PERL_PPDEF(Perl_pp_modulo) PERL_PPDEF(Perl_pp_i_modulo) PERL_PPDEF(Perl_pp_repeat) PERL_PPDEF(Perl_pp_add) PERL_PPDEF(Perl_pp_i_add) PERL_PPDEF(Perl_pp_subtract) PERL_PPDEF(Perl_pp_i_subtract) PERL_PPDEF(Perl_pp_concat) PERL_PPDEF(Perl_pp_stringify) PERL_PPDEF(Perl_pp_left_shift) PERL_PPDEF(Perl_pp_right_shift) PERL_PPDEF(Perl_pp_lt) PERL_PPDEF(Perl_pp_i_lt) PERL_PPDEF(Perl_pp_gt) PERL_PPDEF(Perl_pp_i_gt) PERL_PPDEF(Perl_pp_le) PERL_PPDEF(Perl_pp_i_le) PERL_PPDEF(Perl_pp_ge) PERL_PPDEF(Perl_pp_i_ge) PERL_PPDEF(Perl_pp_eq) PERL_PPDEF(Perl_pp_i_eq) PERL_PPDEF(Perl_pp_ne) PERL_PPDEF(Perl_pp_i_ne) PERL_PPDEF(Perl_pp_ncmp) PERL_PPDEF(Perl_pp_i_ncmp) PERL_PPDEF(Perl_pp_slt) PERL_PPDEF(Perl_pp_sgt) PERL_PPDEF(Perl_pp_sle) PERL_PPDEF(Perl_pp_sge) PERL_PPDEF(Perl_pp_seq) PERL_PPDEF(Perl_pp_sne) PERL_PPDEF(Perl_pp_scmp) PERL_PPDEF(Perl_pp_bit_and) PERL_PPDEF(Perl_pp_bit_xor) PERL_PPDEF(Perl_pp_bit_or) PERL_PPDEF(Perl_pp_negate) PERL_PPDEF(Perl_pp_i_negate) PERL_PPDEF(Perl_pp_not) PERL_PPDEF(Perl_pp_complement) PERL_PPDEF(Perl_pp_smartmatch) PERL_PPDEF(Perl_pp_atan2) PERL_PPDEF(Perl_pp_sin) PERL_PPDEF(Perl_pp_cos) PERL_PPDEF(Perl_pp_rand) PERL_PPDEF(Perl_pp_srand) PERL_PPDEF(Perl_pp_exp) PERL_PPDEF(Perl_pp_log) PERL_PPDEF(Perl_pp_sqrt) PERL_PPDEF(Perl_pp_int) PERL_PPDEF(Perl_pp_hex) PERL_PPDEF(Perl_pp_oct) PERL_PPDEF(Perl_pp_abs) PERL_PPDEF(Perl_pp_length) PERL_PPDEF(Perl_pp_substr) PERL_PPDEF(Perl_pp_vec) PERL_PPDEF(Perl_pp_index) PERL_PPDEF(Perl_pp_rindex) PERL_PPDEF(Perl_pp_sprintf) PERL_PPDEF(Perl_pp_formline) PERL_PPDEF(Perl_pp_ord) PERL_PPDEF(Perl_pp_chr) PERL_PPDEF(Perl_pp_crypt) PERL_PPDEF(Perl_pp_ucfirst) PERL_PPDEF(Perl_pp_lcfirst) PERL_PPDEF(Perl_pp_uc) PERL_PPDEF(Perl_pp_lc) PERL_PPDEF(Perl_pp_quotemeta) PERL_PPDEF(Perl_pp_rv2av) PERL_PPDEF(Perl_pp_aelemfast) PERL_PPDEF(Perl_pp_aelem) PERL_PPDEF(Perl_pp_aslice) PERL_PPDEF(Perl_pp_aeach) PERL_PPDEF(Perl_pp_akeys) PERL_PPDEF(Perl_pp_avalues) PERL_PPDEF(Perl_pp_each) PERL_PPDEF(Perl_pp_values) PERL_PPDEF(Perl_pp_keys) PERL_PPDEF(Perl_pp_delete) PERL_PPDEF(Perl_pp_exists) PERL_PPDEF(Perl_pp_rv2hv) PERL_PPDEF(Perl_pp_helem) PERL_PPDEF(Perl_pp_hslice) PERL_PPDEF(Perl_pp_boolkeys) PERL_PPDEF(Perl_pp_unpack) PERL_PPDEF(Perl_pp_pack) PERL_PPDEF(Perl_pp_split) PERL_PPDEF(Perl_pp_join) PERL_PPDEF(Perl_pp_list) PERL_PPDEF(Perl_pp_lslice) PERL_PPDEF(Perl_pp_anonlist) PERL_PPDEF(Perl_pp_anonhash) PERL_PPDEF(Perl_pp_splice) PERL_PPDEF(Perl_pp_push) PERL_PPDEF(Perl_pp_pop) PERL_PPDEF(Perl_pp_shift) PERL_PPDEF(Perl_pp_unshift) PERL_PPDEF(Perl_pp_sort) PERL_PPDEF(Perl_pp_reverse) PERL_PPDEF(Perl_pp_grepstart) PERL_PPDEF(Perl_pp_grepwhile) PERL_PPDEF(Perl_pp_mapstart) PERL_PPDEF(Perl_pp_mapwhile) PERL_PPDEF(Perl_pp_range) PERL_PPDEF(Perl_pp_flip) PERL_PPDEF(Perl_pp_flop) PERL_PPDEF(Perl_pp_and) PERL_PPDEF(Perl_pp_or) PERL_PPDEF(Perl_pp_xor) PERL_PPDEF(Perl_pp_dor) PERL_PPDEF(Perl_pp_cond_expr) PERL_PPDEF(Perl_pp_andassign) PERL_PPDEF(Perl_pp_orassign) PERL_PPDEF(Perl_pp_dorassign) PERL_PPDEF(Perl_pp_method) PERL_PPDEF(Perl_pp_entersub) PERL_PPDEF(Perl_pp_leavesub) PERL_PPDEF(Perl_pp_leavesublv) PERL_PPDEF(Perl_pp_caller) PERL_PPDEF(Perl_pp_warn) PERL_PPDEF(Perl_pp_die) PERL_PPDEF(Perl_pp_reset) PERL_PPDEF(Perl_pp_lineseq) PERL_PPDEF(Perl_pp_nextstate) PERL_PPDEF(Perl_pp_dbstate) PERL_PPDEF(Perl_pp_unstack) PERL_PPDEF(Perl_pp_enter) PERL_PPDEF(Perl_pp_leave) PERL_PPDEF(Perl_pp_scope) PERL_PPDEF(Perl_pp_enteriter) PERL_PPDEF(Perl_pp_iter) PERL_PPDEF(Perl_pp_enterloop) PERL_PPDEF(Perl_pp_leaveloop) PERL_PPDEF(Perl_pp_return) PERL_PPDEF(Perl_pp_last) PERL_PPDEF(Perl_pp_next) PERL_PPDEF(Perl_pp_redo) PERL_PPDEF(Perl_pp_dump) PERL_PPDEF(Perl_pp_goto) PERL_PPDEF(Perl_pp_exit) PERL_PPDEF(Perl_pp_method_named) PERL_PPDEF(Perl_pp_entergiven) PERL_PPDEF(Perl_pp_leavegiven) PERL_PPDEF(Perl_pp_enterwhen) PERL_PPDEF(Perl_pp_leavewhen) PERL_PPDEF(Perl_pp_break) PERL_PPDEF(Perl_pp_continue) PERL_PPDEF(Perl_pp_open) PERL_PPDEF(Perl_pp_close) PERL_PPDEF(Perl_pp_pipe_op) PERL_PPDEF(Perl_pp_fileno) PERL_PPDEF(Perl_pp_umask) PERL_PPDEF(Perl_pp_binmode) PERL_PPDEF(Perl_pp_tie) PERL_PPDEF(Perl_pp_untie) PERL_PPDEF(Perl_pp_tied) PERL_PPDEF(Perl_pp_dbmopen) PERL_PPDEF(Perl_pp_dbmclose) PERL_PPDEF(Perl_pp_sselect) PERL_PPDEF(Perl_pp_select) PERL_PPDEF(Perl_pp_getc) PERL_PPDEF(Perl_pp_read) PERL_PPDEF(Perl_pp_enterwrite) PERL_PPDEF(Perl_pp_leavewrite) PERL_PPDEF(Perl_pp_prtf) PERL_PPDEF(Perl_pp_print) PERL_PPDEF(Perl_pp_say) PERL_PPDEF(Perl_pp_sysopen) PERL_PPDEF(Perl_pp_sysseek) PERL_PPDEF(Perl_pp_sysread) PERL_PPDEF(Perl_pp_syswrite) PERL_PPDEF(Perl_pp_eof) PERL_PPDEF(Perl_pp_tell) PERL_PPDEF(Perl_pp_seek) PERL_PPDEF(Perl_pp_truncate) PERL_PPDEF(Perl_pp_fcntl) PERL_PPDEF(Perl_pp_ioctl) PERL_PPDEF(Perl_pp_flock) PERL_PPDEF(Perl_pp_send) PERL_PPDEF(Perl_pp_recv) PERL_PPDEF(Perl_pp_socket) PERL_PPDEF(Perl_pp_sockpair) PERL_PPDEF(Perl_pp_bind) PERL_PPDEF(Perl_pp_connect) PERL_PPDEF(Perl_pp_listen) PERL_PPDEF(Perl_pp_accept) PERL_PPDEF(Perl_pp_shutdown) PERL_PPDEF(Perl_pp_gsockopt) PERL_PPDEF(Perl_pp_ssockopt) PERL_PPDEF(Perl_pp_getsockname) PERL_PPDEF(Perl_pp_getpeername) PERL_PPDEF(Perl_pp_lstat) PERL_PPDEF(Perl_pp_stat) PERL_PPDEF(Perl_pp_ftrread) PERL_PPDEF(Perl_pp_ftrwrite) PERL_PPDEF(Perl_pp_ftrexec) PERL_PPDEF(Perl_pp_fteread) PERL_PPDEF(Perl_pp_ftewrite) PERL_PPDEF(Perl_pp_fteexec) PERL_PPDEF(Perl_pp_ftis) PERL_PPDEF(Perl_pp_ftsize) PERL_PPDEF(Perl_pp_ftmtime) PERL_PPDEF(Perl_pp_ftatime) PERL_PPDEF(Perl_pp_ftctime) PERL_PPDEF(Perl_pp_ftrowned) PERL_PPDEF(Perl_pp_fteowned) PERL_PPDEF(Perl_pp_ftzero) PERL_PPDEF(Perl_pp_ftsock) PERL_PPDEF(Perl_pp_ftchr) PERL_PPDEF(Perl_pp_ftblk) PERL_PPDEF(Perl_pp_ftfile) PERL_PPDEF(Perl_pp_ftdir) PERL_PPDEF(Perl_pp_ftpipe) PERL_PPDEF(Perl_pp_ftsuid) PERL_PPDEF(Perl_pp_ftsgid) PERL_PPDEF(Perl_pp_ftsvtx) PERL_PPDEF(Perl_pp_ftlink) PERL_PPDEF(Perl_pp_fttty) PERL_PPDEF(Perl_pp_fttext) PERL_PPDEF(Perl_pp_ftbinary) PERL_PPDEF(Perl_pp_chdir) PERL_PPDEF(Perl_pp_chown) PERL_PPDEF(Perl_pp_chroot) PERL_PPDEF(Perl_pp_unlink) PERL_PPDEF(Perl_pp_chmod) PERL_PPDEF(Perl_pp_utime) PERL_PPDEF(Perl_pp_rename) PERL_PPDEF(Perl_pp_link) PERL_PPDEF(Perl_pp_symlink) PERL_PPDEF(Perl_pp_readlink) PERL_PPDEF(Perl_pp_mkdir) PERL_PPDEF(Perl_pp_rmdir) PERL_PPDEF(Perl_pp_open_dir) PERL_PPDEF(Perl_pp_readdir) PERL_PPDEF(Perl_pp_telldir) PERL_PPDEF(Perl_pp_seekdir) PERL_PPDEF(Perl_pp_rewinddir) PERL_PPDEF(Perl_pp_closedir) PERL_PPDEF(Perl_pp_fork) PERL_PPDEF(Perl_pp_wait) PERL_PPDEF(Perl_pp_waitpid) PERL_PPDEF(Perl_pp_system) PERL_PPDEF(Perl_pp_exec) PERL_PPDEF(Perl_pp_kill) PERL_PPDEF(Perl_pp_getppid) PERL_PPDEF(Perl_pp_getpgrp) PERL_PPDEF(Perl_pp_setpgrp) PERL_PPDEF(Perl_pp_getpriority) PERL_PPDEF(Perl_pp_setpriority) PERL_PPDEF(Perl_pp_time) PERL_PPDEF(Perl_pp_tms) PERL_PPDEF(Perl_pp_localtime) PERL_PPDEF(Perl_pp_gmtime) PERL_PPDEF(Perl_pp_alarm) PERL_PPDEF(Perl_pp_sleep) PERL_PPDEF(Perl_pp_shmget) PERL_PPDEF(Perl_pp_shmctl) PERL_PPDEF(Perl_pp_shmread) PERL_PPDEF(Perl_pp_shmwrite) PERL_PPDEF(Perl_pp_msgget) PERL_PPDEF(Perl_pp_msgctl) PERL_PPDEF(Perl_pp_msgsnd) PERL_PPDEF(Perl_pp_msgrcv) PERL_PPDEF(Perl_pp_semop) PERL_PPDEF(Perl_pp_semget) PERL_PPDEF(Perl_pp_semctl) PERL_PPDEF(Perl_pp_require) PERL_PPDEF(Perl_pp_dofile) PERL_PPDEF(Perl_pp_hintseval) PERL_PPDEF(Perl_pp_entereval) PERL_PPDEF(Perl_pp_leaveeval) PERL_PPDEF(Perl_pp_entertry) PERL_PPDEF(Perl_pp_leavetry) PERL_PPDEF(Perl_pp_ghbyname) PERL_PPDEF(Perl_pp_ghbyaddr) PERL_PPDEF(Perl_pp_ghostent) PERL_PPDEF(Perl_pp_gnbyname) PERL_PPDEF(Perl_pp_gnbyaddr) PERL_PPDEF(Perl_pp_gnetent) PERL_PPDEF(Perl_pp_gpbyname) PERL_PPDEF(Perl_pp_gpbynumber) PERL_PPDEF(Perl_pp_gprotoent) PERL_PPDEF(Perl_pp_gsbyname) PERL_PPDEF(Perl_pp_gsbyport) PERL_PPDEF(Perl_pp_gservent) PERL_PPDEF(Perl_pp_shostent) PERL_PPDEF(Perl_pp_snetent) PERL_PPDEF(Perl_pp_sprotoent) PERL_PPDEF(Perl_pp_sservent) PERL_PPDEF(Perl_pp_ehostent) PERL_PPDEF(Perl_pp_enetent) PERL_PPDEF(Perl_pp_eprotoent) PERL_PPDEF(Perl_pp_eservent) PERL_PPDEF(Perl_pp_gpwnam) PERL_PPDEF(Perl_pp_gpwuid) PERL_PPDEF(Perl_pp_gpwent) PERL_PPDEF(Perl_pp_spwent) PERL_PPDEF(Perl_pp_epwent) PERL_PPDEF(Perl_pp_ggrnam) PERL_PPDEF(Perl_pp_ggrgid) PERL_PPDEF(Perl_pp_ggrent) PERL_PPDEF(Perl_pp_sgrent) PERL_PPDEF(Perl_pp_egrent) PERL_PPDEF(Perl_pp_getlogin) PERL_PPDEF(Perl_pp_syscall) PERL_PPDEF(Perl_pp_lock) PERL_PPDEF(Perl_pp_once) /* ex: set ro: */ perl-5.12.0-RC0/doop.c0000444000175000017500000010344011325127001013224 0ustar jessejesse/* doop.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, * 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * 'So that was the job I felt I had to do when I started,' thought Sam. * * [p.934 of _The Lord of the Rings_, VI/iii: "Mount Doom"] */ /* This file contains some common functions needed to carry out certain * ops. For example both pp_schomp() and pp_chomp() - scalar and array * chomp operations - call the function do_chomp() found in this file. */ #include "EXTERN.h" #define PERL_IN_DOOP_C #include "perl.h" #ifndef PERL_MICRO #include #endif STATIC I32 S_do_trans_simple(pTHX_ SV * const sv) { dVAR; I32 matches = 0; STRLEN len; U8 *s = (U8*)SvPV(sv,len); U8 * const send = s+len; const short * const tbl = (short*)cPVOP->op_pv; PERL_ARGS_ASSERT_DO_TRANS_SIMPLE; if (!tbl) Perl_croak(aTHX_ "panic: do_trans_simple line %d",__LINE__); /* First, take care of non-UTF-8 input strings, because they're easy */ if (!SvUTF8(sv)) { while (s < send) { const I32 ch = tbl[*s]; if (ch >= 0) { matches++; *s = (U8)ch; } s++; } SvSETMAGIC(sv); } else { const I32 grows = PL_op->op_private & OPpTRANS_GROWS; U8 *d; U8 *dstart; /* Allow for expansion: $_="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; I32 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[c]) >= 0) { matches++; d = uvchr_to_utf8(d, 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); } return matches; } STATIC I32 S_do_trans_count(pTHX_ SV * const sv) { dVAR; STRLEN len; const U8 *s = (const U8*)SvPV_const(sv, len); const U8 * const send = s + len; I32 matches = 0; const short * const tbl = (short*)cPVOP->op_pv; PERL_ARGS_ASSERT_DO_TRANS_COUNT; if (!tbl) Perl_croak(aTHX_ "panic: do_trans_count line %d",__LINE__); if (!SvUTF8(sv)) { while (s < send) { if (tbl[*s++] >= 0) matches++; } } else { const I32 complement = 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[c] >= 0) matches++; } else if (complement) matches++; s += ulen; } } return matches; } STATIC I32 S_do_trans_complex(pTHX_ SV * const sv) { dVAR; STRLEN len; U8 *s = (U8*)SvPV(sv, len); U8 * const send = s+len; I32 matches = 0; const short * const tbl = (short*)cPVOP->op_pv; PERL_ARGS_ASSERT_DO_TRANS_COMPLEX; if (!tbl) Perl_croak(aTHX_ "panic: do_trans_complex line %d",__LINE__); if (!SvUTF8(sv)) { U8 *d = s; U8 * const dstart = d; if (PL_op->op_private & OPpTRANS_SQUASH) { const U8* p = send; while (s < send) { const I32 ch = tbl[*s]; if (ch >= 0) { *d = (U8)ch; matches++; if (p != d - 1 || *p != *d) p = d++; } else if (ch == -1) /* -1 is unmapped character */ *d++ = *s; else if (ch == -2) /* -2 is delete character */ matches++; s++; } } else { while (s < send) { const I32 ch = tbl[*s]; if (ch >= 0) { matches++; *d++ = (U8)ch; } else if (ch == -1) /* -1 is unmapped character */ *d++ = *s; else if (ch == -2) /* -2 is delete character */ matches++; s++; } } *d = '\0'; SvCUR_set(sv, d - dstart); } else { /* is utf8 */ const I32 complement = PL_op->op_private & OPpTRANS_COMPLEMENT; const I32 grows = PL_op->op_private & OPpTRANS_GROWS; const I32 del = PL_op->op_private & OPpTRANS_DELETE; U8 *d; U8 *dstart; STRLEN rlen = 0; if (grows) Newx(d, len*2+1, U8); else d = s; dstart = d; if (complement && !del) rlen = tbl[0x100]; if (PL_op->op_private & OPpTRANS_SQUASH) { UV pch = 0xfeedface; while (s < send) { STRLEN len; const UV comp = utf8n_to_uvchr(s, send - s, &len, UTF8_ALLOW_DEFAULT); I32 ch; if (comp > 0xff) { if (!complement) { Move(s, d, len, U8); d += len; } else { matches++; if (!del) { ch = (rlen == 0) ? (I32)comp : (comp - 0x100 < rlen) ? tbl[comp+1] : tbl[0x100+rlen]; if ((UV)ch != pch) { d = uvchr_to_utf8(d, ch); pch = (UV)ch; } s += len; continue; } } } else if ((ch = tbl[comp]) >= 0) { matches++; if ((UV)ch != pch) { d = uvchr_to_utf8(d, ch); pch = (UV)ch; } s += len; continue; } else if (ch == -1) { /* -1 is unmapped character */ Move(s, d, len, U8); d += len; } else if (ch == -2) /* -2 is delete character */ matches++; s += len; pch = 0xfeedface; } } else { while (s < send) { STRLEN len; const UV comp = utf8n_to_uvchr(s, send - s, &len, UTF8_ALLOW_DEFAULT); I32 ch; if (comp > 0xff) { if (!complement) { Move(s, d, len, U8); d += len; } else { matches++; if (!del) { if (comp - 0x100 < rlen) d = uvchr_to_utf8(d, tbl[comp+1]); else d = uvchr_to_utf8(d, tbl[0x100+rlen]); } } } else if ((ch = tbl[comp]) >= 0) { d = uvchr_to_utf8(d, ch); matches++; } else if (ch == -1) { /* -1 is unmapped character */ Move(s, d, len, U8); d += len; } else if (ch == -2) /* -2 is delete character */ matches++; s += len; } } if (grows) { sv_setpvn(sv, (char*)dstart, d - dstart); Safefree(dstart); } else { *d = '\0'; SvCUR_set(sv, d - dstart); } SvUTF8_on(sv); } SvSETMAGIC(sv); return matches; } STATIC I32 S_do_trans_simple_utf8(pTHX_ SV * const sv) { dVAR; U8 *s; U8 *send; U8 *d; U8 *start; U8 *dstart, *dend; I32 matches = 0; const I32 grows = PL_op->op_private & OPpTRANS_GROWS; STRLEN len; SV* const rv = #ifdef USE_ITHREADS PAD_SVl(cPADOP->op_padix); #else MUTABLE_SV(cSVOP->op_sv); #endif HV* const hv = MUTABLE_HV(SvRV(rv)); SV* const * svp = hv_fetchs(hv, "NONE", FALSE); const UV none = svp ? SvUV(*svp) : 0x7fffffff; const UV extra = none + 1; UV final = 0; U8 hibit = 0; PERL_ARGS_ASSERT_DO_TRANS_SIMPLE_UTF8; s = (U8*)SvPV(sv, len); if (!SvUTF8(sv)) { const U8 *t = s; const U8 * const e = s + len; while (t < e) { const U8 ch = *t++; hibit = !NATIVE_IS_INVARIANT(ch); if (hibit) { s = bytes_to_utf8(s, &len); break; } } } send = s + len; start = s; svp = hv_fetchs(hv, "FINAL", FALSE); if (svp) final = SvUV(*svp); if (grows) { /* d needs to be bigger than s, in case e.g. upgrading is required */ Newx(d, len * 3 + UTF8_MAXBYTES, U8); dend = d + len * 3; dstart = d; } else { dstart = d = s; dend = d + len; } while (s < send) { const UV uv = swash_fetch(rv, s, TRUE); if (uv < none) { s += UTF8SKIP(s); matches++; d = uvuni_to_utf8(d, uv); } else if (uv == none) { const int i = UTF8SKIP(s); Move(s, d, i, U8); d += i; s += i; } else if (uv == extra) { s += UTF8SKIP(s); matches++; d = uvuni_to_utf8(d, final); } else s += UTF8SKIP(s); if (d > dend) { const STRLEN clen = d - dstart; const STRLEN nlen = dend - dstart + len + UTF8_MAXBYTES; if (!grows) Perl_croak(aTHX_ "panic: do_trans_simple_utf8 line %d",__LINE__); Renew(dstart, nlen + UTF8_MAXBYTES, U8); d = dstart + clen; dend = dstart + nlen; } } if (grows || hibit) { sv_setpvn(sv, (char*)dstart, d - dstart); Safefree(dstart); if (grows && hibit) Safefree(start); } else { *d = '\0'; SvCUR_set(sv, d - dstart); } SvSETMAGIC(sv); SvUTF8_on(sv); return matches; } STATIC I32 S_do_trans_count_utf8(pTHX_ SV * const sv) { dVAR; const U8 *s; const U8 *start = NULL; const U8 *send; I32 matches = 0; STRLEN len; SV* const rv = #ifdef USE_ITHREADS PAD_SVl(cPADOP->op_padix); #else MUTABLE_SV(cSVOP->op_sv); #endif HV* const hv = MUTABLE_HV(SvRV(rv)); SV* const * const svp = hv_fetchs(hv, "NONE", FALSE); const UV none = svp ? SvUV(*svp) : 0x7fffffff; const UV extra = none + 1; U8 hibit = 0; PERL_ARGS_ASSERT_DO_TRANS_COUNT_UTF8; s = (const U8*)SvPV_const(sv, len); if (!SvUTF8(sv)) { const U8 *t = s; const U8 * const e = s + len; while (t < e) { const U8 ch = *t++; hibit = !NATIVE_IS_INVARIANT(ch); if (hibit) { start = s = bytes_to_utf8(s, &len); break; } } } send = s + len; while (s < send) { const UV uv = swash_fetch(rv, s, TRUE); if (uv < none || uv == extra) matches++; s += UTF8SKIP(s); } if (hibit) Safefree(start); return matches; } STATIC I32 S_do_trans_complex_utf8(pTHX_ SV * const sv) { dVAR; U8 *start, *send; U8 *d; I32 matches = 0; const I32 squash = PL_op->op_private & OPpTRANS_SQUASH; const I32 del = PL_op->op_private & OPpTRANS_DELETE; const I32 grows = PL_op->op_private & OPpTRANS_GROWS; SV* const rv = #ifdef USE_ITHREADS PAD_SVl(cPADOP->op_padix); #else MUTABLE_SV(cSVOP->op_sv); #endif HV * const hv = MUTABLE_HV(SvRV(rv)); SV * const *svp = hv_fetchs(hv, "NONE", FALSE); const UV none = svp ? SvUV(*svp) : 0x7fffffff; const UV extra = none + 1; UV final = 0; bool havefinal = FALSE; STRLEN len; U8 *dstart, *dend; U8 hibit = 0; U8 *s = (U8*)SvPV(sv, len); PERL_ARGS_ASSERT_DO_TRANS_COMPLEX_UTF8; if (!SvUTF8(sv)) { const U8 *t = s; const U8 * const e = s + len; while (t < e) { const U8 ch = *t++; hibit = !NATIVE_IS_INVARIANT(ch); if (hibit) { s = bytes_to_utf8(s, &len); break; } } } send = s + len; start = s; svp = hv_fetchs(hv, "FINAL", FALSE); if (svp) { final = SvUV(*svp); havefinal = TRUE; } if (grows) { /* d needs to be bigger than s, in case e.g. upgrading is required */ Newx(d, len * 3 + UTF8_MAXBYTES, U8); dend = d + len * 3; dstart = d; } else { dstart = d = s; dend = d + len; } if (squash) { UV puv = 0xfeedface; while (s < send) { UV uv = swash_fetch(rv, s, TRUE); if (d > dend) { const STRLEN clen = d - dstart; const STRLEN nlen = dend - dstart + len + UTF8_MAXBYTES; if (!grows) Perl_croak(aTHX_ "panic: do_trans_complex_utf8 line %d",__LINE__); Renew(dstart, nlen + UTF8_MAXBYTES, U8); d = dstart + clen; dend = dstart + nlen; } if (uv < none) { matches++; s += UTF8SKIP(s); if (uv != puv) { d = uvuni_to_utf8(d, uv); puv = uv; } continue; } else if (uv == none) { /* "none" is unmapped character */ const int i = UTF8SKIP(s); Move(s, d, i, U8); d += i; s += i; puv = 0xfeedface; continue; } else if (uv == extra && !del) { matches++; if (havefinal) { s += UTF8SKIP(s); if (puv != final) { d = uvuni_to_utf8(d, final); puv = final; } } else { STRLEN len; uv = utf8n_to_uvuni(s, send - s, &len, UTF8_ALLOW_DEFAULT); if (uv != puv) { Move(s, d, len, U8); d += len; puv = uv; } s += len; } continue; } matches++; /* "none+1" is delete character */ s += UTF8SKIP(s); } } else { while (s < send) { const UV uv = swash_fetch(rv, s, TRUE); if (d > dend) { const STRLEN clen = d - dstart; const STRLEN nlen = dend - dstart + len + UTF8_MAXBYTES; if (!grows) Perl_croak(aTHX_ "panic: do_trans_complex_utf8 line %d",__LINE__); Renew(dstart, nlen + UTF8_MAXBYTES, U8); d = dstart + clen; dend = dstart + nlen; } if (uv < none) { matches++; s += UTF8SKIP(s); d = uvuni_to_utf8(d, uv); continue; } else if (uv == none) { /* "none" is unmapped character */ const int i = UTF8SKIP(s); Move(s, d, i, U8); d += i; s += i; continue; } else if (uv == extra && !del) { matches++; s += UTF8SKIP(s); d = uvuni_to_utf8(d, final); continue; } matches++; /* "none+1" is delete character */ s += UTF8SKIP(s); } } if (grows || hibit) { sv_setpvn(sv, (char*)dstart, d - dstart); Safefree(dstart); if (grows && hibit) Safefree(start); } else { *d = '\0'; SvCUR_set(sv, d - dstart); } SvUTF8_on(sv); SvSETMAGIC(sv); return matches; } I32 Perl_do_trans(pTHX_ SV *sv) { dVAR; STRLEN len; const I32 hasutf = (PL_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)); PERL_ARGS_ASSERT_DO_TRANS; if (SvREADONLY(sv) && !(PL_op->op_private & OPpTRANS_IDENTICAL)) { if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); if (SvREADONLY(sv)) Perl_croak(aTHX_ "%s", PL_no_modify); } (void)SvPV_const(sv, len); if (!len) return 0; if (!(PL_op->op_private & OPpTRANS_IDENTICAL)) { if (!SvPOKp(sv)) (void)SvPV_force(sv, len); (void)SvPOK_only_UTF8(sv); } DEBUG_t( Perl_deb(aTHX_ "2.TBL\n")); switch (PL_op->op_private & ~hasutf & ( OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF|OPpTRANS_IDENTICAL| OPpTRANS_SQUASH|OPpTRANS_DELETE|OPpTRANS_COMPLEMENT)) { case 0: if (hasutf) return do_trans_simple_utf8(sv); else return do_trans_simple(sv); case OPpTRANS_IDENTICAL: case OPpTRANS_IDENTICAL|OPpTRANS_COMPLEMENT: if (hasutf) return do_trans_count_utf8(sv); else return do_trans_count(sv); default: if (hasutf) return do_trans_complex_utf8(sv); else return do_trans_complex(sv); } } void Perl_do_join(pTHX_ register SV *sv, SV *delim, register SV **mark, register SV **sp) { dVAR; SV ** const oldmark = mark; register I32 items = sp - mark; register STRLEN len; STRLEN delimlen; PERL_ARGS_ASSERT_DO_JOIN; (void) SvPV_const(delim, delimlen); /* stringify and get the delimlen */ /* SvCUR assumes it's SvPOK() and woe betide you if it's not. */ mark++; 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; } sv_setpvs(sv, ""); /* sv_setpv retains old UTF8ness [perl #24846] */ SvUTF8_off(sv); if (PL_tainting && SvMAGICAL(sv)) SvTAINTED_off(sv); if (items-- > 0) { if (*mark) sv_catsv(sv, *mark); mark++; } if (delimlen) { for (; items > 0; items--,mark++) { sv_catsv(sv,delim); sv_catsv(sv,*mark); } } else { for (; items > 0; items--,mark++) sv_catsv(sv,*mark); } SvSETMAGIC(sv); } void Perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg) { dVAR; STRLEN patlen; const char * const pat = SvPV_const(*sarg, patlen); bool do_taint = FALSE; PERL_ARGS_ASSERT_DO_SPRINTF; SvUTF8_off(sv); if (DO_UTF8(*sarg)) SvUTF8_on(sv); sv_vsetpvfn(sv, pat, patlen, NULL, sarg + 1, len - 1, &do_taint); SvSETMAGIC(sv); if (do_taint) SvTAINTED_on(sv); } /* currently converts input to bytes if possible, but doesn't sweat failure */ UV Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size) { dVAR; STRLEN srclen, len, uoffset, bitoffs = 0; const unsigned char *s = (const unsigned char *) SvPV_const(sv, srclen); UV retnum = 0; PERL_ARGS_ASSERT_DO_VECGET; if (offset < 0) return 0; if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */ Perl_croak(aTHX_ "Illegal number of bits in vec"); if (SvUTF8(sv)) (void) Perl_sv_utf8_downgrade(aTHX_ sv, TRUE); if (size < 8) { bitoffs = ((offset%8)*size)%8; uoffset = offset/(8/size); } else if (size > 8) uoffset = offset*(size/8); else uoffset = offset; len = uoffset + (bitoffs + size + 7)/8; /* required number of bytes */ if (len > srclen) { if (size <= 8) retnum = 0; else { if (size == 16) { if (uoffset >= srclen) retnum = 0; else retnum = (UV) s[uoffset] << 8; } else if (size == 32) { if (uoffset >= srclen) retnum = 0; else if (uoffset + 1 >= srclen) retnum = ((UV) s[uoffset ] << 24); else if (uoffset + 2 >= srclen) 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"); if (uoffset >= srclen) retnum = 0; else if (uoffset + 1 >= srclen) retnum = (UV) s[uoffset ] << 56; else if (uoffset + 2 >= srclen) retnum = ((UV) s[uoffset ] << 56) + ((UV) s[uoffset + 1] << 48); else if (uoffset + 3 >= srclen) retnum = ((UV) s[uoffset ] << 56) + ((UV) s[uoffset + 1] << 48) + ((UV) s[uoffset + 2] << 40); else if (uoffset + 4 >= srclen) retnum = ((UV) s[uoffset ] << 56) + ((UV) s[uoffset + 1] << 48) + ((UV) s[uoffset + 2] << 40) + ((UV) s[uoffset + 3] << 32); else if (uoffset + 5 >= srclen) retnum = ((UV) s[uoffset ] << 56) + ((UV) s[uoffset + 1] << 48) + ((UV) s[uoffset + 2] << 40) + ((UV) s[uoffset + 3] << 32) + ( s[uoffset + 4] << 24); else if (uoffset + 6 >= srclen) 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) + ( s[uoffset + 6] << 8); } #endif } } else if (size < 8) retnum = (s[uoffset] >> bitoffs) & ((1 << size) - 1); 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]; #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]; } #endif } return retnum; } /* currently converts input to bytes if possible but doesn't sweat failures, * although it does ensure that the string it clobbers is not marked as * utf8-valid any more */ void Perl_do_vecset(pTHX_ SV *sv) { dVAR; register I32 offset, bitoffs = 0; register I32 size; register unsigned char *s; register UV lval; I32 mask; STRLEN targlen; STRLEN len; SV * const targ = LvTARG(sv); PERL_ARGS_ASSERT_DO_VECSET; if (!targ) return; s = (unsigned char*)SvPV_force(targ, targlen); if (SvUTF8(targ)) { /* This is handled by the SvPOK_only below... if (!Perl_sv_utf8_downgrade(aTHX_ targ, TRUE)) SvUTF8_off(targ); */ (void) Perl_sv_utf8_downgrade(aTHX_ targ, TRUE); } (void)SvPOK_only(targ); lval = SvUV(sv); offset = LvTARGOFF(sv); if (offset < 0) Perl_croak(aTHX_ "Negative offset to vec in lvalue context"); 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"); if (size < 8) { bitoffs = ((offset%8)*size)%8; offset /= 8/size; } else if (size > 8) offset *= size/8; len = offset + (bitoffs + size + 7)/8; /* required number of bytes */ if (len > targlen) { s = (unsigned char*)SvGROW(targ, len + 1); (void)memzero((char *)(s + targlen), len - targlen + 1); SvCUR_set(targ, len); } if (size < 8) { mask = (1 << size) - 1; 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); } #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); } #endif } SvSETMAGIC(targ); } void Perl_do_chop(pTHX_ register SV *astr, register SV *sv) { dVAR; STRLEN len; char *s; PERL_ARGS_ASSERT_DO_CHOP; if (SvTYPE(sv) == SVt_PVAV) { register I32 i; AV *const av = MUTABLE_AV(sv); const I32 max = AvFILL(av); for (i = 0; i <= max; i++) { sv = MUTABLE_SV(av_fetch(av, i, FALSE)); if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef)) do_chop(astr, sv); } return; } else if (SvTYPE(sv) == SVt_PVHV) { HV* const hv = MUTABLE_HV(sv); HE* entry; (void)hv_iterinit(hv); while ((entry = hv_iternext(hv))) do_chop(astr,hv_iterval(hv,entry)); return; } else if (SvREADONLY(sv)) { if (SvFAKE(sv)) { /* SV is copy-on-write */ sv_force_normal_flags(sv, 0); } if (SvREADONLY(sv)) Perl_croak(aTHX_ "%s", PL_no_modify); } if (PL_encoding && !SvUTF8(sv)) { /* like in do_chomp(), utf8-ize the sv as a side-effect * if we're using encoding. */ sv_recode_to_utf8(sv, PL_encoding); } s = SvPV(sv, len); if (len && !SvPOK(sv)) s = SvPV_force_nomg(sv, len); if (DO_UTF8(sv)) { if (s && len) { char * const send = s + len; char * const start = s; s = send - 1; while (s > start && UTF8_IS_CONTINUATION(*s)) s--; if (is_utf8_string((U8*)s, send - s)) { sv_setpvn(astr, s, send - s); *s = '\0'; SvCUR_set(sv, s - start); SvNIOK_off(sv); SvUTF8_on(astr); } } else sv_setpvs(astr, ""); } else if (s && len) { s += --len; sv_setpvn(astr, s, 1); *s = '\0'; SvCUR_set(sv, len); SvUTF8_off(sv); SvNIOK_off(sv); } else sv_setpvs(astr, ""); SvSETMAGIC(sv); } I32 Perl_do_chomp(pTHX_ register SV *sv) { dVAR; register I32 count; STRLEN len; char *s; char *temp_buffer = NULL; SV* svrecode = NULL; PERL_ARGS_ASSERT_DO_CHOMP; if (RsSNARF(PL_rs)) return 0; if (RsRECORD(PL_rs)) return 0; count = 0; if (SvTYPE(sv) == SVt_PVAV) { register I32 i; AV *const av = MUTABLE_AV(sv); const I32 max = AvFILL(av); for (i = 0; i <= max; i++) { sv = MUTABLE_SV(av_fetch(av, i, FALSE)); if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef)) count += do_chomp(sv); } return count; } else if (SvTYPE(sv) == SVt_PVHV) { HV* const hv = MUTABLE_HV(sv); HE* entry; (void)hv_iterinit(hv); while ((entry = hv_iternext(hv))) count += do_chomp(hv_iterval(hv,entry)); return count; } else if (SvREADONLY(sv)) { if (SvFAKE(sv)) { /* SV is copy-on-write */ sv_force_normal_flags(sv, 0); } if (SvREADONLY(sv)) Perl_croak(aTHX_ "%s", PL_no_modify); } if (PL_encoding) { if (!SvUTF8(sv)) { /* XXX, here sv is utf8-ized as a side-effect! If encoding.pm is used properly, almost string-generating operations, including literal strings, chr(), input data, etc. should have been utf8-ized already, right? */ sv_recode_to_utf8(sv, PL_encoding); } } s = SvPV(sv, len); if (s && len) { s += --len; if (RsPARA(PL_rs)) { if (*s != '\n') goto nope; ++count; while (len && s[-1] == '\n') { --len; --s; ++count; } } else { STRLEN rslen, rs_charlen; const char *rsptr = SvPV_const(PL_rs, rslen); rs_charlen = SvUTF8(PL_rs) ? sv_len_utf8(PL_rs) : rslen; if (SvUTF8(PL_rs) != SvUTF8(sv)) { /* Assumption is that rs is shorter than the scalar. */ if (SvUTF8(PL_rs)) { /* RS is utf8, scalar is 8 bit. */ bool is_utf8 = TRUE; temp_buffer = (char*)bytes_from_utf8((U8*)rsptr, &rslen, &is_utf8); if (is_utf8) { /* Cannot downgrade, therefore cannot possibly match */ assert (temp_buffer == rsptr); temp_buffer = NULL; goto nope; } rsptr = temp_buffer; } else if (PL_encoding) { /* RS is 8 bit, encoding.pm is used. * Do not recode PL_rs as a side-effect. */ svrecode = newSVpvn(rsptr, rslen); sv_recode_to_utf8(svrecode, PL_encoding); rsptr = SvPV_const(svrecode, rslen); rs_charlen = sv_len_utf8(svrecode); } else { /* RS is 8 bit, scalar is utf8. */ temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen); rsptr = temp_buffer; } } if (rslen == 1) { if (*s != *rsptr) goto nope; ++count; } else { if (len < rslen - 1) goto nope; len -= rslen - 1; s -= rslen - 1; if (memNE(s, rsptr, rslen)) goto nope; count += rs_charlen; } } s = SvPV_force_nolen(sv); SvCUR_set(sv, len); *SvEND(sv) = '\0'; SvNIOK_off(sv); SvSETMAGIC(sv); } nope: SvREFCNT_dec(svrecode); Safefree(temp_buffer); return count; } void Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) { dVAR; #ifdef LIBERAL register long *dl; register long *ll; register long *rl; #endif register char *dc; STRLEN leftlen; STRLEN rightlen; register const char *lc; register const char *rc; register STRLEN len; STRLEN lensave; const char *lsave; const char *rsave; bool left_utf; bool right_utf; STRLEN needlen = 0; PERL_ARGS_ASSERT_DO_VOP; if (sv != left || (optype != OP_BIT_AND && !SvOK(sv) && !SvGMAGICAL(sv))) sv_setpvs(sv, ""); /* avoid undef warning on |= and ^= */ if (sv == left) { lsave = lc = SvPV_force_nomg(left, leftlen); } else { lsave = lc = SvPV_nomg_const(left, leftlen); SvPV_force_nomg_nolen(sv); } rsave = rc = SvPV_nomg_const(right, rightlen); /* This need to come after SvPV to ensure that string overloading has fired off. */ left_utf = DO_UTF8(left); right_utf = DO_UTF8(right); if (left_utf && !right_utf) { /* Avoid triggering overloading again by using temporaries. Maybe there should be a variant of sv_utf8_upgrade that takes pvn */ right = newSVpvn_flags(rsave, rightlen, SVs_TEMP); sv_utf8_upgrade(right); rsave = rc = SvPV_nomg_const(right, rightlen); right_utf = TRUE; } else if (!left_utf && right_utf) { left = newSVpvn_flags(lsave, leftlen, SVs_TEMP); sv_utf8_upgrade(left); lsave = lc = SvPV_nomg_const(left, leftlen); left_utf = TRUE; } len = leftlen < rightlen ? leftlen : rightlen; lensave = len; SvCUR_set(sv, len); (void)SvPOK_only(sv); if ((left_utf || right_utf) && (sv == left || sv == right)) { needlen = optype == OP_BIT_AND ? len : leftlen + rightlen; Newxz(dc, needlen + 1, char); } else 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); } if (optype != OP_BIT_AND && (left_utf || right_utf)) dc = SvGROW(sv, leftlen + rightlen + 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() */ } if (left_utf || right_utf) { UV duc, luc, ruc; char *dcorig = dc; char *dcsave = NULL; STRLEN lulen = leftlen; STRLEN rulen = rightlen; STRLEN ulen; switch (optype) { case OP_BIT_AND: while (lulen && rulen) { luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV); lc += ulen; lulen -= ulen; ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV); rc += ulen; rulen -= ulen; duc = luc & ruc; dc = (char*)uvchr_to_utf8((U8*)dc, duc); } if (sv == left || sv == right) (void)sv_usepvn(sv, dcorig, needlen); SvCUR_set(sv, dc - dcorig); break; case OP_BIT_XOR: while (lulen && rulen) { luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV); lc += ulen; lulen -= ulen; ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV); rc += ulen; rulen -= ulen; duc = luc ^ ruc; dc = (char*)uvchr_to_utf8((U8*)dc, duc); } goto mop_up_utf; case OP_BIT_OR: while (lulen && rulen) { luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV); lc += ulen; lulen -= ulen; ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV); rc += ulen; rulen -= ulen; duc = luc | ruc; dc = (char*)uvchr_to_utf8((U8*)dc, duc); } mop_up_utf: if (rulen) dcsave = savepvn(rc, rulen); else if (lulen) dcsave = savepvn(lc, lulen); if (sv == left || sv == right) (void)sv_usepvn(sv, dcorig, needlen); /* Uses Renew(). */ SvCUR_set(sv, dc - dcorig); if (rulen) sv_catpvn(sv, dcsave, rulen); else if (lulen) sv_catpvn(sv, dcsave, lulen); else *SvEND(sv) = '\0'; Safefree(dcsave); break; default: if (sv == left || sv == right) Safefree(dcorig); Perl_croak(aTHX_ "panic: do_vop called for op %u (%s)", (unsigned)optype, PL_op_name[optype]); } SvUTF8_on(sv); goto finish; } else #ifdef LIBERAL if (len >= sizeof(long)*4 && !((unsigned long)dc % sizeof(long)) && !((unsigned long)lc % sizeof(long)) && !((unsigned long)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; } #endif { switch (optype) { case OP_BIT_AND: while (len--) *dc++ = *lc++ & *rc++; *dc = '\0'; break; case OP_BIT_XOR: while (len--) *dc++ = *lc++ ^ *rc++; goto mop_up; case OP_BIT_OR: while (len--) *dc++ = *lc++ | *rc++; mop_up: len = lensave; if (rightlen > len) sv_catpvn(sv, rsave + len, rightlen - len); else if (leftlen > (STRLEN)len) sv_catpvn(sv, lsave + len, leftlen - len); else *SvEND(sv) = '\0'; break; } } finish: SvTAINT(sv); } OP * Perl_do_kv(pTHX) { dVAR; dSP; HV * const hv = MUTABLE_HV(POPs); HV *keys; register HE *entry; const I32 gimme = GIMME_V; const I32 dokv = (PL_op->op_type == OP_RV2HV || PL_op->op_type == OP_PADHV); const I32 dokeys = dokv || (PL_op->op_type == OP_KEYS); const I32 dovalues = dokv || (PL_op->op_type == OP_VALUES); if (!hv) { if (PL_op->op_flags & OPf_MOD || LVRET) { /* lvalue */ dTARGET; /* make sure to clear its target here */ if (SvTYPE(TARG) == SVt_PVLV) LvTARG(TARG) = NULL; PUSHs(TARG); } RETURN; } keys = hv; (void)hv_iterinit(keys); /* always reset iterator regardless */ if (gimme == G_VOID) RETURN; if (gimme == G_SCALAR) { IV i; dTARGET; if (PL_op->op_flags & OPf_MOD || LVRET) { /* lvalue */ if (SvTYPE(TARG) < SVt_PVLV) { sv_upgrade(TARG, SVt_PVLV); sv_magic(TARG, NULL, PERL_MAGIC_nkeys, NULL, 0); } LvTYPE(TARG) = 'k'; if (LvTARG(TARG) != (const SV *)keys) { SvREFCNT_dec(LvTARG(TARG)); LvTARG(TARG) = SvREFCNT_inc_simple(keys); } PUSHs(TARG); RETURN; } if (! SvTIED_mg((const SV *)keys, PERL_MAGIC_tied) ) { i = HvKEYS(keys); } else { i = 0; while (hv_iternext(keys)) i++; } PUSHi( i ); RETURN; } EXTEND(SP, HvKEYS(keys) * (dokeys + dovalues)); PUTBACK; /* hv_iternext and hv_iterval might clobber stack_sp */ while ((entry = hv_iternext(keys))) { SPAGAIN; if (dokeys) { SV* const sv = hv_iterkeysv(entry); XPUSHs(sv); /* won't clobber stack_sp */ } if (dovalues) { SV *tmpstr; PUTBACK; tmpstr = hv_iterval(hv,entry); DEBUG_H(Perl_sv_setpvf(aTHX_ tmpstr, "%lu%%%d=%lu", (unsigned long)HeHASH(entry), (int)HvMAX(keys)+1, (unsigned long)(HeHASH(entry) & HvMAX(keys)))); SPAGAIN; XPUSHs(tmpstr); } PUTBACK; } return NORMAL; } /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */ perl-5.12.0-RC0/README.tru640000444000175000017500000001707011325125741013776 0ustar jessejesseIf you read this file _as_is_, just ignore the funny characters you see. It is written in the POD format (see pod/perlpod.pod) which is specially designed to be readable as is. =head1 NAME README.tru64 - Perl version 5 on Tru64 (formerly known as Digital UNIX formerly known as DEC OSF/1) systems =head1 DESCRIPTION This document describes various features of HP's (formerly Compaq's, formerly Digital's) Unix operating system (Tru64) that will affect how Perl version 5 (hereafter just Perl) is configured, compiled and/or runs. =head2 Compiling Perl 5 on Tru64 The recommended compiler to use in Tru64 is the native C compiler. The native compiler produces much faster code (the speed difference is noticeable: several dozen percentages) and also more correct code: if you are considering using the GNU C compiler you should use at the very least the release of 2.95.3 since all older gcc releases are known to produce broken code when compiling Perl. One manifestation of this brokenness is the lib/sdbm test dumping core; another is many of the op/regexp and op/pat, or ext/Storable tests dumping core (the exact pattern of failures depending on the GCC release and optimization flags). gcc 3.2.1 is known to work okay with Perl 5.8.0. However, when optimizing the toke.c gcc likes to have a lot of memory, 256 megabytes seems to be enough. The default setting of the process data section in Tru64 should be one gigabyte, but some sites/setups might have lowered that. The configuration process of Perl checks for too low process limits, and lowers the optimization for the toke.c if necessary, and also gives advice on how to raise the process limits. Also, Configure might abort with Build a threading Perl? [n] Configure[2437]: Syntax error at line 1 : `config.sh' is not expected. This indicates that Configure is being run with a broken Korn shell (even though you think you are using a Bourne shell by using "sh Configure" or "./Configure"). The Korn shell bug has been reported to Compaq as of February 1999 but in the meanwhile, the reason ksh is being used is that you have the environment variable BIN_SH set to 'xpg4'. This causes /bin/sh to delegate its duties to /bin/posix/sh (a ksh). Unset the environment variable and rerun Configure. =head2 Using Large Files with Perl on Tru64 In Tru64 Perl is automatically able to use large files, that is, files larger than 2 gigabytes, there is no need to use the Configure -Duselargefiles option as described in INSTALL (though using the option is harmless). =head2 Threaded Perl on Tru64 If you want to use threads, you should primarily use the Perl 5.8.0 threads model by running Configure with -Duseithreads. Perl threading is going to work only in Tru64 4.0 and newer releases, older operating releases like 3.2 aren't probably going to work properly with threads. In Tru64 V5 (at least V5.1A, V5.1B) you cannot build threaded Perl with gcc because the system header explicitly checks for supported C compilers, gcc (at least 3.2.2) not being one of them. But the system C compiler should work just fine. =head2 Long Doubles on Tru64 You cannot Configure Perl to use long doubles unless you have at least Tru64 V5.0, the long double support simply wasn't functional enough before that. Perl's Configure will override attempts to use the long doubles (you can notice this by Configure finding out that the modfl() function does not work as it should). At the time of this writing (June 2002), there is a known bug in the Tru64 libc printing of long doubles when not using "e" notation. The values are correct and usable, but you only get a limited number of digits displayed unless you force the issue by using C or the like. For Tru64 versions V5.0A through V5.1A, a patch is expected sometime after perl 5.8.0 is released. If your libc has not yet been patched, you'll get a warning from Configure when selecting long doubles. =head2 DB_File tests failing on Tru64 The DB_File tests (db-btree.t, db-hash.t, db-recno.t) may fail you have installed a newer version of Berkeley DB into the system and the -I and -L compiler and linker flags introduce version conflicts with the DB 1.85 headers and libraries that came with the Tru64. For example, mixing a DB v2 library with the DB v1 headers is a bad idea. Watch out for Configure options -Dlocincpth and -Dloclibpth, and check your /usr/local/include and /usr/local/lib since they are included by default. The second option is to explicitly instruct Configure to detect the newer Berkeley DB installation, by supplying the right directories with C<-Dlocincpth=/some/include> and C<-Dloclibpth=/some/lib> B before running "make test" setting your LD_LIBRARY_PATH to F. The third option is to work around the problem by disabling the DB_File completely when build Perl by specifying -Ui_db to Configure, and then using the BerkeleyDB module from CPAN instead of DB_File. The BerkeleyDB works with Berkeley DB versions 2.* or greater. The Berkeley DB 4.1.25 has been tested with Tru64 V5.1A and found to work. The latest Berkeley DB can be found from F. =head2 64-bit Perl on Tru64 In Tru64 Perl's integers are automatically 64-bit wide, there is no need to use the Configure -Duse64bitint option as described in INSTALL. Similarly, there is no need for -Duse64bitall since pointers are automatically 64-bit wide. =head2 Warnings about floating-point overflow when compiling Perl on Tru64 When compiling Perl in Tru64 you may (depending on the compiler release) see two warnings like this cc: Warning: numeric.c, line 104: In this statement, floating-point overflow occurs in evaluating the expression "1.8e308". (floatoverfl) return HUGE_VAL; -----------^ and when compiling the POSIX extension cc: Warning: const-c.inc, line 2007: In this statement, floating-point overflow occurs in evaluating the expression "1.8e308". (floatoverfl) return HUGE_VAL; -------------------^ The exact line numbers may vary between Perl releases. The warnings are benign and can be ignored: in later C compiler releases the warnings should be gone. When the file F is being compiled you may (depending on the operating system release) see an additional compiler flag being used: C<-DNO_EFF_ONLY_OK>. This is normal and refers to a feature that is relevant only if you use the C pragma. In older releases of the operating system the feature was broken and the NO_EFF_ONLY_OK instructs Perl not to use the feature. =head1 Testing Perl on Tru64 During "make test" the C will be skipped because on Tru64 it cannot be tested before Perl has been installed. The test refers to the use of the C<-P> option of Perl. =head1 ext/ODBM_File/odbm Test Failing With Static Builds The ext/ODBM_File/odbm is known to fail with static builds (Configure -Uusedl) due to a known bug in Tru64's static libdbm library. The good news is that you very probably don't need to ever use the ODBM_File extension since more advanced NDBM_File works fine, not to mention the even more advanced DB_File. =head1 Perl Fails Because Of Unresolved Symbol sockatmark If you get an error like Can't load '.../OSF1/lib/perl5/5.8.0/alpha-dec_osf/auto/IO/IO.so' for module IO: Unresolved symbol in .../lib/perl5/5.8.0/alpha-dec_osf/auto/IO/IO.so: sockatmark at .../lib/perl5/5.8.0/alpha-dec_osf/XSLoader.pm line 75. you need to either recompile your Perl in Tru64 4.0D or upgrade your Tru64 4.0D to at least 4.0F: the sockatmark() system call was added in Tru64 4.0F, and the IO extension refers that symbol. =head1 AUTHOR Jarkko Hietaniemi =cut perl-5.12.0-RC0/pad.h0000444000175000017500000003072411325127001013040 0ustar jessejesse/* pad.h * * Copyright (C) 2002, 2003, 2005, 2006, 2007, 2008 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * * This file defines the types and macros associated with the API for * manipulating scratchpads, which are used by perl to store lexical * variables, op targets and constants. */ /* a padlist is currently just an AV; but that might change, * so hide the type. Ditto a pad. */ typedef AV PADLIST; typedef AV PAD; /* offsets within a pad */ #if PTRSIZE == 4 typedef U32TYPE PADOFFSET; #else # if PTRSIZE == 8 typedef U64TYPE PADOFFSET; # endif #endif #define NOT_IN_PAD ((PADOFFSET) -1) /* B.xs needs these for the benefit of B::Deparse */ /* Low range end is exclusive (valid from the cop seq after this one) */ /* High range end is inclusive (valid up to this cop seq) */ #if defined (DEBUGGING) && defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) # define COP_SEQ_RANGE_LOW(sv) \ (({ const SV *const _sv_cop_seq_range_low = (const SV *) (sv); \ assert(SvTYPE(_sv_cop_seq_range_low) == SVt_NV \ || SvTYPE(_sv_cop_seq_range_low) >= SVt_PVNV); \ assert(SvTYPE(_sv_cop_seq_range_low) != SVt_PVAV); \ assert(SvTYPE(_sv_cop_seq_range_low) != SVt_PVHV); \ assert(SvTYPE(_sv_cop_seq_range_low) != SVt_PVCV); \ assert(SvTYPE(_sv_cop_seq_range_low) != SVt_PVFM); \ assert(!isGV_with_GP(_sv_cop_seq_range_low)); \ ((XPVNV*) MUTABLE_PTR(SvANY(_sv_cop_seq_range_low)))->xnv_u.xpad_cop_seq.xlow; \ })) # define COP_SEQ_RANGE_HIGH(sv) \ (({ const SV *const _sv_cop_seq_range_high = (const SV *) (sv); \ assert(SvTYPE(_sv_cop_seq_range_high) == SVt_NV \ || SvTYPE(_sv_cop_seq_range_high) >= SVt_PVNV); \ assert(SvTYPE(_sv_cop_seq_range_high) != SVt_PVAV); \ assert(SvTYPE(_sv_cop_seq_range_high) != SVt_PVHV); \ assert(SvTYPE(_sv_cop_seq_range_high) != SVt_PVCV); \ assert(SvTYPE(_sv_cop_seq_range_high) != SVt_PVFM); \ assert(!isGV_with_GP(_sv_cop_seq_range_high)); \ ((XPVNV*) MUTABLE_PTR(SvANY(_sv_cop_seq_range_high)))->xnv_u.xpad_cop_seq.xhigh; \ })) # define PARENT_PAD_INDEX(sv) \ (({ const SV *const _sv_parent_pad_index = (const SV *) (sv); \ assert(SvTYPE(_sv_parent_pad_index) == SVt_NV \ || SvTYPE(_sv_parent_pad_index) >= SVt_PVNV); \ assert(SvTYPE(_sv_parent_pad_index) != SVt_PVAV); \ assert(SvTYPE(_sv_parent_pad_index) != SVt_PVHV); \ assert(SvTYPE(_sv_parent_pad_index) != SVt_PVCV); \ assert(SvTYPE(_sv_parent_pad_index) != SVt_PVFM); \ assert(!isGV_with_GP(_sv_parent_pad_index)); \ ((XPVNV*) MUTABLE_PTR(SvANY(_sv_parent_pad_index)))->xnv_u.xpad_cop_seq.xlow; \ })) # define PARENT_FAKELEX_FLAGS(sv) \ (({ const SV *const _sv_parent_fakelex_flags = (const SV *) (sv); \ assert(SvTYPE(_sv_parent_fakelex_flags) == SVt_NV \ || SvTYPE(_sv_parent_fakelex_flags) >= SVt_PVNV); \ assert(SvTYPE(_sv_parent_fakelex_flags) != SVt_PVAV); \ assert(SvTYPE(_sv_parent_fakelex_flags) != SVt_PVHV); \ assert(SvTYPE(_sv_parent_fakelex_flags) != SVt_PVCV); \ assert(SvTYPE(_sv_parent_fakelex_flags) != SVt_PVFM); \ assert(!isGV_with_GP(_sv_parent_fakelex_flags)); \ ((XPVNV*) MUTABLE_PTR(SvANY(_sv_parent_fakelex_flags)))->xnv_u.xpad_cop_seq.xhigh; \ })) #else # define COP_SEQ_RANGE_LOW(sv) \ (0 + (((XPVNV*) SvANY(sv))->xnv_u.xpad_cop_seq.xlow)) # define COP_SEQ_RANGE_HIGH(sv) \ (0 + (((XPVNV*) SvANY(sv))->xnv_u.xpad_cop_seq.xhigh)) # define PARENT_PAD_INDEX(sv) \ (0 + (((XPVNV*) SvANY(sv))->xnv_u.xpad_cop_seq.xlow)) # define PARENT_FAKELEX_FLAGS(sv) \ (0 + (((XPVNV*) SvANY(sv))->xnv_u.xpad_cop_seq.xhigh)) #endif /* Flags set in the SvIVX field of FAKE namesvs */ #define PAD_FAKELEX_ANON 1 /* the lex is declared in an ANON, or ... */ #define PAD_FAKELEX_MULTI 2 /* the lex can be instantiated multiple times */ /* flags for the pad_new() function */ #define padnew_CLONE 1 /* this pad is for a cloned CV */ #define padnew_SAVE 2 /* save old globals */ #define padnew_SAVESUB 4 /* also save extra stuff for start of sub */ /* 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_type; #ifdef PERL_CORE /* flags for pad_add_name. SVf_UTF8 will also be valid in the future. */ # define padadd_OUR 0x01 /* our declaration. */ # define padadd_STATE 0x02 /* state declaration. */ # define padadd_NO_DUP_CHECK 0x04 /* skip warning on dups. */ #endif /* ASSERT_CURPAD_LEGAL and ASSERT_CURPAD_ACTIVE respectively determine * whether PL_comppad and PL_curpad are consistent and whether they have * active values */ #ifndef PERL_MAD # define pad_peg(label) #endif #ifdef DEBUGGING # 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)); # 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)); #else # define ASSERT_CURPAD_LEGAL(label) # define ASSERT_CURPAD_ACTIVE(label) #endif /* Note: the following three macros are actually defined in scope.h, but * they are documented here for completeness, since they directly or * indirectly affect pads. =for apidoc m|void|SAVEPADSV |PADOFFSET po Save a pad slot (used to restore after an iteration) XXX DAPM it would make more sense to make the arg a PADOFFSET =for apidoc m|void|SAVECLEARSV |SV **svp Clear the pointed to pad value on scope exit. (i.e. the runtime action of 'my') =for apidoc m|void|SAVECOMPPAD save PL_comppad and PL_curpad =for apidoc m|SV *|PAD_SETSV |PADOFFSET po|SV* sv Set the slot at offset C in the current pad to C =for apidoc m|void|PAD_SV |PADOFFSET po Get the value at offset C in the current pad =for apidoc m|SV *|PAD_SVl |PADOFFSET po Lightweight and lvalue version of C. Get or set the value at offset C in the current pad. Unlike C, does not print diagnostics with -DX. For internal use only. =for apidoc m|SV *|PAD_BASE_SV |PADLIST padlist|PADOFFSET po Get the value from slot C in the base (DEPTH=1) pad of a padlist =for apidoc m|void|PAD_SET_CUR |PADLIST padlist|I32 n Set the current pad to be pad C in the padlist, saving the previous current pad. NB currently this macro expands to a string too long for some compilers, so it's best to replace it with SAVECOMPPAD(); PAD_SET_CUR_NOSAVE(padlist,n); =for apidoc m|void|PAD_SET_CUR_NOSAVE |PADLIST padlist|I32 n like PAD_SET_CUR, but without the save =for apidoc m|void|PAD_SAVE_SETNULLPAD Save the current pad then set it to null. =for apidoc m|void|PAD_SAVE_LOCAL|PAD *opad|PAD *npad Save the current pad to the local variable opad, then make the current pad equal to npad =for apidoc m|void|PAD_RESTORE_LOCAL|PAD *opad Restore the old pad saved into the local variable opad by PAD_SAVE_LOCAL() =cut */ #ifdef DEBUGGING # define PAD_SV(po) pad_sv(po) # define PAD_SETSV(po,sv) pad_setsv(po,sv) #else # define PAD_SV(po) (PL_curpad[po]) # define PAD_SETSV(po,sv) PL_curpad[po] = (sv) #endif #define PAD_SVl(po) (PL_curpad[po]) #define PAD_BASE_SV(padlist, po) \ (AvARRAY(padlist)[1]) \ ? AvARRAY(MUTABLE_AV((AvARRAY(padlist)[1])))[po] : NULL; #define PAD_SET_CUR_NOSAVE(padlist,nth) \ PL_comppad = (PAD*) (AvARRAY(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); #define PAD_SAVE_SETNULLPAD() SAVECOMPPAD(); \ 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))); #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))); /* =for apidoc m|void|CX_CURPAD_SAVE|struct context Save the current pad in the given context block structure. =for apidoc m|SV *|CX_CURPAD_SV|struct context|PADOFFSET po Access the SV at offset po in the saved current pad in the given context block structure (can be used as an lvalue). =cut */ #define CX_CURPAD_SAVE(block) (block).oldcomppad = PL_comppad #define CX_CURPAD_SV(block,po) (AvARRAY(MUTABLE_AV(((block).oldcomppad)))[po]) /* =for apidoc m|U32|PAD_COMPNAME_FLAGS|PADOFFSET po Return the flags for the current compiling pad name at offset C. Assumes a valid slot entry. =for apidoc m|char *|PAD_COMPNAME_PV|PADOFFSET po Return the name of the current compiling pad name at offset C. Assumes a valid slot entry. =for apidoc m|HV *|PAD_COMPNAME_TYPE|PADOFFSET po Return the type (stash) of the current compiling pad name at offset C. Must be a valid name. Returns null if not typed. =for apidoc m|HV *|PAD_COMPNAME_OURSTASH|PADOFFSET po Return the stash associated with an C variable. Assumes the slot entry is a valid C lexical. =for apidoc m|STRLEN|PAD_COMPNAME_GEN|PADOFFSET po The generation number of the name at offset C in the current compiling pad (lvalue). Note that C is hijacked for this purpose. =for apidoc m|STRLEN|PAD_COMPNAME_GEN_set|PADOFFSET po|int gen Sets the generation number of the name at offset C in the current ling pad (lvalue) to C. Note that C is hijacked for this purpose. =cut */ #define PAD_COMPNAME_SV(po) (*av_fetch(PL_comppad_name, (po), FALSE)) #define PAD_COMPNAME_FLAGS(po) SvFLAGS(PAD_COMPNAME_SV(po)) #define PAD_COMPNAME_FLAGS_isOUR(po) \ ((PAD_COMPNAME_FLAGS(po) & (SVpad_NAME|SVpad_OUR)) == (SVpad_NAME|SVpad_OUR)) #define PAD_COMPNAME_PV(po) SvPV_nolen(PAD_COMPNAME_SV(po)) #define PAD_COMPNAME_TYPE(po) pad_compname_type(po) #define PAD_COMPNAME_OURSTASH(po) \ (SvOURSTASH(PAD_COMPNAME_SV(po))) #define PAD_COMPNAME_GEN(po) ((STRLEN)SvUVX(AvARRAY(PL_comppad_name)[po])) #define PAD_COMPNAME_GEN_set(po, gen) SvUV_set(AvARRAY(PL_comppad_name)[po], (UV)(gen)) /* =for apidoc m|void|PAD_DUP|PADLIST dstpad|PADLIST srcpad|CLONE_PARAMS* param Clone a padlist. =for apidoc m|void|PAD_CLONE_VARS|PerlInterpreter *proto_perl|CLONE_PARAMS* param Clone the state variables associated with running and compiling pads. =cut */ #define PAD_DUP(dstpad, srcpad, param) \ if ((srcpad) && !AvREAL(srcpad)) { \ /* XXX padlists are real, but pretend to be not */ \ AvREAL_on(srcpad); \ (dstpad) = av_dup_inc((srcpad), param); \ AvREAL_off(srcpad); \ AvREAL_off(dstpad); \ } \ else \ (dstpad) = av_dup_inc((srcpad), param); /* NB - we set PL_comppad to null unless it points at a value that * has already been dup'ed, ie it points to part of an active padlist. * Otherwise PL_comppad ends up being a leaked scalar in code like * the following: * threads->create(sub { threads->create(sub {...} ) } ); * where the second thread dups the outer sub's comppad but not the * sub's CV or padlist. */ #define PAD_CLONE_VARS(proto_perl, param) \ PL_comppad = MUTABLE_AV(ptr_table_fetch(PL_ptr_table, proto_perl->Icomppad)); \ PL_curpad = PL_comppad ? AvARRAY(PL_comppad) : NULL; \ PL_comppad_name = av_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; \ PL_max_intro_pending = proto_perl->Imax_intro_pending; \ PL_padix = proto_perl->Ipadix; \ PL_padix_floor = proto_perl->Ipadix_floor; \ PL_pad_reset_pending = proto_perl->Ipad_reset_pending; \ PL_cop_seqmax = proto_perl->Icop_seqmax; /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */ perl-5.12.0-RC0/makedepend.SH0000555000175000017500000001661211325127001014457 0ustar jessejesse#! /bin/sh case $PERL_CONFIG_SH in '') if test -f config.sh; then TOP=.; elif test -f ../config.sh; then TOP=..; elif test -f ../../config.sh; then TOP=../..; elif test -f ../../../config.sh; then TOP=../../..; elif test -f ../../../../config.sh; then TOP=../../../..; else echo "Can't find config.sh."; exit 1 fi . $TOP/config.sh ;; esac : This forces SH files to create target in same directory as SH file. : This is so that make depend always knows where to find SH derivatives. case "$0" in */*) cd `expr X$0 : 'X\(.*\)/'` ;; esac echo "Extracting makedepend (with variable substitutions)" rm -f makedepend $spitshell >makedepend <>makedepend <<'!NO!SUBS!' if test -d .depending; then echo "$0: Already running, exiting." exit 0 fi mkdir .depending # This script should be called with # sh ./makedepend MAKE=$(MAKE) case "$1" in MAKE=*) eval $1 ;; esac export PATH || (echo "OOPS, this isn't sh. Desperation time. I will feed myself to sh."; sh \$0; kill \$\$) case $PERL_CONFIG_SH in '') if test -f config.sh; then TOP=.; elif test -f ../config.sh; then TOP=..; elif test -f ../../config.sh; then TOP=../..; elif test -f ../../../config.sh; then TOP=../../..; elif test -f ../../../../config.sh; then TOP=../../../..; else echo "Can't find config.sh."; exit 1 fi . $TOP/config.sh ;; esac # Avoid localized gcc messages case "$ccname" in gcc) LC_ALL=C ; export LC_ALL ;; esac # We need .. when we are in the x2p directory if we are using the # cppstdin wrapper script. # Put .. and . first so that we pick up the present cppstdin, not # an older one lying about in /usr/local/bin. PATH=".$path_sep..$path_sep$PATH" export PATH case "$osname" in amigaos) cat=/bin/cat ;; # must be absolute esac $cat /dev/null >.deptmp $rm -f *.c.c c/*.c.c if test -f Makefile; then rm -f $firstmakefile cp Makefile $firstmakefile # On QNX, 'cp' preserves timestamp, so $firstmakefile appears # to be out of date. I don't know if OS/2 has touch, so do this: case "$osname" in os2) ;; *) $touch $firstmakefile ;; esac fi mf=$firstmakefile if test -f $mf; then defrule=`<$mf sed -n \ -e '/^\.c\$(OBJ_EXT):.*;/{' \ -e 's/\$\*\.c//' \ -e 's/^[^;]*;[ ]*//p' \ -e q \ -e '}' \ -e '/^\.c\$(OBJ_EXT): *$/{' \ -e N \ -e 's/\$\*\.c//' \ -e 's/^.*\n[ ]*//p' \ -e q \ -e '}'` fi case "$defrule" in '') defrule='$(CC) -c $(CFLAGS)' ;; esac : Create files in UU directory to avoid problems with long filenames : on systems with 14 character filename limits so file.c.c and file.c : might be identical $test -d UU || mkdir UU $MAKE clist || ($echo "Searching for .c files..."; \ $echo *.c | $tr ' ' $trnl | $egrep -v '\*' >.clist) for file in `$cat .clist`; do # for file in `cat /dev/null`; do case "$osname" in uwin) uwinfix="-e s,\\\\\\\\,/,g -e s,\\([a-zA-Z]\\):/,/\\1/,g" ;; os2) uwinfix="-e s,\\\\\\\\,/,g" ;; cygwin) uwinfix="-e s,\\\\\\\\,/,g" ;; posix-bc) uwinfix="-e s/\\*POSIX(\\(.*\\))/\\1/" ;; vos) uwinfix="-e s/\#/\\\#/" ;; *) uwinfix="" ;; esac case "$file" in *.c) filebase=`basename $file .c` ;; *.y) filebase=`basename $file .y` ;; esac case "$file" in */*) finc="-I`echo $file | sed 's#/[^/]*$##'`" ;; *) finc= ;; esac $echo "Finding dependencies for $filebase$_o." ( $echo "#line 1 \"$file\""; \ $sed -n <$file \ -e "/^${filebase}_init(/q" \ -e '/^#line/d' \ -e '/^#/{' \ -e 's|/\*.*$||' \ -e 's|\\$||' \ -e p \ -e '}' ) >UU/$file.c if [ "$osname" = os390 -a "$file" = perly.c ]; then $echo '#endif' >>UU/$file.c fi if [ "$osname" = os390 ]; then $cppstdin $finc -I. $cppflags $cppminus /d' \ -e '/^#.*"-"/d' \ -e '/^#.*git_version\.h/d' \ -e 's#\.[0-9][0-9]*\.c#'"$file.c#" \ -e 's/^[ ]*#[ ]*line/#/' \ -e '/^# *[0-9][0-9]* *[".\/]/!d' \ -e 's/^.*"\(.*\)".*$/'$filebase'\$(OBJ_EXT): \1/' \ -e 's/^# *[0-9][0-9]* \(.*\)$/'$filebase'\$(OBJ_EXT): \1/' \ -e 's|: \./|: |' \ -e 's|\.c\.c|.c|' $uwinfix | \ $uniq | $sort | $uniq >> .deptmp else $cppstdin $finc -I. $cppflags $cppminus .cout 2>.cerr $sed \ -e '1d' \ -e '/^#.*/d' \ -e '/^#.*/d' \ -e '/^#.*/d' \ -e '/^#.*/d' \ -e '/^#.*/d' \ -e '/^#.*"-"/d' \ -e '/^#.*"\/.*\/"/d' \ -e '/: file path prefix .* never used$/d' \ -e '/^#.*git_version\.h/d' \ -e 's#\.[0-9][0-9]*\.c#'"$file.c#" \ -e 's/^[ ]*#[ ]*line/#/' \ -e '/^# *[0-9][0-9]* *[".\/]/!d' \ -e 's/^.*"\(.*\)".*$/'$filebase'\$(OBJ_EXT): \1/' \ -e 's/^# *[0-9][0-9]* \(.*\)$/'$filebase'\$(OBJ_EXT): \1/' \ -e 's|: \./|: |' \ -e 's|\.c\.c|.c|' $uwinfix .cout .cerr| \ $uniq | $sort | $uniq >> .deptmp fi echo "$filebase\$(OBJ_EXT): cflags" >> .deptmp done $sed <$mf >$mf.new -e '1,/^# AUTOMATICALLY/!d' $MAKE shlist || ($echo "Searching for .SH files..."; \ $echo *.SH | $tr ' ' $trnl | $egrep -v '\*' >.shlist) # Now extract the dependencies on makedepend.SH and Makefile.SH # (they should reside in the main Makefile): rm -f .shlist.old mv .shlist .shlist.old $egrep -v '^makedepend\.SH' <.shlist.old >.shlist rm -f .shlist.old mv .shlist .shlist.old $egrep -v '^Makefile\.SH' <.shlist.old >.shlist rm -f .shlist.old mv .shlist .shlist.old $egrep -v '^perl_exp\.SH' <.shlist.old >.shlist rm -f .shlist.old mv .shlist .shlist.old $egrep -v '^config_h\.SH' <.shlist.old >.shlist rm .shlist.old if $test -s .deptmp; then for file in `cat .shlist`; do $echo `$expr X$file : 'X\(.*\).SH'`: $file $TOP/config.sh \; \ $sh $file >> .deptmp done $echo "Updating $mf..." $echo "# If this runs make out of memory, delete /usr/include lines." \ >> $mf.new if [ "$osname" = vos ]; then $sed 's|\.incl\.c|.h|' .deptmp >.deptmp.vos mv -f .deptmp.vos .deptmp fi $sed 's|^\(.*\$(OBJ_EXT):\) *\(.*/.*\.c\) *$|\1 \2; '"$defrule \2|" .deptmp \ >>$mf.new else $MAKE hlist || ($echo "Searching for .h files..."; \ $echo *.h | $tr ' ' $trnl | $egrep -v '\*' >.hlist) $echo "You don't seem to have a proper C preprocessor. Using grep instead." $egrep '^#include ' `cat .clist` `cat .hlist` >.deptmp $echo "Updating $mf..." <.clist $sed -n \ -e '/\//{' \ -e 's|^\(.*\)/\(.*\)\.c|\2\$(OBJ_EXT): \1/\2.c; '"$defrule \1/\2.c|p" \ -e d \ -e '}' \ -e 's|^\(.*\)\.c|\1\$(OBJ_EXT): \1.c|p' >> $mf.new <.hlist $sed -n 's|\(.*/\)\(.*\)|s= \2= \1\2=|p' >.hsed <.deptmp $sed -n 's|c:#include "\(.*\)".*$|o: \1|p' | \ $sed 's|^[^;]*/||' | \ $sed -f .hsed >> $mf.new <.deptmp $sed -n 's|h:#include "\(.*\)".*$|h: \1|p' | \ $sed -f .hsed >> $mf.new for file in `$cat .shlist`; do $echo `$expr X$file : 'X\(.*\).SH'`: $file $TOP/config.sh \; \ $sh $file >> $mf.new done fi $rm -f $mf.old $cp $mf $mf.old $rm -f $mf $cp $mf.new $mf $rm $mf.new $echo "# WARNING: Put nothing here or make depend will gobble it up!" >> $mf $rm -rf .deptmp UU .shlist .clist .hlist .hsed .cout .cerr rmdir .depending !NO!SUBS! $eunicefix makedepend chmod +x makedepend case `pwd` in *SH) $rm -f ../makedepend ln makedepend ../makedepend ;; esac perl-5.12.0-RC0/README.hpux0000444000175000017500000006636711325127001014002 0ustar jessejesseIf you read this file _as_is_, just ignore the funny characters you see. It is written in the POD format (see pod/perlpod.pod) which is specially designed to be readable as is. =head1 NAME README.hpux - Perl version 5 on Hewlett-Packard Unix (HP-UX) systems =head1 DESCRIPTION This document describes various features of HP's Unix operating system (HP-UX) that will affect how Perl version 5 (hereafter just Perl) is compiled and/or runs. =head2 Using perl as shipped with HP-UX Application release September 2001, HP-UX 11.00 is the first to ship with Perl. By the time it was perl-5.6.1 in /opt/perl. The first occurrence is on CD 5012-7954 and can be installed using swinstall -s /cdrom perl assuming you have mounted that CD on /cdrom. In this version the following modules were installed: ActivePerl::DocTools-0.04 HTML::Parser-3.19 XML::DOM-1.25 Archive::Tar-0.072 HTML::Tagset-3.03 XML::Parser-2.27 Compress::Zlib-1.08 MIME::Base64-2.11 XML::Simple-1.05 Convert::ASN1-0.10 Net-1.07 XML::XPath-1.09 Digest::MD5-2.11 PPM-2.1.5 XML::XSLT-0.32 File::CounterFile-0.12 SOAP::Lite-0.46 libwww-perl-5.51 Font::AFM-1.18 Storable-1.011 libxml-perl-0.07 HTML-Tree-3.11 URI-1.11 perl-ldap-0.23 That build was a portable hppa-1.1 multithread build that supports large files compiled with gcc-2.9-hppa-991112. If you perform a new installation, then (a newer) Perl will be installed automatically. Preinstalled HP-UX systems now slao have more recent versions of Perl and the updated modules. The official (threaded) builds from HP, as they are shipped on the Application DVD/CD's are available on http://www.software.hp.com/portal/swdepot/displayProductInfo.do?productNumber=PERL for both PA-RISC and IPF (Itanium Processor Family). They are built with the HP ANSI-C compiler. Up till 5.8.8 that was done by ActiveState. To see what version is included on the DVD (assumed here to be mounted on /cdrom), issue this command: # swlist -s /cdrom perl # perl D.5.8.8.B 5.8.8 Perl Programming Language perl.Perl5-32 D.5.8.8.B 32-bit 5.8.8 Perl Programming Language with Extensions perl.Perl5-64 D.5.8.8.B 64-bit 5.8.8 Perl Programming Language with Extensions =head2 Using perl from HP's porting centre HP porting centre tries very hard to keep up with customer demand and release updates from the Open Source community. Having precompiled Perl binaries available is obvious. The HP porting centres are limited in what systems they are allowed to port to and they usually choose the two most recent OS versions available. This means that at the moment of writing, there are only HP-UX 11.11 (pa-risc 2.0) and HP-UX 11.23 (Itanium 2) ports available on the porting centres. HP has asked the porting centre to move Open Source binaries from /opt to /usr/local, so binaries produced since the start of July 2002 are located in /usr/local. One of HP porting centres URL's is http://hpux.connect.org.uk/ The port currently available is built with GNU gcc. =head2 Compiling Perl 5 on HP-UX When compiling Perl, you must use an ANSI C compiler. The C compiler that ships with all HP-UX systems is a K&R compiler that should only be used to build new kernels. Perl can be compiled with either HP's ANSI C compiler or with gcc. The former is recommended, as not only can it compile Perl with no difficulty, but also can take advantage of features listed later that require the use of HP compiler-specific command-line flags. If you decide to use gcc, make sure your installation is recent and complete, and be sure to read the Perl INSTALL file for more gcc-specific details. =head2 PA-RISC HP's HP9000 Unix systems run on HP's own Precision Architecture (PA-RISC) chip. HP-UX used to run on the Motorola MC68000 family of chips, but any machine with this chip in it is quite obsolete and this document will not attempt to address issues for compiling Perl on the Motorola chipset. The version of PA-RISC at the time of this document's last update is 2.0, which is also the last there will be. HP PA-RISC systems are usually refered to with model description "HP 9000". The last CPU in this series is the PA-8900. Support for PA-RISC architectured machines officially ends as shown in the following table: PA-RISC End-of-Life Roadmap +--------+----------------+----------------+-----------------+ | HP9000 | Superdome | PA-8700 | Spring 2011 | | 4-128 | | PA-8800/sx1000 | Summer 2012 | | cores | | PA-8900/sx1000 | 2014 | | | | PA-8900/sx2000 | 2015 | +--------+----------------+----------------+-----------------+ | HP9000 | rp7410, rp8400 | PA-8700 | Spring 2011 | | 2-32 | rp7420, rp8420 | PA-8800/sx1000 | 2012 | | cores | rp7440, rp8440 | PA-8900/sx1000 | Autumn 2013 | | | | PA-8900/sx2000 | 2015 | +--------+----------------+----------------+-----------------+ | HP9000 | rp44x0 | PA-8700 | Spring 2011 | | 1-8 | | PA-8800/rp44x0 | 2012 | | cores | | PA-8900/rp44x0 | 2014 | +--------+----------------+----------------+-----------------+ | HP9000 | rp34x0 | PA-8700 | Spring 2011 | | 1-4 | | PA-8800/rp34x0 | 2012 | | cores | | PA-8900/rp34x0 | 2014 | +--------+----------------+----------------+-----------------+ From http://www.hp.com/products1/evolution/9000/faqs.html The last order date for HP 9000 systems was December 31, 2008. A complete list of models at the time the OS was built is in the file /usr/sam/lib/mo/sched.models. The first column corresponds to the last part of the output of the "model" command. The second column is the PA-RISC version and the third column is the exact chip type used. (Start browsing at the bottom to prevent confusion ;-) # model 9000/800/L1000-44 # grep L1000-44 /usr/sam/lib/mo/sched.models L1000-44 2.0 PA8500 =head2 Portability Between PA-RISC Versions An executable compiled on a PA-RISC 2.0 platform will not execute on a PA-RISC 1.1 platform, even if they are running the same version of HP-UX. If you are building Perl on a PA-RISC 2.0 platform and want that Perl to also run on a PA-RISC 1.1, the compiler flags +DAportable and +DS32 should be used. It is no longer possible to compile PA-RISC 1.0 executables on either the PA-RISC 1.1 or 2.0 platforms. The command-line flags are accepted, but the resulting executable will not run when transferred to a PA-RISC 1.0 system. =head2 PA-RISC 1.0 The original version of PA-RISC, HP no longer sells any system with this chip. The following systems contained PA-RISC 1.0 chips: 600, 635, 645, 808, 815, 822, 825, 832, 834, 835, 840, 842, 845, 850, 852, 855, 860, 865, 870, 890 =head2 PA-RISC 1.1 An upgrade to the PA-RISC design, it shipped for many years in many different system. The following systems contain with PA-RISC 1.1 chips: 705, 710, 712, 715, 720, 722, 725, 728, 730, 735, 742, 743, 744, 745, 747, 750, 755, 770, 777, 778, 779, 800, 801, 803, 806, 807, 809, 811, 813, 816, 817, 819, 821, 826, 827, 829, 831, 837, 839, 841, 847, 849, 851, 856, 857, 859, 867, 869, 877, 887, 891, 892, 897, A180, A180C, B115, B120, B132L, B132L+, B160L, B180L, C100, C110, C115, C120, C160L, D200, D210, D220, D230, D250, D260, D310, D320, D330, D350, D360, D410, DX0, DX5, DXO, E25, E35, E45, E55, F10, F20, F30, G30, G40, G50, G60, G70, H20, H30, H40, H50, H60, H70, I30, I40, I50, I60, I70, J200, J210, J210XC, K100, K200, K210, K220, K230, K400, K410, K420, S700i, S715, S744, S760, T500, T520 =head2 PA-RISC 2.0 The most recent upgrade to the PA-RISC design, it added support for 64-bit integer data. As of the date of this document's last update, the following systems contain PA-RISC 2.0 chips: 700, 780, 781, 782, 783, 785, 802, 804, 810, 820, 861, 871, 879, 889, 893, 895, 896, 898, 899, A400, A500, B1000, B2000, C130, C140, C160, C180, C180+, C180-XP, C200+, C400+, C3000, C360, C3600, CB260, D270, D280, D370, D380, D390, D650, J220, J2240, J280, J282, J400, J410, J5000, J5500XM, J5600, J7000, J7600, K250, K260, K260-EG, K270, K360, K370, K380, K450, K460, K460-EG, K460-XP, K470, K570, K580, L1000, L2000, L3000, N4000, R380, R390, SD16000, SD32000, SD64000, T540, T600, V2000, V2200, V2250, V2500, V2600 Just before HP took over Compaq, some systems were renamed. the link that contained the explanation is dead, so here's a short summary: HP 9000 A-Class servers, now renamed HP Server rp2400 series. HP 9000 L-Class servers, now renamed HP Server rp5400 series. HP 9000 N-Class servers, now renamed HP Server rp7400. rp2400, rp2405, rp2430, rp2450, rp2470, rp3410, rp3440, rp4410, rp4440, rp5400, rp5405, rp5430, rp5450, rp5470, rp7400, rp7405, rp7410, rp7420, rp7440, rp8400, rp8420, rp8440, Superdome The current naming convention is: aadddd ||||`+- 00 - 99 relative capacity & newness (upgrades, etc.) |||`--- unique number for each architecture to ensure different ||| systems do not have the same numbering across ||| architectures ||`---- 1 - 9 identifies family and/or relative positioning || |`----- c = ia32 (cisc) | p = pa-risc | x = ia-64 (Itanium & Itanium 2) | h = housing `------ t = tower r = rack optimized s = super scalable b = blade sa = appliance =head2 Itanium Processor Family (IPF) and HP-UX HP-UX also runs on the new Itanium processor. This requires the use of a different version of HP-UX (currently 11.23 or 11i v2), and with the exception of a few differences detailed below and in later sections, Perl should compile with no problems. Although PA-RISC binaries can run on Itanium systems, you should not attempt to use a PA-RISC version of Perl on an Itanium system. This is because shared libraries created on an Itanium system cannot be loaded while running a PA-RISC executable. HP Itanium 2 systems are usually refered to with model description "HP Integrity". =head2 Itanium, Itanium 2 & Madison 6 HP also ships servers with the 128-bit Itanium processor(s). The cx26x0 is told to have Madison 6. As of the date of this document's last update, the following systems contain Itanium or Itanium 2 chips (this is likely to be out of date): BL60p, BL860c, BL870c, cx2600, cx2620, rx1600, rx1620, rx2600, rx2600hptc, rx2620, rx2660, rx3600, rx4610, rx4640, rx5670, rx6600, rx7420, rx7620, rx7640, rx8420, rx8620, rx8640, rx9610, sx1000, sx2000 To see all about your machine, type # model ia64 hp server rx2600 # /usr/contrib/bin/machinfo =head2 HP-UX versions Not all architectures (PA = PA-RISC, IPF = Itanium Processor Family) support all versions of HP-UX, here is a short list HP-UX version Kernel Architecture ------------- ------ ------------ 10.20 32 bit PA 11.00 32/64 PA 11.11 11i v1 32/64 PA 11.22 11i v2 64 IPF 11.23 11i v2 64 PA & IPF 11.31 11i v3 64 PA & IPF See for the full list of hardware/OS support and expected end-of-life http://www.hp.com/go/hpuxservermatrix =head2 Building Dynamic Extensions on HP-UX HP-UX supports dynamically loadable libraries (shared libraries). Shared libraries end with the suffix .sl. On Itanium systems, they end with the suffix .so. Shared libraries created on a platform using a particular PA-RISC version are not usable on platforms using an earlier PA-RISC version by default. However, this backwards compatibility may be enabled using the same +DAportable compiler flag (with the same PA-RISC 1.0 caveat mentioned above). Shared libraries created on an Itanium platform cannot be loaded on a PA-RISC platform. Shared libraries created on a PA-RISC platform can only be loaded on an Itanium platform if it is a PA-RISC executable that is attempting to load the PA-RISC library. A PA-RISC shared library cannot be loaded into an Itanium executable nor vice-versa. To create a shared library, the following steps must be performed: 1. Compile source modules with +z or +Z flag to create a .o module which contains Position-Independent Code (PIC). The linker will tell you in the next step if +Z was needed. (For gcc, the appropriate flag is -fpic or -fPIC.) 2. Link the shared library using the -b flag. If the code calls any functions in other system libraries (e.g., libm), it must be included on this line. (Note that these steps are usually handled automatically by the extension's Makefile). If these dependent libraries are not listed at shared library creation time, you will get fatal "Unresolved symbol" errors at run time when the library is loaded. You may create a shared library that refers to another library, which may be either an archive library or a shared library. If this second library is a shared library, this is called a "dependent library". The dependent library's name is recorded in the main shared library, but it is not linked into the shared library. Instead, it is loaded when the main shared library is loaded. This can cause problems if you build an extension on one system and move it to another system where the libraries may not be located in the same place as on the first system. If the referred library is an archive library, then it is treated as a simple collection of .o modules (all of which must contain PIC). These modules are then linked into the shared library. Note that it is okay to create a library which contains a dependent library that is already linked into perl. Some extensions, like DB_File and Compress::Zlib use/require prebuilt libraries for the perl extensions/modules to work. If these libraries are built using the default configuration, it might happen that you run into an error like "invalid loader fixup" during load phase. HP is aware of this problem. Search the HP-UX cxx-dev forums for discussions about the subject. The short answer is that B (all libraries, everything) must be compiled with C<+z> or C<+Z> to be PIC (position independent code). (For gcc, that would be C<-fpic> or C<-fPIC>). In HP-UX 11.00 or newer the linker error message should tell the name of the offending object file. A more general approach is to intervene manually, as with an example for the DB_File module, which requires SleepyCat's libdb.sl: # cd .../db-3.2.9/build_unix # vi Makefile ... add +Z to all cflags to create shared objects CFLAGS= -c $(CPPFLAGS) +Z -Ae +O2 +Onolimit \ -I/usr/local/include -I/usr/include/X11R6 CXXFLAGS= -c $(CPPFLAGS) +Z -Ae +O2 +Onolimit \ -I/usr/local/include -I/usr/include/X11R6 # make clean # make # mkdir tmp # cd tmp # ar x ../libdb.a # ld -b -o libdb-3.2.sl *.o # mv libdb-3.2.sl /usr/local/lib # rm *.o # cd /usr/local/lib # rm -f libdb.sl # ln -s libdb-3.2.sl libdb.sl # cd .../DB_File-1.76 # make distclean # perl Makefile.PL # make # make test # make install As of db-4.2.x it is no longer needed to do this by hand. Sleepycat has changed the configuration process to add +z on HP-UX automatically. # cd .../db-4.2.25/build_unix # env CFLAGS=+DD64 LDFLAGS=+DD64 ../dist/configure should work to generate 64bit shared libraries for HP-UX 11.00 and 11i. It is no longer possible to link PA-RISC 1.0 shared libraries (even though the command-line flags are still present). PA-RISC and Itanium object files are not interchangeable. Although you may be able to use ar to create an archive library of PA-RISC object files on an Itanium system, you cannot link against it using an Itanium link editor. =head2 The HP ANSI C Compiler When using this compiler to build Perl, you should make sure that the flag -Aa is added to the cpprun and cppstdin variables in the config.sh file (though see the section on 64-bit perl below). If you are using a recent version of the Perl distribution, these flags are set automatically. Even though HP-UX 10.20 and 11.00 are not actively maintained by HP anymore, updates for the HP ANSI C compiler are still available from time to time, and it might be advisable to see if updates are applicable. At the moment of writing, the latests available patches for 11.00 that should be applied are PHSS_35098, PHSS_35175, PHSS_35100, PHSS_33036, and PHSS_33902). If you have a SUM account, you can use it to search for updates/patches. Enter "ANSI" as keyword. =head2 The GNU C Compiler When you are going to use the GNU C compiler (gcc), and you don't have gcc yet, you can either build it yourself from the sources (available from e.g. http://www.gnu.ai.mit.edu/software/gcc/releases.html) or fetch a prebuilt binary from the HP porting center. gcc prebuilds can be fetched from http://h21007.www2.hp.com/dspp/tech/tech_TechSoftwareDetailPage_IDX/1,1703,547,00.html (Browse through the list, because there are often multiple versions of the same package available). Above mentioned distributions are depots. H.Merijn Brand has made prebuilt gcc binaries available on http://mirrors.develooper.com/hpux/ and/or http://www.cmve.net/~merijn/ for HP-UX 10.20, HP-UX 11.00, HP-UX 11.11 (HP-UX 11i v1), and HP-UX 11.23 (HP-UX 11i v2) in both 32- and 64-bit versions. These are bzipped tar archives that also include recent GNU binutils and GNU gdb. Read the instructions on that page to rebuild gcc using itself. On PA-RISC you need a different compiler for 32-bit applications and for 64-bit applications. On PA-RISC, 32-bit objects and 64-bit objects do not mix. Period. There is no different behaviour for HP C-ANSI-C or GNU gcc. So if you require your perl binary to use 64-bit libraries, like Oracle-64bit, you MUST build a 64-bit perl. Building a 64-bit capable gcc on PA-RISC from source is possible only when you have the HP C-ANSI C compiler or an already working 64-bit binary of gcc available. Best performance for perl is achieved with HP's native compiler. =head2 Using Large Files with Perl on HP-UX Beginning with HP-UX version 10.20, files larger than 2GB (2^31 bytes) may be created and manipulated. Three separate methods of doing this are available. Of these methods, the best method for Perl is to compile using the -Duselargefiles flag to Configure. This causes Perl to be compiled using structures and functions in which these are 64 bits wide, rather than 32 bits wide. (Note that this will only work with HP's ANSI C compiler. If you want to compile Perl using gcc, you will have to get a version of the compiler that supports 64-bit operations. See above for where to find it.) There are some drawbacks to this approach. One is that any extension which calls any file-manipulating C function will need to be recompiled (just follow the usual "perl Makefile.PL; make; make test; make install" procedure). The list of functions that will need to recompiled is: creat, fgetpos, fopen, freopen, fsetpos, fstat, fstatvfs, fstatvfsdev, ftruncate, ftw, lockf, lseek, lstat, mmap, nftw, open, prealloc, stat, statvfs, statvfsdev, tmpfile, truncate, getrlimit, setrlimit Another drawback is only valid for Perl versions before 5.6.0. This drawback is that the seek and tell functions (both the builtin version and POSIX module version) will not perform correctly. It is strongly recommended that you use this flag when you run Configure. If you do not do this, but later answer the question about large files when Configure asks you, you may get a configuration that cannot be compiled, or that does not function as expected. =head2 Threaded Perl on HP-UX It is possible to compile a version of threaded Perl on any version of HP-UX before 10.30, but it is strongly suggested that you be running on HP-UX 11.00 at least. To compile Perl with threads, add -Dusethreads to the arguments of Configure. Verify that the -D_POSIX_C_SOURCE=199506L compiler flag is automatically added to the list of flags. Also make sure that -lpthread is listed before -lc in the list of libraries to link Perl with. The hints provided for HP-UX during Configure will try very hard to get this right for you. HP-UX versions before 10.30 require a separate installation of a POSIX threads library package. Two examples are the HP DCE package, available on "HP-UX Hardware Extensions 3.0, Install and Core OS, Release 10.20, April 1999 (B3920-13941)" or the Freely available PTH package, available on H.Merijn's site (http://mirrors.develooper.com/hpux/). The use of PTH will be unsupported in perl-5.12 and up and is rather buggy in 5.11.x. If you are going to use the HP DCE package, the library used for threading is /usr/lib/libcma.sl, but there have been multiple updates of that library over time. Perl will build with the first version, but it will not pass the test suite. Older Oracle versions might be a compelling reason not to update that library, otherwise please find a newer version in one of the following patches: PHSS_19739, PHSS_20608, or PHSS_23672 reformatted output: d3:/usr/lib 106 > what libcma-*.1 libcma-00000.1: HP DCE/9000 1.5 Module: libcma.sl (Export) Date: Apr 29 1996 22:11:24 libcma-19739.1: HP DCE/9000 1.5 PHSS_19739-40 Module: libcma.sl (Export) Date: Sep 4 1999 01:59:07 libcma-20608.1: HP DCE/9000 1.5 PHSS_20608 Module: libcma.1 (Export) Date: Dec 8 1999 18:41:23 libcma-23672.1: HP DCE/9000 1.5 PHSS_23672 Module: libcma.1 (Export) Date: Apr 9 2001 10:01:06 d3:/usr/lib 107 > If you choose for the PTH package, use swinstall to install pth in the default location (/opt/pth), and then make symbolic links to the libraries from /usr/lib # cd /usr/lib # ln -s /opt/pth/lib/libpth* . For building perl to support Oracle, it needs to be linked with libcl and libpthread. So even if your perl is an unthreaded build, these libraries might be required. See "Oracle on HP-UX" below. =head2 64-bit Perl on HP-UX Beginning with HP-UX 11.00, programs compiled under HP-UX can take advantage of the LP64 programming environment (LP64 means Longs and Pointers are 64 bits wide), in which scalar variables will be able to hold numbers larger than 2^32 with complete precision. Perl has proven to be consistent and reliable in 64bit mode since 5.8.1 on all HP-UX 11.xx. As of the date of this document, Perl is fully 64-bit compliant on HP-UX 11.00 and up for both cc- and gcc builds. If you are about to build a 64-bit perl with GNU gcc, please read the gcc section carefully. Should a user have the need for compiling Perl in the LP64 environment, use the -Duse64bitall flag to Configure. This will force Perl to be compiled in a pure LP64 environment (with the +DD64 flag for HP C-ANSI-C, with no additional options for GNU gcc 64-bit on PA-RISC, and with -mlp64 for GNU gcc on Itanium). If you want to compile Perl using gcc, you will have to get a version of the compiler that supports 64-bit operations.) You can also use the -Duse64bitint flag to Configure. Although there are some minor differences between compiling Perl with this flag versus the -Duse64bitall flag, they should not be noticeable from a Perl user's perspective. When configuring -Duse64bitint using a 64bit gcc on a pa-risc architecture, -Duse64bitint is silently promoted to -Duse64bitall. In both cases, it is strongly recommended that you use these flags when you run Configure. If you do not use do this, but later answer the questions about 64-bit numbers when Configure asks you, you may get a configuration that cannot be compiled, or that does not function as expected. =head2 Oracle on HP-UX Using perl to connect to Oracle databases through DBI and DBD::Oracle has caused a lot of people many headaches. Read README.hpux in the DBD::Oracle for much more information. The reason to mention it here is that Oracle requires a perl built with libcl and libpthread, the latter even when perl is build without threads. Building perl using all defaults, but still enabling to build DBD::Oracle later on can be achieved using Configure -A prepend:libswanted='cl pthread ' ... Do not forget the space before the trailing quote. Also note that this does not (yet) work with all configurations, it is known to fail with 64-bit versions of GCC. =head2 GDBM and Threads on HP-UX If you attempt to compile Perl with (POSIX) threads on an 11.X system and also link in the GDBM library, then Perl will immediately core dump when it starts up. The only workaround at this point is to relink the GDBM library under 11.X, then relink it into Perl. the error might show something like: Pthread internal error: message: __libc_reinit() failed, file: ../pthreads/pthread.c, line: 1096 Return Pointer is 0xc082bf33 sh: 5345 Quit(coredump) and Configure will give up. =head2 NFS filesystems and utime(2) on HP-UX If you are compiling Perl on a remotely-mounted NFS filesystem, the test io/fs.t may fail on test #18. This appears to be a bug in HP-UX and no fix is currently available. =head2 HP-UX Kernel Parameters (maxdsiz) for Compiling Perl By default, HP-UX comes configured with a maximum data segment size of 64MB. This is too small to correctly compile Perl with the maximum optimization levels. You can increase the size of the maxdsiz kernel parameter through the use of SAM. When using the GUI version of SAM, click on the Kernel Configuration icon, then the Configurable Parameters icon. Scroll down and select the maxdsiz line. From the Actions menu, select the Modify Configurable Parameter item. Insert the new formula into the Formula/Value box. Then follow the instructions to rebuild your kernel and reboot your system. In general, a value of 256MB (or "256*1024*1024") is sufficient for Perl to compile at maximum optimization. =head1 nss_delete core dump from op/pwent or op/grent You may get a bus error core dump from the op/pwent or op/grent tests. If compiled with -g you will see a stack trace much like the following: #0 0xc004216c in () from /usr/lib/libc.2 #1 0xc00d7550 in __nss_src_state_destr () from /usr/lib/libc.2 #2 0xc00d7768 in __nss_src_state_destr () from /usr/lib/libc.2 #3 0xc00d78a8 in nss_delete () from /usr/lib/libc.2 #4 0xc01126d8 in endpwent () from /usr/lib/libc.2 #5 0xd1950 in Perl_pp_epwent () from ./perl #6 0x94d3c in Perl_runops_standard () from ./perl #7 0x23728 in S_run_body () from ./perl #8 0x23428 in perl_run () from ./perl #9 0x2005c in main () from ./perl The key here is the C call. One workaround for this bug seems to be to create add to the file F (at least) the following lines group: files passwd: files Whether you are using NIS does not matter. Amazingly enough, the same bug also affects Solaris. =head1 Miscellaneous HP-UX 11 Y2K patch "Y2K-1100 B.11.00.B0125 HP-UX Core OS Year 2000 Patch Bundle" has been reported to break the io/fs test #18 which tests whether utime() can change timestamps. The Y2K patch seems to break utime() so that over NFS the timestamps do not get changed (on local filesystems utime() still works). This has probably been fixed on your system by now. =head1 AUTHOR H.Merijn Brand Jeff Okamoto With much assistance regarding shared libraries from Marc Sabatella. =head1 DATE Version 0.8.3: 2008-06-24 =cut perl-5.12.0-RC0/uts/0000755000175000017500000000000011351321567012746 5ustar jessejesseperl-5.12.0-RC0/uts/sprintf_wrap.c0000444000175000017500000001074311143650501015623 0ustar jessejesse#include #include #include #include char *UTS_sprintf_wrap(); char *do_efmt(); char *do_gfmt(); char *Fill(); /* main(argc, argv) * char **argv; * { * double d; * char *Fmt, *Ret; * char obuf[200]; * * assert(argc > 2); * Fmt = argv[1]; * d = strtod(argv[2], (char **)0); * * putchar('{'); * printf(Fmt, d); * printf("}\n"); * * Ret = UTS_sprintf_wrap(obuf, Fmt, d); * assert(Ret == obuf); * * printf("{%s}\n", obuf); * } */ char * UTS_sprintf_wrap(obuf, fmt, d, a0,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15) char *obuf, *fmt; double d; { int fmtlen, Width=0, Precision=6, Alt=0, Plus=0, Minus=0, Zero = 0; int FmtChar, BaseFmt = 0; char *f = fmt, *AfterWidth = 0, *AfterPrecision = 0; char *Dot; if(*f++ != '%') { return sprintf(obuf, fmt, d, a0,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15); } fmtlen = strlen(fmt); FmtChar = fmt[fmtlen - 1]; switch(FmtChar) { case 'f': case 'F': return sprintf(obuf, fmt, d, a0,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15); case 'e': case 'E': BaseFmt = 'e'; goto BaseFmt_IsSet; case 'g': case 'G': BaseFmt = 'g'; BaseFmt_IsSet: if(*f == '#') { Alt = 1; ++f; } /* Always has '.' */ if(*f == '+') { Plus = 1; ++f; } /* Force explicit sign */ if(*f == '-') { Minus = 1; ++f; } /* Left justify */ if(*f == '0') { Zero = 1; ++f;} /* Fill using 0s*/ if(Dot = strchr(f, '.')) { Precision = strtol(Dot+1, &AfterPrecision, 0); } if(!Dot || (Dot && Dot > f)) { /* Next char=='.' => no width*/ Width = strtol(f, &AfterWidth, 0); } if(Dot) { f = AfterPrecision; } else if(AfterWidth) { f = AfterWidth; } if(*f != FmtChar) goto regular_sprintf; /* It doesn't look like a f.p. sprintf call */ /* from Perl_sv_vcatpvfn */ if(BaseFmt == 'e') { return do_efmt(d, obuf, Width, Precision, Alt, Plus, Minus, Zero, FmtChar == 'E'); } else { return do_gfmt(d, obuf, Width, Precision, Alt, Plus, Minus, Zero, FmtChar == 'G'); } default: regular_sprintf: return sprintf(obuf, fmt, d, a0,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15); } } char * do_efmt(d, obuf, Width, Precision, Alt, Plus, Minus, Zero, UpperCase) char *obuf; double d; { char *Ecvt; char *ob; int decpt, sign, E; int len; int AllZeroes = 0; Ecvt = ecvt( d , Precision+1, &decpt, &sign); /* fprintf(stderr, "decpt=%d, sign=%d\n", decpt, sign); */ len = strlen(Ecvt); if(strspn(Ecvt, "0") == len) AllZeroes = 1; ob = obuf; if(sign) *ob++ = '-'; else if(Plus) *ob++ = '+'; *ob++ = Ecvt[0]; if(Precision > 0 || Alt) *ob++ = '.'; strcpy(ob, &Ecvt[1]); ob += strlen(ob); /* ADVANCE TO END OF WHAT WE JUST ADDED */ *ob++ = UpperCase ? 'E' : 'e'; if(AllZeroes) E = 0; else E = decpt - 1; if(E < 0) { *ob++ = '-'; E = -E; } else { *ob++ = '+'; } sprintf(ob, "%.2d", E); /* Too much horsepower used here */ if(Width > strlen(obuf)) return Fill(obuf, Width, Minus, Zero); else return obuf; } char * do_gfmt(d, obuf, Width, Precision, Alt, Plus, Minus, Zero, UpperCase) char *obuf; double d; { char *Ecvt = gcvt(d, Precision ? Precision : 1, obuf); int len = strlen(obuf); /* gcvt fails (maybe give a warning? For now return empty string): */ if(!Ecvt) { *obuf = '\0'; return obuf; } /* printf("Ecvt='%s'\n", Ecvt); */ if(Plus && (Ecvt[0] != '-')) { memmove(obuf+1, obuf, len+1); /* "+1" to get '\0' at end */ obuf[0] = '+'; ++len; } if(Alt && !strchr(Ecvt, '.')) { int LenUpTo_E = strcspn(obuf, "eE"); int E_etc_len = strlen(&obuf[LenUpTo_E]); /* ABOVE: Will be 0 if there's no E/e because */ /* strcspn will return length of whole string */ if(E_etc_len) memmove(obuf+LenUpTo_E+1, obuf+LenUpTo_E, E_etc_len); obuf[LenUpTo_E] = '.'; obuf[LenUpTo_E + 1 + E_etc_len ] = '\0'; } { char *E_loc; if(UpperCase && (E_loc = strchr(obuf, 'e'))) { *E_loc = 'E'; } } if(Width > len) return Fill(obuf, Width, Minus, Zero); else return obuf; } char * Fill(obuf, Width, LeftJustify, Zero) char *obuf; { int W = strlen(obuf); int diff = Width - W; /* LeftJustify means there was a '-' flag, and in that case, */ /* printf man page (UTS4.4) says ignore '0' */ char FillChar = (Zero && !LeftJustify) ? '0' : ' '; int i; int LeftFill = ! LeftJustify; if(Width <= W) return obuf; if(LeftFill) { memmove(obuf+diff, obuf, W+1); /* "+1" to get '\0' at end */ for(i=0 ; i < diff ; ++i) { obuf[i] = FillChar; } } else { for(i=W ; i < Width ; ++i) obuf[i] = FillChar; obuf[Width] = '\0'; } return obuf; } perl-5.12.0-RC0/uts/strtol_wrap.c0000444000175000017500000000722111143650501015462 0ustar jessejesse/* A wrapper around strtol() and strtoul() to correct some * "out of bounds" cases that don't work well on at least UTS. * If a value is Larger than the max, strto[u]l should return * the max value, and set errno to ERANGE * The same if a value is smaller than the min value (only * relevant for strtol(); not strtoul()), except the minimum * value is returned (and errno == ERANGE). */ #include #include #include #include extern int errno; #undef I32 #undef U32 #define I32 int #define U32 unsigned int struct base_info { char *ValidChars; char *Ulong_max_str; char *Long_max_str; char *Long_min_str; /* Absolute value */ int Ulong_max_str_len; int Long_max_str_len; int Long_min_str_len; /* Absolute value */ U32 Ulong_max; I32 Long_max; I32 Long_min; /* NOT Absolute value */ }; static struct base_info Base_info[37]; static struct base_info Base_info_16 = { "0123456789abcdefABCDEF", "4294967295", "2147483648" /* <== ABS VAL */ , "2147483647", 10, 10, 10, 4294967295, 2147483647, - 2147483648, }; static struct base_info Base_info_10 = { "0123456789", "4294967295", "2147483648" /* <== ABS VAL */ , "2147483647", 10, 10, 10, 4294967295, 2147483647, - 2147483648, }; /* Used eventually (if this is fully developed) to hold info * for processing bases 2-36. So that we can just plug the * base in as a selector for its info, we sacrifice * Base_info[0] and Base_info[1] (unless they are used * at some point for special information). */ /* This may be replaced later by something more universal */ static void init_Base_info() { if(Base_info[10].ValidChars) return; Base_info[10] = Base_info_10; Base_info[16] = Base_info_16; } unsigned int strtoul_wrap32(char *s, char **pEnd, int base) { int Len; int isNegated = 0; char *sOrig = s; init_Base_info(); while(*s && isspace(*s)) ++s; if(*s == '-') { ++isNegated; ++s; while(*s && isspace(*s)) ++s; } if(base == 0) { if(*s == '0') { if(s[1] == 'x' || s[1] == 'X') { s += 2; base = 16; } else { ++s; base = 8; } } else if(isdigit(*s)) { base = 10; } } if(base != 10) { return strtoul(sOrig, pEnd, base); } Len = strspn(s, Base_info[base].ValidChars); if(Len > Base_info[base].Ulong_max_str_len || (Len == Base_info[base].Ulong_max_str_len && strncmp(Base_info[base].Ulong_max_str, s, Len) < 0) ) { /* In case isNegated is set - what to do?? */ /* Mightn't we say a negative number is ERANGE for strtoul? */ errno = ERANGE; return Base_info[base].Ulong_max; } return strtoul(sOrig, pEnd, base); } int strtol_wrap32(char *s, char **pEnd, int base) { int Len; int isNegated = 0; char *sOrig = s; init_Base_info(); while(*s && isspace(*s)) ++s; if(*s == '-') { ++isNegated; ++s; while(*s && isspace(*s)) ++s; } if(base == 0) { if(*s == '0') { if(s[1] == 'x' || s[1] == 'X') { s += 2; base = 16; } else { ++s; base = 8; } } else if(isdigit(*s)) { base = 10; } } if(base != 10) { return strtol(sOrig, pEnd, base); } Len = strspn(s, Base_info[base].ValidChars); if(Len > Base_info[base].Long_max_str_len || (!isNegated && Len == Base_info[base].Long_max_str_len && strncmp(Base_info[base].Long_max_str, s, Len) < 0) || (isNegated && Len == Base_info[base].Long_min_str_len && strncmp(Base_info[base].Long_min_str, s, Len) < 0) ) { /* In case isNegated is set - what to do?? */ /* Mightn't we say a negative number is ERANGE for strtol? */ errno = ERANGE; return(isNegated ? Base_info[base].Long_min : Base_info[base].Long_min); } return strtol(sOrig, pEnd, base); } perl-5.12.0-RC0/util.h0000444000175000017500000000270511325125742013261 0ustar jessejesse/* util.h * * Copyright (C) 1991, 1992, 1993, 1999, 2001, 2002, 2003, 2004, 2005, * 2007, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ #ifdef VMS # define PERL_FILE_IS_ABSOLUTE(f) \ (*(f) == '/' \ || (strchr(f,':') \ || ((*(f) == '[' || *(f) == '<') \ && (isALNUM((f)[1]) || strchr("$-_]>",(f)[1]))))) #else /* !VMS */ # if defined(WIN32) || defined(__CYGWIN__) # define PERL_FILE_IS_ABSOLUTE(f) \ (*(f) == '/' || *(f) == '\\' /* UNC/rooted path */ \ || ((f)[0] && (f)[1] == ':')) /* drive name */ # else /* !WIN32 */ # ifdef 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 */ # else /* !NETWARE */ # if defined(DOSISH) || defined(EPOC) || defined(__SYMBIAN32__) # define PERL_FILE_IS_ABSOLUTE(f) \ (*(f) == '/' \ || ((f)[0] && (f)[1] == ':')) /* drive name */ # else /* NEITHER DOSISH NOR EPOCISH NOR SYMBIANISH */ # define PERL_FILE_IS_ABSOLUTE(f) (*(f) == '/') # endif /* DOSISH */ # endif /* NETWARE */ # endif /* WIN32 */ #endif /* VMS */ /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */ perl-5.12.0-RC0/README.qnx0000444000175000017500000001022711325127001013604 0ustar jessejesseIf you read this file _as_is_, just ignore the funny characters you see. It is written in the POD format (see pod/perlpod.pod) which is specially designed to be readable as is. =head1 NAME README.qnx - Perl version 5 on QNX =head1 DESCRIPTION As of perl5.7.2 all tests pass under: QNX 4.24G Watcom 10.6 with Beta/970211.wcc.update.tar.F socket3r.lib Nov21 1996. As of perl5.8.1 there is at least one test still failing. Some tests may complain under known circumstances. See below and hints/qnx.sh for more information. Under QNX 6.2.0 there are still a few tests which fail. See below and hints/qnx.sh for more information. =head2 Required Software for Compiling Perl on QNX4 As with many unix ports, this one depends on a few "standard" unix utilities which are not necessarily standard for QNX4. =over 4 =item /bin/sh This is used heavily by Configure and then by perl itself. QNX4's version is fine, but Configure will choke on the 16-bit version, so if you are running QNX 4.22, link /bin/sh to /bin32/ksh =item ar This is the standard unix library builder. We use wlib. With Watcom 10.6, when wlib is linked as "ar", it behaves like ar and all is fine. Under 9.5, a cover is required. One is included in ../qnx =item nm This is used (optionally) by configure to list the contents of libraries. I will generate a cover function on the fly in the UU directory. =item cpp Configure and perl need a way to invoke a C preprocessor. I have created a simple cover for cc which does the right thing. Without this, Configure will create its own wrapper which works, but it doesn't handle some of the command line arguments that perl will throw at it. =item make You really need GNU make to compile this. GNU make ships by default with QNX 4.23, but you can get it from quics for earlier versions. =back =head2 Outstanding Issues with Perl on QNX4 There is no support for dynamically linked libraries in QNX4. If you wish to compile with the Socket extension, you need to have the TCP/IP toolkit, and you need to make sure that -lsocket locates the correct copy of socket3r.lib. Beware that the Watcom compiler ships with a stub version of socket3r.lib which has very little functionality. Also beware the order in which wlink searches directories for libraries. You may have /usr/lib/socket3r.lib pointing to the correct library, but wlink may pick up /usr/watcom/10.6/usr/lib/socket3r.lib instead. Make sure they both point to the correct library, that is, /usr/tcptk/current/usr/lib/socket3r.lib. The following tests may report errors under QNX4: cpan/Cwd/Cwd.t will complain if `pwd` and cwd don't give the same results. cwd calls `fullpath -t`, so if you cd `fullpath -t` before running the test, it will pass. lib/File/Find/taint.t will complain if '.' is in your PATH. The PATH test is triggered because cwd calls `fullpath -t`. ext/IO/lib/IO/t/io_sock.t: Subtests 14 and 22 are skipped due to the fact that the functionality to read back the non-blocking status of a socket is not implemented in QNX's TCP/IP. This has been reported to QNX and it may work with later versions of TCP/IP. t/io/tell.t: Subtest 27 is failing. We are still investigating. =head2 QNX auxiliary files The files in the "qnx" directory are: =over 4 =item qnx/ar A script that emulates the standard unix archive (aka library) utility. Under Watcom 10.6, ar is linked to wlib and provides the expected interface. With Watcom 9.5, a cover function is required. This one is fairly crude but has proved adequate for compiling perl. =item qnx/cpp A script that provides C preprocessing functionality. Configure can generate a similar cover, but it doesn't handle all the command-line options that perl throws at it. This might be reasonably placed in /usr/local/bin. =back =head2 Outstanding issues with perl under QNX6 The following tests are still failing for Perl 5.8.1 under QNX 6.2.0: op/sprintf.........................FAILED at test 91 lib/Benchmark......................FAILED at test 26 This is due to a bug in the C library's printf routine. printf("'%e'", 0. ) produces '0.000000e+0', but ANSI requires '0.000000e+00'. QNX has acknowledged the bug. =head1 AUTHOR Norton T. Allen (allen@huarp.harvard.edu) perl-5.12.0-RC0/perlapi.h0000644000175000017500000007302011325127001013726 0ustar jessejesse/* -*- buffer-read-only: t -*- * * perlapi.h * * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * * !!!!!!! DO NOT EDIT THIS FILE !!!!!!! * This file is built by embed.pl from data in embed.fnc, embed.pl, * pp.sym, intrpvar.h, and perlvars.h. * Any changes made here will be lost! * * Edit those files and run 'make regen_headers' to effect changes. */ /* declare accessor functions for Perl variables */ #ifndef __perlapi_h__ #define __perlapi_h__ #if defined (MULTIPLICITY) START_EXTERN_C #undef PERLVAR #undef PERLVARA #undef PERLVARI #undef PERLVARIC #undef PERLVARISC #define PERLVAR(v,t) EXTERN_C t* Perl_##v##_ptr(pTHX); #define PERLVARA(v,n,t) typedef t PL_##v##_t[n]; \ EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX); #define PERLVARI(v,t,i) PERLVAR(v,t) #define PERLVARIC(v,t,i) PERLVAR(v, const t) #define PERLVARISC(v,i) typedef const char PL_##v##_t[sizeof(i)]; \ EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX); #include "intrpvar.h" #include "perlvars.h" #undef PERLVAR #undef PERLVARA #undef PERLVARI #undef PERLVARIC #undef PERLVARISC #ifndef PERL_GLOBAL_STRUCT EXTERN_C Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX); EXTERN_C Perl_check_t** Perl_Gcheck_ptr(pTHX); EXTERN_C unsigned char** Perl_Gfold_locale_ptr(pTHX); #define Perl_ppaddr_ptr Perl_Gppaddr_ptr #define Perl_check_ptr Perl_Gcheck_ptr #define Perl_fold_locale_ptr Perl_Gfold_locale_ptr #endif END_EXTERN_C #if defined(PERL_CORE) /* accessor functions for Perl variables (provide binary compatibility) */ /* these need to be mentioned here, or most linkers won't put them in the perl executable */ #ifndef PERL_NO_FORCE_LINK START_EXTERN_C #ifndef DOINIT EXTCONST void * const PL_force_link_funcs[]; #else EXTCONST void * const PL_force_link_funcs[] = { #undef PERLVAR #undef PERLVARA #undef PERLVARI #undef PERLVARIC #define PERLVAR(v,t) (void*)Perl_##v##_ptr, #define PERLVARA(v,n,t) PERLVAR(v,t) #define PERLVARI(v,t,i) PERLVAR(v,t) #define PERLVARIC(v,t,i) PERLVAR(v,t) #define PERLVARISC(v,i) PERLVAR(v,char) /* In Tru64 (__DEC && __osf__) the cc option -std1 causes that one * cannot cast between void pointers and function pointers without * info level warnings. The PL_force_link_funcs[] would cause a few * hundred of those warnings. In code one can circumnavigate this by using * unions that overlay the different pointers, but in declarations one * cannot use this trick. Therefore we just disable the warning here * for the duration of the PL_force_link_funcs[] declaration. */ #if defined(__DECC) && defined(__osf__) #pragma message save #pragma message disable (nonstandcast) #endif #include "intrpvar.h" #include "perlvars.h" #if defined(__DECC) && defined(__osf__) #pragma message restore #endif #undef PERLVAR #undef PERLVARA #undef PERLVARI #undef PERLVARIC #undef PERLVARISC }; #endif /* DOINIT */ END_EXTERN_C #endif /* PERL_NO_FORCE_LINK */ #else /* !PERL_CORE */ #undef PL_Argv #define PL_Argv (*Perl_IArgv_ptr(aTHX)) #undef PL_Cmd #define PL_Cmd (*Perl_ICmd_ptr(aTHX)) #undef PL_DBcv #define PL_DBcv (*Perl_IDBcv_ptr(aTHX)) #undef PL_DBgv #define PL_DBgv (*Perl_IDBgv_ptr(aTHX)) #undef PL_DBline #define PL_DBline (*Perl_IDBline_ptr(aTHX)) #undef PL_DBsignal #define PL_DBsignal (*Perl_IDBsignal_ptr(aTHX)) #undef PL_DBsingle #define PL_DBsingle (*Perl_IDBsingle_ptr(aTHX)) #undef PL_DBsub #define PL_DBsub (*Perl_IDBsub_ptr(aTHX)) #undef PL_DBtrace #define PL_DBtrace (*Perl_IDBtrace_ptr(aTHX)) #undef PL_Dir #define PL_Dir (*Perl_IDir_ptr(aTHX)) #undef PL_Env #define PL_Env (*Perl_IEnv_ptr(aTHX)) #undef PL_LIO #define PL_LIO (*Perl_ILIO_ptr(aTHX)) #undef PL_Mem #define PL_Mem (*Perl_IMem_ptr(aTHX)) #undef PL_MemParse #define PL_MemParse (*Perl_IMemParse_ptr(aTHX)) #undef PL_MemShared #define PL_MemShared (*Perl_IMemShared_ptr(aTHX)) #undef PL_OpPtr #define PL_OpPtr (*Perl_IOpPtr_ptr(aTHX)) #undef PL_OpSlab #define PL_OpSlab (*Perl_IOpSlab_ptr(aTHX)) #undef PL_OpSpace #define PL_OpSpace (*Perl_IOpSpace_ptr(aTHX)) #undef PL_Proc #define PL_Proc (*Perl_IProc_ptr(aTHX)) #undef PL_Sock #define PL_Sock (*Perl_ISock_ptr(aTHX)) #undef PL_StdIO #define PL_StdIO (*Perl_IStdIO_ptr(aTHX)) #undef PL_Sv #define PL_Sv (*Perl_ISv_ptr(aTHX)) #undef PL_Xpv #define PL_Xpv (*Perl_IXpv_ptr(aTHX)) #undef PL_amagic_generation #define PL_amagic_generation (*Perl_Iamagic_generation_ptr(aTHX)) #undef PL_an #define PL_an (*Perl_Ian_ptr(aTHX)) #undef PL_argvgv #define PL_argvgv (*Perl_Iargvgv_ptr(aTHX)) #undef PL_argvout_stack #define PL_argvout_stack (*Perl_Iargvout_stack_ptr(aTHX)) #undef PL_argvoutgv #define PL_argvoutgv (*Perl_Iargvoutgv_ptr(aTHX)) #undef PL_basetime #define PL_basetime (*Perl_Ibasetime_ptr(aTHX)) #undef PL_beginav #define PL_beginav (*Perl_Ibeginav_ptr(aTHX)) #undef PL_beginav_save #define PL_beginav_save (*Perl_Ibeginav_save_ptr(aTHX)) #undef PL_body_arenas #define PL_body_arenas (*Perl_Ibody_arenas_ptr(aTHX)) #undef PL_body_roots #define PL_body_roots (*Perl_Ibody_roots_ptr(aTHX)) #undef PL_bodytarget #define PL_bodytarget (*Perl_Ibodytarget_ptr(aTHX)) #undef PL_breakable_sub_gen #define PL_breakable_sub_gen (*Perl_Ibreakable_sub_gen_ptr(aTHX)) #undef PL_checkav #define PL_checkav (*Perl_Icheckav_ptr(aTHX)) #undef PL_checkav_save #define PL_checkav_save (*Perl_Icheckav_save_ptr(aTHX)) #undef PL_chopset #define PL_chopset (*Perl_Ichopset_ptr(aTHX)) #undef PL_clocktick #define PL_clocktick (*Perl_Iclocktick_ptr(aTHX)) #undef PL_collation_ix #define PL_collation_ix (*Perl_Icollation_ix_ptr(aTHX)) #undef PL_collation_name #define PL_collation_name (*Perl_Icollation_name_ptr(aTHX)) #undef PL_collation_standard #define PL_collation_standard (*Perl_Icollation_standard_ptr(aTHX)) #undef PL_collxfrm_base #define PL_collxfrm_base (*Perl_Icollxfrm_base_ptr(aTHX)) #undef PL_collxfrm_mult #define PL_collxfrm_mult (*Perl_Icollxfrm_mult_ptr(aTHX)) #undef PL_colors #define PL_colors (*Perl_Icolors_ptr(aTHX)) #undef PL_colorset #define PL_colorset (*Perl_Icolorset_ptr(aTHX)) #undef PL_compcv #define PL_compcv (*Perl_Icompcv_ptr(aTHX)) #undef PL_compiling #define PL_compiling (*Perl_Icompiling_ptr(aTHX)) #undef PL_comppad #define PL_comppad (*Perl_Icomppad_ptr(aTHX)) #undef PL_comppad_name #define PL_comppad_name (*Perl_Icomppad_name_ptr(aTHX)) #undef PL_comppad_name_fill #define PL_comppad_name_fill (*Perl_Icomppad_name_fill_ptr(aTHX)) #undef PL_comppad_name_floor #define PL_comppad_name_floor (*Perl_Icomppad_name_floor_ptr(aTHX)) #undef PL_cop_seqmax #define PL_cop_seqmax (*Perl_Icop_seqmax_ptr(aTHX)) #undef PL_cryptseen #define PL_cryptseen (*Perl_Icryptseen_ptr(aTHX)) #undef PL_curcop #define PL_curcop (*Perl_Icurcop_ptr(aTHX)) #undef PL_curcopdb #define PL_curcopdb (*Perl_Icurcopdb_ptr(aTHX)) #undef PL_curpad #define PL_curpad (*Perl_Icurpad_ptr(aTHX)) #undef PL_curpm #define PL_curpm (*Perl_Icurpm_ptr(aTHX)) #undef PL_curstack #define PL_curstack (*Perl_Icurstack_ptr(aTHX)) #undef PL_curstackinfo #define PL_curstackinfo (*Perl_Icurstackinfo_ptr(aTHX)) #undef PL_curstash #define PL_curstash (*Perl_Icurstash_ptr(aTHX)) #undef PL_curstname #define PL_curstname (*Perl_Icurstname_ptr(aTHX)) #undef PL_custom_op_descs #define PL_custom_op_descs (*Perl_Icustom_op_descs_ptr(aTHX)) #undef PL_custom_op_names #define PL_custom_op_names (*Perl_Icustom_op_names_ptr(aTHX)) #undef PL_cv_has_eval #define PL_cv_has_eval (*Perl_Icv_has_eval_ptr(aTHX)) #undef PL_dbargs #define PL_dbargs (*Perl_Idbargs_ptr(aTHX)) #undef PL_debstash #define PL_debstash (*Perl_Idebstash_ptr(aTHX)) #undef PL_debug #define PL_debug (*Perl_Idebug_ptr(aTHX)) #undef PL_debug_pad #define PL_debug_pad (*Perl_Idebug_pad_ptr(aTHX)) #undef PL_def_layerlist #define PL_def_layerlist (*Perl_Idef_layerlist_ptr(aTHX)) #undef PL_defgv #define PL_defgv (*Perl_Idefgv_ptr(aTHX)) #undef PL_defoutgv #define PL_defoutgv (*Perl_Idefoutgv_ptr(aTHX)) #undef PL_defstash #define PL_defstash (*Perl_Idefstash_ptr(aTHX)) #undef PL_delaymagic #define PL_delaymagic (*Perl_Idelaymagic_ptr(aTHX)) #undef PL_destroyhook #define PL_destroyhook (*Perl_Idestroyhook_ptr(aTHX)) #undef PL_diehook #define PL_diehook (*Perl_Idiehook_ptr(aTHX)) #undef PL_dirty #define PL_dirty (*Perl_Idirty_ptr(aTHX)) #undef PL_doextract #define PL_doextract (*Perl_Idoextract_ptr(aTHX)) #undef PL_doswitches #define PL_doswitches (*Perl_Idoswitches_ptr(aTHX)) #undef PL_dowarn #define PL_dowarn (*Perl_Idowarn_ptr(aTHX)) #undef PL_dumper_fd #define PL_dumper_fd (*Perl_Idumper_fd_ptr(aTHX)) #undef PL_dumpindent #define PL_dumpindent (*Perl_Idumpindent_ptr(aTHX)) #undef PL_e_script #define PL_e_script (*Perl_Ie_script_ptr(aTHX)) #undef PL_efloatbuf #define PL_efloatbuf (*Perl_Iefloatbuf_ptr(aTHX)) #undef PL_efloatsize #define PL_efloatsize (*Perl_Iefloatsize_ptr(aTHX)) #undef PL_egid #define PL_egid (*Perl_Iegid_ptr(aTHX)) #undef PL_encoding #define PL_encoding (*Perl_Iencoding_ptr(aTHX)) #undef PL_endav #define PL_endav (*Perl_Iendav_ptr(aTHX)) #undef PL_envgv #define PL_envgv (*Perl_Ienvgv_ptr(aTHX)) #undef PL_errgv #define PL_errgv (*Perl_Ierrgv_ptr(aTHX)) #undef PL_errors #define PL_errors (*Perl_Ierrors_ptr(aTHX)) #undef PL_euid #define PL_euid (*Perl_Ieuid_ptr(aTHX)) #undef PL_eval_root #define PL_eval_root (*Perl_Ieval_root_ptr(aTHX)) #undef PL_eval_start #define PL_eval_start (*Perl_Ieval_start_ptr(aTHX)) #undef PL_evalseq #define PL_evalseq (*Perl_Ievalseq_ptr(aTHX)) #undef PL_exit_flags #define PL_exit_flags (*Perl_Iexit_flags_ptr(aTHX)) #undef PL_exitlist #define PL_exitlist (*Perl_Iexitlist_ptr(aTHX)) #undef PL_exitlistlen #define PL_exitlistlen (*Perl_Iexitlistlen_ptr(aTHX)) #undef PL_fdpid #define PL_fdpid (*Perl_Ifdpid_ptr(aTHX)) #undef PL_filemode #define PL_filemode (*Perl_Ifilemode_ptr(aTHX)) #undef PL_firstgv #define PL_firstgv (*Perl_Ifirstgv_ptr(aTHX)) #undef PL_forkprocess #define PL_forkprocess (*Perl_Iforkprocess_ptr(aTHX)) #undef PL_formfeed #define PL_formfeed (*Perl_Iformfeed_ptr(aTHX)) #undef PL_formtarget #define PL_formtarget (*Perl_Iformtarget_ptr(aTHX)) #undef PL_generation #define PL_generation (*Perl_Igeneration_ptr(aTHX)) #undef PL_gensym #define PL_gensym (*Perl_Igensym_ptr(aTHX)) #undef PL_gid #define PL_gid (*Perl_Igid_ptr(aTHX)) #undef PL_glob_index #define PL_glob_index (*Perl_Iglob_index_ptr(aTHX)) #undef PL_globalstash #define PL_globalstash (*Perl_Iglobalstash_ptr(aTHX)) #undef PL_hash_seed #define PL_hash_seed (*Perl_Ihash_seed_ptr(aTHX)) #undef PL_hintgv #define PL_hintgv (*Perl_Ihintgv_ptr(aTHX)) #undef PL_hints #define PL_hints (*Perl_Ihints_ptr(aTHX)) #undef PL_hv_fetch_ent_mh #define PL_hv_fetch_ent_mh (*Perl_Ihv_fetch_ent_mh_ptr(aTHX)) #undef PL_in_clean_all #define PL_in_clean_all (*Perl_Iin_clean_all_ptr(aTHX)) #undef PL_in_clean_objs #define PL_in_clean_objs (*Perl_Iin_clean_objs_ptr(aTHX)) #undef PL_in_eval #define PL_in_eval (*Perl_Iin_eval_ptr(aTHX)) #undef PL_in_load_module #define PL_in_load_module (*Perl_Iin_load_module_ptr(aTHX)) #undef PL_incgv #define PL_incgv (*Perl_Iincgv_ptr(aTHX)) #undef PL_initav #define PL_initav (*Perl_Iinitav_ptr(aTHX)) #undef PL_inplace #define PL_inplace (*Perl_Iinplace_ptr(aTHX)) #undef PL_isarev #define PL_isarev (*Perl_Iisarev_ptr(aTHX)) #undef PL_known_layers #define PL_known_layers (*Perl_Iknown_layers_ptr(aTHX)) #undef PL_last_in_gv #define PL_last_in_gv (*Perl_Ilast_in_gv_ptr(aTHX)) #undef PL_last_swash_hv #define PL_last_swash_hv (*Perl_Ilast_swash_hv_ptr(aTHX)) #undef PL_last_swash_key #define PL_last_swash_key (*Perl_Ilast_swash_key_ptr(aTHX)) #undef PL_last_swash_klen #define PL_last_swash_klen (*Perl_Ilast_swash_klen_ptr(aTHX)) #undef PL_last_swash_slen #define PL_last_swash_slen (*Perl_Ilast_swash_slen_ptr(aTHX)) #undef PL_last_swash_tmps #define PL_last_swash_tmps (*Perl_Ilast_swash_tmps_ptr(aTHX)) #undef PL_lastfd #define PL_lastfd (*Perl_Ilastfd_ptr(aTHX)) #undef PL_lastgotoprobe #define PL_lastgotoprobe (*Perl_Ilastgotoprobe_ptr(aTHX)) #undef PL_lastscream #define PL_lastscream (*Perl_Ilastscream_ptr(aTHX)) #undef PL_laststatval #define PL_laststatval (*Perl_Ilaststatval_ptr(aTHX)) #undef PL_laststype #define PL_laststype (*Perl_Ilaststype_ptr(aTHX)) #undef PL_localizing #define PL_localizing (*Perl_Ilocalizing_ptr(aTHX)) #undef PL_localpatches #define PL_localpatches (*Perl_Ilocalpatches_ptr(aTHX)) #undef PL_lockhook #define PL_lockhook (*Perl_Ilockhook_ptr(aTHX)) #undef PL_madskills #define PL_madskills (*Perl_Imadskills_ptr(aTHX)) #undef PL_main_cv #define PL_main_cv (*Perl_Imain_cv_ptr(aTHX)) #undef PL_main_root #define PL_main_root (*Perl_Imain_root_ptr(aTHX)) #undef PL_main_start #define PL_main_start (*Perl_Imain_start_ptr(aTHX)) #undef PL_mainstack #define PL_mainstack (*Perl_Imainstack_ptr(aTHX)) #undef PL_markstack #define PL_markstack (*Perl_Imarkstack_ptr(aTHX)) #undef PL_markstack_max #define PL_markstack_max (*Perl_Imarkstack_max_ptr(aTHX)) #undef PL_markstack_ptr #define PL_markstack_ptr (*Perl_Imarkstack_ptr_ptr(aTHX)) #undef PL_max_intro_pending #define PL_max_intro_pending (*Perl_Imax_intro_pending_ptr(aTHX)) #undef PL_maxo #define PL_maxo (*Perl_Imaxo_ptr(aTHX)) #undef PL_maxscream #define PL_maxscream (*Perl_Imaxscream_ptr(aTHX)) #undef PL_maxsysfd #define PL_maxsysfd (*Perl_Imaxsysfd_ptr(aTHX)) #undef PL_memory_debug_header #define PL_memory_debug_header (*Perl_Imemory_debug_header_ptr(aTHX)) #undef PL_mess_sv #define PL_mess_sv (*Perl_Imess_sv_ptr(aTHX)) #undef PL_min_intro_pending #define PL_min_intro_pending (*Perl_Imin_intro_pending_ptr(aTHX)) #undef PL_minus_E #define PL_minus_E (*Perl_Iminus_E_ptr(aTHX)) #undef PL_minus_F #define PL_minus_F (*Perl_Iminus_F_ptr(aTHX)) #undef PL_minus_a #define PL_minus_a (*Perl_Iminus_a_ptr(aTHX)) #undef PL_minus_c #define PL_minus_c (*Perl_Iminus_c_ptr(aTHX)) #undef PL_minus_l #define PL_minus_l (*Perl_Iminus_l_ptr(aTHX)) #undef PL_minus_n #define PL_minus_n (*Perl_Iminus_n_ptr(aTHX)) #undef PL_minus_p #define PL_minus_p (*Perl_Iminus_p_ptr(aTHX)) #undef PL_modcount #define PL_modcount (*Perl_Imodcount_ptr(aTHX)) #undef PL_modglobal #define PL_modglobal (*Perl_Imodglobal_ptr(aTHX)) #undef PL_my_cxt_keys #define PL_my_cxt_keys (*Perl_Imy_cxt_keys_ptr(aTHX)) #undef PL_my_cxt_list #define PL_my_cxt_list (*Perl_Imy_cxt_list_ptr(aTHX)) #undef PL_my_cxt_size #define PL_my_cxt_size (*Perl_Imy_cxt_size_ptr(aTHX)) #undef PL_na #define PL_na (*Perl_Ina_ptr(aTHX)) #undef PL_nice_chunk #define PL_nice_chunk (*Perl_Inice_chunk_ptr(aTHX)) #undef PL_nice_chunk_size #define PL_nice_chunk_size (*Perl_Inice_chunk_size_ptr(aTHX)) #undef PL_nomemok #define PL_nomemok (*Perl_Inomemok_ptr(aTHX)) #undef PL_numeric_local #define PL_numeric_local (*Perl_Inumeric_local_ptr(aTHX)) #undef PL_numeric_name #define PL_numeric_name (*Perl_Inumeric_name_ptr(aTHX)) #undef PL_numeric_radix_sv #define PL_numeric_radix_sv (*Perl_Inumeric_radix_sv_ptr(aTHX)) #undef PL_numeric_standard #define PL_numeric_standard (*Perl_Inumeric_standard_ptr(aTHX)) #undef PL_ofsgv #define PL_ofsgv (*Perl_Iofsgv_ptr(aTHX)) #undef PL_oldname #define PL_oldname (*Perl_Ioldname_ptr(aTHX)) #undef PL_op #define PL_op (*Perl_Iop_ptr(aTHX)) #undef PL_op_mask #define PL_op_mask (*Perl_Iop_mask_ptr(aTHX)) #undef PL_opfreehook #define PL_opfreehook (*Perl_Iopfreehook_ptr(aTHX)) #undef PL_opsave #define PL_opsave (*Perl_Iopsave_ptr(aTHX)) #undef PL_origalen #define PL_origalen (*Perl_Iorigalen_ptr(aTHX)) #undef PL_origargc #define PL_origargc (*Perl_Iorigargc_ptr(aTHX)) #undef PL_origargv #define PL_origargv (*Perl_Iorigargv_ptr(aTHX)) #undef PL_origenviron #define PL_origenviron (*Perl_Iorigenviron_ptr(aTHX)) #undef PL_origfilename #define PL_origfilename (*Perl_Iorigfilename_ptr(aTHX)) #undef PL_ors_sv #define PL_ors_sv (*Perl_Iors_sv_ptr(aTHX)) #undef PL_osname #define PL_osname (*Perl_Iosname_ptr(aTHX)) #undef PL_pad_reset_pending #define PL_pad_reset_pending (*Perl_Ipad_reset_pending_ptr(aTHX)) #undef PL_padix #define PL_padix (*Perl_Ipadix_ptr(aTHX)) #undef PL_padix_floor #define PL_padix_floor (*Perl_Ipadix_floor_ptr(aTHX)) #undef PL_parser #define PL_parser (*Perl_Iparser_ptr(aTHX)) #undef PL_patchlevel #define PL_patchlevel (*Perl_Ipatchlevel_ptr(aTHX)) #undef PL_peepp #define PL_peepp (*Perl_Ipeepp_ptr(aTHX)) #undef PL_perl_destruct_level #define PL_perl_destruct_level (*Perl_Iperl_destruct_level_ptr(aTHX)) #undef PL_perldb #define PL_perldb (*Perl_Iperldb_ptr(aTHX)) #undef PL_perlio #define PL_perlio (*Perl_Iperlio_ptr(aTHX)) #undef PL_pidstatus #define PL_pidstatus (*Perl_Ipidstatus_ptr(aTHX)) #undef PL_ppid #define PL_ppid (*Perl_Ippid_ptr(aTHX)) #undef PL_preambleav #define PL_preambleav (*Perl_Ipreambleav_ptr(aTHX)) #undef PL_profiledata #define PL_profiledata (*Perl_Iprofiledata_ptr(aTHX)) #undef PL_psig_name #define PL_psig_name (*Perl_Ipsig_name_ptr(aTHX)) #undef PL_psig_pend #define PL_psig_pend (*Perl_Ipsig_pend_ptr(aTHX)) #undef PL_psig_ptr #define PL_psig_ptr (*Perl_Ipsig_ptr_ptr(aTHX)) #undef PL_ptr_table #define PL_ptr_table (*Perl_Iptr_table_ptr(aTHX)) #undef PL_reentrant_buffer #define PL_reentrant_buffer (*Perl_Ireentrant_buffer_ptr(aTHX)) #undef PL_reentrant_retint #define PL_reentrant_retint (*Perl_Ireentrant_retint_ptr(aTHX)) #undef PL_reg_state #define PL_reg_state (*Perl_Ireg_state_ptr(aTHX)) #undef PL_regdummy #define PL_regdummy (*Perl_Iregdummy_ptr(aTHX)) #undef PL_regex_pad #define PL_regex_pad (*Perl_Iregex_pad_ptr(aTHX)) #undef PL_regex_padav #define PL_regex_padav (*Perl_Iregex_padav_ptr(aTHX)) #undef PL_reginterp_cnt #define PL_reginterp_cnt (*Perl_Ireginterp_cnt_ptr(aTHX)) #undef PL_registered_mros #define PL_registered_mros (*Perl_Iregistered_mros_ptr(aTHX)) #undef PL_regmatch_slab #define PL_regmatch_slab (*Perl_Iregmatch_slab_ptr(aTHX)) #undef PL_regmatch_state #define PL_regmatch_state (*Perl_Iregmatch_state_ptr(aTHX)) #undef PL_rehash_seed #define PL_rehash_seed (*Perl_Irehash_seed_ptr(aTHX)) #undef PL_rehash_seed_set #define PL_rehash_seed_set (*Perl_Irehash_seed_set_ptr(aTHX)) #undef PL_replgv #define PL_replgv (*Perl_Ireplgv_ptr(aTHX)) #undef PL_restartop #define PL_restartop (*Perl_Irestartop_ptr(aTHX)) #undef PL_rs #define PL_rs (*Perl_Irs_ptr(aTHX)) #undef PL_runops #define PL_runops (*Perl_Irunops_ptr(aTHX)) #undef PL_savebegin #define PL_savebegin (*Perl_Isavebegin_ptr(aTHX)) #undef PL_savestack #define PL_savestack (*Perl_Isavestack_ptr(aTHX)) #undef PL_savestack_ix #define PL_savestack_ix (*Perl_Isavestack_ix_ptr(aTHX)) #undef PL_savestack_max #define PL_savestack_max (*Perl_Isavestack_max_ptr(aTHX)) #undef PL_sawampersand #define PL_sawampersand (*Perl_Isawampersand_ptr(aTHX)) #undef PL_scopestack #define PL_scopestack (*Perl_Iscopestack_ptr(aTHX)) #undef PL_scopestack_ix #define PL_scopestack_ix (*Perl_Iscopestack_ix_ptr(aTHX)) #undef PL_scopestack_max #define PL_scopestack_max (*Perl_Iscopestack_max_ptr(aTHX)) #undef PL_scopestack_name #define PL_scopestack_name (*Perl_Iscopestack_name_ptr(aTHX)) #undef PL_screamfirst #define PL_screamfirst (*Perl_Iscreamfirst_ptr(aTHX)) #undef PL_screamnext #define PL_screamnext (*Perl_Iscreamnext_ptr(aTHX)) #undef PL_secondgv #define PL_secondgv (*Perl_Isecondgv_ptr(aTHX)) #undef PL_sharehook #define PL_sharehook (*Perl_Isharehook_ptr(aTHX)) #undef PL_sig_pending #define PL_sig_pending (*Perl_Isig_pending_ptr(aTHX)) #undef PL_sighandlerp #define PL_sighandlerp (*Perl_Isighandlerp_ptr(aTHX)) #undef PL_signals #define PL_signals (*Perl_Isignals_ptr(aTHX)) #undef PL_slab_count #define PL_slab_count (*Perl_Islab_count_ptr(aTHX)) #undef PL_slabs #define PL_slabs (*Perl_Islabs_ptr(aTHX)) #undef PL_sort_RealCmp #define PL_sort_RealCmp (*Perl_Isort_RealCmp_ptr(aTHX)) #undef PL_sortcop #define PL_sortcop (*Perl_Isortcop_ptr(aTHX)) #undef PL_sortstash #define PL_sortstash (*Perl_Isortstash_ptr(aTHX)) #undef PL_splitstr #define PL_splitstr (*Perl_Isplitstr_ptr(aTHX)) #undef PL_srand_called #define PL_srand_called (*Perl_Isrand_called_ptr(aTHX)) #undef PL_stack_base #define PL_stack_base (*Perl_Istack_base_ptr(aTHX)) #undef PL_stack_max #define PL_stack_max (*Perl_Istack_max_ptr(aTHX)) #undef PL_stack_sp #define PL_stack_sp (*Perl_Istack_sp_ptr(aTHX)) #undef PL_start_env #define PL_start_env (*Perl_Istart_env_ptr(aTHX)) #undef PL_stashcache #define PL_stashcache (*Perl_Istashcache_ptr(aTHX)) #undef PL_statbuf #define PL_statbuf (*Perl_Istatbuf_ptr(aTHX)) #undef PL_statcache #define PL_statcache (*Perl_Istatcache_ptr(aTHX)) #undef PL_statgv #define PL_statgv (*Perl_Istatgv_ptr(aTHX)) #undef PL_statname #define PL_statname (*Perl_Istatname_ptr(aTHX)) #undef PL_statusvalue #define PL_statusvalue (*Perl_Istatusvalue_ptr(aTHX)) #undef PL_statusvalue_posix #define PL_statusvalue_posix (*Perl_Istatusvalue_posix_ptr(aTHX)) #undef PL_statusvalue_vms #define PL_statusvalue_vms (*Perl_Istatusvalue_vms_ptr(aTHX)) #undef PL_stderrgv #define PL_stderrgv (*Perl_Istderrgv_ptr(aTHX)) #undef PL_stdingv #define PL_stdingv (*Perl_Istdingv_ptr(aTHX)) #undef PL_strtab #define PL_strtab (*Perl_Istrtab_ptr(aTHX)) #undef PL_sub_generation #define PL_sub_generation (*Perl_Isub_generation_ptr(aTHX)) #undef PL_subline #define PL_subline (*Perl_Isubline_ptr(aTHX)) #undef PL_subname #define PL_subname (*Perl_Isubname_ptr(aTHX)) #undef PL_sv_arenaroot #define PL_sv_arenaroot (*Perl_Isv_arenaroot_ptr(aTHX)) #undef PL_sv_count #define PL_sv_count (*Perl_Isv_count_ptr(aTHX)) #undef PL_sv_no #define PL_sv_no (*Perl_Isv_no_ptr(aTHX)) #undef PL_sv_objcount #define PL_sv_objcount (*Perl_Isv_objcount_ptr(aTHX)) #undef PL_sv_root #define PL_sv_root (*Perl_Isv_root_ptr(aTHX)) #undef PL_sv_serial #define PL_sv_serial (*Perl_Isv_serial_ptr(aTHX)) #undef PL_sv_undef #define PL_sv_undef (*Perl_Isv_undef_ptr(aTHX)) #undef PL_sv_yes #define PL_sv_yes (*Perl_Isv_yes_ptr(aTHX)) #undef PL_sys_intern #define PL_sys_intern (*Perl_Isys_intern_ptr(aTHX)) #undef PL_taint_warn #define PL_taint_warn (*Perl_Itaint_warn_ptr(aTHX)) #undef PL_tainted #define PL_tainted (*Perl_Itainted_ptr(aTHX)) #undef PL_tainting #define PL_tainting (*Perl_Itainting_ptr(aTHX)) #undef PL_threadhook #define PL_threadhook (*Perl_Ithreadhook_ptr(aTHX)) #undef PL_timesbuf #define PL_timesbuf (*Perl_Itimesbuf_ptr(aTHX)) #undef PL_tmps_floor #define PL_tmps_floor (*Perl_Itmps_floor_ptr(aTHX)) #undef PL_tmps_ix #define PL_tmps_ix (*Perl_Itmps_ix_ptr(aTHX)) #undef PL_tmps_max #define PL_tmps_max (*Perl_Itmps_max_ptr(aTHX)) #undef PL_tmps_stack #define PL_tmps_stack (*Perl_Itmps_stack_ptr(aTHX)) #undef PL_top_env #define PL_top_env (*Perl_Itop_env_ptr(aTHX)) #undef PL_toptarget #define PL_toptarget (*Perl_Itoptarget_ptr(aTHX)) #undef PL_uid #define PL_uid (*Perl_Iuid_ptr(aTHX)) #undef PL_unicode #define PL_unicode (*Perl_Iunicode_ptr(aTHX)) #undef PL_unitcheckav #define PL_unitcheckav (*Perl_Iunitcheckav_ptr(aTHX)) #undef PL_unitcheckav_save #define PL_unitcheckav_save (*Perl_Iunitcheckav_save_ptr(aTHX)) #undef PL_unlockhook #define PL_unlockhook (*Perl_Iunlockhook_ptr(aTHX)) #undef PL_unsafe #define PL_unsafe (*Perl_Iunsafe_ptr(aTHX)) #undef PL_utf8_X_L #define PL_utf8_X_L (*Perl_Iutf8_X_L_ptr(aTHX)) #undef PL_utf8_X_LV #define PL_utf8_X_LV (*Perl_Iutf8_X_LV_ptr(aTHX)) #undef PL_utf8_X_LVT #define PL_utf8_X_LVT (*Perl_Iutf8_X_LVT_ptr(aTHX)) #undef PL_utf8_X_LV_LVT_V #define PL_utf8_X_LV_LVT_V (*Perl_Iutf8_X_LV_LVT_V_ptr(aTHX)) #undef PL_utf8_X_T #define PL_utf8_X_T (*Perl_Iutf8_X_T_ptr(aTHX)) #undef PL_utf8_X_V #define PL_utf8_X_V (*Perl_Iutf8_X_V_ptr(aTHX)) #undef PL_utf8_X_begin #define PL_utf8_X_begin (*Perl_Iutf8_X_begin_ptr(aTHX)) #undef PL_utf8_X_extend #define PL_utf8_X_extend (*Perl_Iutf8_X_extend_ptr(aTHX)) #undef PL_utf8_X_non_hangul #define PL_utf8_X_non_hangul (*Perl_Iutf8_X_non_hangul_ptr(aTHX)) #undef PL_utf8_X_prepend #define PL_utf8_X_prepend (*Perl_Iutf8_X_prepend_ptr(aTHX)) #undef PL_utf8_alnum #define PL_utf8_alnum (*Perl_Iutf8_alnum_ptr(aTHX)) #undef PL_utf8_alpha #define PL_utf8_alpha (*Perl_Iutf8_alpha_ptr(aTHX)) #undef PL_utf8_ascii #define PL_utf8_ascii (*Perl_Iutf8_ascii_ptr(aTHX)) #undef PL_utf8_cntrl #define PL_utf8_cntrl (*Perl_Iutf8_cntrl_ptr(aTHX)) #undef PL_utf8_digit #define PL_utf8_digit (*Perl_Iutf8_digit_ptr(aTHX)) #undef PL_utf8_graph #define PL_utf8_graph (*Perl_Iutf8_graph_ptr(aTHX)) #undef PL_utf8_idcont #define PL_utf8_idcont (*Perl_Iutf8_idcont_ptr(aTHX)) #undef PL_utf8_idstart #define PL_utf8_idstart (*Perl_Iutf8_idstart_ptr(aTHX)) #undef PL_utf8_lower #define PL_utf8_lower (*Perl_Iutf8_lower_ptr(aTHX)) #undef PL_utf8_mark #define PL_utf8_mark (*Perl_Iutf8_mark_ptr(aTHX)) #undef PL_utf8_perl_space #define PL_utf8_perl_space (*Perl_Iutf8_perl_space_ptr(aTHX)) #undef PL_utf8_perl_word #define PL_utf8_perl_word (*Perl_Iutf8_perl_word_ptr(aTHX)) #undef PL_utf8_posix_digit #define PL_utf8_posix_digit (*Perl_Iutf8_posix_digit_ptr(aTHX)) #undef PL_utf8_print #define PL_utf8_print (*Perl_Iutf8_print_ptr(aTHX)) #undef PL_utf8_punct #define PL_utf8_punct (*Perl_Iutf8_punct_ptr(aTHX)) #undef PL_utf8_space #define PL_utf8_space (*Perl_Iutf8_space_ptr(aTHX)) #undef PL_utf8_tofold #define PL_utf8_tofold (*Perl_Iutf8_tofold_ptr(aTHX)) #undef PL_utf8_tolower #define PL_utf8_tolower (*Perl_Iutf8_tolower_ptr(aTHX)) #undef PL_utf8_totitle #define PL_utf8_totitle (*Perl_Iutf8_totitle_ptr(aTHX)) #undef PL_utf8_toupper #define PL_utf8_toupper (*Perl_Iutf8_toupper_ptr(aTHX)) #undef PL_utf8_upper #define PL_utf8_upper (*Perl_Iutf8_upper_ptr(aTHX)) #undef PL_utf8_xdigit #define PL_utf8_xdigit (*Perl_Iutf8_xdigit_ptr(aTHX)) #undef PL_utf8cache #define PL_utf8cache (*Perl_Iutf8cache_ptr(aTHX)) #undef PL_utf8locale #define PL_utf8locale (*Perl_Iutf8locale_ptr(aTHX)) #undef PL_warnhook #define PL_warnhook (*Perl_Iwarnhook_ptr(aTHX)) #undef PL_watchaddr #define PL_watchaddr (*Perl_Iwatchaddr_ptr(aTHX)) #undef PL_watchok #define PL_watchok (*Perl_Iwatchok_ptr(aTHX)) #undef PL_xmlfp #define PL_xmlfp (*Perl_Ixmlfp_ptr(aTHX)) #undef PL_No #define PL_No (*Perl_GNo_ptr(NULL)) #undef PL_Yes #define PL_Yes (*Perl_GYes_ptr(NULL)) #undef PL_appctx #define PL_appctx (*Perl_Gappctx_ptr(NULL)) #undef PL_check #define PL_check (*Perl_Gcheck_ptr(NULL)) #undef PL_csighandlerp #define PL_csighandlerp (*Perl_Gcsighandlerp_ptr(NULL)) #undef PL_curinterp #define PL_curinterp (*Perl_Gcurinterp_ptr(NULL)) #undef PL_do_undump #define PL_do_undump (*Perl_Gdo_undump_ptr(NULL)) #undef PL_dollarzero_mutex #define PL_dollarzero_mutex (*Perl_Gdollarzero_mutex_ptr(NULL)) #undef PL_fold_locale #define PL_fold_locale (*Perl_Gfold_locale_ptr(NULL)) #undef PL_global_struct_size #define PL_global_struct_size (*Perl_Gglobal_struct_size_ptr(NULL)) #undef PL_hexdigit #define PL_hexdigit (*Perl_Ghexdigit_ptr(NULL)) #undef PL_hints_mutex #define PL_hints_mutex (*Perl_Ghints_mutex_ptr(NULL)) #undef PL_interp_size #define PL_interp_size (*Perl_Ginterp_size_ptr(NULL)) #undef PL_interp_size_5_10_0 #define PL_interp_size_5_10_0 (*Perl_Ginterp_size_5_10_0_ptr(NULL)) #undef PL_keyword_plugin #define PL_keyword_plugin (*Perl_Gkeyword_plugin_ptr(NULL)) #undef PL_malloc_mutex #define PL_malloc_mutex (*Perl_Gmalloc_mutex_ptr(NULL)) #undef PL_mmap_page_size #define PL_mmap_page_size (*Perl_Gmmap_page_size_ptr(NULL)) #undef PL_my_ctx_mutex #define PL_my_ctx_mutex (*Perl_Gmy_ctx_mutex_ptr(NULL)) #undef PL_my_cxt_index #define PL_my_cxt_index (*Perl_Gmy_cxt_index_ptr(NULL)) #undef PL_op_mutex #define PL_op_mutex (*Perl_Gop_mutex_ptr(NULL)) #undef PL_op_seq #define PL_op_seq (*Perl_Gop_seq_ptr(NULL)) #undef PL_op_sequence #define PL_op_sequence (*Perl_Gop_sequence_ptr(NULL)) #undef PL_patleave #define PL_patleave (*Perl_Gpatleave_ptr(NULL)) #undef PL_perlio_debug_fd #define PL_perlio_debug_fd (*Perl_Gperlio_debug_fd_ptr(NULL)) #undef PL_perlio_fd_refcnt #define PL_perlio_fd_refcnt (*Perl_Gperlio_fd_refcnt_ptr(NULL)) #undef PL_perlio_fd_refcnt_size #define PL_perlio_fd_refcnt_size (*Perl_Gperlio_fd_refcnt_size_ptr(NULL)) #undef PL_perlio_mutex #define PL_perlio_mutex (*Perl_Gperlio_mutex_ptr(NULL)) #undef PL_ppaddr #define PL_ppaddr (*Perl_Gppaddr_ptr(NULL)) #undef PL_revision #define PL_revision (*Perl_Grevision_ptr(NULL)) #undef PL_runops_dbg #define PL_runops_dbg (*Perl_Grunops_dbg_ptr(NULL)) #undef PL_runops_std #define PL_runops_std (*Perl_Grunops_std_ptr(NULL)) #undef PL_sh_path #define PL_sh_path (*Perl_Gsh_path_ptr(NULL)) #undef PL_sig_defaulting #define PL_sig_defaulting (*Perl_Gsig_defaulting_ptr(NULL)) #undef PL_sig_handlers_initted #define PL_sig_handlers_initted (*Perl_Gsig_handlers_initted_ptr(NULL)) #undef PL_sig_ignoring #define PL_sig_ignoring (*Perl_Gsig_ignoring_ptr(NULL)) #undef PL_sig_sv #define PL_sig_sv (*Perl_Gsig_sv_ptr(NULL)) #undef PL_sig_trapped #define PL_sig_trapped (*Perl_Gsig_trapped_ptr(NULL)) #undef PL_sigfpe_saved #define PL_sigfpe_saved (*Perl_Gsigfpe_saved_ptr(NULL)) #undef PL_subversion #define PL_subversion (*Perl_Gsubversion_ptr(NULL)) #undef PL_sv_placeholder #define PL_sv_placeholder (*Perl_Gsv_placeholder_ptr(NULL)) #undef PL_thr_key #define PL_thr_key (*Perl_Gthr_key_ptr(NULL)) #undef PL_timesbase #define PL_timesbase (*Perl_Gtimesbase_ptr(NULL)) #undef PL_use_safe_putenv #define PL_use_safe_putenv (*Perl_Guse_safe_putenv_ptr(NULL)) #undef PL_version #define PL_version (*Perl_Gversion_ptr(NULL)) #undef PL_veto_cleanup #define PL_veto_cleanup (*Perl_Gveto_cleanup_ptr(NULL)) #undef PL_watch_pvx #define PL_watch_pvx (*Perl_Gwatch_pvx_ptr(NULL)) #endif /* !PERL_CORE */ #endif /* MULTIPLICITY */ #endif /* __perlapi_h__ */ /* ex: set ro: */ perl-5.12.0-RC0/install_lib.pl0000444000175000017500000000665011325125741014766 0ustar jessejesse#!perl # Initialisation code and subroutines shared between installperl and installman # Probably installhtml needs to join the club. use strict; use vars qw($Is_VMS $Is_W32 $Is_OS2 $Is_Cygwin $Is_Darwin $Is_NetWare %opts $packlist); use subs qw(unlink link chmod); use Config; BEGIN { if ($Config{userelocatableinc}) { # This might be a considered a hack. Need to get information about the # configuration from Config.pm *before* Config.pm expands any .../ # prefixes. # # So we set $^X to pretend that we're the already installed perl, so # Config.pm doesits ... expansion off that location. my $location = $Config{initialinstalllocation}; die <<'OS' unless defined $location; $Config{initialinstalllocation} is not defined - can't install a relocatable perl without this. OS $^X = "$location/perl"; # And then remove all trace of ever having loaded Config.pm, so that # it will reload with the revised $^X undef %Config::; delete $INC{"Config.pm"}; delete $INC{"Config_heavy.pl"}; delete $INC{"Config_git.pl"}; # You never saw us. We weren't here. require Config; Config->import; } } if ($Config{d_umask}) { umask(022); # umasks like 077 aren't that useful for installations } $Is_VMS = $^O eq 'VMS'; $Is_W32 = $^O eq 'MSWin32'; $Is_OS2 = $^O eq 'os2'; $Is_Cygwin = $^O eq 'cygwin'; $Is_Darwin = $^O eq 'darwin'; $Is_NetWare = $Config{osname} eq 'NetWare'; sub unlink { my(@names) = @_; my($cnt) = 0; return scalar(@names) if $Is_VMS; foreach my $name (@names) { next unless -e $name; chmod 0777, $name if ($Is_OS2 || $Is_W32 || $Is_Cygwin || $Is_NetWare); print " unlink $name\n" if $opts{verbose}; ( CORE::unlink($name) and ++$cnt or warn "Couldn't unlink $name: $!\n" ) unless $opts{notify}; } return $cnt; } sub link { my($from,$to) = @_; my($success) = 0; my $xfrom = $from; $xfrom =~ s/^\Q$opts{destdir}\E// if $opts{destdir}; my $xto = $to; $xto =~ s/^\Q$opts{destdir}\E// if $opts{destdir}; print $opts{verbose} ? " ln $xfrom $xto\n" : " $xto\n" unless $opts{silent}; eval { CORE::link($from, $to) ? $success++ : ($from =~ m#^/afs/# || $to =~ m#^/afs/#) ? die "AFS" # okay inside eval {} : die "Couldn't link $from to $to: $!\n" unless $opts{notify}; $packlist->{$xto} = { from => $xfrom, type => 'link' }; }; if ($@) { warn "Replacing link() with File::Copy::copy(): $@"; print $opts{verbose} ? " cp $from $xto\n" : " $xto\n" unless $opts{silent}; print " creating new version of $xto\n" if $Is_VMS and -e $to and !$opts{silent}; unless ($opts{notify} or File::Copy::copy($from, $to) and ++$success) { # Might have been that F::C::c can't overwrite the target warn "Couldn't copy $from to $to: $!\n" unless -f $to and (chmod(0666, $to), unlink $to) and File::Copy::copy($from, $to) and ++$success; } $packlist->{$xto} = { type => 'file' }; } $success; } sub chmod { my($mode,$name) = @_; return if ($^O eq 'dos'); printf " chmod %o %s\n", $mode, $name if $opts{verbose}; CORE::chmod($mode,$name) || warn sprintf("Couldn't chmod %o %s: $!\n", $mode, $name) unless $opts{notify}; } sub samepath { my($p1, $p2) = @_; return (lc($p1) eq lc($p2)) if ($Is_W32 || $Is_NetWare); if ($p1 ne $p2) { my($dev1, $ino1, $dev2, $ino2); ($dev1, $ino1) = stat($p1); ($dev2, $ino2) = stat($p2); ($dev1 == $dev2 && $ino1 == $ino2); } else { 1; } } 1; perl-5.12.0-RC0/Configure0000555000175000017500000203012111337306301013770 0ustar jessejesse#! /bin/sh # # If these # comments don't work, trim them. Don't worry about any other # shell scripts, Configure will trim # comments from them for you. # # (If you are trying to port this package to a machine without sh, # I would suggest you have a look at the prototypical config_h.SH file # and edit it to reflect your system. Some packages may include samples # of config.h for certain machines, so you might look for one of those.) # # Yes, you may rip this off to use in other distribution packages. This # script belongs to the public domain and cannot be copyrighted. # # Note: this Configure script was generated automatically. Rather than # working with this copy of Configure, you may wish to get metaconfig. # The dist package (which contains metaconfig) is available via SVN: # svn co https://svn.sourceforge.net/svnroot/dist/trunk/dist # # Though this script was generated by metaconfig from metaunits, it is # OK to send patches against Configure itself. It's up to the Configure # pumpkin to backport the patch to the metaunits if it is accepted. # For more information on patching Configure, see pod/perlhack.pod # # The metaunits are also available from the public git repository: # http://perl5.git.perl.org/metaconfig.git/ or # $ git clone git://perl5.git.perl.org/metaconfig.git metaconfig # # See Porting/pumpkin.pod for more information on metaconfig. # # $Id: Head.U 6 2006-08-25 22:21:46Z rmanfredi $ # # Generated on Sat Feb 13 19:05:42 CET 2010 [metaconfig 3.5 PL0] # (with additional metaconfig patches by perlbug@perl.org) cat >c1$$ <c2$$ </dev/null` test "$me" || me=$0 ;; esac : Proper separator for the PATH environment variable p_=: : On OS/2 this directory should exist if this is not floppy only system ":-]" if test -d c:/. || ( uname -a | grep -i 'os\(/\|\)2' ) 2>&1 >/dev/null ; then if test -n "$OS2_SHELL"; then p_=\; PATH=`cmd /c "echo %PATH%" | tr '\\\\' / ` OS2_SHELL=`cmd /c "echo %OS2_SHELL%" | tr '\\\\' / | tr '[A-Z]' '[a-z]'` is_os2=yes elif test -n "$DJGPP"; then case "X${MACHTYPE:-nonesuchmach}" in *cygwin) ;; *) p_=\; ;; esac fi fi : Proper PATH setting paths='/bin /usr/bin /usr/local/bin /usr/ucb /usr/local /usr/lbin' paths="$paths /opt/bin /opt/local/bin /opt/local /opt/lbin" paths="$paths /usr/5bin /etc /usr/gnu/bin /usr/new /usr/new/bin /usr/nbin" paths="$paths /opt/gnu/bin /opt/new /opt/new/bin /opt/nbin" paths="$paths /sys5.3/bin /sys5.3/usr/bin /bsd4.3/bin /bsd4.3/usr/ucb" paths="$paths /bsd4.3/usr/bin /usr/bsd /bsd43/bin /opt/ansic/bin /usr/ccs/bin" paths="$paths /etc /usr/lib /usr/ucblib /lib /usr/ccs/lib" paths="$paths /sbin /usr/sbin /usr/libexec" paths="$paths /system/gnu_library/bin" for p in $paths do case "$p_$PATH$p_" in *$p_$p$p_*) ;; *) test -d $p && PATH=$PATH$p_$p ;; esac done PATH=.$p_$PATH export PATH : shall we be using ksh? inksh='' needksh='' avoidksh='' newsh=/bin/ksh changesh='' if (PATH=.; alias -x) >/dev/null 2>&1; then inksh=true fi if test -f /hp-ux -a -f /bin/ksh; then needksh='to avoid sh bug in "here document" expansion' fi if test -d /usr/lpp -a -f /usr/bin/bsh -a -f /usr/bin/uname; then if test X`/usr/bin/uname -v` = X4; then avoidksh="to avoid AIX 4's /bin/sh" newsh=/usr/bin/bsh fi fi if test -f /osf_boot -a -f /usr/sbin/setld; then if test X`/usr/bin/uname -s` = XOSF1; then avoidksh="to avoid Digital UNIX' ksh" newsh=/bin/sh unset BIN_SH fi fi case "$inksh/$needksh" in /[a-z]*) ENV='' changesh=true reason="$needksh" ;; esac case "$inksh/$avoidksh" in true/[a-z]*) changesh=true reason="$avoidksh" ;; esac case "$inksh/$needksh-$avoidksh-" in true/--) cat <&2 </dev/null 2>&1`; then shsharp=true spitshell=cat xcat=/bin/cat test -f $xcat$_exe || xcat=/usr/bin/cat if test ! -f $xcat$_exe; then for p in `echo $PATH | sed -e "s/$p_/ /g"` $paths; do if test -f $p/cat$_exe; then xcat=$p/cat break fi done if test ! -f $xcat$_exe; then echo "Can't find cat anywhere!" exit 1 fi fi echo "#!$xcat" >sharp $eunicefix sharp chmod +x sharp ./sharp > today 2>/dev/null if test -s today; then sharpbang='#!' else echo "#! $xcat" > sharp $eunicefix sharp chmod +x sharp ./sharp > today 2>/dev/null if test -s today; then sharpbang='#! ' else sharpbang=': use ' fi fi else echo " " echo "Your $sh doesn't grok # comments--I will strip them later on." shsharp=false cd .. echo "exec grep -v '^[ ]*#'" >spitshell chmod +x spitshell $eunicefix spitshell spitshell=`pwd`/spitshell cd UU echo "I presume that if # doesn't work, #! won't work either!" sharpbang=': use ' fi rm -f sharp today : figure out how to guarantee sh startup case "$startsh" in '') startsh=${sharpbang}${sh} ;; *) esac cat >sharp < cmdline.opt <>cmdline.opt < cmdl.opt $arg EOC arg_exp=`cat cmdl.opt` args_exp="$args_exp$args_sep'$arg_exp'" argn=`expr $argn + 1` args_sep=' ' done rm -f cmdl.opt : produce awk script to parse command line options cat >options.awk <<'EOF' BEGIN { optstr = "A:dD:eEf:hKOrsSU:V"; # getopt-style specification len = length(optstr); for (i = 1; i <= len; i++) { c = substr(optstr, i, 1); if (i < len) a = substr(optstr, i + 1, 1); else a = ""; if (a == ":") { arg[c] = 1; i++; } opt[c] = 1; } } { expect = 0; str = $0; if (substr(str, 1, 1) != "-") { printf("'%s'\n", str); next; } len = length($0); for (i = 2; i <= len; i++) { c = substr(str, i, 1); if (!opt[c]) { printf("-%s\n", substr(str, i)); next; } printf("-%s\n", c); if (arg[c]) { if (i < len) printf("'%s'\n", substr(str, i + 1)); else expect = 1; next; } } } END { if (expect) print "?"; } EOF : process the command line options set X `for arg in "$@"; do echo "X$arg"; done | sed -e s/X// | awk -f options.awk` eval "set $*" shift rm -f options.awk : set up default values fastread='' reuseval=false config_sh='' alldone='' error='' silent='' extractsh='' override='' knowitall='' rm -f optdef.sh posthint.sh cat >optdef.sh <&2 error=true fi cd UU shift;; --help|\ -h) shift; error=true;; -r) shift; reuseval=true;; -s) shift; silent=true; realsilent=true;; -E) shift; alldone=exit;; -K) shift; knowitall=true;; -O) shift; override=true;; -S) shift; silent=true; extractsh=true;; -D) shift case "$1" in *=) echo "$me: use '-U symbol=', not '-D symbol='." >&2 echo "$me: ignoring -D $1" >&2 ;; *=*) echo "$1" | \ sed -e "s/'/'\"'\"'/g" -e "s/=\(.*\)/='\1'/" >> optdef.sh;; *) echo "$1='define'" >> optdef.sh;; esac shift ;; -U) shift case "$1" in *=) echo "$1" >> optdef.sh;; *=*) echo "$me: use '-D symbol=val', not '-U symbol=val'." >&2 echo "$me: ignoring -U $1" >&2 ;; *) echo "$1='undef'" >> optdef.sh;; esac shift ;; -A) shift xxx='' yyy="$1" zzz='' uuu=undef case "$yyy" in *=*) zzz=`echo "$yyy"|sed 's!=.*!!'` case "$zzz" in *:*) zzz='' ;; *) xxx=append zzz=" "`echo "$yyy"|sed 's!^[^=]*=!!'` yyy=`echo "$yyy"|sed 's!=.*!!'` ;; esac ;; esac case "$xxx" in '') case "$yyy" in *:*) xxx=`echo "$yyy"|sed 's!:.*!!'` yyy=`echo "$yyy"|sed 's!^[^:]*:!!'` zzz=`echo "$yyy"|sed 's!^[^=]*=!!'` yyy=`echo "$yyy"|sed 's!=.*!!'` ;; *) xxx=`echo "$yyy"|sed 's!:.*!!'` yyy=`echo "$yyy"|sed 's!^[^:]*:!!'` ;; esac ;; esac case "$xxx" in append) echo "$yyy=\"\${$yyy}$zzz\"" >> posthint.sh ;; clear) echo "$yyy=''" >> posthint.sh ;; define) case "$zzz" in '') zzz=define ;; esac echo "$yyy='$zzz'" >> posthint.sh ;; eval) echo "eval \"$yyy=$zzz\"" >> posthint.sh ;; prepend) echo "$yyy=\"$zzz\${$yyy}\"" >> posthint.sh ;; undef) case "$zzz" in '') zzz="$uuu" ;; esac echo "$yyy=$zzz" >> posthint.sh ;; *) echo "$me: unknown -A command '$xxx', ignoring -A $1" >&2 ;; esac shift ;; -V) echo "$me generated by metaconfig 3.5 PL0." >&2 exit 0;; --) break;; -*) echo "$me: unknown option $1" >&2; shift; error=true;; *) break;; esac done case "$error" in true) cat >&2 <&1 case "$silent" in true) exec 1>/dev/null;; esac : run the defines and the undefines, if any, but leave the file out there... touch optdef.sh . ./optdef.sh : create the posthint manipulation script and leave the file out there... touch posthint.sh : set package name package='perl5' first=`echo $package | sed -e 's/^\(.\).*/\1/'` last=`echo $package | sed -e 's/^.\(.*\)/\1/'` case "`echo AbyZ | tr '[:lower:]' '[:upper:]' 2>/dev/null`" in ABYZ) spackage=`echo $first | tr '[:lower:]' '[:upper:]'`$last;; *) spackage=`echo $first | tr '[a-z]' '[A-Z]'`$last;; esac : Some greps do not return status, grrr. echo "grimblepritz" >grimble if grep blurfldyick grimble >/dev/null 2>&1 ; then contains=contains elif grep grimblepritz grimble >/dev/null 2>&1 ; then contains=grep else contains=contains fi rm -f grimble : the following should work in any shell case "$contains" in contains*) echo " " echo "AGH! Grep doesn't return a status. Attempting remedial action." cat >contains <<'EOSS' grep "$1" "$2" >.greptmp && cat .greptmp && test -s .greptmp EOSS chmod +x contains esac : Find the path to the source tree case "$src" in '') case "$0" in */*) src=`echo $0 | sed -e 's%/[^/][^/]*$%%'` case "$src" in /*) ;; .) ;; *) src=`cd ../$src && pwd` ;; esac ;; *) src='.';; esac;; esac case "$src" in '') src=/ rsrc=/ ;; /*) rsrc="$src";; *) rsrc="../$src";; esac if test -f $rsrc/Configure && \ $contains "^package='$package'\$" $rsrc/Configure >/dev/null 2>&1 then : found it, so we are ok. else rsrc='' for src in . .. ../.. ../../.. ../../../..; do if test -f ../$src/Configure && \ $contains "^package=$package$" ../$src/Configure >/dev/null 2>&1 then rsrc=../$src break fi done fi case "$rsrc" in '') cat <&4 Sorry, I can't seem to locate the source dir for $package. Please start Configure with an explicit path -- i.e. /some/path/Configure. EOM exit 1 ;; ../.) rsrc='..';; *) echo " " echo "Sources for $package found in \"$src\"." >&4 ;; esac : script used to extract .SH files with variable substitutions cat >extract <<'EOS' PERL_CONFIG_SH=true echo "Doing variable substitutions on .SH files..." if test -f MANIFEST; then set x `awk '{print $1}' < MANIFEST | grep '\.SH$'` else echo "(Looking for .SH files under the source directory.)" set x `(cd "$src"; find . -name "*.SH" -print)` fi shift case $# in 0) set x `(cd "$src"; echo *.SH)`; shift;; esac if test ! -f "$src/$1"; then shift fi mkdir_p=' name=$1; create=""; while test $name; do if test ! -d "$name"; then create="$name $create"; name=`echo $name | sed -e "s|^[^/]*$||"`; name=`echo $name | sed -e "s|\(.*\)/.*|\1|"`; else name=""; fi; done; for file in $create; do mkdir $file; done ' for file in $*; do case "$src" in ".") case "$file" in */*) dir=`expr X$file : 'X\(.*\)/'` file=`expr X$file : 'X.*/\(.*\)'` (cd "$dir" && . ./$file) ;; *) . ./$file ;; esac ;; *) case "$file" in */*) dir=`expr X$file : 'X\(.*\)/'` file=`expr X$file : 'X.*/\(.*\)'` (set x $dir; shift; eval $mkdir_p) sh <"$src/$dir/$file" ;; *) sh <"$src/$file" ;; esac ;; esac done if test -f "$src/config_h.SH"; then if test ! -f config.h; then : oops, they left it out of MANIFEST, probably, so do it anyway. . "$src/config_h.SH" fi fi EOS : extract files and exit if asked to do so case "$extractsh" in true) case "$realsilent" in true) ;; *) exec 1>&4;; esac case "$config_sh" in '') config_sh='config.sh';; esac echo " " echo "Fetching answers from $config_sh..." cd .. . $config_sh test "$override" && . ./optdef.sh echo " " . UU/extract rm -rf UU echo "Extraction done." exit 0 ;; esac : Eunice requires " " instead of "", can you believe it echo " " : Here we go... echo "Beginning of configuration questions for $package." trap 'echo " "; test -d ../UU && rm -rf X $rmlist; exit 1' 1 2 3 15 : first determine how to suppress newline on echo command echo " " echo "Checking echo to see how to suppress newlines..." (echo "hi there\c" ; echo " ") >.echotmp if $contains c .echotmp >/dev/null 2>&1 ; then echo "...using -n." n='-n' c='' else cat <<'EOM' ...using \c EOM n='' c='\c' fi echo $n "The star should be here-->$c" echo '*' rm -f .echotmp : Now test for existence of everything in MANIFEST echo " " if test -f "$rsrc/MANIFEST"; then echo "First let's make sure your kit is complete. Checking..." >&4 awk '$1 !~ /PACK[A-Z]+/ {print $1}' "$rsrc/MANIFEST" | \ (split -l 50 2>/dev/null || split -50) rm -f missing tmppwd=`pwd` for filelist in x??; do (cd "$rsrc"; ls `cat "$tmppwd/$filelist"` \ >/dev/null 2>>"$tmppwd/missing") done if test -s missing; then cat missing >&4 cat >&4 <<'EOM' THIS PACKAGE SEEMS TO BE INCOMPLETE. You have the option of continuing the configuration process, despite the distinct possibility that your kit is damaged, by typing 'y'es. If you do, don't blame me if something goes wrong. I advise you to type 'n'o and contact the author (perlbug@perl.org). EOM echo $n "Continue? [n] $c" >&4 read ans case "$ans" in y*) echo "Continuing..." >&4 rm -f missing ;; *) echo "ABORTING..." >&4 kill $$ ;; esac else echo "Looks good..." fi else echo "There is no MANIFEST file. I hope your kit is complete !" fi rm -f missing x?? : Find the appropriate value for a newline for tr echo " " if test -n "$DJGPP"; then trnl='\012' fi if test X"$trnl" = X; then case "`echo foo|tr '\n' x 2>/dev/null`" in foox) trnl='\n' ;; esac fi if test X"$trnl" = X; then case "`echo foo|tr '\012' x 2>/dev/null`" in foox) trnl='\012' ;; esac fi if test X"$trnl" = X; then case "`echo foo|tr '\r\n' xy 2>/dev/null`" in fooxy) trnl='\n\r' ;; esac fi if test X"$trnl" = X; then cat <&2 $me: Fatal Error: cannot figure out how to translate newlines with 'tr'. EOM exit 1 fi : compute the number of columns on the terminal for proper question formatting case "$COLUMNS" in '') COLUMNS='80';; esac : set up the echo used in my read myecho="case \"\$xxxm\" in '') echo $n \"\$rp $c\" >&4;; *) case \"\$rp\" in '') echo $n \"[\$xxxm] $c\";; *) if test \`echo \"\$rp [\$xxxm] \" | wc -c\` -ge $COLUMNS; then echo \"\$rp\" >&4 echo $n \"[\$xxxm] $c\" >&4 else echo $n \"\$rp [\$xxxm] $c\" >&4 fi ;; esac;; esac" : now set up to do reads with possible shell escape and default assignment cat <myread $startsh xxxm=\$dflt $myecho ans='!' case "\$fastread" in yes) case "\$dflt" in '') ;; *) ans=''; case "\$silent-\$rp" in true-) ;; *) echo " " >&4;; esac;; esac;; *) case "\$silent" in true) case "\$rp" in '') ans='';; esac;; esac;; esac while expr "X\$ans" : "X!" >/dev/null; do read answ set x \$xxxm shift aok=''; eval "ans=\\"\$answ\\"" && aok=y case "\$answ" in "!") sh 1>&4 echo " " $myecho ;; !*) set x \`expr "X\$ans" : "X!\(.*\)\$"\` shift sh 1>&4 -c "\$*" echo " " $myecho ;; "\$ans") case "\$ans" in \\&*) set x \`expr "X\$ans" : "X&\(.*\)\$"\` shift case "\$1" in -d) fastread=yes echo "(OK, I'll run with -d after this question.)" >&4 ;; -*) echo "*** Sorry, \$1 not supported yet." >&4 ;; esac $myecho ans=! ;; esac;; *) case "\$aok" in y) echo "*** Substitution done -- please confirm." xxxm="\$ans" ans=\`echo $n "\$ans$c" | tr '$trnl' ' '\` xxxm="\$ans" ans=! ;; *) echo "*** Error -- try again." ans=! ;; esac $myecho ;; esac case "\$ans\$xxxm\$nostick" in '') ans=! $myecho ;; esac done case "\$ans" in '') ans="\$xxxm";; esac EOSC : create .config dir to save info across Configure sessions test -d ../.config || mkdir ../.config cat >../.config/README <&4 <&4 "Okay, continuing." usedevel="$define" ;; *) echo >&4 "Okay, bye." exit 1 ;; esac ;; esac usedevel="$undef" ;; esac case "$usedevel" in $define|true|[yY]*) case "$versiononly" in '') versiononly="$define" ;; esac case "$installusrbinperl" in '') installusrbinperl="$undef" ;; esac ;; esac : general instructions needman=true firsttime=true user=`(logname) 2>/dev/null` case "$user" in '') user=`whoami 2>&1`;; esac if $contains "^$user\$" ../.config/instruct >/dev/null 2>&1; then firsttime=false echo " " rp='Would you like to see the instructions?' dflt=n . ./myread case "$ans" in [yY]*) ;; *) needman=false;; esac fi if $needman; then cat <>../.config/instruct;; esac fi : find out where common programs are echo " " echo "Locating common programs..." >&4 cat <loc $startsh case \$# in 0) exit 1;; esac thing=\$1 shift dflt=\$1 shift for dir in \$*; do case "\$thing" in .) if test -d \$dir/\$thing; then echo \$dir exit 0 fi ;; *) for thisthing in \$dir/\$thing; do : just loop through to pick last item done if test -f \$thisthing; then echo \$thisthing exit 0 elif test "X$_exe" != X -a -f \$thisthing$_exe; then echo \$thisthing exit 0 elif test -f \$dir/\$thing.exe; then if test -n "$DJGPP"; then echo \$dir/\$thing.exe elif test "$eunicefix" != ":"; then : on Eunice apparently echo \$dir/\$thing fi exit 0 fi ;; esac done echo \$dflt exit 1 EOSC chmod +x loc $eunicefix loc loclist=" awk cat chmod comm cp echo expr grep ls mkdir rm sed sort touch tr uniq " trylist=" ar bison byacc cpp csh date egrep gmake gzip less ln make more nm nroff pg test uname zip " pth=`echo $PATH | sed -e "s/$p_/ /g"` pth="$pth /lib /usr/lib" for file in $loclist; do eval xxx=\$$file case "$xxx" in /*|?:[\\/]*) if test -f "$xxx"; then : ok else echo "WARNING: no $xxx -- ignoring your setting for $file." >&4 xxx=`./loc $file $file $pth` fi ;; '') xxx=`./loc $file $file $pth`;; *) xxx=`./loc $xxx $xxx $pth`;; esac eval $file=$xxx$_exe eval _$file=$xxx case "$xxx" in /*) echo $file is in $xxx. ;; ?:[\\/]*) echo $file is in $xxx. ;; *) echo "I don't know where '$file' is, and my life depends on it." >&4 echo "Go find a public domain implementation or fix your PATH setting!" >&4 exit 1 ;; esac done echo " " echo "Don't worry if any of the following aren't found..." say=offhand for file in $trylist; do eval xxx=\$$file case "$xxx" in /*|?:[\\/]*) if test -f "$xxx"; then : ok else echo "WARNING: no $xxx -- ignoring your setting for $file." >&4 xxx=`./loc $file $file $pth` fi ;; '') xxx=`./loc $file $file $pth`;; *) xxx=`./loc $xxx $xxx $pth`;; esac eval $file=$xxx$_exe eval _$file=$xxx case "$xxx" in /*) echo $file is in $xxx. ;; ?:[\\/]*) echo $file is in $xxx. ;; *) echo "I don't see $file out there, $say." say=either ;; esac done case "$egrep" in egrep) echo "Substituting grep for egrep." egrep=$grep _egrep=$grep ;; esac case "$less" in '') ;; *) if $less -R /dev/null; then echo "Substituting less -R for less." less="$less -R" _less=$less fi ;; esac case "$ln" in ln) echo "Substituting cp for ln." ln=$cp _ln=$cp ;; esac case "$make" in make) case "$gmake" in gmake) echo "I can't find make or gmake, and my life depends on it." >&4 echo "Go find a public domain implementation or fix your PATH setting!" >&4 exit 1 ;; esac ;; esac case "$gmake" in gmake) ;; *) # We can't have osname yet. if test -f "/system/gnu_library/bin/ar.pm"; then # Stratus VOS # Assume that gmake, if found, is definitely GNU make # and prefer it over the system make. echo "Substituting gmake for make." make=$gmake _make=$gmake fi ;; esac case "$test" in test) echo "Hopefully test is built into your sh." ;; *) if `sh -c "PATH= test true" >/dev/null 2>&1`; then echo "Using the test built into your sh." test=test _test=test fi ;; esac case "$echo" in echo) echo "Hopefully echo is built into your sh." ;; '') ;; *) echo " " echo "Checking compatibility between $echo and builtin echo (if any)..." >&4 $echo $n "hi there$c" >foo1 echo $n "hi there$c" >foo2 if cmp foo1 foo2 >/dev/null 2>&1; then echo "They are compatible. In fact, they may be identical." else case "$n" in '-n') n='' c='\c';; *) n='-n' c='';; esac cat <$c" $echo "*" fi $rm -f foo1 foo2 ;; esac # This question was auctioned at YAPC::Europe-2007 in Vienna # I never promised you could answer it. I only auctioned the question. cat <trygcc $startsh EOS cat <<'EOSC' >>trygcc case "$cc" in '') ;; *) $rm -f try try.* $cat >try.c <&4 despair=yes trygcc=yes case "$cc" in *gcc*) trygcc=no ;; esac # Skip this test because it gives a false match on output like: # ./trygcc: line 23: cc: command not found # case "`$cc -v -c try.c 2>&1`" in # *gcc*) trygcc=no ;; # esac if $test X"$trygcc" = Xyes; then if gcc -o try -c try.c; then echo " " echo "You seem to have a working gcc, though." >&4 # Switching compilers may undo the work of hints files. # The most common problem is -D_REENTRANT for threads. # This heuristic catches that case, but gets false positives # if -Dusethreads was not actually specified. Better to # bail out here with a useful message than fail # mysteriously later. Should we perhaps just try to # re-invoke Configure -Dcc=gcc config_args ? if $test -f usethreads.cbu; then $cat >&4 <&2 exit 1 fi fi case "$ans" in [yY]*) cc=gcc; ccname=gcc; ccflags=''; despair=no; esac fi fi fi $rm -f try try.* ;; esac EOSC cat <checkcc $startsh EOS cat <<'EOSC' >>checkcc case "$cc" in '') ;; *) $rm -f try try.* $cat >try.c <&4 fi $cat >&4 < /dev/null 2>&1 ; then echo "Symbolic links are supported." >&4 lns="$ln -s" else echo "Symbolic links are NOT supported." >&4 lns="$ln" fi $rm -f blurfl sym : determine whether symbolic links are supported echo " " case "$lns" in *"ln"*" -s") echo "Checking how to test for symbolic links..." >&4 $lns blurfl sym if $test "X$issymlink" = X; then case "$newsh" in '') sh -c "PATH= test -h sym" >/dev/null 2>&1 ;; *) $newsh -c "PATH= test -h sym" >/dev/null 2>&1 ;; esac if test $? = 0; then issymlink="test -h" else echo "Your builtin 'test -h' may be broken." >&4 case "$test" in /*) ;; *) pth=`echo $PATH | sed -e "s/$p_/ /g"` for p in $pth do if test -f "$p/$test"; then test="$p/$test" break fi done ;; esac case "$test" in /*) echo "Trying external '$test -h'." >&4 issymlink="$test -h" if $test ! -h sym >/dev/null 2>&1; then echo "External '$test -h' is broken, too." >&4 issymlink='' fi ;; *) issymlink='' ;; esac fi fi if $test "X$issymlink" = X; then if $test -L sym 2>/dev/null; then issymlink="$test -L" echo "The builtin '$test -L' worked." >&4 fi fi if $test "X$issymlink" != X; then echo "You can test for symbolic links with '$issymlink'." >&4 else echo "I do not know how you can test for symbolic links." >&4 fi $rm -f blurfl sym ;; *) echo "No symbolic links, so not testing for their testing..." >&4 ;; esac echo " " : Make symlinks util case "$mksymlinks" in $define|true|[yY]*) case "$src" in ''|'.') echo "Cannot create symlinks in the original directory." >&4 exit 1 ;; *) case "$lns:$issymlink" in *"ln"*" -s:"*"test -"?) echo "Creating the symbolic links..." >&4 echo "(First creating the subdirectories...)" >&4 cd .. awk '{print $1}' $src/MANIFEST | grep / | sed 's:/[^/]*$::' | sort -u | while true; do read directory test -z "$directory" && break mkdir -p $directory done # Sanity check 1. if test ! -d t/base; then echo "Failed to create the subdirectories. Aborting." >&4 exit 1 fi echo "(Then creating the symlinks...)" >&4 awk '{print $1}' $src/MANIFEST | while true; do read filename test -z "$filename" && break if test -f $filename; then if $issymlink $filename; then rm -f $filename fi fi if test -f $filename; then echo "$filename already exists, not symlinking." else ln -s $src/$filename $filename fi done # Sanity check 2. if test ! -f t/base/lex.t; then echo "Failed to create the symlinks (t/base/lex.t missing). Aborting." >&4 exit 1 fi cd UU ;; *) echo "(I cannot figure out how to do symbolic links, ignoring mksymlinks)." >&4 ;; esac ;; esac ;; esac : Check for Cross-Compilation case "$usecrosscompile" in $define|true|[yY]*) $echo "Cross-compiling..." croak='' case "$cc" in *-*-gcc) # A cross-compiling gcc, probably. targetarch=`$echo $cc|$sed 's/-gcc$//'` ar=$targetarch-ar # leave out ld, choosing it is more complex nm=$targetarch-nm ranlib=$targetarch-ranlib $echo 'extern int foo;' > try.c set X `$cc -v -E try.c 2>&1 | $awk '/^#include &4 for i in $*; do j="`$echo $i|$sed 's,/include$,/lib,'`" if $test -d $j; then libpth="$libpth $j" fi done libpth="`$echo $libpth|$sed 's/^ //'`" echo "Guessing libpth '$libpth'." >&4 fi $rm -f try.c ;; esac case "$targetarch" in '') echo "Targetarch not defined." >&4; croak=y ;; *) echo "Using targetarch $targetarch." >&4 ;; esac case "$incpth" in '') echo "Incpth not defined." >&4; croak=y ;; *) echo "Using incpth '$incpth'." >&4 ;; esac case "$libpth" in '') echo "Libpth not defined." >&4; croak=y ;; *) echo "Using libpth '$libpth'." >&4 ;; esac case "$usrinc" in '') for i in $incpth; do if $test -f $i/errno.h -a -f $i/stdio.h -a -f $i/time.h; then usrinc=$i echo "Guessing usrinc $usrinc." >&4 break fi done case "$usrinc" in '') echo "Usrinc not defined." >&4; croak=y ;; esac ;; *) echo "Using usrinc $usrinc." >&4 ;; esac case "$targethost" in '') echo "Targethost not defined." >&4; croak=y ;; *) echo "Using targethost $targethost." >&4 esac locincpth=' ' loclibpth=' ' case "$croak" in y) echo "Cannot continue, aborting." >&4; exit 1 ;; esac case "$src" in /*) run=$src/Cross/run targetmkdir=$src/Cross/mkdir to=$src/Cross/to from=$src/Cross/from ;; *) pwd=`$test -f ../Configure & cd ..; pwd` run=$pwd/Cross/run targetmkdir=$pwd/Cross/mkdir to=$pwd/Cross/to from=$pwd/Cross/from ;; esac case "$targetrun" in '') targetrun=ssh ;; esac case "$targetto" in '') targetto=scp ;; esac case "$targetfrom" in '') targetfrom=scp ;; esac run=$run-$targetrun to=$to-$targetto from=$from-$targetfrom case "$targetdir" in '') targetdir=/tmp echo "Guessing targetdir $targetdir." >&4 ;; esac case "$targetuser" in '') targetuser=root echo "Guessing targetuser $targetuser." >&4 ;; esac case "$targetfrom" in scp) q=-q ;; *) q='' ;; esac case "$targetrun" in ssh|rsh) cat >$run <&4 exit 1 ;; esac case "$targetmkdir" in */Cross/mkdir) cat >$targetmkdir <&4 exit 1 ;; esac case "$targetto" in scp|rcp) cat >$to <$to <&4 exit 1 ;; esac case "$targetfrom" in scp|rcp) cat >$from <$from <&4 exit 1 ;; esac if $test ! -f $run; then echo "Target 'run' script '$run' not found." >&4 else $chmod a+rx $run fi if $test ! -f $to; then echo "Target 'to' script '$to' not found." >&4 else $chmod a+rx $to fi if $test ! -f $from; then echo "Target 'from' script '$from' not found." >&4 else $chmod a+rx $from fi if $test ! -f $run -o ! -f $to -o ! -f $from; then exit 1 fi cat >&4 </dev/null`" in ABYZ) echo "Good, your tr supports [:lower:] and [:upper:] to convert case." >&4 up='[:upper:]' low='[:lower:]' ;; *) # There is a discontinuity in EBCDIC between 'R' and 'S' # (0xd9 and 0xe2), therefore that is a nice testing point. if test "X$up" = X -o "X$low" = X; then case "`echo RS | $tr '[R-S]' '[r-s]' 2>/dev/null`" in rs) up='[A-Z]' low='[a-z]' ;; esac fi if test "X$up" = X -o "X$low" = X; then case "`echo RS | $tr R-S r-s 2>/dev/null`" in rs) up='A-Z' low='a-z' ;; esac fi if test "X$up" = X -o "X$low" = X; then case "`echo RS | od -x 2>/dev/null`" in *D9E2*|*d9e2*) echo "Hey, this might be EBCDIC." >&4 if test "X$up" = X -o "X$low" = X; then case "`echo RS | $tr '[A-IJ-RS-Z]' '[a-ij-rs-z]' 2>/dev/null`" in rs) up='[A-IJ-RS-Z]' low='[a-ij-rs-z]' ;; esac fi if test "X$up" = X -o "X$low" = X; then case "`echo RS | $tr A-IJ-RS-Z a-ij-rs-z 2>/dev/null`" in rs) up='A-IJ-RS-Z' low='a-ij-rs-z' ;; esac fi ;; esac fi esac case "`echo RS | $tr \"$up\" \"$low\" 2>/dev/null`" in rs) echo "Using $up and $low to convert case." >&4 ;; *) echo "I don't know how to translate letters from upper to lower case." >&4 echo "Your tr is not acting any way I know of." >&4 exit 1 ;; esac : set up the translation script tr, must be called with ./tr of course cat >tr </dev/null` $test -z "$myuname" && myuname=`hostname 2>/dev/null` # tr '[A-Z]' '[a-z]' would not work in EBCDIC # because the A-Z/a-z are not consecutive. myuname=`echo $myuname | $sed -e 's/^[^=]*=//' -e "s,['/],,g" | \ ./tr '[A-Z]' '[a-z]' | $tr $trnl ' '` newmyuname="$myuname" dflt=n case "$knowitall" in '') if test -f ../config.sh; then if $contains myuname= ../config.sh >/dev/null 2>&1; then eval "`grep myuname= ../config.sh`" fi if test "X$myuname" = "X$newmyuname"; then dflt=y fi fi ;; *) dflt=y;; esac : Get old answers from old config file if Configure was run on the : same system, otherwise use the hints. hint=default cd .. if test -f config.sh; then echo " " rp="I see a config.sh file. Shall I use it to set the defaults?" . UU/myread case "$ans" in n*|N*) echo "OK, I'll ignore it." mv config.sh config.sh.old myuname="$newmyuname" ;; *) echo "Fetching default answers from your old config.sh file..." >&4 tmp_n="$n" tmp_c="$c" tmp_sh="$sh" . ./config.sh cp config.sh UU n="$tmp_n" c="$tmp_c" : Older versions did not always set $sh. Catch re-use of such : an old config.sh. case "$sh" in '') sh="$tmp_sh" ;; esac hint=previous ;; esac fi . ./UU/checkcc if test ! -f config.sh; then $cat <&4 dflt='' : Half the following guesses are probably wrong... If you have better : tests or hints, please send them to perlbug@perl.org : The metaconfig authors would also appreciate a copy... $test -f /irix && osname=irix $test -f /xenix && osname=sco_xenix $test -f /dynix && osname=dynix $test -f /dnix && osname=dnix $test -f /lynx.os && osname=lynxos $test -f /unicos && osname=unicos && osvers=`$uname -r` $test -f /unicosmk && osname=unicosmk && osvers=`$uname -r` $test -f /unicosmk.ar && osname=unicosmk && osvers=`$uname -r` $test -f /bin/mips && /bin/mips && osname=mips $test -d /NextApps && set X `hostinfo | grep 'NeXT Mach.*:' | \ $sed -e 's/://' -e 's/\./_/'` && osname=next && osvers=$4 $test -d /usr/apollo/bin && osname=apollo $test -f /etc/saf/_sactab && osname=svr4 $test -d /usr/include/minix && osname=minix $test -f /system/gnu_library/bin/ar.pm && osname=vos if $test -d /MachTen -o -d /MachTen_Folder; then osname=machten if $test -x /sbin/version; then osvers=`/sbin/version | $awk '{print $2}' | $sed -e 's/[A-Za-z]$//'` elif $test -x /usr/etc/version; then osvers=`/usr/etc/version | $awk '{print $2}' | $sed -e 's/[A-Za-z]$//'` else osvers="$2.$3" fi fi $test -f /sys/posix.dll && $test -f /usr/bin/what && set X `/usr/bin/what /sys/posix.dll` && $test "$3" = UWIN && osname=uwin && osvers="$5" if $test -f $uname; then set X $myuname shift case "$5" in fps*) osname=fps ;; mips*) case "$4" in umips) osname=umips ;; *) osname=mips ;; esac;; [23]100) osname=mips ;; next*) osname=next ;; i386*) tmp=`/bin/uname -X 2>/dev/null|awk '/3\.2v[45]/{ print $(NF) }'` if $test "$tmp" != "" -a "$3" = "3.2" -a -f '/etc/systemid'; then osname='sco' osvers=$tmp elif $test -f /etc/kconfig; then osname=isc if test "$lns" = "$ln -s"; then osvers=4 elif $contains _SYSV3 /usr/include/stdio.h > /dev/null 2>&1 ; then osvers=3 elif $contains _POSIX_SOURCE /usr/include/stdio.h > /dev/null 2>&1 ; then osvers=2 fi fi tmp='' ;; pc*) if test -n "$DJGPP"; then osname=dos osvers=djgpp fi ;; esac case "$1" in aix) osname=aix tmp=`( (oslevel) 2>/dev/null || echo "not found") 2>&1` case "$tmp" in # oslevel can fail with: # oslevel: Unable to acquire lock. *not\ found) osvers="$4"."$3" ;; '<3240'|'<>3240') osvers=3.2.0 ;; '=3240'|'>3240'|'<3250'|'<>3250') osvers=3.2.4 ;; '=3250'|'>3250') osvers=3.2.5 ;; *) osvers=$tmp;; esac ;; bsd386) osname=bsd386 osvers=`$uname -r` ;; cygwin*) osname=cygwin osvers="$3" ;; *dc.osx) osname=dcosx osvers="$3" ;; dnix) osname=dnix osvers="$3" ;; domainos) osname=apollo osvers="$3" ;; dgux) osname=dgux osvers="$3" ;; dragonfly) osname=dragonfly osvers="$3" ;; dynixptx*) osname=dynixptx osvers=`echo "$4"|sed 's/^v//'` ;; freebsd) osname=freebsd osvers="$3" ;; genix) osname=genix ;; gnu) osname=gnu osvers="$3" ;; hp*) osname=hpux osvers=`echo "$3" | $sed 's,.*\.\([0-9]*\.[0-9]*\),\1,'` ;; irix*) osname=irix case "$3" in 4*) osvers=4 ;; 5*) osvers=5 ;; *) osvers="$3" ;; esac ;; linux) osname=linux case "$3" in *) osvers="$3" ;; esac ;; MiNT) osname=mint ;; netbsd*) osname=netbsd osvers="$3" ;; news-os) osvers="$3" case "$3" in 4*) osname=newsos4 ;; *) osname=newsos ;; esac ;; next*) osname=next ;; nonstop-ux) osname=nonstopux ;; openbsd) osname=openbsd osvers="$3" ;; os2) osname=os2 osvers="$4" ;; POSIX-BC | posix-bc ) osname=posix-bc osvers="$3" ;; powerux | power_ux | powermax_os | powermaxos | \ powerunix | power_unix) osname=powerux osvers="$3" ;; qnx) osname=qnx osvers="$4" ;; solaris) osname=solaris case "$3" in 5*) osvers=`echo $3 | $sed 's/^5/2/g'` ;; *) osvers="$3" ;; esac ;; sunos) osname=sunos case "$3" in 5*) osname=solaris osvers=`echo $3 | $sed 's/^5/2/g'` ;; *) osvers="$3" ;; esac ;; titanos) osname=titanos case "$3" in 1*) osvers=1 ;; 2*) osvers=2 ;; 3*) osvers=3 ;; 4*) osvers=4 ;; *) osvers="$3" ;; esac ;; ultrix) osname=ultrix osvers="$3" ;; osf1|mls+) case "$5" in alpha) osname=dec_osf osvers=`sizer -v | awk -FUNIX '{print $2}' | awk '{print $1}' | tr '[A-Z]' '[a-z]' | sed 's/^[xvt]//'` case "$osvers" in [1-9].[0-9]*) ;; *) osvers=`echo "$3" | sed 's/^[xvt]//'` ;; esac ;; hp*) osname=hp_osf1 ;; mips) osname=mips_osf1 ;; esac ;; # UnixWare 7.1.2 is known as Open UNIX 8 openunix|unixware) osname=svr5 osvers="$4" ;; uts) osname=uts osvers="$3" ;; vos) osvers="$3" ;; $2) case "$osname" in *isc*) ;; *freebsd*) ;; svr*) : svr4.x or possibly later case "svr$3" in ${osname}*) osname=svr$3 osvers=$4 ;; esac case "$osname" in svr4.0) : Check for ESIX if test -f /stand/boot ; then eval `grep '^INITPROG=[a-z/0-9]*$' /stand/boot` if test -n "$INITPROG" -a -f "$INITPROG"; then isesix=`strings -a $INITPROG|grep 'ESIX SYSTEM V/386 Release 4.0'` if test -n "$isesix"; then osname=esix4 fi fi fi ;; esac ;; *) if test -f /etc/systemid; then osname=sco set `echo $3 | $sed 's/\./ /g'` $4 if $test -f $src/hints/sco_$1_$2_$3.sh; then osvers=$1.$2.$3 elif $test -f $src/hints/sco_$1_$2.sh; then osvers=$1.$2 elif $test -f $src/hints/sco_$1.sh; then osvers=$1 fi else case "$osname" in '') : Still unknown. Probably a generic Sys V. osname="sysv" osvers="$3" ;; esac fi ;; esac ;; *) case "$osname" in '') : Still unknown. Probably a generic BSD. osname="$1" osvers="$3" ;; esac ;; esac else if test -f /vmunix -a -f $src/hints/news_os.sh; then (what /vmunix | UU/tr '[A-Z]' '[a-z]') > UU/kernel.what 2>&1 if $contains news-os UU/kernel.what >/dev/null 2>&1; then osname=news_os fi $rm -f UU/kernel.what elif test -d c:/. -o -n "$is_os2" ; then set X $myuname osname=os2 osvers="$5" fi fi case "$targetarch" in '') ;; *) hostarch=$osname osname=`echo $targetarch|sed 's,^[^-]*-,,'` osvers='' ;; esac : Now look for a hint file osname_osvers, unless one has been : specified already. case "$hintfile" in ''|' ') file=`echo "${osname}_${osvers}" | $sed -e 's%\.%_%g' -e 's%_$%%'` : Also try without trailing minor version numbers. xfile=`echo $file | $sed -e 's%_[^_]*$%%'` xxfile=`echo $xfile | $sed -e 's%_[^_]*$%%'` xxxfile=`echo $xxfile | $sed -e 's%_[^_]*$%%'` xxxxfile=`echo $xxxfile | $sed -e 's%_[^_]*$%%'` case "$file" in '') dflt=none ;; *) case "$osvers" in '') dflt=$file ;; *) if $test -f $src/hints/$file.sh ; then dflt=$file elif $test -f $src/hints/$xfile.sh ; then dflt=$xfile elif $test -f $src/hints/$xxfile.sh ; then dflt=$xxfile elif $test -f $src/hints/$xxxfile.sh ; then dflt=$xxxfile elif $test -f $src/hints/$xxxxfile.sh ; then dflt=$xxxxfile elif $test -f "$src/hints/${osname}.sh" ; then dflt="${osname}" else dflt=none fi ;; esac ;; esac if $test -f Policy.sh ; then case "$dflt" in *Policy*) ;; none) dflt="Policy" ;; *) dflt="Policy $dflt" ;; esac fi ;; *) dflt=`echo $hintfile | $sed 's/\.sh$//'` ;; esac if $test -f Policy.sh ; then $cat <> UU/config.sh elif $test -f $src/hints/$file.sh; then . $src/hints/$file.sh $cat $src/hints/$file.sh >> UU/config.sh elif $test X"$tans" = X -o X"$tans" = Xnone ; then : nothing else : Give one chance to correct a possible typo. echo "$file.sh does not exist" dflt=$file rp="hint to use instead?" . UU/myread for file in $ans; do if $test -f "$src/hints/$file.sh"; then . $src/hints/$file.sh $cat $src/hints/$file.sh >> UU/config.sh elif $test X$ans = X -o X$ans = Xnone ; then : nothing else echo "$file.sh does not exist -- ignored." fi done fi done hint=recommended : Remember our hint file for later. if $test -f "$src/hints/$file.sh" ; then hintfile="$file" else hintfile='' fi fi cd UU ;; *) echo " " echo "Fetching default answers from $config_sh..." >&4 tmp_n="$n" tmp_c="$c" cd .. cp $config_sh config.sh 2>/dev/null chmod +w config.sh . ./config.sh cd UU cp ../config.sh . n="$tmp_n" c="$tmp_c" hint=previous ;; esac test "$override" && . ./optdef.sh : Restore computed paths for file in $loclist $trylist; do eval $file="\$_$file" done cat << EOM Configure uses the operating system name and version to set some defaults. The default value is probably right if the name rings a bell. Otherwise, since spelling matters for me, either accept the default or answer "none" to leave it blank. EOM case "$osname" in ''|' ') case "$hintfile" in ''|' '|none) dflt=none ;; *) dflt=`echo $hintfile | $sed -e 's/\.sh$//' -e 's/_.*$//'` ;; esac ;; *) dflt="$osname" ;; esac rp="Operating system name?" . ./myread case "$ans" in none) osname='' ;; *) osname=`echo "$ans" | $sed -e 's/[ ][ ]*/_/g' | ./tr '[A-Z]' '[a-z]'`;; esac echo " " case "$osvers" in ''|' ') case "$hintfile" in ''|' '|none) dflt=none ;; *) dflt=`echo $hintfile | $sed -e 's/\.sh$//' -e 's/^[^_]*//'` dflt=`echo $dflt | $sed -e 's/^_//' -e 's/_/./g'` case "$dflt" in ''|' ') dflt=none ;; esac ;; esac ;; *) dflt="$osvers" ;; esac rp="Operating system version?" . ./myread case "$ans" in none) osvers='' ;; *) osvers="$ans" ;; esac . ./posthint.sh : who configured the system cf_time=`LC_ALL=C; LANGUAGE=C; export LC_ALL; export LANGUAGE; $date 2>&1` case "$cf_by" in "") cf_by=`(logname) 2>/dev/null` case "$cf_by" in "") cf_by=`(whoami) 2>/dev/null` case "$cf_by" in "") cf_by=unknown ;; esac ;; esac ;; esac : decide how portable to be. Allow command line overrides. case "$d_portable" in "$undef") ;; *) d_portable="$define" ;; esac : set up shell script to do ~ expansion cat >filexp <&2 exit 1 fi case "\$1" in */*) echo \$dir/\`$expr x\$1 : '..[^/]*/\(.*\)'\` ;; *) echo \$dir ;; esac fi ;; *) echo \$1 ;; esac EOSS chmod +x filexp $eunicefix filexp : now set up to get a file name cat <getfile $startsh EOS cat <<'EOSC' >>getfile tilde='' fullpath='' already='' skip='' none_ok='' exp_file='' nopath_ok='' orig_rp="$rp" orig_dflt="$dflt" case "$gfpth" in '') gfpth='.' ;; esac case "$fn" in *\(*) : getfile will accept an answer from the comma-separated list : enclosed in parentheses even if it does not meet other criteria. expr "$fn" : '.*(\(.*\)).*' | $tr ',' $trnl >getfile.ok fn=`echo $fn | sed 's/(.*)//'` ;; esac case "$fn" in *:*) loc_file=`expr $fn : '.*:\(.*\)'` fn=`expr $fn : '\(.*\):.*'` ;; esac case "$fn" in *~*) tilde=true;; esac case "$fn" in */*) fullpath=true;; esac case "$fn" in *+*) skip=true;; esac case "$fn" in *n*) none_ok=true;; esac case "$fn" in *e*) exp_file=true;; esac case "$fn" in *p*) nopath_ok=true;; esac case "$fn" in *f*) type='File';; *d*) type='Directory';; *l*) type='Locate';; esac what="$type" case "$what" in Locate) what='File';; esac case "$exp_file" in '') case "$d_portable" in "$define") ;; *) exp_file=true;; esac ;; esac cd .. while test "$type"; do redo='' rp="$orig_rp" dflt="$orig_dflt" case "$tilde" in true) rp="$rp (~name ok)";; esac . UU/myread if test -f UU/getfile.ok && \ $contains "^$ans\$" UU/getfile.ok >/dev/null 2>&1 then value="$ans" ansexp="$ans" break fi case "$ans" in none) value='' ansexp='' case "$none_ok" in true) type='';; esac ;; *) case "$tilde" in '') value="$ans" ansexp="$ans";; *) value=`UU/filexp $ans` case $? in 0) if test "$ans" != "$value"; then echo "(That expands to $value on this system.)" fi ;; *) value="$ans";; esac ansexp="$value" case "$exp_file" in '') value="$ans";; esac ;; esac case "$fullpath" in true) case "$ansexp" in /*) value="$ansexp" ;; [a-zA-Z]:/*) value="$ansexp" ;; *) redo=true case "$already" in true) echo "I shall only accept a full path name, as in /bin/ls." >&4 echo "Use a ! shell escape if you wish to check pathnames." >&4 ;; *) echo "Please give a full path name, starting with slash." >&4 case "$tilde" in true) echo "Note that using ~name is ok provided it expands well." >&4 already=true ;; esac esac ;; esac ;; esac case "$redo" in '') case "$type" in File) for fp in $gfpth; do if test "X$fp" = X.; then pf="$ansexp" else pf="$fp/$ansexp" fi if test -f "$pf"; then type='' elif test -r "$pf" || (test -h "$pf") >/dev/null 2>&1 then echo "($value is not a plain file, but that's ok.)" type='' fi if test X"$type" = X; then value="$pf" break fi done ;; Directory) for fp in $gfpth; do if test "X$fp" = X.; then dir="$ans" direxp="$ansexp" else dir="$fp/$ansexp" direxp="$fp/$ansexp" fi if test -d "$direxp"; then type='' value="$dir" break fi done ;; Locate) if test -d "$ansexp"; then echo "(Looking for $loc_file in directory $value.)" value="$value/$loc_file" ansexp="$ansexp/$loc_file" fi if test -f "$ansexp"; then type='' fi case "$nopath_ok" in true) case "$value" in */*) ;; *) echo "Assuming $value will be in people's path." type='' ;; esac ;; esac ;; esac case "$skip" in true) type=''; esac case "$type" in '') ;; *) if test "$fastread" = yes; then dflt=y else dflt=n fi rp="$what $value doesn't exist. Use that name anyway?" . UU/myread dflt='' case "$ans" in y*) type='';; *) echo " ";; esac ;; esac ;; esac ;; esac done cd UU ans="$value" rp="$orig_rp" dflt="$orig_dflt" rm -f getfile.ok test "X$gfpthkeep" != Xy && gfpth="" EOSC : determine root of directory hierarchy where package will be installed. case "$prefix" in '') dflt=`./loc . /usr/local /usr/local /local /opt /usr` ;; *?/) dflt=`echo "$prefix" | sed 's/.$//'` ;; *) dflt="$prefix" ;; esac $cat <&4 else echo "AFS does not seem to be running..." >&4 fi : determine installation prefix for where package is to be installed. if $afs; then $cat <installprefix $startsh EOS cat <<'EOSC' >>installprefix : Change installation prefix, if necessary. if $test X"$prefix" != X"$installprefix"; then eval "install${prefixvar}=\`echo \$${prefixvar}exp | sed \"s#^\$prefixexp#\$installprefixexp#\"\`" else eval "install${prefixvar}=\"\$${prefixvar}exp\"" fi EOSC chmod +x installprefix $eunicefix installprefix : Set variables such as privlib and privlibexp from the output of ./getfile : performing the prefixexp/installprefixexp correction if necessary. cat <setprefixvar $startsh EOS cat <<'EOSC' >>setprefixvar eval "${prefixvar}=\"\$ans\"" eval "${prefixvar}exp=\"\$ansexp\"" . ./installprefix EOSC chmod +x setprefixvar $eunicefix setprefixvar : set up the script used to warn in case of inconsistency cat <whoa $startsh EOS cat <<'EOSC' >>whoa dflt=y case "$hint" in recommended) case "$hintfile" in '') echo "The $hint value for \$$var on this machine was \"$was\"!" >&4 ;; *) echo "Hmm. Based on the hints in hints/$hintfile.sh, " >&4 echo "the $hint value for \$$var on this machine was \"$was\"!" >&4 ;; esac ;; *) echo " " echo "*** WHOA THERE!!! ***" >&4 echo " The $hint value for \$$var on this machine was \"$was\"!" >&4 ;; esac rp=" Keep the $hint value?" . ./myread case "$ans" in y) td=$was; tu=$was;; esac EOSC : function used to set '$1' to '$val' setvar='var=$1; eval "was=\$$1"; td=$define; tu=$undef; case "$val$was" in $define$undef) . ./whoa; eval "$var=\$td";; $undef$define) . ./whoa; eval "$var=\$tu";; *) eval "$var=$val";; esac' : Check is we will use socks case "$usesocks" in $define|true|[yY]*) dflt='y';; *) dflt='n';; esac cat <. Versions 5.003_02 and later of $package allow alternate IO mechanisms via the PerlIO abstraction layer, but the stdio mechanism is still available if needed. The abstraction layer can use AT&T's sfio (if you already have sfio installed) or regular stdio. Using PerlIO with sfio may cause problems with some extension modules. If this doesn't make any sense to you, just accept the default '$dflt'. EOM rp='Use the PerlIO abstraction layer?' . ./myread case "$ans" in y|Y) val="$define" ;; *) echo "Ok, doing things the stdio way." val="$undef" ;; esac set useperlio eval $setvar case "$usesocks" in $define|true|[yY]*) case "$useperlio" in $define|true|[yY]*) ;; *) cat >&4 <&4 if $test -r $rsrc/patchlevel.h;then revision=`awk '/define[ ]+PERL_REVISION/ {print $3}' $rsrc/patchlevel.h` patchlevel=`awk '/define[ ]+PERL_VERSION/ {print $3}' $rsrc/patchlevel.h` subversion=`awk '/define[ ]+PERL_SUBVERSION/ {print $3}' $rsrc/patchlevel.h` api_revision=`awk '/define[ ]+PERL_API_REVISION/ {print $3}' $rsrc/patchlevel.h` api_version=`awk '/define[ ]+PERL_API_VERSION/ {print $3}' $rsrc/patchlevel.h` api_subversion=`awk '/define[ ]+PERL_API_SUBVERSION/ {print $3}' $rsrc/patchlevel.h` perl_patchlevel=`egrep ',"(MAINT|SMOKE)[0-9][0-9]*"' $rsrc/patchlevel.h|tail -1|sed 's/[^0-9]//g'` else revision=0 patchlevel=0 subversion=0 api_revision=0 api_version=0 api_subversion=0 perl_patchlevel=0 $echo "(You do not have patchlevel.h. Eek.)" fi if $test -r $rsrc/.patch ; then if $test "X$perl_patchlevel" = "X" || $test "`cat $rsrc/.patch`" -gt "$perl_patchlevel" ; then perl_patchlevel=`cat $rsrc/.patch` fi fi : Define a handy string here to avoid duplication in myconfig.SH and configpm. version_patchlevel_string="version $patchlevel subversion $subversion" case "$perl_patchlevel" in 0|'') ;; *) perl_patchlevel=`echo $perl_patchlevel | sed 's/.* //'` version_patchlevel_string="$version_patchlevel_string patch $perl_patchlevel" ;; esac $echo "(You have $package $version_patchlevel_string.)" case "$osname" in dos|vms) : XXX Should be a Configure test for double-dots in filenames. version=`echo $revision $patchlevel $subversion | \ $awk '{ printf "%d_%d_%d\n", $1, $2, $3 }'` api_versionstring=`echo $api_revision $api_version $api_subversion | \ $awk '{ printf "%d_%d_%d\n", $1, $2, $3 }'` ;; *) version=`echo $revision $patchlevel $subversion | \ $awk '{ printf "%d.%d.%d\n", $1, $2, $3 }'` api_versionstring=`echo $api_revision $api_version $api_subversion | \ $awk '{ printf "%d.%d.%d\n", $1, $2, $3 }'` ;; esac : Special case the 5.005_xx maintenance series, which used 5.005 : without any subversion label as a subdirectory in $sitelib if test "${api_revision}${api_version}${api_subversion}" = "550"; then api_versionstring='5.005' fi : Do we want threads support and if so, what type case "$usethreads" in $define|true|[yY]*) dflt='y';; *) # Catch case where user specified ithreads or 5005threads but # forgot -Dusethreads (A.D. 4/2002) case "$useithreads$use5005threads" in *$define*) case "$useperlio" in "$define") dflt='y' ;; *) dflt='n' ;; esac ;; *) dflt='n';; esac ;; esac cat <&4 <&4 <&4 <bsd echo exit 1 >usg echo exit 1 >v7 echo exit 1 >osf1 echo exit 1 >eunice echo exit 1 >xenix echo exit 1 >venix echo exit 1 >os2 d_bsd="$undef" $cat /usr/include/signal.h /usr/include/sys/signal.h >foo 2>/dev/null if test -f /osf_boot || $contains 'OSF/1' /usr/include/ctype.h >/dev/null 2>&1 then echo "Looks kind of like an OSF/1 system, but we'll see..." echo exit 0 >osf1 elif test `echo abc | $tr a-z A-Z` = Abc ; then xxx=`./loc addbib blurfl $pth` if $test -f $xxx; then echo "Looks kind of like a USG system with BSD features, but we'll see..." echo exit 0 >bsd echo exit 0 >usg else if $contains SIGTSTP foo >/dev/null 2>&1 ; then echo "Looks kind of like an extended USG system, but we'll see..." else echo "Looks kind of like a USG system, but we'll see..." fi echo exit 0 >usg fi elif $contains SIGTSTP foo >/dev/null 2>&1 ; then echo "Looks kind of like a BSD system, but we'll see..." d_bsd="$define" echo exit 0 >bsd else echo "Looks kind of like a Version 7 system, but we'll see..." echo exit 0 >v7 fi case "$eunicefix" in *unixtovms*) $cat <<'EOI' There is, however, a strange, musty smell in the air that reminds me of something...hmm...yes...I've got it...there's a VMS nearby, or I'm a Blit. EOI echo exit 0 >eunice d_eunice="$define" : it so happens the Eunice I know will not run shell scripts in Unix format ;; *) echo " " echo "Congratulations. You aren't running Eunice." d_eunice="$undef" ;; esac : Detect OS2. The p_ variable is set above in the Head.U unit. : Note that this also -- wrongly -- detects e.g. dos-djgpp, which also uses : semicolon as a patch separator case "$p_" in :) ;; *) $cat <<'EOI' I have the feeling something is not exactly right, however...don't tell me... lemme think...does HAL ring a bell?...no, of course, you're only running OS/2! (Or you may be running DOS with DJGPP.) EOI echo exit 0 >os2 ;; esac if test -f /xenix; then echo "Actually, this looks more like a XENIX system..." echo exit 0 >xenix d_xenix="$define" else echo " " echo "It's not Xenix..." d_xenix="$undef" fi chmod +x xenix $eunicefix xenix if test -f /venix; then echo "Actually, this looks more like a VENIX system..." echo exit 0 >venix else echo " " if ./xenix; then : null else echo "Nor is it Venix..." fi fi chmod +x bsd usg v7 osf1 eunice xenix venix os2 $eunicefix bsd usg v7 osf1 eunice xenix venix os2 $rm -f foo : Check if we are using GNU gcc and what its version is echo " " echo "Checking for GNU cc in disguise and/or its version number..." >&4 $cat >try.c < int main() { #if defined(__GNUC__) && !defined(__INTEL_COMPILER) #ifdef __VERSION__ printf("%s\n", __VERSION__); #else printf("%s\n", "1"); #endif #endif return(0); } EOM if $cc -o try $ccflags $ldflags try.c; then gccversion=`$run ./try` case "$gccversion" in '') echo "You are not using GNU cc." ;; *) echo "You are using GNU cc $gccversion." ccname=gcc ;; esac else echo " " echo "*** WHOA THERE!!! ***" >&4 echo " Your C compiler \"$cc\" doesn't seem to be working!" >&4 case "$knowitall" in '') echo " You'd better start hunting for one and let me know about it." >&4 exit 1 ;; esac fi $rm -f try try.* case "$gccversion" in 1*) cpp=`./loc gcc-cpp $cpp $pth` ;; esac case "$gccversion" in '') gccosandvers='' ;; *) gccshortvers=`echo "$gccversion"|sed 's/ .*//'` gccosandvers=`$cc -v 2>&1|grep '/specs$'|sed "s!.*/[^-/]*-[^-/]*-\([^-/]*\)/$gccshortvers/specs!\1!"` gccshortvers='' case "$gccosandvers" in $osname) gccosandvers='' ;; # linux gccs seem to have no linux osvers, grr $osname$osvers) ;; # looking good $osname*) cat <&4 *** WHOA THERE!!! *** Your gcc has not been compiled for the exact release of your operating system ($gccosandvers versus $osname$osvers). In general it is a good idea to keep gcc synchronized with the operating system because otherwise serious problems may ensue when trying to compile software, like Perl. I'm trying to be optimistic here, though, and will continue. If later during the configuration and build icky compilation problems appear (headerfile conflicts being the most common manifestation), I suggest reinstalling the gcc to match your operating system release. EOM ;; *) gccosandvers='' ;; # failed to parse, better be silent esac ;; esac case "$ccname" in '') ccname="$cc" ;; esac # gcc 3.* complain about adding -Idirectories that they already know about, # so we will take those off from locincpth. case "$gccversion" in 3*) echo "main(){}">try.c for incdir in $locincpth; do warn=`$cc $ccflags -I$incdir -c try.c 2>&1 | \ grep '^c[cp]p*[01]: warning: changing search order '` if test "X$warn" != X; then locincpth=`echo " $locincpth " | sed "s! $incdir ! !"` fi done $rm -f try try.* esac : What should the include directory be ? echo " " $echo $n "Hmm... $c" dflt='/usr/include' incpath='' mips_type='' if $test -f /bin/mips && /bin/mips; then echo "Looks like a MIPS system..." $cat >usr.c <<'EOCP' #ifdef SYSTYPE_BSD43 /bsd43 #endif EOCP if cc -E usr.c > usr.out && $contains / usr.out >/dev/null 2>&1; then dflt='/bsd43/usr/include' incpath='/bsd43' mips_type='BSD 4.3' else mips_type='System V' fi $rm -f usr.c usr.out echo "and you're compiling with the $mips_type compiler and libraries." xxx_prompt=y echo "exit 0" >mips else echo "Doesn't look like a MIPS system." xxx_prompt=n echo "exit 1" >mips fi chmod +x mips $eunicefix mips case "$usrinc" in '') ;; *) dflt="$usrinc";; esac case "$xxx_prompt" in y) fn=d/ echo " " rp='Where are the include files you want to use?' . ./getfile usrinc="$ans" ;; *) usrinc="$dflt" ;; esac : see how we invoke the C preprocessor echo " " echo "Now, how can we feed standard input to your C preprocessor..." >&4 cat <<'EOT' >testcpp.c #define ABC abc #define XYZ xyz ABC.XYZ EOT cd .. if test ! -f cppstdin; then if test "X$osname" = "Xaix" -a "X$gccversion" = X; then # AIX cc -E doesn't show the absolute headerfile # locations but we'll cheat by using the -M flag. echo 'cat >.$$.c; rm -f .$$.u; '"$cc"' ${1+"$@"} -M -c .$$.c 2>/dev/null; test -s .$$.u && awk '"'"'$2 ~ /\.h$/ { print "# 0 \""$2"\"" }'"'"' .$$.u; rm -f .$$.o .$$.u; '"$cc"' -E ${1+"$@"} .$$.c; rm .$$.c' > cppstdin else echo 'cat >.$$.c; '"$cc"' -E ${1+"$@"} .$$.c; rm .$$.c' >cppstdin fi else echo "Keeping your $hint cppstdin wrapper." fi chmod 755 cppstdin wrapper=`pwd`/cppstdin ok='false' cd UU if $test "X$cppstdin" != "X" && \ $cppstdin $cppminus testcpp.out 2>&1 && \ $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 then echo "You used to use $cppstdin $cppminus so we'll use that again." case "$cpprun" in '') echo "But let's see if we can live without a wrapper..." ;; *) if $cpprun $cpplast testcpp.out 2>&1 && \ $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 then echo "(And we'll use $cpprun $cpplast to preprocess directly.)" ok='true' else echo "(However, $cpprun $cpplast does not work, let's see...)" fi ;; esac else case "$cppstdin" in '') ;; *) echo "Good old $cppstdin $cppminus does not seem to be of any help..." ;; esac fi if $ok; then : nothing elif echo 'Maybe "'"$cc"' -E" will work...'; \ $cc -E testcpp.out 2>&1; \ $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then echo "Yup, it does." x_cpp="$cc -E" x_minus=''; elif echo 'Nope...maybe "'"$cc"' -E -" will work...'; \ $cc -E - testcpp.out 2>&1; \ $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then echo "Yup, it does." x_cpp="$cc -E" x_minus='-'; elif echo 'Nope...maybe "'"$cc"' -P" will work...'; \ $cc -P testcpp.out 2>&1; \ $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then echo "Yipee, that works!" x_cpp="$cc -P" x_minus=''; elif echo 'Nope...maybe "'"$cc"' -P -" will work...'; \ $cc -P - testcpp.out 2>&1; \ $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then echo "At long last!" x_cpp="$cc -P" x_minus='-'; elif echo 'No such luck, maybe "'$cpp'" will work...'; \ $cpp testcpp.out 2>&1; \ $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then echo "It works!" x_cpp="$cpp" x_minus=''; elif echo 'Nixed again...maybe "'$cpp' -" will work...'; \ $cpp - testcpp.out 2>&1; \ $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then echo "Hooray, it works! I was beginning to wonder." x_cpp="$cpp" x_minus='-'; elif echo 'Uh-uh. Time to get fancy. Trying a wrapper...'; \ $wrapper testcpp.out 2>&1; \ $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then x_cpp="$wrapper" x_minus='' echo "Eureka!" else dflt='' rp="No dice. I can't find a C preprocessor. Name one:" . ./myread x_cpp="$ans" x_minus='' $x_cpp testcpp.out 2>&1 if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then echo "OK, that will do." >&4 else echo "Sorry, I can't get that to work. Go find one and rerun Configure." >&4 exit 1 fi fi case "$ok" in false) cppstdin="$x_cpp" cppminus="$x_minus" cpprun="$x_cpp" cpplast="$x_minus" set X $x_cpp shift case "$1" in "$cpp") echo "Perhaps can we force $cc -E using a wrapper..." if $wrapper testcpp.out 2>&1; \ $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 then echo "Yup, we can." cppstdin="$wrapper" cppminus=''; else echo "Nope, we'll have to live without it..." fi ;; esac case "$cpprun" in "$wrapper") cpprun='' cpplast='' ;; esac ;; esac case "$cppstdin" in "$wrapper"|'cppstdin') ;; *) $rm -f $wrapper;; esac $rm -f testcpp.c testcpp.out : Set private lib path case "$plibpth" in '') if ./mips; then plibpth="$incpath/usr/lib /usr/local/lib /usr/ccs/lib" fi;; esac case "$libpth" in ' ') dlist='';; '') dlist="$loclibpth $plibpth $glibpth";; *) dlist="$libpth";; esac : Now check and see which directories actually exist, avoiding duplicates libpth='' for xxx in $dlist do if $test -d $xxx; then case " $libpth " in *" $xxx "*) ;; *) libpth="$libpth $xxx";; esac fi done $cat <<'EOM' Some systems have incompatible or broken versions of libraries. Among the directories listed in the question below, please remove any you know not to be holding relevant libraries, and add any that are needed. Say "none" for none. EOM case "$libpth" in '') dflt='none';; *) set X $libpth shift dflt=${1+"$@"} ;; esac rp="Directories to use for library searches?" . ./myread case "$ans" in none) libpth=' ';; *) libpth="$ans";; esac : compute shared library extension case "$so" in '') if xxx=`./loc libc.sl X $libpth`; $test -f "$xxx"; then dflt='sl' else dflt='so' fi ;; *) dflt="$so";; esac $cat <&4 case "$libs" in ' '|'') dflt='';; *) dflt="$libs";; esac case "$libswanted" in '') libswanted='c_s';; esac case "$usesocks" in "$define") libswanted="$libswanted socks5 socks5_sh" ;; esac libsfound='' libsfiles='' libsdirs='' libspath='' for thisdir in $libpth $xlibpth; do test -d $thisdir && libspath="$libspath $thisdir" done for thislib in $libswanted; do for thisdir in $libspath; do xxx='' if $test ! -f "$xxx" -a "X$ignore_versioned_solibs" = "X"; then xxx=`ls $thisdir/lib$thislib.$so.[0-9] 2>/dev/null|sed -n '$p'` $test -f "$xxx" && eval $libscheck $test -f "$xxx" && libstyle=shared fi if test ! -f "$xxx"; then xxx=$thisdir/lib$thislib.$so $test -f "$xxx" && eval $libscheck $test -f "$xxx" && libstyle=shared fi if test ! -f "$xxx"; then xxx=$thisdir/lib$thislib$_a $test -f "$xxx" && eval $libscheck $test -f "$xxx" && libstyle=static fi if test ! -f "$xxx"; then xxx=$thisdir/$thislib$_a $test -f "$xxx" && eval $libscheck $test -f "$xxx" && libstyle=static fi if test ! -f "$xxx"; then xxx=$thisdir/lib${thislib}_s$_a $test -f "$xxx" && eval $libscheck $test -f "$xxx" && libstyle=static $test -f "$xxx" && thislib=${thislib}_s fi if test ! -f "$xxx"; then xxx=$thisdir/Slib$thislib$_a $test -f "$xxx" && eval $libscheck $test -f "$xxx" && libstyle=static fi if $test -f "$xxx"; then case "$libstyle" in shared) echo "Found -l$thislib (shared)." ;; static) echo "Found -l$thislib." ;; *) echo "Found -l$thislib ($libstyle)." ;; esac case " $dflt " in *"-l$thislib "*);; *) dflt="$dflt -l$thislib" libsfound="$libsfound $xxx" yyy=`basename $xxx` libsfiles="$libsfiles $yyy" yyy=`echo $xxx|$sed -e "s%/$yyy\\$%%"` case " $libsdirs " in *" $yyy "*) ;; *) libsdirs="$libsdirs $yyy" ;; esac ;; esac break fi done if $test ! -f "$xxx"; then echo "No -l$thislib." fi done set X $dflt shift dflt="$*" case "$libs" in '') dflt="$dflt";; *) dflt="$libs";; esac case "$dflt" in ' '|'') dflt='none';; esac $cat </dev/null 2>&1 then # Interactive Systems (ISC) POSIX mode. dflt="$dflt -posix" fi ;; esac case "$gccversion" in 1*) ;; 2.[0-8]*) ;; ?*) set strict-aliasing -fno-strict-aliasing eval $checkccflag ;; esac # For gcc, adding -pipe speeds up compilations for some, but apparently # some assemblers can't read from stdin. (It also slows down compilations # in other cases, but those are apparently rarer these days.) AD 5/2004. case "$gccversion" in ?*) set pipe -pipe eval $checkccflag ;; esac # on x86_64 (at least) we require an extra library (libssp) in the # link command line. This library is not named, so I infer that it is # an implementation detail that may change. Hence the safest approach # is to add the flag to the flags passed to the compiler at link time, # as that way the compiler can do the right implementation dependant # thing. (NWC) case "$gccversion" in ?*) set stack-protector -fstack-protector eval $checkccflag ;; esac ;; esac case "$mips_type" in *BSD*|'') inclwanted="$locincpth $usrinc";; *) inclwanted="$locincpth $inclwanted $usrinc/bsd";; esac for thisincl in $inclwanted; do if $test -d $thisincl; then if $test x$thisincl != x$usrinc; then case "$dflt" in *" -I$thisincl "*);; *) dflt="$dflt -I$thisincl ";; esac fi fi done inctest='if $contains $2 $usrinc/$1 >/dev/null 2>&1; then xxx=true; elif $contains $2 $usrinc/sys/$1 >/dev/null 2>&1; then xxx=true; else xxx=false; fi; if $xxx; then case "$dflt" in *$2*);; *) dflt="$dflt -D$2";; esac; fi' set signal.h LANGUAGE_C; eval $inctest case "$usesocks" in $define) ccflags="$ccflags -DSOCKS" ;; esac case "$hint" in default|recommended) dflt="$ccflags $dflt" ;; *) dflt="$ccflags";; esac case "$dflt" in ''|' ') dflt=none;; esac $cat <&4 set X $cppflags shift cppflags='' $cat >cpp.c <<'EOM' #define BLURFL foo BLURFL xx LFRULB EOM previous='' for flag in $* do case "$flag" in -*) ftry="$flag";; *) ftry="$previous $flag";; esac if $cppstdin -DLFRULB=bar $cppflags $ftry $cppminus cpp1.out 2>/dev/null && \ $cpprun -DLFRULB=bar $cppflags $ftry $cpplast cpp2.out 2>/dev/null && \ $contains 'foo.*xx.*bar' cpp1.out >/dev/null 2>&1 && \ $contains 'foo.*xx.*bar' cpp2.out >/dev/null 2>&1 then cppflags="$cppflags $ftry" previous='' else previous="$flag" fi done set X $cppflags shift cppflags=${1+"$@"} case "$cppflags" in *-*) echo "They appear to be: $cppflags";; esac $rm -f cpp.c cpp?.out ;; esac : flags used in final linking phase case "$ldflags" in '') if ./venix; then dflt='-i -z' else dflt='' fi case "$ccflags" in *-posix*) dflt="$dflt -posix" ;; esac ;; *) dflt="$ldflags";; esac # See note above about -fstack-protector case "$ccflags" in *-fstack-protector*) case "$dflt" in *-fstack-protector*) ;; # Don't add it again *) dflt="$dflt -fstack-protector" ;; esac ;; esac : Try to guess additional flags to pick up local libraries. for thislibdir in $libpth; do case " $loclibpth " in *" $thislibdir "*) case "$dflt " in *"-L$thislibdir "*) ;; *) dflt="$dflt -L$thislibdir" ;; esac ;; esac done case "$dflt" in '') dflt='none' ;; esac $cat <&4 $cat > try.c <<'EOF' #include int main() { printf("Ok\n"); return(0); } EOF set X $cc -o try $optimize $ccflags $ldflags try.c $libs shift $cat >try.msg <<'EOM' I've tried to compile and run the following simple program: EOM $cat try.c >> try.msg $cat >> try.msg <>try.msg 2>&1; then if $sh -c "$run ./try " >>try.msg 2>&1; then xxx=`$run ./try` case "$xxx" in "Ok") dflt=n ;; *) echo 'The program compiled OK, but produced no output.' >> try.msg case " $libs " in *" -lsfio "*) cat >> try.msg <<'EOQS' If $libs contains -lsfio, and sfio is mis-configured, then it sometimes (apparently) runs and exits with a 0 status, but with no output! It may have to do with sfio's use of _exit vs. exit. EOQS rp="You have a big problem. Shall I abort Configure" dflt=y ;; esac ;; esac else echo "The program compiled OK, but exited with status $?." >>try.msg rp="You have a problem. Shall I abort Configure" dflt=y fi else echo "I can't compile the test program." >>try.msg rp="You have a BIG problem. Shall I abort Configure" dflt=y fi case "$dflt" in y) $cat try.msg >&4 case "$knowitall" in '') echo "(The supplied flags or libraries might be incorrect.)" ;; *) dflt=n;; esac echo " " . ./myread case "$ans" in n*|N*) ;; *) echo "Ok. Stopping Configure." >&4 exit 1 ;; esac ;; n) echo "OK, that should do.";; esac $rm_try gcctest gcctest.out : define a shorthand compile call compile=' mc_file=$1; shift; case "$usedevel" in $define|true|[yY]*) if $test ! -f "${mc_file}.c"; then echo "Internal Configure script bug - compiler test file ${mc_file}.c is missing. Please report this to perlbug@perl.org" >&4; exit 1; fi; esac; $cc -o ${mc_file} $optimize $ccflags $ldflags $* ${mc_file}.c $libs > /dev/null 2>&1;' : define a shorthand compile call for compilations that should be ok. compile_ok=' mc_file=$1; shift; $cc -o ${mc_file} $optimize $ccflags $ldflags $* ${mc_file}.c $libs;' : determine filename position in cpp output echo " " echo "Computing filename position in cpp output for #include directives..." >&4 case "$osname" in vos) testaccess=-e ;; *) testaccess=-r ;; esac echo '#include ' > foo.c $cat >fieldn </dev/null | \ $grep '^[ ]*#.*stdio\.h' | \ while read cline; do pos=1 set \$cline while $test \$# -gt 0; do if $test $testaccess \`echo \$1 | $tr -d '"'\`; then echo "\$pos" exit 0 fi shift pos=\`expr \$pos + 1\` done done EOF chmod +x fieldn fieldn=`./fieldn` $rm -f foo.c fieldn case $fieldn in '') pos='???';; 1) pos=first;; 2) pos=second;; 3) pos=third;; *) pos="${fieldn}th";; esac echo "Your cpp writes the filename in the $pos field of the line." case "$osname" in vos) cppfilter="tr '\\\\>' '/' |" ;; # path component separator is > os2) cppfilter="sed -e 's|\\\\\\\\|/|g' |" ;; # path component separator is \ *) cppfilter='' ;; esac : locate header file $cat >findhdr <" > foo\$\$.c $cppstdin $cppminus $cppflags < foo\$\$.c 2>/dev/null | \ $cppfilter $grep "^[ ]*#.*\$wanted" | \ while read cline; do name=\`echo \$cline | $awk "\$awkprg" | $tr -d '"'\` case "\$name" in *[/\\\\]\$wanted) echo "\$name"; exit 1;; *[\\\\/]\$wanted) echo "\$name"; exit 1;; *) exit 2;; esac; done; # # status = 0: grep returned 0 lines, case statement not executed # status = 1: headerfile found # status = 2: while loop executed, no headerfile found # status=\$? $rm -f foo\$\$.c; if test \$status -eq 1; then exit 0; fi exit 1 EOF chmod +x findhdr : define an alternate in-header-list? function inhdr='echo " "; td=$define; tu=$undef; yyy=$@; cont=true; xxf="echo \"<\$1> found.\" >&4"; case $# in 2) xxnf="echo \"<\$1> NOT found.\" >&4";; *) xxnf="echo \"<\$1> NOT found, ...\" >&4";; esac; case $# in 4) instead=instead;; *) instead="at last";; esac; while $test "$cont"; do xxx=`./findhdr $1` var=$2; eval "was=\$$2"; if $test "$xxx" && $test -r "$xxx"; then eval $xxf; eval "case \"\$$var\" in $undef) . ./whoa; esac"; eval "$var=\$td"; cont=""; else eval $xxnf; eval "case \"\$$var\" in $define) . ./whoa; esac"; eval "$var=\$tu"; fi; set $yyy; shift; shift; yyy=$@; case $# in 0) cont="";; 2) xxf="echo \"but I found <\$1> $instead.\" >&4"; xxnf="echo \"and I did not find <\$1> either.\" >&4";; *) xxf="echo \"but I found <\$1\> instead.\" >&4"; xxnf="echo \"there is no <\$1>, ...\" >&4";; esac; done; while $test "$yyy"; do set $yyy; var=$2; eval "was=\$$2"; eval "case \"\$$var\" in $define) . ./whoa; esac"; eval "$var=\$tu"; set $yyy; shift; shift; yyy=$@; done' : see if stdlib is available set stdlib.h i_stdlib eval $inhdr : check for lengths of integral types echo " " case "$intsize" in '') echo "Checking to see how big your integers are..." >&4 $cat >try.c < #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif int main() { printf("intsize=%d;\n", (int)sizeof(int)); printf("longsize=%d;\n", (int)sizeof(long)); printf("shortsize=%d;\n", (int)sizeof(short)); exit(0); } EOCP set try if eval $compile_ok && $run ./try > /dev/null; then eval `$run ./try` echo "Your integers are $intsize bytes long." echo "Your long integers are $longsize bytes long." echo "Your short integers are $shortsize bytes long." else $cat >&4 <&4 echo 'int main() { long long x = 7; return 0; }' > try.c set try if eval $compile; then val="$define" echo "You have long long." else val="$undef" echo "You do not have long long." fi $rm_try set d_longlong eval $setvar : check for length of long long case "${d_longlong}${longlongsize}" in $define) echo " " echo "Checking to see how big your long longs are..." >&4 $cat >try.c <<'EOCP' #include int main() { printf("%d\n", (int)sizeof(long long)); return(0); } EOCP set try if eval $compile_ok; then longlongsize=`$run ./try` echo "Your long longs are $longlongsize bytes long." else dflt='8' echo " " echo "(I can't seem to compile the test program. Guessing...)" rp="What is the size of a long long (in bytes)?" . ./myread longlongsize="$ans" fi if $test "X$longsize" = "X$longlongsize"; then echo "(That isn't any different from an ordinary long.)" fi ;; esac $rm_try : see if inttypes.h is available : we want a real compile instead of Inhdr because some systems : have an inttypes.h which includes non-existent headers echo " " $cat >try.c < int main() { static int32_t foo32 = 0x12345678; } EOCP set try if eval $compile; then echo " found." >&4 val="$define" else echo " NOT found." >&4 val="$undef" fi $rm_try set i_inttypes eval $setvar : check for int64_t echo " " echo "Checking to see if you have int64_t..." >&4 $cat >try.c < #$i_inttypes I_INTTYPES #ifdef I_INTTYPES #include #endif int main() { int64_t x = 7; } EOCP set try if eval $compile; then val="$define" echo "You have int64_t." else val="$undef" echo "You do not have int64_t." fi $rm_try set d_int64_t eval $setvar : Check if 64bit ints have a quad type echo " " echo "Checking which 64-bit integer type we could use..." >&4 case "$intsize" in 8) val=int set quadtype eval $setvar val='"unsigned int"' set uquadtype eval $setvar quadkind=1 ;; *) case "$longsize" in 8) val=long set quadtype eval $setvar val='"unsigned long"' set uquadtype eval $setvar quadkind=2 ;; *) case "$d_longlong:$longlongsize" in define:8) val='"long long"' set quadtype eval $setvar val='"unsigned long long"' set uquadtype eval $setvar quadkind=3 ;; *) case "$d_int64_t" in define) val=int64_t set quadtype eval $setvar val=uint64_t set uquadtype eval $setvar quadkind=4 ;; esac ;; esac ;; esac ;; esac case "$quadtype" in '') echo "Alas, no 64-bit integer types in sight." >&4 d_quad="$undef" ;; *) echo "We could use '$quadtype' for 64-bit integers." >&4 d_quad="$define" ;; esac : Do we want 64bit support case "$uselonglong" in "$define"|true|[yY]*) cat <&4 *** Configure -Duselonglong is deprecated, using -Duse64bitint instead. EOM use64bitint="$define" ;; esac case "$use64bits" in "$define"|true|[yY]*) cat <&4 *** Configure -Duse64bits is deprecated, using -Duse64bitint instead. EOM use64bitint="$define" ;; esac case "$use64bitints" in "$define"|true|[yY]*) cat <&4 *** There is no Configure -Duse64bitints, using -Duse64bitint instead. EOM use64bitint="$define" ;; esac case "$use64bitsint" in "$define"|true|[yY]*) cat <&4 *** There is no Configure -Duse64bitsint, using -Duse64bitint instead. EOM use64bitint="$define" ;; esac case "$uselonglongs" in "$define"|true|[yY]*) cat <&4 *** There is no Configure -Duselonglongs, using -Duse64bitint instead. EOM use64bitint="$define" ;; esac case "$use64bitsall" in "$define"|true|[yY]*) cat <&4 *** There is no Configure -Duse64bitsall, using -Duse64bitall instead. EOM use64bitall="$define" ;; esac case "$ccflags" in *-DUSE_LONG_LONG*|*-DUSE_64_BIT_INT*|*-DUSE_64_BIT_ALL*) use64bitint="$define";; esac case "$use64bitall" in "$define"|true|[yY]*) use64bitint="$define" ;; esac case "$longsize" in 8) cat <&4 <&4 $cat >try.c < #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif int main() { printf("%d\n", (int)sizeof(double)); exit(0); } EOCP set try if eval $compile_ok; then doublesize=`$run ./try` echo "Your double is $doublesize bytes long." else dflt='8' echo "(I can't seem to compile the test program. Guessing...)" rp="What is the size of a double precision number (in bytes)?" . ./myread doublesize="$ans" fi ;; esac $rm_try : check for long doubles echo " " echo "Checking to see if you have long double..." >&4 echo 'int main() { long double x = 7.0; }' > try.c set try if eval $compile; then val="$define" echo "You have long double." else val="$undef" echo "You do not have long double." fi $rm_try set d_longdbl eval $setvar : check for length of long double case "${d_longdbl}${longdblsize}" in $define) echo " " echo "Checking to see how big your long doubles are..." >&4 $cat >try.c <<'EOCP' #include int main() { printf("%d\n", sizeof(long double)); } EOCP set try set try if eval $compile; then longdblsize=`$run ./try` echo "Your long doubles are $longdblsize bytes long." else dflt='8' echo " " echo "(I can't seem to compile the test program. Guessing...)" >&4 rp="What is the size of a long double (in bytes)?" . ./myread longdblsize="$ans" fi if $test "X$doublesize" = "X$longdblsize"; then echo "That isn't any different from an ordinary double." echo "I'll keep your setting anyway, but you may see some" echo "harmless compilation warnings." fi ;; esac $rm_try : determine the architecture name echo " " if xxx=`./loc arch blurfl $pth`; $test -f "$xxx"; then tarch=`arch`"-$osname" elif xxx=`./loc uname blurfl $pth`; $test -f "$xxx" ; then if uname -m > tmparch 2>&1 ; then tarch=`$sed -e 's/ *$//' -e 's/ /_/g' \ -e 's/$/'"-$osname/" tmparch` else tarch="$osname" fi $rm -f tmparch else tarch="$osname" fi case "$myarchname" in ''|"$tarch") ;; *) echo "(Your architecture name used to be $myarchname.)" archname='' ;; esac case "$targetarch" in '') ;; *) archname=`echo $targetarch|sed 's,^[^-]*-,,'` ;; esac myarchname="$tarch" case "$archname" in '') dflt="$tarch";; *) dflt="$archname";; esac rp='What is your architecture name' . ./myread archname="$ans" case "$usethreads" in $define) echo "Threads selected." >&4 case "$archname" in *-thread*) echo "...and architecture name already has -thread." >&4 ;; *) archname="$archname-thread" echo "...setting architecture name to $archname." >&4 ;; esac ;; esac case "$usemultiplicity" in $define) echo "Multiplicity selected." >&4 case "$archname" in *-multi*) echo "...and architecture name already has -multi." >&4 ;; *) archname="$archname-multi" echo "...setting architecture name to $archname." >&4 ;; esac ;; esac case "$use64bitint$use64bitall" in *"$define"*) case "$archname64" in '') echo "This architecture is naturally 64-bit, not changing architecture name." >&4 ;; *) case "$use64bitint" in "$define") echo "64 bit integers selected." >&4 ;; esac case "$use64bitall" in "$define") echo "Maximal 64 bitness selected." >&4 ;; esac case "$archname" in *-$archname64*) echo "...and architecture name already has $archname64." >&4 ;; *) archname="$archname-$archname64" echo "...setting architecture name to $archname." >&4 ;; esac ;; esac esac case "$uselongdouble" in $define) echo "Long doubles selected." >&4 case "$longdblsize" in $doublesize) echo "...but long doubles are equal to doubles, not changing architecture name." >&4 ;; *) case "$archname" in *-ld*) echo "...and architecture name already has -ld." >&4 ;; *) archname="$archname-ld" echo "...setting architecture name to $archname." >&4 ;; esac ;; esac ;; esac case "$useperlio" in $define) echo "Perlio selected." >&4 ;; *) echo "Perlio not selected, using stdio." >&4 case "$archname" in *-stdio*) echo "...and architecture name already has -stdio." >&4 ;; *) archname="$archname-stdio" echo "...setting architecture name to $archname." >&4 ;; esac ;; esac if $test -f archname.cbu; then echo "Your platform has some specific hints for architecture name, using them..." . ./archname.cbu fi : set the prefixit variable, to compute a suitable default value prefixit='case "$3" in ""|none) case "$oldprefix" in "") eval "$1=\"\$$2\"";; *) case "$3" in "") eval "$1=";; none) eval "tp=\"\$$2\""; case "$tp" in ""|" ") eval "$1=\"\$$2\"";; *) eval "$1=";; esac;; esac;; esac;; *) eval "tp=\"$oldprefix-\$$2-\""; eval "tp=\"$tp\""; case "$tp" in --|/*--|\~*--) eval "$1=\"$prefix/$3\"";; /*-$oldprefix/*|\~*-$oldprefix/*) eval "$1=\`echo \$$2 | sed \"s,^$oldprefix,$prefix,\"\`";; *) eval "$1=\"\$$2\"";; esac;; esac' : determine installation style : For now, try to deduce it from prefix unless it is already set. : Reproduce behavior of 5.005 and earlier, maybe drop that in 5.7. case "$installstyle" in '') case "$prefix" in *perl*) dflt='lib';; *) dflt='lib/perl5' ;; esac ;; *) dflt="$installstyle" ;; esac : Probably not worth prompting for this since we prompt for all : the directories individually, and the prompt would be too long and : confusing anyway. installstyle=$dflt : determine where public executables go echo " " set dflt bin bin eval $prefixit fn=d~ rp='Pathname where the public executables will reside?' . ./getfile if $test "X$ansexp" != "X$binexp"; then installbin='' fi prefixvar=bin : XXX Bug? -- ignores Configure -Dinstallprefix setting. : XXX If this is fixed, also fix the "start perl" hunk below, which relies on : this via initialinstalllocation . ./setprefixvar case "$userelocatableinc" in $define|true|[yY]*) dflt='y' ;; *) dflt='n' ;; esac cat <reflect chmod +x,u+s reflect ./reflect >flect 2>&1 if $contains "/dev/fd" flect >/dev/null; then echo "Congratulations, your kernel has secure setuid scripts!" >&4 val="$define" else $cat <&4 dflt=n;; "$undef") echo "Well, the $hint value is *not* secure." >&4 dflt=n;; *) echo "Well, the $hint value *is* secure." >&4 dflt=y;; esac ;; *) $rm -f reflect flect echo "#!$ls" >reflect chmod +x,u+s reflect echo >flect chmod a+w flect echo '"su" will (probably) prompt you for '"$ans's password." su $ans -c './reflect >flect' if $contains "/dev/fd" flect >/dev/null; then echo "Okay, it looks like setuid scripts are secure." >&4 dflt=y else echo "I don't think setuid scripts are secure." >&4 dflt=n fi ;; esac rp='Does your kernel have *secure* setuid scripts?' . ./myread case "$ans" in [yY]*) val="$define";; *) val="$undef";; esac fi else echo "I don't think setuid scripts are secure (no /dev/fd directory)." >&4 echo "(That's for file descriptors, not floppy disks.)" val="$undef" fi set d_suidsafe eval $setvar $rm -f reflect flect : now see if they want to do setuid emulation if $test $patchlevel -lt 11; then echo " " val="$undef" case "$d_suidsafe" in "$define") val="$undef" echo "No need to emulate SUID scripts since they are secure here." >&4 ;; *) $cat <&4 </dev/null 2>&1; then perl5=$tdir/perl break; elif $test -x $tdir/perl5$exe_ext && $tdir/perl5 -Mless -e 'use 5.005;' >/dev/null 2>&1; then perl5=$tdir/perl5 break; fi done ;; *) perl5="$perl5" ;; esac case "$perl5" in '') echo "None found. That's ok.";; *) echo "Using $perl5." ;; esac : Set the siteprefix variables $cat < getverlist <> getverlist <<'EOPL' # The list found is store twice for each entry: the original name, and # the binary broken down version as pack "sss", so sorting is easy and # unambiguous. This will work for all versions that have a maximum of # three digit groups, separate by '.'s or '_'s. Names are extended with # ".0.0" to ensure at least three elements for the pack. # -- H.Merijn Brand (m)'06 23-10-2006 # Can't have leading @ because metaconfig interprets it as a command! ;@inc_version_list=(); # XXX Redo to do opendir/readdir? if (-d $stem) { chdir($stem); ;@candidates = map { [ $_, pack "sss", split m/[._]/, "$_.0.0" ] } glob("5.*"); ;@candidates = sort { $a->[1] cmp $b->[1]} @candidates; } else { ;@candidates = (); } ($pversion, $aversion, $vsn5005) = map { pack "sss", split m/[._]/, "$_.0.0" } $version, $api_versionstring, "5.005"; foreach $d (@candidates) { if ($d->[1] lt $pversion) { if ($d->[1] ge $aversion) { unshift(@inc_version_list, grep { -d } $d->[0]."/$archname", $d->[0]); } elsif ($d->[1] ge $vsn5005) { unshift(@inc_version_list, grep { -d } $d->[0]); } } else { # Skip newer version. I.e. don't look in # 5.7.0 if we're installing 5.6.1. } } if (@inc_version_list) { print join(' ', @inc_version_list); } else { # Blank space to preserve value for next Configure run. print " "; } EOPL chmod +x getverlist case "$inc_version_list" in '') if test -x "$perl5$exe_ext"; then dflt=`$perl5 getverlist` else dflt='none' fi ;; $undef) dflt='none' ;; *) eval dflt=\"$inc_version_list\" ;; esac case "$dflt" in ''|' ') dflt=none ;; esac case "$dflt" in 5.005) dflt=none ;; esac $cat <try.c < #include #$i_mallocmalloc I_MALLOCMALLOC #ifdef I_MALLOCMALLOC # include #endif int main () { return 0; } EOCP set try if eval $compile; then echo " found." >&4 val="$define" else echo " NOT found." >&4 val="$undef" fi $rm_try set i_malloc eval $setvar : check for void type echo " " echo "Checking to see how well your C compiler groks the void type..." >&4 case "$voidflags" in '') $cat >try.c < #endif #if TRY & 1 void sub() { #else sub() { #endif extern void moo(); /* function returning void */ void (*goo)(); /* ptr to func returning void */ #if TRY & 8 void *hue; /* generic ptr */ #endif #if TRY & 2 void (*foo[10])(); #endif #if TRY & 4 if(goo == moo) { exit(0); } #endif exit(0); } int main() { sub(); } EOCP if $cc $ccflags -c -DTRY=$defvoidused try.c >.out 2>&1 ; then voidflags=$defvoidused echo "Good. It appears to support void to the level $package wants.">&4 if $contains warning .out >/dev/null 2>&1; then echo "However, you might get some warnings that look like this:" $cat .out fi else echo "Hmm, your compiler has some difficulty with void. Checking further..." >&4 if $cc $ccflags -c -DTRY=1 try.c >/dev/null 2>&1; then echo "It supports 1..." if $cc $ccflags -c -DTRY=3 try.c >/dev/null 2>&1; then echo "It also supports 2..." if $cc $ccflags -c -DTRY=7 try.c >/dev/null 2>&1; then voidflags=7 echo "And it supports 4 but not 8 definitely." else echo "It doesn't support 4..." if $cc $ccflags -c -DTRY=11 try.c >/dev/null 2>&1; then voidflags=11 echo "But it supports 8." else voidflags=3 echo "Neither does it support 8." fi fi else echo "It does not support 2..." if $cc $ccflags -c -DTRY=13 try.c >/dev/null 2>&1; then voidflags=13 echo "But it supports 4 and 8." else if $cc $ccflags -c -DTRY=5 try.c >/dev/null 2>&1; then voidflags=5 echo "And it supports 4 but has not heard about 8." else echo "However it supports 8 but not 4." fi fi fi else echo "There is no support at all for void." voidflags=0 fi fi esac case "$voidflags" in "$defvoidused") ;; *) $cat >&4 <<'EOM' Support flag bits are: 1: basic void declarations. 2: arrays of pointers to functions returning void. 4: operations between pointers to and addresses of void functions. 8: generic void pointers. EOM dflt="$voidflags"; rp="Your void support flags add up to what?" . ./myread voidflags="$ans" ;; esac $rm_try : check for length of pointer echo " " case "$ptrsize" in '') echo "Checking to see how big your pointers are..." >&4 if test "$voidflags" -gt 7; then echo '#define VOID_PTR char *' > try.c else echo '#define VOID_PTR void *' > try.c fi $cat >>try.c < #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif int main() { printf("%d\n", (int)sizeof(VOID_PTR)); exit(0); } EOCP set try if eval $compile_ok; then ptrsize=`$run ./try` echo "Your pointers are $ptrsize bytes long." else dflt='4' echo "(I can't seem to compile the test program. Guessing...)" >&4 rp="What is the size of a pointer (in bytes)?" . ./myread ptrsize="$ans" fi ;; esac $rm_try case "$use64bitall" in "$define"|true|[yY]*) case "$ptrsize" in 4) cat <&4 *** You have chosen a maximally 64-bit build, *** but your pointers are only 4 bytes wide. *** Please rerun Configure without -Duse64bitall. EOM case "$d_quad" in define) cat <&4 *** Since you have quads, you could possibly try with -Duse64bitint. EOM ;; esac cat <&4 *** Cannot continue, aborting. EOM exit 1 ;; esac ;; esac : determine whether to use malloc wrapping echo " " case "$usemallocwrap" in [yY]*|true|$define) dflt='y' ;; [nN]*|false|$undef) dflt='n' ;; *) case "$usedevel" in [yY]*|true|$define) dflt='y' ;; *) dflt='n' ;; esac ;; esac rp="Do you wish to wrap malloc calls to protect against potential overflows?" . ./myread usemallocwrap="$ans" case "$ans" in y*|true) usemallocwrap="$define" ;; *) usemallocwrap="$undef" ;; esac : determine which malloc to compile in echo " " case "$usemymalloc" in [yY]*|true|$define) dflt='y' ;; [nN]*|false|$undef) dflt='n' ;; *) case "$ptrsize" in 4) dflt='y' ;; *) dflt='n' ;; esac ;; esac rp="Do you wish to attempt to use the malloc that comes with $package?" . ./myread usemymalloc="$ans" case "$ans" in y*|true) usemymalloc='y' mallocsrc='malloc.c' mallocobj="malloc$_o" d_mymalloc="$define" case "$libs" in *-lmalloc*) : Remove malloc from list of libraries to use echo "Removing unneeded -lmalloc from library list" >&4 set `echo X $libs | $sed -e 's/-lmalloc / /' -e 's/-lmalloc$//'` shift libs="$*" echo "libs = $libs" >&4 ;; esac ;; *) usemymalloc='n' mallocsrc='' mallocobj='' d_mymalloc="$undef" ;; esac : compute the return types of malloc and free echo " " $cat >malloc.c < #include #ifdef I_MALLOC #include #endif #ifdef I_STDLIB #include #endif #ifdef TRY_MALLOC void *malloc(); #endif #ifdef TRY_FREE void free(); #endif END case "$malloctype" in '') if $cc $ccflags -c -DTRY_MALLOC malloc.c >/dev/null 2>&1; then malloctype='void *' else malloctype='char *' fi ;; esac echo "Your system wants malloc to return '$malloctype', it would seem." >&4 case "$freetype" in '') if $cc $ccflags -c -DTRY_FREE malloc.c >/dev/null 2>&1; then freetype='void' else freetype='int' fi ;; esac echo "Your system uses $freetype free(), it would seem." >&4 $rm -f malloc.[co] : determine where site specific architecture-dependent libraries go. : sitelib default is /usr/local/lib/perl5/site_perl/$version : sitearch default is /usr/local/lib/perl5/site_perl/$version/$archname : sitelib may have an optional trailing /share. case "$sitearch" in '') dflt=`echo $sitelib | $sed 's,/share$,,'` dflt="$dflt/$archname" ;; *) dflt="$sitearch" ;; esac set sitearch sitearch none eval $prefixit $cat <&4 $cat >prototype.c < #endif int main(int argc, char *argv[]) { exit(0);} EOCP if $cc $ccflags -c prototype.c >prototype.out 2>&1 ; then echo "Your C compiler appears to support function prototypes." val="$define" else echo "Your C compiler doesn't seem to understand function prototypes." val="$undef" fi set prototype eval $setvar $rm -f prototype* : Check if ansi2knr is required case "$prototype" in "$define") ;; *) ansi2knr='ansi2knr' echo " " cat <&4 $me: FATAL ERROR: This version of $package can only be compiled by a compiler that understands function prototypes. Unfortunately, your C compiler $cc $ccflags doesn't seem to understand them. Sorry about that. If GNU cc is available for your system, perhaps you could try that instead. Eventually, we hope to support building Perl with pre-ANSI compilers. If you would like to help in that effort, please contact . Aborting Configure now. EOM exit 2 ;; esac : DTrace support dflt_dtrace='/usr/sbin/dtrace' $test -x /usr/bin/dtrace && dflt_dtrace='/usr/bin/dtrace' cat </dev/null 2>&1 \ && rm -f perldtrace.tmp then echo " " echo "Good: your $dtrace knows about the -h flag." else cat >&2 <&2 < ../extras.lst val="'$extras'" ;; esac set extras eval $setvar echo " " : determine where html pages for programs go set html1dir html1dir none eval $prefixit $cat <&4 cat >try.c <<'EOCP' /* Find out version of GNU C library. __GLIBC__ and __GLIBC_MINOR__ alone are insufficient to distinguish different versions, such as 2.0.6 and 2.0.7. The function gnu_get_libc_version() appeared in libc version 2.1.0. A. Dougherty, June 3, 2002. */ #include int main(void) { #ifdef __GLIBC__ # ifdef __GLIBC_MINOR__ # if __GLIBC__ >= 2 && __GLIBC_MINOR__ >= 1 && !defined(__cplusplus) # include printf("%s\n", gnu_get_libc_version()); # else printf("%d.%d\n", __GLIBC__, __GLIBC_MINOR__); # endif # else printf("%d\n", __GLIBC__); # endif return 0; #else return 1; #endif } EOCP set try if eval $compile_ok && $run ./try > glibc.ver; then val="$define" gnulibc_version=`$cat glibc.ver` echo "You are using the GNU C Library version $gnulibc_version" else val="$undef" gnulibc_version='' echo "You are not using the GNU C Library" fi $rm_try glibc.ver set d_gnulibc eval $setvar : see if nm is to be used to determine whether a symbol is defined or not case "$usenm" in '') dflt='' case "$d_gnulibc" in "$define") echo " " echo "nm probably won't work on the GNU C Library." >&4 dflt=n ;; esac case "$dflt" in '') if $test "$osname" = aix -a "X$PASE" != "Xdefine" -a ! -f /lib/syscalls.exp; then echo " " echo "Whoops! This is an AIX system without /lib/syscalls.exp!" >&4 echo "'nm' won't be sufficient on this sytem." >&4 dflt=n fi ;; esac case "$dflt" in '') dflt=`$egrep 'inlibc|csym' $rsrc/Configure | wc -l 2>/dev/null` if $test $dflt -gt 20; then dflt=y else dflt=n fi ;; esac ;; *) case "$usenm" in true|$define) dflt=y;; *) dflt=n;; esac ;; esac $cat < /dev/null 2>&1; then nm_so_opt='--dynamic' fi ;; esac ;; esac : Figure out where the libc is located case "$runnm" in true) : get list of predefined functions in a handy place echo " " case "$libc" in '') libc=unknown case "$libs" in *-lc_s*) libc=`./loc libc_s$_a $libc $libpth` esac ;; esac case "$libs" in '') ;; *) for thislib in $libs; do case "$thislib" in -lc|-lc_s) : Handle C library specially below. ;; -l*) thislib=`echo $thislib | $sed -e 's/^-l//'` if try=`./loc lib$thislib.$so.'*' X $libpth`; $test -f "$try"; then : elif try=`./loc lib$thislib.$so X $libpth`; $test -f "$try"; then : elif try=`./loc lib$thislib$_a X $libpth`; $test -f "$try"; then : elif try=`./loc $thislib$_a X $libpth`; $test -f "$try"; then : elif try=`./loc lib$thislib X $libpth`; $test -f "$try"; then : elif try=`./loc $thislib X $libpth`; $test -f "$try"; then : elif try=`./loc Slib$thislib$_a X $xlibpth`; $test -f "$try"; then : else try='' fi libnames="$libnames $try" ;; *) libnames="$libnames $thislib" ;; esac done ;; esac xxx=normal case "$libc" in unknown) set /lib/libc.$so for xxx in $libpth; do $test -r $1 || set $xxx/libc.$so : The messy sed command sorts on library version numbers. $test -r $1 || \ set `echo blurfl; echo $xxx/libc.$so.[0-9]* | \ tr ' ' $trnl | egrep -v '\.[A-Za-z]*$' | $sed -e ' h s/[0-9][0-9]*/0000&/g s/0*\([0-9][0-9][0-9][0-9][0-9]\)/\1/g G s/\n/ /' | \ $sort | $sed -e 's/^.* //'` eval set \$$# done $test -r $1 || set /usr/ccs/lib/libc.$so $test -r $1 || set /lib/libsys_s$_a ;; *) set blurfl ;; esac if $test -r "$1"; then echo "Your (shared) C library seems to be in $1." libc="$1" elif $test -r /lib/libc && $test -r /lib/clib; then echo "Your C library seems to be in both /lib/clib and /lib/libc." xxx=apollo libc='/lib/clib /lib/libc' if $test -r /lib/syslib; then echo "(Your math library is in /lib/syslib.)" libc="$libc /lib/syslib" fi elif $test -r "$libc" || (test -h "$libc") >/dev/null 2>&1; then echo "Your C library seems to be in $libc, as you said before." elif $test -r $incpath/usr/lib/libc$_a; then libc=$incpath/usr/lib/libc$_a; echo "Your C library seems to be in $libc. That's fine." elif $test -r /lib/libc$_a; then libc=/lib/libc$_a; echo "Your C library seems to be in $libc. You're normal." else if tans=`./loc libc$_a blurfl/dyick $libpth`; $test -r "$tans"; then : elif tans=`./loc libc blurfl/dyick $libpth`; $test -r "$tans"; then libnames="$libnames "`./loc clib blurfl/dyick $libpth` elif tans=`./loc clib blurfl/dyick $libpth`; $test -r "$tans"; then : elif tans=`./loc Slibc$_a blurfl/dyick $xlibpth`; $test -r "$tans"; then : elif tans=`./loc Mlibc$_a blurfl/dyick $xlibpth`; $test -r "$tans"; then : else tans=`./loc Llibc$_a blurfl/dyick $xlibpth` fi if $test -r "$tans"; then echo "Your C library seems to be in $tans, of all places." libc=$tans else libc='blurfl' fi fi if $test $xxx = apollo -o -r "$libc" || (test -h "$libc") >/dev/null 2>&1; then dflt="$libc" cat < libpath cat >&4 < libnames set X `cat libnames` shift xxx=files case $# in 1) xxx=file; esac echo "Extracting names from the following $xxx for later perusal:" >&4 echo " " $sed 's/^/ /' libnames >&4 echo " " $echo $n "This may take a while...$c" >&4 for file in $*; do case $file in *$so*) $nm $nm_so_opt $nm_opt $file 2>/dev/null;; *) $nm $nm_opt $file 2>/dev/null;; esac done >libc.tmp $echo $n ".$c" $grep fprintf libc.tmp > libc.ptf xscan='eval "libc.list"; $echo $n ".$c" >&4' xrun='eval "libc.list"; echo "done." >&4' xxx='[ADTSIW]' if com="$sed -n -e 's/__IO//' -e 's/^.* $xxx *//p'";\ eval $xscan;\ $contains '^fprintf$' libc.list >/dev/null 2>&1; then eval $xrun elif com="$sed -n -e 's/^__*//' -e 's/^\([a-zA-Z_0-9$]*\).*xtern.*/\1/p'";\ eval $xscan;\ $contains '^fprintf$' libc.list >/dev/null 2>&1; then eval $xrun elif com="$sed -n -e '/|UNDEF/d' -e '/FUNC..GL/s/^.*|__*//p'";\ eval $xscan;\ $contains '^fprintf$' libc.list >/dev/null 2>&1; then eval $xrun elif com="$sed -n -e 's/^.* D __*//p' -e 's/^.* D //p'";\ eval $xscan;\ $contains '^fprintf$' libc.list >/dev/null 2>&1; then eval $xrun elif com="$sed -n -e 's/^_//' -e 's/^\([a-zA-Z_0-9]*\).*xtern.*text.*/\1/p'";\ eval $xscan;\ $contains '^fprintf$' libc.list >/dev/null 2>&1; then eval $xrun elif com="$sed -n -e 's/^.*|FUNC |GLOB .*|//p'";\ eval $xscan;\ $contains '^fprintf$' libc.list >/dev/null 2>&1; then eval $xrun elif com="$grep '|' | $sed -n -e '/|COMMON/d' -e '/|DATA/d' \ -e '/ file/d' -e 's/^\([^ ]*\).*/\1/p'";\ eval $xscan;\ $contains '^fprintf$' libc.list >/dev/null 2>&1; then eval $xrun elif com="$sed -n -e 's/^.*|FUNC |GLOB .*|//p' -e 's/^.*|FUNC |WEAK .*|//p'";\ eval $xscan;\ $contains '^fprintf$' libc.list >/dev/null 2>&1; then eval $xrun elif com="$sed -n -e 's/^__//' -e '/|Undef/d' -e '/|Proc/s/ .*//p'";\ eval $xscan;\ $contains '^fprintf$' libc.list >/dev/null 2>&1; then eval $xrun elif com="$sed -n -e 's/^.*|Proc .*|Text *| *//p'";\ eval $xscan;\ $contains '^fprintf$' libc.list >/dev/null 2>&1; then eval $xrun elif com="$sed -n -e '/Def. Text/s/.* \([^ ]*\)\$/\1/p'";\ eval $xscan;\ $contains '^fprintf$' libc.list >/dev/null 2>&1; then eval $xrun elif com="$sed -n -e 's/^[-0-9a-f ]*_\(.*\)=.*/\1/p'";\ eval $xscan;\ $contains '^fprintf$' libc.list >/dev/null 2>&1; then eval $xrun elif com="$sed -n -e 's/.*\.text n\ \ \ \.//p'";\ eval $xscan;\ $contains '^fprintf$' libc.list >/dev/null 2>&1; then eval $xrun elif com="sed -n -e 's/^__.*//' -e 's/[ ]*D[ ]*[0-9]*.*//p'";\ eval $xscan;\ $contains '^fprintf$' libc.list >/dev/null 2>&1; then eval $xrun else $nm -p $* 2>/dev/null >libc.tmp $grep fprintf libc.tmp > libc.ptf if com="$sed -n -e 's/^.* [ADTSIW] *_[_.]*//p' -e 's/^.* [ADTSIW] //p'";\ eval $xscan; $contains '^fprintf$' libc.list >/dev/null 2>&1 then nm_opt='-p' eval $xrun else echo " " echo "$nm didn't seem to work right. Trying $ar instead..." >&4 com='' if $ar t $libc > libc.tmp && \ $contains '^fprintf$' libc.tmp >/dev/null 2>&1 then for thisname in $libnames $libc; do $ar t $thisname >>libc.tmp done $sed -e "s/\\$_o\$//" < libc.tmp > libc.list echo "Ok." >&4 elif test "X$osname" = "Xos2" && $ar tv $libc > libc.tmp; then for thisname in $libnames $libc; do $ar tv $thisname >>libc.tmp emximp -o tmp.imp $thisname \ 2>/dev/null && \ $sed -e 's/^\([_a-zA-Z0-9]*\) .*$/\1/p' \ < tmp.imp >>libc.tmp $rm -f tmp.imp done $sed -e "s/\\$_o\$//" -e 's/^ \+//' < libc.tmp > libc.list echo "Ok." >&4 else echo "$ar didn't seem to work right." >&4 echo "Maybe this is a Cray...trying bld instead..." >&4 if bld t $libc | \ $sed -e 's/.*\///' -e "s/\\$_o:.*\$//" > libc.list && $test -s libc.list then for thisname in $libnames; do bld t $libnames | \ $sed -e 's/.*\///' -e "s/\\$_o:.*\$//" >>libc.list $ar t $thisname >>libc.tmp done echo "Ok." >&4 else echo "That didn't work either. Giving up." >&4 exit 1 fi fi fi fi nm_extract="$com" case "$PASE" in define) echo " " echo "Since you are compiling for PASE, extracting more symbols from libc.a ...">&4 dump -Tv /lib/libc.a | awk '$7 == "/unix" {print $5 " " $8}' | grep "^SV" | awk '{print $2}' >> libc.list ;; *) if $test -f /lib/syscalls.exp; then echo " " echo "Also extracting names from /lib/syscalls.exp for good ole AIX..." >&4 $sed -n 's/^\([^ ]*\)[ ]*syscall[0-9]*[ ]*$/\1/p' \ /lib/syscalls.exp >>libc.list fi ;; esac ;; esac $rm -f libnames libpath : see if dld is available set dld.h i_dld eval $inhdr : Check if we are using C++ echo " " echo "Checking for C++..." >&4 $cat >try.c <<'EOCP' #include int main(void) { #ifdef __cplusplus return 0; #else return 1; #endif } EOCP set try if eval $compile_ok && $run ./try; then val="$define" echo "You are using a C++ compiler." else val="$undef" echo "You are not using a C++ compiler." fi $rm_try cplusplus$$ set d_cplusplus eval $setvar : is a C symbol defined? csym='tlook=$1; case "$3" in -v) tf=libc.tmp; tdc="";; -a) tf=libc.tmp; tdc="[]";; *) tlook="^$1\$"; tf=libc.list; tdc="()";; esac; case "$d_cplusplus" in $define) extern_C="extern \"C\"" ;; *) extern_C="extern" ;; esac; tx=yes; case "$reuseval-$4" in true-) ;; true-*) tx=no; eval "tval=\$$4"; case "$tval" in "") tx=yes;; esac;; esac; case "$tx" in yes) tval=false; if $test "$runnm" = true; then if $contains $tlook $tf >/dev/null 2>&1; then tval=true; elif $test "$mistrustnm" = compile -o "$mistrustnm" = run; then echo "$extern_C void *$1$tdc; void *(*(p()))$tdc { return &$1; } int main() { if(p()) return(0); else return(1); }"> try.c; $cc -o try $optimize $ccflags $ldflags try.c >/dev/null 2>&1 $libs && tval=true; $test "$mistrustnm" = run -a -x try && { $run ./try$_exe >/dev/null 2>&1 || tval=false; }; $rm_try; fi; else echo "$extern_C void *$1$tdc; void *(*(p()))$tdc { return &$1; } int main() { if(p()) return(0); else return(1); }"> try.c; $cc -o try $optimize $ccflags $ldflags try.c $libs >/dev/null 2>&1 && tval=true; $rm_try; fi; ;; *) case "$tval" in $define) tval=true;; *) tval=false;; esac; ;; esac; eval "$2=$tval"' : define an is-in-libc? function inlibc='echo " "; td=$define; tu=$undef; sym=$1; var=$2; eval "was=\$$2"; tx=yes; case "$reuseval$was" in true) ;; true*) tx=no;; esac; case "$tx" in yes) set $sym tres -f; eval $csym; case "$tres" in true) echo "$sym() found." >&4; case "$was" in $undef) . ./whoa; esac; eval "$var=\$td";; *) echo "$sym() NOT found." >&4; case "$was" in $define) . ./whoa; esac; eval "$var=\$tu";; esac;; *) case "$was" in $define) echo "$sym() found." >&4;; *) echo "$sym() NOT found." >&4;; esac;; esac' : see if dlopen exists xxx_runnm="$runnm" xxx_ccflags="$ccflags" runnm=false : with g++ one needs -shared to get is-in-libc to work for dlopen case "$gccversion" in '') ;; *) case "$d_cplusplus" in "$define") ccflags="$ccflags -shared" ;; esac ;; esac set dlopen d_dlopen eval $inlibc runnm="$xxx_runnm" ccflags="$xxx_ccflags" : see if this is a unistd.h system set unistd.h i_unistd eval $inhdr : determine which dynamic loading, if any, to compile in echo " " dldir="ext/DynaLoader" case "$usedl" in $define|y|true) dflt='y' usedl="$define" ;; $undef|n|false) dflt='n' usedl="$undef" ;; *) dflt='n' case "$d_dlopen" in $define) dflt='y' ;; esac case "$i_dld" in $define) dflt='y' ;; esac : Does a dl_xxx.xs file exist for this operating system $test -f $rsrc/$dldir/dl_${osname}.xs && dflt='y' ;; esac rp="Do you wish to use dynamic loading?" . ./myread usedl="$ans" bin_ELF="$undef" case "$ans" in y*) usedl="$define" case "$dlsrc" in '') if $test -f $rsrc/$dldir/dl_${osname}.xs ; then dflt="$dldir/dl_${osname}.xs" elif $test "$d_dlopen" = "$define" ; then dflt="$dldir/dl_dlopen.xs" elif $test "$i_dld" = "$define" ; then dflt="$dldir/dl_dld.xs" else dflt='' fi ;; *) dflt="$dldir/$dlsrc" ;; esac echo "The following dynamic loading files are available:" : Can not go over to $dldir because getfile has path hard-coded in. tdir=`pwd`; cd "$rsrc"; $ls -C $dldir/dl*.xs; cd "$tdir" rp="Source file to use for dynamic loading" fn="fne" gfpth="$src" . ./getfile usedl="$define" : emulate basename dlsrc=`echo $ans | $sed -e 's%.*/\([^/]*\)$%\1%'` $cat << EOM Some systems may require passing special flags to $cc -c to compile modules that will be used to create a shared library. To use no flags, say "none". EOM case "$cccdlflags" in '') case "$gccversion" in '') case "$osname" in hpux) dflt='+z' ;; next) dflt='none' ;; irix*) dflt='-KPIC' ;; svr4*|esix*|solaris|nonstopux) dflt='-KPIC' ;; sunos) dflt='-pic' ;; *) dflt='none' ;; esac ;; *) case "$osname" in darwin) dflt='none' ;; linux*|svr4*|esix*|solaris|nonstopux) dflt='-fPIC' ;; *) dflt='-fpic' ;; esac ;; esac ;; ' ') dflt='none' ;; *) dflt="$cccdlflags" ;; esac rp="Any special flags to pass to $cc -c to compile shared library modules?" . ./myread case "$ans" in none) cccdlflags=' ' ;; *) cccdlflags="$ans" ;; esac cat << EOM Some systems use ld to create libraries that can be dynamically loaded, while other systems (such as those using ELF) use $cc. EOM case "$ld" in '') $cat >try.c < #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif #$i_unistd I_UNISTD #ifdef I_UNISTD #include #endif int main() { char b[4]; int i = open("a.out",O_RDONLY); if(i == -1) exit(1); /* fail */ if(read(i,b,4)==4 && b[0]==127 && b[1]=='E' && b[2]=='L' && b[3]=='F') exit(0); /* succeed (yes, it's ELF) */ else exit(1); /* fail */ } EOM if $cc $ccflags $ldflags try.c >/dev/null 2>&1 && $run ./a.out; then cat <&4 echo "See INSTALL for an explanation why that won't work." >&4 exit 4 ;; esac case "$libperl" in '') # Figure out a good name for libperl.so. Since it gets stored in # a version-specific architecture-dependent library, the version # number isn't really that important, except for making cc/ld happy. # # A name such as libperl.so.10.1 majmin="libperl.$so.$patchlevel.$subversion" # A name such as libperl.so.100 majonly=`echo $patchlevel $subversion | $awk '{printf "%d%02d", $1, $2}'` majonly=libperl.$so.$majonly # I'd prefer to keep the os-specific stuff here to a minimum, and # rely on figuring it out from the naming of libc. case "${osname}${osvers}" in next4*) dflt=libperl.5.$so # XXX How handle the --version stuff for MAB? ;; linux*|gnu*) # ld won't link with a bare -lperl otherwise. dflt=libperl.$so ;; cygwin*) # ld links now against the dll directly majmin="cygperl5_${patchlevel}_${subversion}.${so}" majonly=`echo $patchlevel $subversion | $awk '{printf "%03d%03d", $1, $2}'` majonly=cygperl5.$majonly.$so dflt=$majmin ;; *) # Try to guess based on whether libc has major.minor. case "$libc" in *libc.$so.[0-9]*.[0-9]*) dflt=$majmin ;; *libc.$so.[0-9]*) dflt=$majonly ;; *) dflt=libperl.$so ;; esac ;; esac ;; *) dflt=$libperl ;; esac cat << EOM I need to select a good name for the shared libperl. If your system uses library names with major and minor numbers, then you might want something like $majmin. Alternatively, if your system uses a single version number for shared libraries, then you might want to use $majonly. Or, your system might be quite happy with a simple libperl.$so. Since the shared libperl will get installed into a version-specific architecture-dependent directory, the version number of the shared perl library probably isn't important, so the default should be o.k. EOM rp='What name do you want to give to the shared libperl?' . ./myread libperl=$ans echo "Ok, I'll use $libperl" ;; *) libperl="libperl${_a}" ;; esac # Detect old use of shrpdir via undocumented Configure -Dshrpdir case "$shrpdir" in '') ;; *) $cat >&4 <&4 <&4 <&4 Adding $xxx to the flags passed to $ld so that the perl executable will find the installed shared $libperl. EOM ;; esac ;; esac fi # Fix ccdlflags in AIX for building external extensions. # (For building Perl itself bare -bE:perl.exp is needed, # Makefile.SH takes care of this.) case "$osname" in aix) ccdlflags="$ccdlflags -bE:$installarchlib/CORE/perl.exp" ;; esac # Respect a hint or command-line value. case "$shrpenv" in '') shrpenv="$tmp_shrpenv" ;; esac case "$ldlibpthname" in '') ldlibpthname=LD_LIBRARY_PATH ;; none) ldlibpthname='' ;; esac : determine where manual pages are on this system echo " " case "$sysman" in '') syspath='/usr/share/man/man1 /usr/man/man1' syspath="$syspath /usr/man/mann /usr/man/manl /usr/man/local/man1" syspath="$syspath /usr/man/u_man/man1" syspath="$syspath /usr/catman/u_man/man1 /usr/man/l_man/man1" syspath="$syspath /usr/local/man/u_man/man1 /usr/local/man/l_man/man1" syspath="$syspath /usr/man/man.L /local/man/man1 /usr/local/man/man1" sysman=`./loc . /usr/man/man1 $syspath` ;; esac if $test -d "$sysman"; then echo "System manual is in $sysman." >&4 else echo "Could not find manual pages in source form." >&4 fi : determine where manual pages go set man1dir man1dir none eval $prefixit $cat <$first) 2>/dev/null; then if $test -f 123456789abcde; then echo 'You cannot have filenames longer than 14 characters. Sigh.' >&4 val="$undef" else echo 'You can have filenames longer than 14 characters.'>&4 val="$define" fi else $cat <<'EOM' You can't have filenames longer than 14 chars. You can't even think about them! EOM val="$undef" fi set d_flexfnam eval $setvar $rm -rf 123456789abcde* : determine where library module manual pages go set man3dir man3dir none eval $prefixit $cat <&4 WARNING: Previous versions of perl installed man3 pages into $privlib/man/man3. This version will suggest a new default of $dflt. EOM tdflt=$dflt dflt='n' rp='Do you wish to preserve the old behavior?(y/n)' . ./myread case "$ans" in y*) dflt="$privlib/man/man3" ;; *) dflt=$tdflt ;; esac fi ;; *) dflt="$man3dir" ;; esac case "$dflt" in ' ') dflt=none ;; esac echo " " fn=dn+~ rp="Where do the $package library man pages (source) go?" . ./getfile prefixvar=man3dir . ./setprefixvar case "$man3dir" in '') man3dir=' ' installman3dir='';; esac : What suffix to use on installed man pages case "$man3dir" in ' ') man3ext='0' ;; *) rp="What suffix should be used for the $package library man pages?" case "$man3ext" in '') case "$man3dir" in *3) dflt=3 ;; *3p) dflt=3p ;; *3pm) dflt=3pm ;; *l) dflt=l;; *n) dflt=n;; *o) dflt=o;; *p) dflt=p;; *C) dflt=C;; *L) dflt=L;; *L3) dflt=L3;; *) dflt=3;; esac ;; *) dflt="$man3ext";; esac . ./myread man3ext="$ans" ;; esac : see if we have to deal with yellow pages, now NIS. if $test -d /usr/etc/yp || $test -d /etc/yp || $test -d /usr/lib/yp; then if $test -f /usr/etc/nibindd; then echo " " echo "I'm fairly confident you're on a NeXT." echo " " rp='Do you get the hosts file via NetInfo?' dflt=y case "$hostcat" in nidump*) ;; '') ;; *) dflt=n;; esac . ./myread case "$ans" in y*) hostcat='nidump hosts .';; *) case "$hostcat" in nidump*) hostcat='';; esac ;; esac fi case "$hostcat" in nidump*) ;; *) case "$hostcat" in *ypcat*) dflt=y;; '') if $contains '^\+' /etc/passwd >/dev/null 2>&1; then dflt=y else dflt=n fi;; *) dflt=n;; esac echo " " rp='Are you getting the hosts file via yellow pages?' . ./myread case "$ans" in y*) hostcat='ypcat hosts';; *) hostcat='cat /etc/hosts';; esac ;; esac fi case "$hostcat" in '') test -f /etc/hosts && hostcat='cat /etc/hosts';; esac case "$groupcat" in '') test -f /etc/group && groupcat='cat /etc/group';; esac case "$passcat" in '') test -f /etc/passwd && passcat='cat /etc/passwd';; esac : now get the host name echo " " echo "Figuring out host name..." >&4 case "$myhostname" in '') cont=true echo 'Maybe "hostname" will work...' if tans=`sh -c hostname 2>&1` ; then myhostname=$tans phostname=hostname cont='' fi ;; *) cont='';; esac if $test "$cont"; then if ./xenix; then echo 'Oh, dear. Maybe "/etc/systemid" is the key...' if tans=`cat /etc/systemid 2>&1` ; then myhostname=$tans phostname='cat /etc/systemid' echo "Whadyaknow. Xenix always was a bit strange..." cont='' fi elif $test -r /etc/systemid; then echo "(What is a non-Xenix system doing with /etc/systemid?)" fi fi if $test "$cont"; then echo 'No, maybe "uuname -l" will work...' if tans=`sh -c 'uuname -l' 2>&1` ; then myhostname=$tans phostname='uuname -l' else echo 'Strange. Maybe "uname -n" will work...' if tans=`sh -c 'uname -n' 2>&1` ; then myhostname=$tans phostname='uname -n' else echo 'Oh well, maybe I can mine it out of whoami.h...' if tans=`sh -c $contains' sysname $usrinc/whoami.h' 2>&1` ; then myhostname=`echo "$tans" | $sed 's/^.*"\(.*\)"/\1/'` phostname="sed -n -e '"'/sysname/s/^.*\"\\(.*\\)\"/\1/{'"' -e p -e q -e '}' <$usrinc/whoami.h" else case "$myhostname" in '') echo "Does this machine have an identity crisis or something?" phostname='';; *) echo "Well, you said $myhostname before..." phostname='echo $myhostname';; esac fi fi fi fi case "$myhostname" in '') myhostname=noname ;; esac : you do not want to know about this set $myhostname myhostname=$1 : verify guess if $test "$myhostname" ; then dflt=y rp='Your host name appears to be "'$myhostname'".'" Right?" . ./myread case "$ans" in y*) ;; *) myhostname='';; esac fi : bad guess or no guess while $test "X$myhostname" = X ; do dflt='' rp="Please type the (one word) name of your host:" . ./myread myhostname="$ans" done : translate upper to lower if necessary case "$myhostname" in *[A-Z]*) echo "(Normalizing case in your host name)" myhostname=`echo $myhostname | ./tr '[A-Z]' '[a-z]'` ;; esac case "$myhostname" in *.*) dflt=`expr "X$myhostname" : "X[^.]*\(\..*\)"` myhostname=`expr "X$myhostname" : "X\([^.]*\)\."` echo "(Trimming domain name from host name--host name is now $myhostname)" ;; *) case "$mydomain" in '') { test "X$hostcat" = "Xypcat hosts" && ypmatch "$myhostname" hosts 2>/dev/null |\ $sed -e 's/[ ]*#.*//; s/$/ /' > hosts && \ $test -s hosts } || { test "X$hostcat" != "X" && $hostcat | $sed -n -e "s/[ ]*#.*//; s/\$/ / /[ ]$myhostname[ . ]/p" > hosts } tmp_re="[ . ]" if $test -f hosts; then $test x`$awk "/[0-9].*[ ]$myhostname$tmp_re/ { sum++ } END { print sum }" hosts` = x1 || tmp_re="[ ]" dflt=.`$awk "/[0-9].*[ ]$myhostname$tmp_re/ {for(i=2; i<=NF;i++) print \\\$i}" \ hosts | $sort | $uniq | \ $sed -n -e "s/$myhostname\.\([-a-zA-Z0-9_.]\)/\1/p"` case `$echo X$dflt` in X*\ *) echo "(Several hosts in the database matched hostname)" dflt=. ;; X.) echo "(You do not have fully-qualified names in the hosts database)" ;; esac else echo "(I cannot locate a hosts database anywhere)" dflt=. fi case "$dflt" in .) tans=`./loc resolv.conf X /etc /usr/etc` if $test -f "$tans"; then echo "(Attempting domain name extraction from $tans)" dflt=.`$sed -n -e 's/ / /g' \ -e 's/^search *\([^ ]*\).*/\1/p' $tans \ -e 1q 2>/dev/null` case "$dflt" in .) dflt=.`$sed -n -e 's/ / /g' \ -e 's/^domain *\([^ ]*\).*/\1/p' $tans \ -e 1q 2>/dev/null` ;; esac fi ;; esac case "$dflt" in .) echo "(No help from resolv.conf either -- attempting clever guess)" dflt=.`sh -c domainname 2>/dev/null` case "$dflt" in '') dflt='.';; .nis.*|.yp.*|.main.*) dflt=`echo $dflt | $sed -e 's/^\.[^.]*//'`;; esac ;; esac case "$dflt$osname" in .os390) echo "(Attempting domain name extraction from //'SYS1.TCPPARMS(TCPDATA)')" dflt=.`awk '/^DOMAINORIGIN/ {print $2}' "//'SYS1.TCPPARMS(TCPDATA)'" 2>/dev/null` ;; esac case "$dflt" in .) echo "(Lost all hope -- silly guess then)" dflt='.nonet' ;; esac $rm -f hosts ;; *) dflt="$mydomain";; esac;; esac echo " " rp="What is your domain name?" . ./myread tans="$ans" case "$ans" in '') ;; .*) ;; *) tans=".$tans";; esac mydomain="$tans" : translate upper to lower if necessary case "$mydomain" in *[A-Z]*) echo "(Normalizing case in your domain name)" mydomain=`echo $mydomain | ./tr '[A-Z]' '[a-z]'` ;; esac : a little sanity check here case "$phostname" in '') ;; *) case `$phostname | ./tr '[A-Z]' '[a-z]'` in $myhostname$mydomain|$myhostname) ;; *) case "$phostname" in sed*) echo "(That doesn't agree with your whoami.h file, by the way.)" ;; *) echo "(That doesn't agree with your $phostname command, by the way.)" ;; esac ;; esac ;; esac : determine the e-mail address of the user who is running us $cat <&4 <&4 $cat >try.c < #include int main() { printf("%d\n", (int)sizeof($lseektype)); return(0); } EOCP set try if eval $compile_ok; then lseeksize=`$run ./try` echo "Your file offsets are $lseeksize bytes long." else dflt=$longsize echo " " echo "(I can't seem to compile the test program. Guessing...)" rp="What is the size of your file offsets (in bytes)?" . ./myread lseeksize="$ans" fi $rm_try : see what type file positions are declared as in the library rp="What is the type for file position used by fsetpos()?" set fpos_t fpostype long stdio.h sys/types.h eval $typedef_ask : Check size for Fpos_t echo " " case "$fpostype" in *_t) zzz="$fpostype" ;; *) zzz="fpos_t" ;; esac echo "Checking the size of $zzz..." >&4 cat > try.c < #include #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif int main() { printf("%d\n", (int)sizeof($fpostype)); exit(0); } EOCP set try if eval $compile_ok; then yyy=`$run ./try` case "$yyy" in '') fpossize=4 echo "(I can't execute the test program--guessing $fpossize.)" >&4 ;; *) fpossize=$yyy echo "Your $zzz is $fpossize bytes long." ;; esac else dflt="$longsize" echo " " >&4 echo "(I can't compile the test program. Guessing...)" >&4 rp="What is the size of your file positions (in bytes)?" . ./myread fpossize="$ans" fi : Check for large file support # Backward compatibility (uselfs is deprecated). case "$uselfs" in "$define"|true|[yY]*) cat <&4 *** Configure -Duselfs is deprecated, using -Duselargefiles instead. EOM uselargefiles="$define" ;; esac case "$lseeksize:$fpossize" in 8:8) cat <&4 $cat >try.c < #include int main() { printf("%d\n", (int)sizeof($lseektype)); return(0); } EOCP set try if eval $compile_ok; then lseeksize=`$run ./try` $echo "Your file offsets are now $lseeksize bytes long." else dflt="$lseeksize" echo " " echo "(I can't seem to compile the test program. Guessing...)" rp="What is the size of your file offsets (in bytes)?" . ./myread lseeksize="$ans" fi case "$fpostype" in *_t) zzz="$fpostype" ;; *) zzz="fpos_t" ;; esac $echo $n "Rechecking the size of $zzz...$c" >&4 $cat > try.c < #include #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif int main() { printf("%d\n", (int)sizeof($fpostype)); return(0); } EOCP set try if eval $compile_ok; then yyy=`$run ./try` dflt="$lseeksize" case "$yyy" in '') echo " " echo "(I can't execute the test program--guessing $fpossize.)" >&4 ;; *) fpossize=$yyy echo " $fpossize bytes." >&4 ;; esac else dflt="$fpossize" echo " " echo "(I can't compile the test program. Guessing...)" >&4 rp="What is the size of your file positions (in bytes)?" . ./myread fpossize="$ans" fi $rm_try fi ;; esac : Set the vendorbin variables case "$vendorprefix" in '') d_vendorbin="$undef" vendorbin='' vendorbinexp='' ;; *) d_vendorbin="$define" : determine where vendor-supplied executables go. case "$vendorbin" in '') dflt=$vendorprefix/bin ;; *) dflt="$vendorbin" ;; esac fn=d~+ rp='Pathname for the vendor-supplied executables directory?' . ./getfile vendorbin="$ans" vendorbinexp="$ansexp" ;; esac prefixvar=vendorbin . ./installprefix : Set the vendorhtml1dir variables case "$vendorprefix" in '') vendorhtml1dir='' vendorhtml1direxp='' ;; *) : determine where vendor-supplied html pages go. : There is no standard location, so try to copy the previously-selected : directory structure for the core html pages. : XXX Better default suggestions would be welcome. case "$vendorhtml1dir" in '') dflt=`echo "$html1dir" | $sed "s#^$prefix#$vendorprefix#"` ;; *) dflt=$vendorhtml1dir ;; esac case "$dflt" in ''|' ') dflt=none ;; esac fn=dn+~ rp='Pathname for the vendor-supplied html pages?' . ./getfile vendorhtml1dir="$ans" vendorhtml1direxp="$ansexp" ;; esac : Use ' ' for none so value is preserved next time through Configure $test X"$vendorhtml1dir" = "X" && vendorhtml1dir=' ' prefixvar=vendorhtml1dir . ./installprefix : Set the vendorhtml3dir variables case "$vendorprefix" in '') vendorhtml3dir='' vendorhtml3direxp='' ;; *) : determine where vendor-supplied module html pages go. : There is no standard location, so try to copy the previously-selected : directory structure for the core html pages. : XXX Better default suggestions would be welcome. case "$vendorhtml3dir" in '') dflt=`echo "$html3dir" | $sed "s#^$prefix#$vendorprefix#"` ;; *) dflt=$vendorhtml3dir ;; esac case "$dflt" in ''|' ') dflt=none ;; esac fn=dn+~ rp='Pathname for the vendor-supplied html pages?' . ./getfile vendorhtml3dir="$ans" vendorhtml3direxp="$ansexp" ;; esac : Use ' ' for none so value is preserved next time through Configure $test X"$vendorhtml3dir" = "X" && vendorhtml3dir=' ' prefixvar=vendorhtml3dir . ./installprefix : Set the vendorman1dir variables case "$vendorprefix" in '') vendorman1dir='' vendorman1direxp='' ;; *) : determine where vendor-supplied manual pages go. case "$vendorman1dir" in '') dflt=`echo "$man1dir" | $sed "s#^$prefix#$vendorprefix#"` ;; *) dflt=$vendorman1dir ;; esac case "$dflt" in ''|' ') dflt=none ;; esac fn=nd~+ rp='Pathname for the vendor-supplied manual section 1 pages?' . ./getfile vendorman1dir="$ans" vendorman1direxp="$ansexp" ;; esac : Use ' ' for none so value is preserved next time through Configure $test X"$vendorman1dir" = "X" && vendorman1dir=' ' prefixvar=vendorman1dir . ./installprefix : Set the vendorman3dir variables case "$vendorprefix" in '') vendorman3dir='' vendorman3direxp='' ;; *) : determine where vendor-supplied module manual pages go. case "$vendorman3dir" in '') dflt=`echo "$man3dir" | $sed "s#^$prefix#$vendorprefix#"` ;; *) dflt=$vendorman3dir ;; esac case "$dflt" in ''|' ') dflt=none ;; esac fn=nd~+ rp='Pathname for the vendor-supplied manual section 3 pages?' . ./getfile vendorman3dir="$ans" vendorman3direxp="$ansexp" ;; esac : Use ' ' for none so value is preserved next time through Configure $test X"$vendorman3dir" = "X" && vendorman3dir=' ' prefixvar=vendorman3dir . ./installprefix : Set the vendorscript variables case "$vendorprefix" in '') d_vendorscript="$undef" vendorscript='' vendorscriptexp='' ;; *) d_vendorscript="$define" : determine where vendor-supplied scripts go. case "$vendorscript" in '') dflt=$vendorprefix/script $test -d $dflt || dflt=$vendorbin ;; *) dflt="$vendorscript" ;; esac $cat <warn <msg else cat >msg fi echo "*** WARNING:" >&4 sed -e 's/^/*** /' &4 echo "*** " >&4 cat msg >>config.msg echo " " >>config.msg rm -f msg EOS chmod +x warn $eunicefix warn : see which of string.h or strings.h is needed echo " " strings=`./findhdr string.h` if $test "$strings" && $test -r "$strings"; then echo "Using instead of ." >&4 val="$define" else val="$undef" strings=`./findhdr strings.h` if $test "$strings" && $test -r "$strings"; then echo "Using instead of ." >&4 else ./warn "No string header found -- You'll surely have problems." fi fi set i_string eval $setvar case "$i_string" in "$undef") strings=`./findhdr strings.h`;; *) strings=`./findhdr string.h`;; esac : see if qgcvt exists set qgcvt d_qgcvt eval $inlibc : Check print/scan long double stuff echo " " if $test X"$d_longdbl" = X"$define"; then echo "Checking how to print long doubles..." >&4 if $test X"$sPRIfldbl" = X -a X"$doublesize" = X"$longdblsize"; then $cat >try.c <<'EOCP' #include #include int main() { double d = 123.456; printf("%.3f\n", d); } EOCP set try if eval $compile; then yyy=`$run ./try` case "$yyy" in 123.456) sPRIfldbl='"f"'; sPRIgldbl='"g"'; sPRIeldbl='"e"'; sPRIFUldbl='"F"'; sPRIGUldbl='"G"'; sPRIEUldbl='"E"'; echo "We will use %f." ;; esac fi fi if $test X"$sPRIfldbl" = X; then $cat >try.c <<'EOCP' #include #include int main() { long double d = 123.456; printf("%.3Lf\n", d); } EOCP set try if eval $compile; then yyy=`$run ./try` case "$yyy" in 123.456) sPRIfldbl='"Lf"'; sPRIgldbl='"Lg"'; sPRIeldbl='"Le"'; sPRIFUldbl='"LF"'; sPRIGUldbl='"LG"'; sPRIEUldbl='"LE"'; echo "We will use %Lf." ;; esac fi fi if $test X"$sPRIfldbl" = X; then $cat >try.c <<'EOCP' #include #include int main() { long double d = 123.456; printf("%.3llf\n", d); } EOCP set try if eval $compile; then yyy=`$run ./try` case "$yyy" in 123.456) sPRIfldbl='"llf"'; sPRIgldbl='"llg"'; sPRIeldbl='"lle"'; sPRIFUldbl='"llF"'; sPRIGUldbl='"llG"'; sPRIEUldbl='"llE"'; echo "We will use %llf." ;; esac fi fi if $test X"$sPRIfldbl" = X; then $cat >try.c <<'EOCP' #include #include int main() { long double d = 123.456; printf("%.3lf\n", d); } EOCP set try if eval $compile; then yyy=`$run ./try` case "$yyy" in 123.456) sPRIfldbl='"lf"'; sPRIgldbl='"lg"'; sPRIeldbl='"le"'; sPRIFUldbl='"lF"'; sPRIGUldbl='"lG"'; sPRIEUldbl='"lE"'; echo "We will use %lf." ;; esac fi fi if $test X"$sPRIfldbl" = X; then echo "Cannot figure out how to print long doubles." >&4 else sSCNfldbl=$sPRIfldbl # expect consistency fi $rm_try fi # d_longdbl case "$sPRIfldbl" in '') d_PRIfldbl="$undef"; d_PRIgldbl="$undef"; d_PRIeldbl="$undef"; d_PRIFUldbl="$undef"; d_PRIGUldbl="$undef"; d_PRIEUldbl="$undef"; d_SCNfldbl="$undef"; ;; *) d_PRIfldbl="$define"; d_PRIgldbl="$define"; d_PRIeldbl="$define"; d_PRIFUldbl="$define"; d_PRIGUldbl="$define"; d_PRIEUldbl="$define"; d_SCNfldbl="$define"; ;; esac : Check how to convert floats to strings. if test "X$d_Gconvert" = X; then echo " " echo "Checking for an efficient way to convert floats to strings." echo " " > try.c case "$uselongdouble" in "$define") echo "#define USE_LONG_DOUBLE" >>try.c ;; esac case "$d_longdbl" in "$define") echo "#define HAS_LONG_DOUBLE" >>try.c ;; esac case "$d_PRIgldbl" in "$define") echo "#define HAS_PRIgldbl" >>try.c ;; esac $cat >>try.c < #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif #$i_string I_STRING #ifdef I_STRING # include #else # include #endif int checkit(char *expect, char *got) { if (strcmp(expect, got)) { printf("%s oddity: Expected %s, got %s\n", myname, expect, got); exit(1); } } int main() { char buf[64]; buf[63] = '\0'; /* This must be 1st test on (which?) platform */ /* Alan Burlison */ Gconvert((DOUBLETYPE)0.1, 8, 0, buf); checkit("0.1", buf); Gconvert((DOUBLETYPE)0.01, 8, 0, buf); checkit("0.01", buf); Gconvert((DOUBLETYPE)0.001, 8, 0, buf); checkit("0.001", buf); Gconvert((DOUBLETYPE)0.0001, 8, 0, buf); checkit("0.0001", buf); Gconvert((DOUBLETYPE)0.00009, 8, 0, buf); if (strlen(buf) > 5) checkit("9e-005", buf); /* for Microsoft ?? */ else checkit("9e-05", buf); Gconvert((DOUBLETYPE)1.0, 8, 0, buf); checkit("1", buf); Gconvert((DOUBLETYPE)1.1, 8, 0, buf); checkit("1.1", buf); Gconvert((DOUBLETYPE)1.01, 8, 0, buf); checkit("1.01", buf); Gconvert((DOUBLETYPE)1.001, 8, 0, buf); checkit("1.001", buf); Gconvert((DOUBLETYPE)1.0001, 8, 0, buf); checkit("1.0001", buf); Gconvert((DOUBLETYPE)1.00001, 8, 0, buf); checkit("1.00001", buf); Gconvert((DOUBLETYPE)1.000001, 8, 0, buf); checkit("1.000001", buf); Gconvert((DOUBLETYPE)0.0, 8, 0, buf); checkit("0", buf); Gconvert((DOUBLETYPE)-1.0, 8, 0, buf); checkit("-1", buf); /* Some Linux gcvt's give 1.e+5 here. */ Gconvert((DOUBLETYPE)100000.0, 8, 0, buf); checkit("100000", buf); /* Some Linux gcvt's give -1.e+5 here. */ Gconvert((DOUBLETYPE)-100000.0, 8, 0, buf); checkit("-100000", buf); Gconvert((DOUBLETYPE)123.456, 8, 0, buf); checkit("123.456", buf); /* Testing of 1e+129 in bigintpm.t must not get extra '.' here. */ Gconvert((DOUBLETYPE)1e34, 8, 0, buf); /* 34 should be enough to scare even long double * places into using the e notation. */ if (strlen(buf) > 5) checkit("1e+034", buf); /* for Microsoft */ else checkit("1e+34", buf); /* For Perl, if you add additional tests here, also add them to * t/base/num.t for benefit of platforms not using Configure or * overriding d_Gconvert */ exit(0); } EOP : first add preferred functions to our list xxx_list="" for xxx_convert in $gconvert_preference; do case $xxx_convert in gcvt|gconvert|sprintf) xxx_list="$xxx_list $xxx_convert" ;; *) echo "Discarding unrecognized gconvert_preference $xxx_convert" >&4 ;; esac done : then add any others for xxx_convert in gconvert gcvt sprintf; do case "$xxx_list" in *$xxx_convert*) ;; *) xxx_list="$xxx_list $xxx_convert" ;; esac done case "$d_longdbl$uselongdouble" in "$define$define") : again, add prefered functions to our list first xxx_ld_list="" for xxx_convert in $gconvert_ld_preference; do case $xxx_convert in qgcvt|gcvt|gconvert|sprintf) xxx_ld_list="$xxx_ld_list $xxx_convert" ;; *) echo "Discarding unrecognized gconvert_ld_preference $xxx_convert" ;; esac done : then add qgcvt, sprintf--then, in xxx_list order, gconvert and gcvt for xxx_convert in qgcvt sprintf $xxx_list; do case "$xxx_ld_list" in $xxx_convert*|*" $xxx_convert"*) ;; *) xxx_ld_list="$xxx_ld_list $xxx_convert" ;; esac done : if sprintf cannot do long doubles, move it to the end if test "$d_PRIgldbl" != "$define"; then xxx_ld_list="`echo $xxx_ld_list|sed s/sprintf//` sprintf" fi : if no qgcvt, remove it if test "$d_qgcvt" != "$define"; then xxx_ld_list="`echo $xxx_ld_list|sed s/qgcvt//`" fi : use the ld_list xxx_list="$xxx_ld_list" ;; esac for xxx_convert in $xxx_list; do echo "Trying $xxx_convert..." $rm -f try try$_o core set try -DTRY_$xxx_convert if eval $compile; then echo "$xxx_convert() found." >&4 if $run ./try; then echo "I'll use $xxx_convert to convert floats into a string." >&4 break; else echo "...But $xxx_convert didn't work as I expected." xxx_convert='' fi else echo "$xxx_convert NOT found." >&4 fi done if test X$xxx_convert = X; then echo "*** WHOA THERE!!! ***" >&4 echo "None of ($xxx_list) seemed to work properly. I'll use sprintf." >&4 xxx_convert=sprintf fi case "$xxx_convert" in gconvert) d_Gconvert='gconvert((x),(n),(t),(b))' ;; gcvt) d_Gconvert='gcvt((x),(n),(b))' ;; qgcvt) d_Gconvert='qgcvt((x),(n),(b))' ;; *) case "$uselongdouble$d_longdbl$d_PRIgldbl" in "$define$define$define") d_Gconvert="sprintf((b),\"%.*\"$sPRIgldbl,(n),(x))" ;; "$define$define$undef") d_Gconvert='sprintf((b),"%.*g",(n),(double)(x))' ;; *) d_Gconvert='sprintf((b),"%.*g",(n),(x))' ;; esac ;; esac fi $rm_try : see if _fwalk exists set fwalk d__fwalk eval $inlibc : Initialize h_fcntl h_fcntl=false : Initialize h_sysfile h_sysfile=false : access call always available on UNIX set access d_access eval $inlibc : locate the flags for 'access()' case "$d_access" in "$define") echo " " $cat >access.c < #ifdef I_FCNTL #include #endif #ifdef I_SYS_FILE #include #endif #ifdef I_UNISTD #include #endif #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif int main() { exit(R_OK); } EOCP : check sys/file.h first, no particular reason here if $test `./findhdr sys/file.h` && \ $cc -o access $cppflags -DI_SYS_FILE access.c >/dev/null 2>&1 ; then h_sysfile=true; echo " defines the *_OK access constants." >&4 elif $test `./findhdr fcntl.h` && \ $cc -o access $cppflags -DI_FCNTL access.c >/dev/null 2>&1 ; then h_fcntl=true; echo " defines the *_OK access constants." >&4 elif $test `./findhdr unistd.h` && \ $cc -o access $cppflags -DI_UNISTD access.c >/dev/null 2>&1 ; then echo " defines the *_OK access constants." >&4 else echo "I can't find the four *_OK access constants--I'll use mine." >&4 fi ;; esac $rm -f access* : see if accessx exists set accessx d_accessx eval $inlibc : see if aintl exists set aintl d_aintl eval $inlibc : see if alarm exists set alarm d_alarm eval $inlibc : see if 64bit time functions exists set ctime64 d_ctime64 eval $inlibc set localtime64 d_localtime64 eval $inlibc set gmtime64 d_gmtime64 eval $inlibc set mktime64 d_mktime64 eval $inlibc set difftime64 d_difftime64 eval $inlibc set asctime64 d_asctime64 eval $inlibc : see if POSIX threads are available set pthread.h i_pthread eval $inhdr : define a fucntion to check prototypes $cat > protochk <> protochk <<'EOSH' $rm_try foo="$1" shift while test $# -ge 2; do case "$1" in $define) echo "#include <$2>" >> try.c ;; literal) echo "$2" >> try.c ;; esac # Extra magic for the benefit of systems that need pthread.h # to be included early to correctly detect threadsafe functions. # Such functions must guarantee themselves, though, that the usethreads # and i_pthread have been defined, before calling protochk. if test "$usethreads" = "$define" -a "$i_pthread" = "$define" -a "$pthread_h_first" = "$define" -a "$pthread_h_done" = ""; then echo "#include " >> try.c pthread_h_done=yes fi shift 2 done test "$prototype" = "$define" && echo '#define CAN_PROTOTYPE' >> try.c cat >> try.c <<'EOCP' #ifdef CAN_PROTOTYPE #define _(args) args #else #define _(args) () #endif EOCP echo "$foo" >> try.c echo 'int no_real_function_has_this_name _((void)) { return 0; }' >> try.c $cc $optimize $ccflags -c try.c > /dev/null 2>&1 status=$? $rm_try exit $status EOSH chmod +x protochk $eunicefix protochk : Define hasproto macro for Configure internal use hasproto='varname=$1; func=$2; shift; shift; while $test $# -ge 2; do case "$1" in $define) echo "#include <$2>";; esac ; shift 2; done > try.c; $cppstdin $cppflags $cppminus < try.c > tryout.c 2>/dev/null; if $contains "$func.*(" tryout.c >/dev/null 2>&1; then echo "$func() prototype found."; val="$define"; else echo "$func() prototype NOT found."; val="$undef"; fi; set $varname; eval $setvar; $rm_try tryout.c' : see if sys/types.h has to be included set sys/types.h i_systypes eval $inhdr : see if sys/select.h has to be included set sys/select.h i_sysselct eval $inhdr : Define hasfield macro for Configure internal use hasfield='varname=$1; struct=$2; field=$3; shift; shift; shift; while $test $# -ge 2; do case "$1" in $define) echo "#include <$2>";; esac ; shift 2; done > try.c; echo "int main () { struct $struct foo; char* bar; bar = (char*)foo.$field; }" >> try.c; set try; if eval $compile; then val="$define"; else val="$undef"; fi; set $varname; eval $setvar; $rm_try' : see if we should include time.h, sys/time.h, or both echo " " if test "X$timeincl" = X; then echo "Testing to see if we should include , or both." >&4 $echo $n "I'm now running the test program...$c" $cat >try.c < #ifdef I_TIME #include #endif #ifdef I_SYSTIME #ifdef SYSTIMEKERNEL #define KERNEL #endif #include #endif #ifdef I_SYSSELECT #include #endif #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif int main() { struct tm foo; #ifdef S_TIMEVAL struct timeval bar; #endif #ifdef S_TIMEZONE struct timezone tzp; #endif if (foo.tm_sec == foo.tm_sec) exit(0); #ifdef S_TIMEVAL if (bar.tv_sec == bar.tv_sec) exit(0); #endif exit(1); } EOCP flags='' for s_timezone in '-DS_TIMEZONE' ''; do sysselect='' for s_timeval in '-DS_TIMEVAL' ''; do for i_systimek in '' '-DSYSTIMEKERNEL'; do for i_time in '' '-DI_TIME'; do for i_systime in '-DI_SYSTIME' ''; do case "$flags" in '') $echo $n ".$c" set try $i_time $i_systime $i_systimek $sysselect $s_timeval $s_timezone if eval $compile; then set X $i_time $i_systime $i_systimek $sysselect $s_timeval shift flags="$*" echo " " $echo $n "Succeeded with $flags$c" fi ;; esac done done done done done timeincl='' echo " " case "$flags" in *SYSTIMEKERNEL*) i_systimek="$define" timeincl=`./findhdr sys/time.h` echo "We'll include with KERNEL defined." >&4;; *) i_systimek="$undef";; esac case "$flags" in *I_TIME*) i_time="$define" timeincl=`./findhdr time.h`" $timeincl" echo "We'll include ." >&4;; *) i_time="$undef";; esac case "$flags" in *I_SYSTIME*) i_systime="$define" timeincl=`./findhdr sys/time.h`" $timeincl" echo "We'll include ." >&4;; *) i_systime="$undef";; esac $rm_try fi : see if struct tm knows about tm_zone case "$i_systime$i_time" in *$define*) echo " " echo "Checking to see if your struct tm has tm_zone field..." >&4 set d_tm_tm_zone tm tm_zone $i_systime sys/time.h $i_time time.h eval $hasfield ;; *) val="$undef" set d_tm_tm_zone eval $setvar ;; esac case "$d_tm_tm_zone" in "$define") echo "Yes, it does." ;; *) echo "No, it doesn't." ;; esac : see if struct tm knows about tm_gmtoff case "$i_systime$i_time" in *$define*) echo " " echo "Checking to see if your struct tm has tm_gmtoff field..." >&4 set d_tm_tm_gmtoff tm tm_gmtoff $i_systime sys/time.h $i_time time.h eval $hasfield ;; *) val="$undef" set d_tm_tm_gmtoff eval $setvar ;; esac case "$d_tm_tm_gmtoff" in "$define") echo "Yes, it does." ;; *) echo "No, it doesn't." ;; esac : see if asctime_r exists set asctime_r d_asctime_r eval $inlibc case "$d_asctime_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_time time.h $i_systime sys/time.h" case "$d_asctime_r_proto:$usethreads" in ":define") d_asctime_r_proto=define set d_asctime_r_proto asctime_r $hdrs eval $hasproto ;; *) ;; esac case "$d_asctime_r_proto" in define) case "$asctime_r_proto" in ''|0) try='char* asctime_r(const struct tm*, char*);' ./protochk "$extern_C $try" $hdrs && asctime_r_proto=B_SB ;; esac case "$asctime_r_proto" in ''|0) try='char* asctime_r(const struct tm*, char*, int);' ./protochk "$extern_C $try" $hdrs && asctime_r_proto=B_SBI ;; esac case "$asctime_r_proto" in ''|0) try='int asctime_r(const struct tm*, char*);' ./protochk "$extern_C $try" $hdrs && asctime_r_proto=I_SB ;; esac case "$asctime_r_proto" in ''|0) try='int asctime_r(const struct tm*, char*, int);' ./protochk "$extern_C $try" $hdrs && asctime_r_proto=I_SBI ;; esac case "$asctime_r_proto" in ''|0) d_asctime_r=undef asctime_r_proto=0 echo "Disabling asctime_r, cannot determine prototype." >&4 ;; * ) case "$asctime_r_proto" in REENTRANT_PROTO*) ;; *) asctime_r_proto="REENTRANT_PROTO_$asctime_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "asctime_r has no prototype, not using it." >&4 ;; esac d_asctime_r=undef asctime_r_proto=0 ;; esac ;; *) asctime_r_proto=0 ;; esac : see if atolf exists set atolf d_atolf eval $inlibc : see if atoll exists set atoll d_atoll eval $inlibc : Look for GCC-style attribute format case "$d_attribute_format" in '') echo " " echo "Checking whether your compiler can handle __attribute__((format)) ..." >&4 $cat >attrib.c <<'EOCP' #include void my_special_printf(char* pat,...) __attribute__((__format__(__printf__,1,2))); EOCP if $cc $ccflags -c attrib.c >attrib.out 2>&1 ; then if $contains 'warning' attrib.out >/dev/null 2>&1; then echo "Your C compiler doesn't support __attribute__((format))." val="$undef" else echo "Your C compiler supports __attribute__((format))." val="$define" fi else echo "Your C compiler doesn't seem to understand __attribute__ at all." val="$undef" fi ;; *) val="$d_attribute_format" ;; esac set d_attribute_format eval $setvar $rm -f attrib* : Look for GCC-style attribute format with null format allowed case "$d_printf_format_null" in '') case "$d_attribute_format" in $define) echo " " echo "Checking whether your compiler allows __printf__ format to be null ..." >&4 $cat >attrib.c < #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif int null_printf (char* pat,...) __attribute__((__format__(__printf__,1,2))); int null_printf (char* pat,...) { return (int)pat; } int main () { exit(null_printf(NULL)); } EOCP if $cc $ccflags -o attrib attrib.c >attrib.out 2>&1 ; then : run the executable in case it produces a run-time warning if $run ./attrib >>attrib.out 2>&1; then if $contains 'warning' attrib.out >/dev/null 2>&1; then echo "Your C compiler doesn't allow __printf__ format to be null." val="$undef" else echo "Your C compiler allows __printf__ format to be null." val="$define" fi else echo "Your C compiler executable failed with __printf__ format null." val="$undef" fi else echo "Your C compiler fails with __printf__ format null." val="$undef" fi ;; *) val="$undef" ;; esac ;; *) val="$d_printf_format_null" ;; esac set d_printf_format_null eval $setvar $rm -f attrib* : Look for GCC-style attribute malloc case "$d_attribute_malloc" in '') echo " " echo "Checking whether your compiler can handle __attribute__((malloc)) ..." >&4 $cat >attrib.c <<'EOCP' #include char *go_get_some_memory( int how_many_bytes ) __attribute__((malloc)); EOCP if $cc $ccflags -c attrib.c >attrib.out 2>&1 ; then if $contains 'warning' attrib.out >/dev/null 2>&1; then echo "Your C compiler doesn't support __attribute__((malloc))." val="$undef" else echo "Your C compiler supports __attribute__((malloc))." val="$define" fi else echo "Your C compiler doesn't seem to understand __attribute__ at all." val="$undef" fi ;; *) val="$d_attribute_malloc" ;; esac set d_attribute_malloc eval $setvar $rm -f attrib* : Look for GCC-style attribute nonnull case "$d_attribute_nonnull" in '') echo " " echo "Checking whether your compiler can handle __attribute__((nonnull(1))) ..." >&4 $cat >attrib.c <<'EOCP' #include void do_something (char *some_pointer,...) __attribute__((nonnull(1))); EOCP if $cc $ccflags -c attrib.c >attrib.out 2>&1 ; then if $contains 'warning' attrib.out >/dev/null 2>&1; then echo "Your C compiler doesn't support __attribute__((nonnull))." val="$undef" else echo "Your C compiler supports __attribute__((nonnull))." val="$define" fi else echo "Your C compiler doesn't seem to understand __attribute__ at all." val="$undef" fi ;; *) val="$d_attribute_nonnull" ;; esac set d_attribute_nonnull eval $setvar $rm -f attrib* : Look for GCC-style attribute noreturn case "$d_attribute_noreturn" in '') echo " " echo "Checking whether your compiler can handle __attribute__((noreturn)) ..." >&4 $cat >attrib.c <<'EOCP' #include void fall_over_dead( void ) __attribute__((noreturn)); EOCP if $cc $ccflags -c attrib.c >attrib.out 2>&1 ; then if $contains 'warning' attrib.out >/dev/null 2>&1; then echo "Your C compiler doesn't support __attribute__((noreturn))." val="$undef" else echo "Your C compiler supports __attribute__((noreturn))." val="$define" fi else echo "Your C compiler doesn't seem to understand __attribute__ at all." val="$undef" fi ;; *) val="$d_attribute_noreturn" ;; esac set d_attribute_noreturn eval $setvar $rm -f attrib* : Look for GCC-style attribute pure case "$d_attribute_pure" in '') echo " " echo "Checking whether your compiler can handle __attribute__((pure)) ..." >&4 $cat >attrib.c <<'EOCP' #include int square( int n ) __attribute__((pure)); EOCP if $cc $ccflags -c attrib.c >attrib.out 2>&1 ; then if $contains 'warning' attrib.out >/dev/null 2>&1; then echo "Your C compiler doesn't support __attribute__((pure))." val="$undef" else echo "Your C compiler supports __attribute__((pure))." val="$define" fi else echo "Your C compiler doesn't seem to understand __attribute__ at all." val="$undef" fi ;; *) val="$d_attribute_pure" ;; esac set d_attribute_pure eval $setvar $rm -f attrib* : Look for GCC-style attribute unused case "$d_attribute_unused" in '') echo " " echo "Checking whether your compiler can handle __attribute__((unused)) ..." >&4 $cat >attrib.c <<'EOCP' #include int do_something( int dummy __attribute__((unused)), int n ); EOCP if $cc $ccflags -c attrib.c >attrib.out 2>&1 ; then if $contains 'warning' attrib.out >/dev/null 2>&1; then echo "Your C compiler doesn't support __attribute__((unused))." val="$undef" else echo "Your C compiler supports __attribute__((unused))." val="$define" fi else echo "Your C compiler doesn't seem to understand __attribute__ at all." val="$undef" fi ;; *) val="$d_attribute_unused" ;; esac set d_attribute_unused eval $setvar $rm -f attrib* : Look for GCC-style attribute deprecated case "$d_attribute_deprecated" in '') echo " " echo "Checking whether your compiler can handle __attribute__((deprecated)) ..." >&4 $cat >attrib.c <<'EOCP' #include int I_am_deprecated(void) __attribute__((deprecated)); EOCP if $cc $ccflags -c attrib.c >attrib.out 2>&1 ; then if $contains 'warning' attrib.out >/dev/null 2>&1; then echo "Your C compiler doesn't support __attribute__((deprecated))." val="$undef" else echo "Your C compiler supports __attribute__((deprecated))." val="$define" fi else echo "Your C compiler doesn't seem to understand __attribute__ at all." val="$undef" fi ;; *) val="$d_attribute_deprecated" ;; esac set d_attribute_deprecated eval $setvar $rm -f attrib* : Look for GCC-style attribute warn_unused_result case "$d_attribute_warn_unused_result" in '') echo " " echo "Checking whether your compiler can handle __attribute__((warn_unused_result)) ..." >&4 $cat >attrib.c <<'EOCP' #include int I_will_not_be_ignored(void) __attribute__((warn_unused_result)); EOCP if $cc $ccflags -c attrib.c >attrib.out 2>&1 ; then if $contains 'warning' attrib.out >/dev/null 2>&1; then echo "Your C compiler doesn't support __attribute__((warn_unused_result))." val="$undef" else echo "Your C compiler supports __attribute__((warn_unused_result))." val="$define" fi else echo "Your C compiler doesn't seem to understand __attribute__ at all." val="$undef" fi ;; *) val="$d_attribute_warn_unused_result" ;; esac set d_attribute_warn_unused_result eval $setvar $rm -f attrib* : see if bcmp exists set bcmp d_bcmp eval $inlibc : see if bcopy exists set bcopy d_bcopy eval $inlibc : see if getpgrp exists set getpgrp d_getpgrp eval $inlibc case "$d_getpgrp" in "$define") echo " " echo "Checking to see which flavor of getpgrp is in use..." $cat >try.c < #ifdef I_UNISTD # include #endif #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif int main() { if (getuid() == 0) { printf("(I see you are running Configure as super-user...)\n"); setuid(1); } #ifdef TRY_BSD_PGRP if (getpgrp(1) == 0) exit(0); #else if (getpgrp() > 0) exit(0); #endif exit(1); } EOP if $cc -o try -DTRY_BSD_PGRP $ccflags $ldflags try.c $libs >/dev/null 2>&1 && $run ./try; then echo "You have to use getpgrp(pid) instead of getpgrp()." >&4 val="$define" elif $cc -o try $ccflags $ldflags try.c $libs >/dev/null 2>&1 && $run ./try; then echo "You have to use getpgrp() instead of getpgrp(pid)." >&4 val="$undef" else echo "I can't seem to compile and run the test program." if ./usg; then xxx="a USG one, i.e. you use getpgrp()." else # SVR4 systems can appear rather BSD-ish. case "$i_unistd" in $undef) xxx="a BSD one, i.e. you use getpgrp(pid)." val="$define" ;; $define) xxx="probably a USG one, i.e. you use getpgrp()." val="$undef" ;; esac fi echo "Assuming your getpgrp is $xxx" >&4 fi ;; *) val="$undef";; esac set d_bsdgetpgrp eval $setvar $rm_try : see if setpgrp exists set setpgrp d_setpgrp eval $inlibc case "$d_setpgrp" in "$define") echo " " echo "Checking to see which flavor of setpgrp is in use..." $cat >try.c < #ifdef I_UNISTD # include #endif #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif int main() { if (getuid() == 0) { printf("(I see you are running Configure as super-user...)\n"); setuid(1); } #ifdef TRY_BSD_PGRP if (-1 == setpgrp(1, 1)) exit(0); #else if (setpgrp() != -1) exit(0); #endif exit(1); } EOP if $cc -o try -DTRY_BSD_PGRP $ccflags $ldflags try.c $libs >/dev/null 2>&1 && $run ./try; then echo 'You have to use setpgrp(pid,pgrp) instead of setpgrp().' >&4 val="$define" elif $cc -o try $ccflags $ldflags try.c $libs >/dev/null 2>&1 && $run ./try; then echo 'You have to use setpgrp() instead of setpgrp(pid,pgrp).' >&4 val="$undef" else echo "(I can't seem to compile and run the test program.)" if ./usg; then xxx="a USG one, i.e. you use setpgrp()." else # SVR4 systems can appear rather BSD-ish. case "$i_unistd" in $undef) xxx="a BSD one, i.e. you use setpgrp(pid,pgrp)." val="$define" ;; $define) xxx="probably a USG one, i.e. you use setpgrp()." val="$undef" ;; esac fi echo "Assuming your setpgrp is $xxx" >&4 fi ;; *) val="$undef";; esac set d_bsdsetpgrp eval $setvar $rm_try : Look for GCC-style __builtin_choose_expr case "$d_builtin_choose_expr" in '') echo " " echo "Checking whether your compiler can handle __builtin_choose_expr ..." >&4 $cat >try.c <<'EOCP' #include #include #include #define SYRINX(x) __builtin_choose_expr( x, (1056*2), (103*50) ) int main(void) { assert( SYRINX(1) == 2112 ); assert( SYRINX(1) != 5150 ); assert( SYRINX(0) == 5150 ); assert( SYRINX(0) != 2112 ); puts( "All good!" ); exit(0); } EOCP set try if eval $compile && $run ./try; then echo "Your C compiler supports __builtin_choose_expr." val="$define" else echo "Your C compiler doesn't seem to understand __builtin_choose_expr." val="$undef" fi ;; *) val="$d_builtin_choose_expr" ;; esac set d_builtin_choose_expr eval $setvar $rm_try : Look for GCC-style __builtin_expect case "$d_builtin_expect" in '') echo " " echo "Checking whether your compiler can handle __builtin_expect ..." >&4 $cat >try.c <<'EOCP' int main(void) { int n = 50; if ( __builtin_expect(n, 0) ) n = 1; /* Remember shell exit code truth is 0, C truth is non-zero */ return !(n == 1); } EOCP set try if eval $compile && $run ./try; then echo "Your C compiler supports __builtin_expect." val="$define" else echo "Your C compiler doesn't seem to understand __builtin_expect." val="$undef" fi ;; *) val="$d_builtin_expect" ;; esac set d_builtin_expect eval $setvar $rm_try : see if bzero exists set bzero d_bzero eval $inlibc : see if stdarg is available echo " " if $test `./findhdr stdarg.h`; then echo " found." >&4 valstd="$define" else echo " NOT found." >&4 valstd="$undef" fi : see if varags is available echo " " if $test `./findhdr varargs.h`; then echo " found." >&4 else echo " NOT found, but that's ok (I hope)." >&4 fi : set up the varargs testing programs $cat > varargs.c < #endif #ifdef I_VARARGS #include #endif #ifdef I_STDARG int f(char *p, ...) #else int f(va_alist) va_dcl #endif { va_list ap; #ifndef I_STDARG char *p; #endif #ifdef I_STDARG va_start(ap,p); #else va_start(ap); p = va_arg(ap, char *); #endif va_end(ap); return 0; } EOP $cat > varargs </dev/null 2>&1; then echo "true" else echo "false" fi $rm -f varargs$_o EOP chmod +x varargs : now check which varargs header should be included echo " " i_varhdr='' case "$valstd" in "$define") if `./varargs I_STDARG`; then val='stdarg.h' elif `./varargs I_VARARGS`; then val='varargs.h' fi ;; *) if `./varargs I_VARARGS`; then val='varargs.h' fi ;; esac case "$val" in '') echo "I could not find the definition for va_dcl... You have problems..." >&4 val="$undef"; set i_stdarg; eval $setvar val="$undef"; set i_varargs; eval $setvar ;; *) set i_varhdr eval $setvar case "$i_varhdr" in stdarg.h) val="$define"; set i_stdarg; eval $setvar val="$undef"; set i_varargs; eval $setvar ;; varargs.h) val="$undef"; set i_stdarg; eval $setvar val="$define"; set i_varargs; eval $setvar ;; esac echo "We'll include <$i_varhdr> to get va_dcl definition." >&4;; esac $rm -f varargs* : see if the Compiler supports C99 variadic macros case "$i_stdarg$i_stdlib" in "$define$define") echo "You have and , so checking for C99 variadic macros." >&4 $cat >try.c < #include #define foo(buffer, format, ...) sprintf(buffer, format, __VA_ARGS__) int main() { char buf[20]; foo(buf, "%d %g %.*s", 123, 456.0, (int)3, "789fail"); puts(buf); return 0; } EOCP set try if eval $compile && $run ./try 2>&1 >/dev/null; then case "`$run ./try`" in "123 456 789") echo "You have C99 variadic macros." >&4 d_c99_variadic_macros="$define" ;; *) echo "You don't have functional C99 variadic macros." >&4 d_c99_variadic_macros="$undef" ;; esac else echo "I couldn't compile and run the test program, so I assume that you don't have functional C99 variadic macros." >&4 d_c99_variadic_macros="$undef" fi $rm_try ;; *) echo "You don't have and , so not checking for C99 variadic macros." >&4 d_c99_variadic_macros="$undef" ;; esac : see if signal is declared as pointer to function returning int or void echo " " xxx=`./findhdr signal.h` $test "$xxx" && $cppstdin $cppminus $cppflags < $xxx >$$.tmp 2>/dev/null if $contains 'int.*\*[ ]*signal' $$.tmp >/dev/null 2>&1 ; then echo "You have int (*signal())() instead of void." >&4 val="$undef" elif $contains 'void.*\*[ ]*signal' $$.tmp >/dev/null 2>&1 ; then echo "You have void (*signal())()." >&4 val="$define" elif $contains 'extern[ ]*[(\*]*signal' $$.tmp >/dev/null 2>&1 ; then echo "You have int (*signal())() instead of void." >&4 val="$undef" elif $contains 'void.*\*.*sig' $$.tmp >/dev/null 2>&1 ; then echo "You have void (*signal())()." >&4 val="$define" else case "$d_voidsig" in '') echo "I can't determine whether signal handler returns void or int..." >&4 dflt=void rp="What type does your signal handler return?" . ./myread case "$ans" in v*) val="$define";; *) val="$undef";; esac;; "$define") echo "As you already told me, signal handler returns void." >&4 val="$define" ;; *) echo "As you already told me, signal handler returns int." >&4 val="$undef" ;; esac fi set d_voidsig eval $setvar case "$d_voidsig" in "$define") signal_t="void";; *) signal_t="int";; esac $rm -f $$.tmp : check for ability to cast large floats to 32-bit ints. echo " " echo 'Checking whether your C compiler can cast large floats to int32.' >&4 if $test "$intsize" -ge 4; then xxx=int else xxx=long fi $cat >try.c < #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif #include #include $signal_t blech(int s) { exit(3); } int main() { $xxx i32; double f, g; int result = 0; char str[16]; signal(SIGFPE, blech); /* Don't let compiler optimize the test away. Store the number in a writable string for gcc to pass to sscanf under HP-UX. */ sprintf(str, "2147483647"); sscanf(str, "%lf", &f); /* f = (double) 0x7fffffff; */ g = 10 * f; i32 = ($xxx) g; /* x86 processors will probably give 0x8000 0000, which is a sign change. We don't want that. We want to mimic SPARC behavior here, which is to preserve the sign and give back 0x7fff ffff. */ if (i32 != ($xxx) f) result |= 1; exit(result); } EOCP set try if eval $compile_ok; then $run ./try yyy=$? else echo "(I can't seem to compile the test program--assuming it can't)" yyy=1 fi case "$yyy" in 0) val="$define" echo "Yup, it can." ;; *) val="$undef" echo "Nope, it can't." ;; esac set d_casti32 eval $setvar $rm_try : check for ability to cast negative floats to unsigned echo " " echo 'Checking whether your C compiler can cast negative float to unsigned.' >&4 $cat >try.c < #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif #include #include $signal_t blech(int s) { exit(7); } $signal_t blech_in_list(int s) { exit(4); } unsigned long dummy_long(unsigned long p) { return p; } unsigned int dummy_int(unsigned int p) { return p; } unsigned short dummy_short(unsigned short p) { return p; } int main() { double f; unsigned long along; unsigned int aint; unsigned short ashort; int result = 0; char str[16]; /* Frustrate gcc-2.7.2's optimizer which failed this test with a direct f = -123. assignment. gcc-2.8.0 reportedly optimized the whole file away */ /* Store the number in a writable string for gcc to pass to sscanf under HP-UX. */ sprintf(str, "-123"); sscanf(str, "%lf", &f); /* f = -123.; */ signal(SIGFPE, blech); along = (unsigned long)f; aint = (unsigned int)f; ashort = (unsigned short)f; if (along != (unsigned long)-123) result |= 1; if (aint != (unsigned int)-123) result |= 1; if (ashort != (unsigned short)-123) result |= 1; sprintf(str, "1073741824."); sscanf(str, "%lf", &f); /* f = (double)0x40000000; */ f = f + f; along = 0; along = (unsigned long)f; if (along != 0x80000000) result |= 2; f -= 1.; along = 0; along = (unsigned long)f; if (along != 0x7fffffff) result |= 1; f += 2.; along = 0; along = (unsigned long)f; if (along != 0x80000001) result |= 2; if (result) exit(result); signal(SIGFPE, blech_in_list); sprintf(str, "123."); sscanf(str, "%lf", &f); /* f = 123.; */ along = dummy_long((unsigned long)f); aint = dummy_int((unsigned int)f); ashort = dummy_short((unsigned short)f); if (along != (unsigned long)123) result |= 4; if (aint != (unsigned int)123) result |= 4; if (ashort != (unsigned short)123) result |= 4; exit(result); } EOCP set try if eval $compile_ok; then $run ./try castflags=$? else echo "(I can't seem to compile the test program--assuming it can't)" castflags=7 fi case "$castflags" in 0) val="$define" echo "Yup, it can." ;; *) val="$undef" echo "Nope, it can't." ;; esac set d_castneg eval $setvar $rm_try : see if vprintf exists echo " " if set vprintf val -f d_vprintf; eval $csym; $val; then echo 'vprintf() found.' >&4 val="$define" $cat >try.c < #else /* I_VARARGS */ # include #endif #ifdef I_UNISTD # include #endif #ifdef I_STDLIB # include #endif #include /* vsprintf prototype */ #ifdef I_STDARG void xxx(int n, ...) { va_list args; char buf[10]; va_start(args, n); exit((unsigned long)vsprintf(buf,"%s",args) > 10L); } int main() { xxx(1, "foo"); } #else /* I_VARARGS */ xxx(va_alist) va_dcl { va_list args; char buf[10]; va_start(args); exit((unsigned long)vsprintf(buf,"%s",args) > 10L); } int main() { xxx("foo"); } #endif EOF set try if eval $compile_ok; then if $run ./try; then echo "Your vsprintf() returns (int)." >&4 val2="$undef" else echo "Your vsprintf() returns (char*)." >&4 val2="$define" fi else echo 'I am unable to compile the vsprintf() test program.' >&4 # We shouldn't get here. If we do, assume the standard signature, # not the old BSD one. echo 'Guessing that vsprintf() returns (int).' >&4 val2="$undef" fi else echo 'vprintf() NOT found.' >&4 val="$undef" val2="$undef" fi $rm_try set d_vprintf eval $setvar val=$val2 set d_charvspr eval $setvar : see if chown exists set chown d_chown eval $inlibc : see if chroot exists set chroot d_chroot eval $inlibc : see if chsize exists set chsize d_chsize eval $inlibc : see if class exists set class d_class eval $inlibc : see if clearenv exists set clearenv d_clearenv eval $inlibc : Define hasstruct macro for Configure internal use hasstruct='varname=$1; struct=$2; shift; shift; while $test $# -ge 2; do case "$1" in $define) echo "#include <$2>";; esac ; shift 2; done > try.c; echo "int main () { struct $struct foo; }" >> try.c; set try; if eval $compile; then val="$define"; else val="$undef"; fi; set $varname; eval $setvar; $rm_try' : see whether socket exists socketlib='' sockethdr='' echo " " $echo $n "Hmm... $c" >&4 if set socket val -f d_socket; eval $csym; $val; then echo "Looks like you have Berkeley networking support." >&4 d_socket="$define" if set setsockopt val -f; eval $csym; $val; then d_oldsock="$undef" else echo "...but it uses the old BSD 4.1c interface, rather than 4.2." >&4 d_oldsock="$define" fi else if $contains socklib libc.list >/dev/null 2>&1; then echo "Looks like you have Berkeley networking support." >&4 d_socket="$define" : we will have to assume that it supports the 4.2 BSD interface d_oldsock="$undef" else echo "You don't have Berkeley networking in libc$_a..." >&4 if test "X$d_socket" = "X$define"; then echo "...but you seem to believe that you have sockets." >&4 else for net in net socket do if test -f /usr/lib/lib$net$_a; then ( ($nm $nm_opt /usr/lib/lib$net$_a | eval $nm_extract) || \ $ar t /usr/lib/lib$net$_a) 2>/dev/null >> libc.list if $contains socket libc.list >/dev/null 2>&1; then d_socket="$define" socketlib="-l$net" case "$net" in net) echo "...but the Wollongong group seems to have hacked it in." >&4 sockethdr="-I/usr/netinclude" ;; esac echo "Found Berkeley sockets interface in lib$net." >&4 if $contains setsockopt libc.list >/dev/null 2>&1; then d_oldsock="$undef" else echo "...using the old BSD 4.1c interface, rather than 4.2." >&4 d_oldsock="$define" fi break fi fi done if test "X$d_socket" != "X$define"; then echo "or anywhere else I see." >&4 d_socket="$undef" d_oldsock="$undef" fi fi fi fi : see if socketpair exists set socketpair d_sockpair eval $inlibc echo " " echo "Checking the availability of certain socket constants..." >&4 for ENUM in MSG_CTRUNC MSG_DONTROUTE MSG_OOB MSG_PEEK MSG_PROXY SCM_RIGHTS; do enum=`$echo $ENUM|./tr '[A-Z]' '[a-z]'` $cat >try.c < #include int main() { int i = $ENUM; } EOF val="$undef" set try; if eval $compile; then val="$define" fi set d_${enum}; eval $setvar $rm_try done : see if this is a sys/uio.h system set sys/uio.h i_sysuio eval $inhdr : Check for cmsghdr support echo " " echo "Checking to see if your system supports struct cmsghdr..." >&4 set d_cmsghdr_s cmsghdr $i_systypes sys/types.h $d_socket sys/socket.h $i_sysuio sys/uio.h eval $hasstruct case "$d_cmsghdr_s" in "$define") echo "Yes, it does." ;; *) echo "No, it doesn't." ;; esac : check for const keyword echo " " echo 'Checking to see if your C compiler knows about "const"...' >&4 $cat >const.c <<'EOCP' typedef struct spug { int drokk; } spug; int main() { const char *foo; const spug y = { 0 }; } EOCP if $cc -c $ccflags const.c >/dev/null 2>&1 ; then val="$define" echo "Yup, it does." else val="$undef" echo "Nope, it doesn't." fi set d_const eval $setvar : see if copysignl exists set copysignl d_copysignl eval $inlibc : see if crypt exists echo " " set crypt d_crypt eval $inlibc case "$d_crypt" in $define) cryptlib='' ;; *) if set crypt val -f d_crypt; eval $csym; $val; then echo 'crypt() found.' >&4 val="$define" cryptlib='' else cryptlib=`./loc Slibcrypt$_a "" $xlibpth` if $test -z "$cryptlib"; then cryptlib=`./loc Mlibcrypt$_a "" $xlibpth` else cryptlib=-lcrypt fi if $test -z "$cryptlib"; then cryptlib=`./loc Llibcrypt$_a "" $xlibpth` else cryptlib=-lcrypt fi if $test -z "$cryptlib"; then cryptlib=`./loc libcrypt$_a "" $libpth` else cryptlib=-lcrypt fi if $test -z "$cryptlib"; then echo 'crypt() NOT found.' >&4 val="$undef" else val="$define" fi fi set d_crypt eval $setvar ;; esac : see if this is a crypt.h system set crypt.h i_crypt eval $inhdr : see if crypt_r exists set crypt_r d_crypt_r eval $inlibc case "$d_crypt_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_crypt crypt.h" case "$d_crypt_r_proto:$usethreads" in ":define") d_crypt_r_proto=define set d_crypt_r_proto crypt_r $hdrs eval $hasproto ;; *) ;; esac case "$d_crypt_r_proto" in define) case "$crypt_r_proto" in ''|0) try='char* crypt_r(const char*, const char*, struct crypt_data*);' ./protochk "$extern_C $try" $hdrs && crypt_r_proto=B_CCS ;; esac case "$crypt_r_proto" in ''|0) try='char* crypt_r(const char*, const char*, CRYPTD*);' ./protochk "$extern_C $try" $hdrs && crypt_r_proto=B_CCD ;; esac case "$crypt_r_proto" in ''|0) d_crypt_r=undef crypt_r_proto=0 echo "Disabling crypt_r, cannot determine prototype." >&4 ;; * ) case "$crypt_r_proto" in REENTRANT_PROTO*) ;; *) crypt_r_proto="REENTRANT_PROTO_$crypt_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "crypt_r has no prototype, not using it." >&4 ;; esac d_crypt_r=undef crypt_r_proto=0 ;; esac ;; *) crypt_r_proto=0 ;; esac : get csh whereabouts case "$csh" in 'csh') val="$undef" ;; *) val="$define" ;; esac set d_csh eval $setvar : Respect a hint or command line value for full_csh. case "$full_csh" in '') full_csh=$csh ;; esac : see if ctermid exists set ctermid d_ctermid eval $inlibc : see if ctermid_r exists set ctermid_r d_ctermid_r eval $inlibc case "$d_ctermid_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h " case "$d_ctermid_r_proto:$usethreads" in ":define") d_ctermid_r_proto=define set d_ctermid_r_proto ctermid_r $hdrs eval $hasproto ;; *) ;; esac case "$d_ctermid_r_proto" in define) case "$ctermid_r_proto" in ''|0) try='char* ctermid_r(char*);' ./protochk "$extern_C $try" $hdrs && ctermid_r_proto=B_B ;; esac case "$ctermid_r_proto" in ''|0) d_ctermid_r=undef ctermid_r_proto=0 echo "Disabling ctermid_r, cannot determine prototype." >&4 ;; * ) case "$ctermid_r_proto" in REENTRANT_PROTO*) ;; *) ctermid_r_proto="REENTRANT_PROTO_$ctermid_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "ctermid_r has no prototype, not using it." >&4 ;; esac d_ctermid_r=undef ctermid_r_proto=0 ;; esac ;; *) ctermid_r_proto=0 ;; esac : see if ctime_r exists set ctime_r d_ctime_r eval $inlibc case "$d_ctime_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_time time.h $i_systime sys/time.h" case "$d_ctime_r_proto:$usethreads" in ":define") d_ctime_r_proto=define set d_ctime_r_proto ctime_r $hdrs eval $hasproto ;; *) ;; esac case "$d_ctime_r_proto" in define) case "$ctime_r_proto" in ''|0) try='char* ctime_r(const time_t*, char*);' ./protochk "$extern_C $try" $hdrs && ctime_r_proto=B_SB ;; esac case "$ctime_r_proto" in ''|0) try='char* ctime_r(const time_t*, char*, int);' ./protochk "$extern_C $try" $hdrs && ctime_r_proto=B_SBI ;; esac case "$ctime_r_proto" in ''|0) try='int ctime_r(const time_t*, char*);' ./protochk "$extern_C $try" $hdrs && ctime_r_proto=I_SB ;; esac case "$ctime_r_proto" in ''|0) try='int ctime_r(const time_t*, char*, int);' ./protochk "$extern_C $try" $hdrs && ctime_r_proto=I_SBI ;; esac case "$ctime_r_proto" in ''|0) d_ctime_r=undef ctime_r_proto=0 echo "Disabling ctime_r, cannot determine prototype." >&4 ;; * ) case "$ctime_r_proto" in REENTRANT_PROTO*) ;; *) ctime_r_proto="REENTRANT_PROTO_$ctime_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "ctime_r has no prototype, not using it." >&4 ;; esac d_ctime_r=undef ctime_r_proto=0 ;; esac ;; *) ctime_r_proto=0 ;; esac : see if cuserid exists set cuserid d_cuserid eval $inlibc : see if this is a limits.h system set limits.h i_limits eval $inhdr : see if this is a float.h system set float.h i_float eval $inhdr : See if number of significant digits in a double precision number is known echo " " $cat >dbl_dig.c < #endif #ifdef I_FLOAT #include #endif #ifdef DBL_DIG printf("Contains DBL_DIG"); #endif EOM $cppstdin $cppflags $cppminus < dbl_dig.c >dbl_dig.E 2>/dev/null if $contains 'DBL_DIG' dbl_dig.E >/dev/null 2>&1; then echo "DBL_DIG found." >&4 val="$define" else echo "DBL_DIG NOT found." >&4 val="$undef" fi $rm -f dbl_dig.? set d_dbl_dig eval $setvar : see if dbm.h is available : see if dbmclose exists set dbmclose d_dbmclose eval $inlibc case "$d_dbmclose" in $define) set dbm.h i_dbm eval $inhdr case "$i_dbm" in $define) val="$undef" set i_rpcsvcdbm eval $setvar ;; *) set rpcsvc/dbm.h i_rpcsvcdbm eval $inhdr ;; esac ;; *) echo "We won't be including " val="$undef" set i_dbm eval $setvar val="$undef" set i_rpcsvcdbm eval $setvar ;; esac : see if prototype for dbminit is available echo " " set d_dbminitproto dbminit $i_dbm dbm.h eval $hasproto : see if difftime exists set difftime d_difftime eval $inlibc : see if this is a dirent system echo " " if xinc=`./findhdr dirent.h`; $test "$xinc"; then val="$define" echo " found." >&4 else val="$undef" if xinc=`./findhdr sys/dir.h`; $test "$xinc"; then echo " found." >&4 echo " " else xinc=`./findhdr sys/ndir.h` fi echo " NOT found." >&4 fi set i_dirent eval $setvar : Look for type of directory structure. echo " " $cppstdin $cppflags $cppminus < "$xinc" > try.c case "$direntrytype" in ''|' ') case "$i_dirent" in $define) guess1='struct dirent' ;; *) guess1='struct direct' ;; esac ;; *) guess1="$direntrytype" ;; esac case "$guess1" in 'struct dirent') guess2='struct direct' ;; *) guess2='struct dirent' ;; esac if $contains "$guess1" try.c >/dev/null 2>&1; then direntrytype="$guess1" echo "Your directory entries are $direntrytype." >&4 elif $contains "$guess2" try.c >/dev/null 2>&1; then direntrytype="$guess2" echo "Your directory entries seem to be $direntrytype." >&4 else echo "I don't recognize your system's directory entries." >&4 rp="What type is used for directory entries on this system?" dflt="$guess1" . ./myread direntrytype="$ans" fi $rm_try : see if the directory entry stores field length echo " " $cppstdin $cppflags $cppminus < "$xinc" > try.c if $contains 'd_namlen' try.c >/dev/null 2>&1; then echo "Good, your directory entry keeps length information in d_namlen." >&4 val="$define" else echo "Your directory entry does not know about the d_namlen field." >&4 val="$undef" fi set d_dirnamlen eval $setvar $rm_try : Look for DIR.dd_fd case "$i_dirent" in "$define") echo "Checking to see if DIR has a dd_fd member variable" >&4 $cat >try.c < #endif #include int main() { DIR dir; dir.dd_fd = 1; return 0; } EOCP val=$undef set try if eval $compile; then echo "Yes, it does." val="$define" else echo "No, it does not." val="$undef" fi ;; *) echo "You don't have a , so not checking for dd_fd." >&4 val="$undef" ;; esac set d_dir_dd_fd eval $setvar $rm_try : see if this is an sysdir system set sys/dir.h i_sysdir eval $inhdr : see if this is an sysndir system set sys/ndir.h i_sysndir eval $inhdr : Look for dirfd echo " " $cat >dirfd.c < #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif #$i_dirent I_DIRENT /**/ #$i_sysdir I_SYS_DIR /**/ #$i_sysndir I_SYS_NDIR /**/ #$i_systypes I_SYS_TYPES /**/ #if defined(I_SYS_TYPES) #include #endif #if defined(I_DIRENT) #include #if defined(NeXT) && defined(I_SYS_DIR) /* NeXT needs dirent + sys/dir.h */ #include #endif #else #ifdef I_SYS_NDIR #include #else #ifdef I_SYS_DIR #ifdef hp9000s500 #include /* may be wrong in the future */ #else #include #endif #endif #endif #endif int main() { DIR *dirp = opendir("."); if (dirfd(dirp) >= 0) exit(0); else exit(1); } EOM val=$undef set dirfd if eval $compile; then val="$define" fi case "$val" in $define) echo "dirfd() found." >&4 ;; *) echo "dirfd() NOT found." >&4 ;; esac set d_dirfd eval $setvar $rm -f dirfd* : see if dlerror exists xxx_runnm="$runnm" runnm=false set dlerror d_dlerror eval $inlibc runnm="$xxx_runnm" : see if dlfcn is available set dlfcn.h i_dlfcn eval $inhdr : Check what extension to use for shared libs case "$usedl" in $define|y|true) $cat << EOM On a few systems, the dynamically loaded modules that perl generates and uses will need a different extension than shared libs. The default will probably be appropriate. EOM case "$dlext" in '') dflt="$so" ;; *) dflt="$dlext" ;; esac rp='What is the extension of dynamically loaded modules' . ./myread dlext="$ans" ;; *) dlext="none" ;; esac : Check if dlsym need a leading underscore echo " " val="$undef" case "$dlsrc" in dl_dlopen.xs) echo "Checking whether your dlsym() needs a leading underscore ..." >&4 $cat >dyna.c <<'EOM' fred () { } EOM $cat >fred.c< #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif #$i_dlfcn I_DLFCN #ifdef I_DLFCN #include /* the dynamic linker include file for SunOS/Solaris */ #else #include #include #include #endif extern int fred() ; int main() { void * handle ; void * symbol ; #ifndef RTLD_LAZY int mode = 1 ; #else int mode = RTLD_LAZY ; #endif handle = dlopen("./dyna.$dlext", mode) ; if (handle == NULL) { printf ("1\n") ; fflush (stdout) ; exit(0); } symbol = dlsym(handle, "fred") ; if (symbol == NULL) { /* try putting a leading underscore */ symbol = dlsym(handle, "_fred") ; if (symbol == NULL) { printf ("2\n") ; fflush (stdout) ; exit(0); } printf ("3\n") ; } else printf ("4\n") ; fflush (stdout) ; exit(0); } EOM : Call the object file tmp-dyna.o in case dlext=o. if $cc $ccflags $cccdlflags -c dyna.c > /dev/null 2>&1 && mv dyna${_o} tmp-dyna${_o} > /dev/null 2>&1 && $ld -o dyna.$dlext $ldflags $lddlflags tmp-dyna${_o} > /dev/null 2>&1 && $cc -o fred $ccflags $ldflags $cccdlflags $ccdlflags fred.c $libs > /dev/null 2>&1 && $to dyna.$dlext; then xxx=`$run ./fred` case $xxx in 1) echo "Test program failed using dlopen." >&4 echo "Perhaps you should not use dynamic loading." >&4;; 2) echo "Test program failed using dlsym." >&4 echo "Perhaps you should not use dynamic loading." >&4;; 3) echo "dlsym needs a leading underscore" >&4 val="$define" ;; 4) echo "dlsym doesn't need a leading underscore." >&4;; esac else echo "I can't compile and run the test program." >&4 echo "I'm guessing that dlsym doesn't need a leading underscore." >&4 fi ;; esac $rm -f fred fred.* dyna.$dlext dyna.* tmp-dyna.* set d_dlsymun eval $setvar : see if drand48_r exists set drand48_r d_drand48_r eval $inlibc case "$d_drand48_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_stdlib stdlib.h" case "$d_drand48_r_proto:$usethreads" in ":define") d_drand48_r_proto=define set d_drand48_r_proto drand48_r $hdrs eval $hasproto ;; *) ;; esac case "$d_drand48_r_proto" in define) case "$drand48_r_proto" in ''|0) try='int drand48_r(struct drand48_data*, double*);' ./protochk "$extern_C $try" $hdrs && drand48_r_proto=I_ST ;; esac case "$drand48_r_proto" in ''|0) d_drand48_r=undef drand48_r_proto=0 echo "Disabling drand48_r, cannot determine prototype." >&4 ;; * ) case "$drand48_r_proto" in REENTRANT_PROTO*) ;; *) drand48_r_proto="REENTRANT_PROTO_$drand48_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "drand48_r has no prototype, not using it." >&4 ;; esac d_drand48_r=undef drand48_r_proto=0 ;; esac ;; *) drand48_r_proto=0 ;; esac : see if prototype for drand48 is available echo " " set d_drand48proto drand48 $i_stdlib stdlib.h $i_unistd unistd.h eval $hasproto : see if dup2 exists set dup2 d_dup2 eval $inlibc : see if eaccess exists set eaccess d_eaccess eval $inlibc : see if endgrent exists set endgrent d_endgrent eval $inlibc : see if this is an grp system set grp.h i_grp eval $inhdr case "$i_grp" in $define) xxx=`./findhdr grp.h` $cppstdin $cppflags $cppminus < $xxx >$$.h if $contains 'gr_passwd' $$.h >/dev/null 2>&1; then val="$define" else val="$undef" fi set d_grpasswd eval $setvar $rm -f $$.h ;; *) val="$undef"; set d_grpasswd; eval $setvar ;; esac : see if endgrent_r exists set endgrent_r d_endgrent_r eval $inlibc case "$d_endgrent_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_grp grp.h" case "$d_endgrent_r_proto:$usethreads" in ":define") d_endgrent_r_proto=define set d_endgrent_r_proto endgrent_r $hdrs eval $hasproto ;; *) ;; esac case "$d_endgrent_r_proto" in define) case "$endgrent_r_proto" in ''|0) try='int endgrent_r(FILE**);' ./protochk "$extern_C $try" $hdrs && endgrent_r_proto=I_H ;; esac case "$endgrent_r_proto" in ''|0) try='void endgrent_r(FILE**);' ./protochk "$extern_C $try" $hdrs && endgrent_r_proto=V_H ;; esac case "$endgrent_r_proto" in ''|0) d_endgrent_r=undef endgrent_r_proto=0 echo "Disabling endgrent_r, cannot determine prototype." >&4 ;; * ) case "$endgrent_r_proto" in REENTRANT_PROTO*) ;; *) endgrent_r_proto="REENTRANT_PROTO_$endgrent_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "endgrent_r has no prototype, not using it." >&4 ;; esac d_endgrent_r=undef endgrent_r_proto=0 ;; esac ;; *) endgrent_r_proto=0 ;; esac : see if endhostent exists set endhostent d_endhent eval $inlibc : see if this is a netdb.h system set netdb.h i_netdb eval $inhdr : see if endhostent_r exists set endhostent_r d_endhostent_r eval $inlibc case "$d_endhostent_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_netdb netdb.h" case "$d_endhostent_r_proto:$usethreads" in ":define") d_endhostent_r_proto=define set d_endhostent_r_proto endhostent_r $hdrs eval $hasproto ;; *) ;; esac case "$d_endhostent_r_proto" in define) case "$endhostent_r_proto" in ''|0) try='int endhostent_r(struct hostent_data*);' ./protochk "$extern_C $try" $hdrs && endhostent_r_proto=I_D ;; esac case "$endhostent_r_proto" in ''|0) try='void endhostent_r(struct hostent_data*);' ./protochk "$extern_C $try" $hdrs && endhostent_r_proto=V_D ;; esac case "$endhostent_r_proto" in ''|0) d_endhostent_r=undef endhostent_r_proto=0 echo "Disabling endhostent_r, cannot determine prototype." >&4 ;; * ) case "$endhostent_r_proto" in REENTRANT_PROTO*) ;; *) endhostent_r_proto="REENTRANT_PROTO_$endhostent_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "endhostent_r has no prototype, not using it." >&4 ;; esac d_endhostent_r=undef endhostent_r_proto=0 ;; esac ;; *) endhostent_r_proto=0 ;; esac : see if endnetent exists set endnetent d_endnent eval $inlibc : see if endnetent_r exists set endnetent_r d_endnetent_r eval $inlibc case "$d_endnetent_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_netdb netdb.h" case "$d_endnetent_r_proto:$usethreads" in ":define") d_endnetent_r_proto=define set d_endnetent_r_proto endnetent_r $hdrs eval $hasproto ;; *) ;; esac case "$d_endnetent_r_proto" in define) case "$endnetent_r_proto" in ''|0) try='int endnetent_r(struct netent_data*);' ./protochk "$extern_C $try" $hdrs && endnetent_r_proto=I_D ;; esac case "$endnetent_r_proto" in ''|0) try='void endnetent_r(struct netent_data*);' ./protochk "$extern_C $try" $hdrs && endnetent_r_proto=V_D ;; esac case "$endnetent_r_proto" in ''|0) d_endnetent_r=undef endnetent_r_proto=0 echo "Disabling endnetent_r, cannot determine prototype." >&4 ;; * ) case "$endnetent_r_proto" in REENTRANT_PROTO*) ;; *) endnetent_r_proto="REENTRANT_PROTO_$endnetent_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "endnetent_r has no prototype, not using it." >&4 ;; esac d_endnetent_r=undef endnetent_r_proto=0 ;; esac ;; *) endnetent_r_proto=0 ;; esac : see if endprotoent exists set endprotoent d_endpent eval $inlibc : see if endprotoent_r exists set endprotoent_r d_endprotoent_r eval $inlibc case "$d_endprotoent_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_netdb netdb.h" case "$d_endprotoent_r_proto:$usethreads" in ":define") d_endprotoent_r_proto=define set d_endprotoent_r_proto endprotoent_r $hdrs eval $hasproto ;; *) ;; esac case "$d_endprotoent_r_proto" in define) case "$endprotoent_r_proto" in ''|0) try='int endprotoent_r(struct protoent_data*);' ./protochk "$extern_C $try" $hdrs && endprotoent_r_proto=I_D ;; esac case "$endprotoent_r_proto" in ''|0) try='void endprotoent_r(struct protoent_data*);' ./protochk "$extern_C $try" $hdrs && endprotoent_r_proto=V_D ;; esac case "$endprotoent_r_proto" in ''|0) d_endprotoent_r=undef endprotoent_r_proto=0 echo "Disabling endprotoent_r, cannot determine prototype." >&4 ;; * ) case "$endprotoent_r_proto" in REENTRANT_PROTO*) ;; *) endprotoent_r_proto="REENTRANT_PROTO_$endprotoent_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "endprotoent_r has no prototype, not using it." >&4 ;; esac d_endprotoent_r=undef endprotoent_r_proto=0 ;; esac ;; *) endprotoent_r_proto=0 ;; esac : see if endpwent exists set endpwent d_endpwent eval $inlibc : see if this is a pwd.h system set pwd.h i_pwd eval $inhdr case "$i_pwd" in $define) xxx=`./findhdr pwd.h` $cppstdin $cppflags $cppminus < $xxx >$$.h if $contains 'pw_quota' $$.h >/dev/null 2>&1; then val="$define" else val="$undef" fi set d_pwquota eval $setvar if $contains 'pw_age' $$.h >/dev/null 2>&1; then val="$define" else val="$undef" fi set d_pwage eval $setvar if $contains 'pw_change' $$.h >/dev/null 2>&1; then val="$define" else val="$undef" fi set d_pwchange eval $setvar if $contains 'pw_class' $$.h >/dev/null 2>&1; then val="$define" else val="$undef" fi set d_pwclass eval $setvar if $contains 'pw_expire' $$.h >/dev/null 2>&1; then val="$define" else val="$undef" fi set d_pwexpire eval $setvar if $contains 'pw_comment' $$.h >/dev/null 2>&1; then val="$define" else val="$undef" fi set d_pwcomment eval $setvar if $contains 'pw_gecos' $$.h >/dev/null 2>&1; then val="$define" else val="$undef" fi set d_pwgecos eval $setvar if $contains 'pw_passwd' $$.h >/dev/null 2>&1; then val="$define" else val="$undef" fi set d_pwpasswd eval $setvar $rm -f $$.h ;; *) val="$undef"; set d_pwquota; eval $setvar set d_pwage; eval $setvar set d_pwchange; eval $setvar set d_pwclass; eval $setvar set d_pwexpire; eval $setvar set d_pwcomment; eval $setvar set d_pwgecos; eval $setvar set d_pwpasswd; eval $setvar ;; esac : see if endpwent_r exists set endpwent_r d_endpwent_r eval $inlibc case "$d_endpwent_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_pwd pwd.h" case "$d_endpwent_r_proto:$usethreads" in ":define") d_endpwent_r_proto=define set d_endpwent_r_proto endpwent_r $hdrs eval $hasproto ;; *) ;; esac case "$d_endpwent_r_proto" in define) case "$endpwent_r_proto" in ''|0) try='int endpwent_r(FILE**);' ./protochk "$extern_C $try" $hdrs && endpwent_r_proto=I_H ;; esac case "$endpwent_r_proto" in ''|0) try='void endpwent_r(FILE**);' ./protochk "$extern_C $try" $hdrs && endpwent_r_proto=V_H ;; esac case "$endpwent_r_proto" in ''|0) d_endpwent_r=undef endpwent_r_proto=0 echo "Disabling endpwent_r, cannot determine prototype." >&4 ;; * ) case "$endpwent_r_proto" in REENTRANT_PROTO*) ;; *) endpwent_r_proto="REENTRANT_PROTO_$endpwent_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "endpwent_r has no prototype, not using it." >&4 ;; esac d_endpwent_r=undef endpwent_r_proto=0 ;; esac ;; *) endpwent_r_proto=0 ;; esac : see if endservent exists set endservent d_endsent eval $inlibc : see if endservent_r exists set endservent_r d_endservent_r eval $inlibc case "$d_endservent_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_netdb netdb.h" case "$d_endservent_r_proto:$usethreads" in ":define") d_endservent_r_proto=define set d_endservent_r_proto endservent_r $hdrs eval $hasproto ;; *) ;; esac case "$d_endservent_r_proto" in define) case "$endservent_r_proto" in ''|0) try='int endservent_r(struct servent_data*);' ./protochk "$extern_C $try" $hdrs && endservent_r_proto=I_D ;; esac case "$endservent_r_proto" in ''|0) try='void endservent_r(struct servent_data*);' ./protochk "$extern_C $try" $hdrs && endservent_r_proto=V_D ;; esac case "$endservent_r_proto" in ''|0) d_endservent_r=undef endservent_r_proto=0 echo "Disabling endservent_r, cannot determine prototype." >&4 ;; * ) case "$endservent_r_proto" in REENTRANT_PROTO*) ;; *) endservent_r_proto="REENTRANT_PROTO_$endservent_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "endservent_r has no prototype, not using it." >&4 ;; esac d_endservent_r=undef endservent_r_proto=0 ;; esac ;; *) endservent_r_proto=0 ;; esac : Locate the flags for 'open()' echo " " $cat >try.c < #ifdef I_FCNTL #include #endif #ifdef I_SYS_FILE #include #endif #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif int main() { if(O_RDONLY); #ifdef O_TRUNC exit(0); #else exit(1); #endif } EOCP : check sys/file.h first to get FREAD on Sun if $test `./findhdr sys/file.h` && \ set try -DI_SYS_FILE && eval $compile; then h_sysfile=true; echo " defines the O_* constants..." >&4 if $run ./try; then echo "and you have the 3 argument form of open()." >&4 val="$define" else echo "but not the 3 argument form of open(). Oh, well." >&4 val="$undef" fi elif $test `./findhdr fcntl.h` && \ set try -DI_FCNTL && eval $compile; then h_fcntl=true; echo " defines the O_* constants..." >&4 if $run ./try; then echo "and you have the 3 argument form of open()." >&4 val="$define" else echo "but not the 3 argument form of open(). Oh, well." >&4 val="$undef" fi else val="$undef" echo "I can't find the O_* constant definitions! You got problems." >&4 fi set d_open3 eval $setvar $rm_try : see if this is a sys/file.h system val='' set sys/file.h val eval $inhdr : do we need to include sys/file.h ? case "$val" in "$define") echo " " if $h_sysfile; then val="$define" echo "We'll be including ." >&4 else val="$undef" echo "We won't be including ." >&4 fi ;; *) h_sysfile=false ;; esac set i_sysfile eval $setvar : see if fcntl.h is there val='' set fcntl.h val eval $inhdr : see if we can include fcntl.h case "$val" in "$define") echo " " if $h_fcntl; then val="$define" echo "We'll be including ." >&4 else val="$undef" if $h_sysfile; then echo "We don't need to include if we include ." >&4 else echo "We won't be including ." >&4 fi fi ;; *) h_fcntl=false val="$undef" ;; esac set i_fcntl eval $setvar : see if fork exists set fork d_fork eval $inlibc : see if pipe exists set pipe d_pipe eval $inlibc : check for non-blocking I/O stuff case "$h_sysfile" in true) echo "#include " > head.c;; *) case "$h_fcntl" in true) echo "#include " > head.c;; *) echo "#include " > head.c;; esac ;; esac echo " " echo "Figuring out the flag used by open() for non-blocking I/O..." >&4 case "$o_nonblock" in '') $cat head.c > try.c $cat >>try.c < #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif #$i_fcntl I_FCNTL #ifdef I_FCNTL #include #endif int main() { #ifdef O_NONBLOCK printf("O_NONBLOCK\n"); exit(0); #endif #ifdef O_NDELAY printf("O_NDELAY\n"); exit(0); #endif #ifdef FNDELAY printf("FNDELAY\n"); exit(0); #endif exit(0); } EOCP set try if eval $compile_ok; then o_nonblock=`$run ./try` case "$o_nonblock" in '') echo "I can't figure it out, assuming O_NONBLOCK will do.";; *) echo "Seems like we can use $o_nonblock.";; esac else echo "(I can't compile the test program; pray O_NONBLOCK is right!)" fi ;; *) echo "Using $hint value $o_nonblock.";; esac $rm_try echo " " echo "Let's see what value errno gets from read() on a $o_nonblock file..." >&4 case "$eagain" in '') case "$d_fork:$d_pipe" in define:define) $cat head.c > try.c $cat >>try.c < #include #include #include #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif #$i_fcntl I_FCNTL #ifdef I_FCNTL #include #endif #define MY_O_NONBLOCK $o_nonblock #ifndef errno /* XXX need better Configure test */ extern int errno; #endif #$i_unistd I_UNISTD #ifdef I_UNISTD #include #endif #$i_string I_STRING #ifdef I_STRING #include #else #include #endif $signal_t blech(int x) { exit(3); } EOCP $cat >> try.c <<'EOCP' int main() { int pd[2]; int pu[2]; char buf[1]; char string[100]; pipe(pd); /* Down: child -> parent */ pipe(pu); /* Up: parent -> child */ if (0 != fork()) { int ret; close(pd[1]); /* Parent reads from pd[0] */ close(pu[0]); /* Parent writes (blocking) to pu[1] */ #ifdef F_SETFL if (-1 == fcntl(pd[0], F_SETFL, MY_O_NONBLOCK)) exit(1); #else exit(4); #endif signal(SIGALRM, blech); alarm(5); if ((ret = read(pd[0], buf, 1)) > 0) /* Nothing to read! */ exit(2); sprintf(string, "%d\n", ret); write(2, string, strlen(string)); alarm(0); #ifdef EAGAIN if (errno == EAGAIN) { printf("EAGAIN\n"); goto ok; } #endif #ifdef EWOULDBLOCK if (errno == EWOULDBLOCK) printf("EWOULDBLOCK\n"); #endif ok: write(pu[1], buf, 1); /* Unblocks child, tell it to close our pipe */ sleep(2); /* Give it time to close our pipe */ alarm(5); ret = read(pd[0], buf, 1); /* Should read EOF */ alarm(0); sprintf(string, "%d\n", ret); write(4, string, strlen(string)); exit(0); } close(pd[0]); /* We write to pd[1] */ close(pu[1]); /* We read from pu[0] */ read(pu[0], buf, 1); /* Wait for parent to signal us we may continue */ close(pd[1]); /* Pipe pd is now fully closed! */ exit(0); /* Bye bye, thank you for playing! */ } EOCP set try if eval $compile_ok; then echo "$startsh" >mtry echo "$run ./try >try.out 2>try.ret 4>try.err || exit 4" >>mtry chmod +x mtry ./mtry >/dev/null 2>&1 case $? in 0) eagain=`$cat try.out`;; 1) echo "Could not perform non-blocking setting!";; 2) echo "I did a successful read() for something that was not there!";; 3) echo "Hmm... non-blocking I/O does not seem to be working!";; 4) echo "Could not find F_SETFL!";; *) echo "Something terribly wrong happened during testing.";; esac rd_nodata=`$cat try.ret` echo "A read() system call with no data present returns $rd_nodata." case "$rd_nodata" in 0|-1) ;; *) echo "(That's peculiar, fixing that to be -1.)" rd_nodata=-1 ;; esac case "$eagain" in '') echo "Forcing errno EAGAIN on read() with no data available." eagain=EAGAIN ;; *) echo "Your read() sets errno to $eagain when no data is available." ;; esac status=`$cat try.err` case "$status" in 0) echo "And it correctly returns 0 to signal EOF.";; -1) echo "But it also returns -1 to signal EOF, so be careful!";; *) echo "However, your read() returns '$status' on EOF??";; esac val="$define" if test "$status" = "$rd_nodata"; then echo "WARNING: you can't distinguish between EOF and no data!" val="$undef" fi else echo "I can't compile the test program--assuming errno EAGAIN will do." eagain=EAGAIN fi ;; *) echo "Can't figure out how to test this--assuming errno EAGAIN will do." eagain=EAGAIN val="$define" ;; esac set d_eofnblk eval $setvar ;; *) echo "Using $hint value $eagain." echo "Your read() returns $rd_nodata when no data is present." case "$d_eofnblk" in "$define") echo "And you can see EOF because read() returns 0.";; "$undef") echo "But you can't see EOF status from read() returned value.";; *) echo "(Assuming you can't see EOF status from read anyway.)" d_eofnblk=$undef ;; esac ;; esac $rm_try head.c mtry : see if _ptr and _cnt from stdio act std echo " " if $contains '_lbfsize' `./findhdr stdio.h` >/dev/null 2>&1 ; then echo "(Looks like you have stdio.h from BSD.)" case "$stdio_ptr" in '') stdio_ptr='((fp)->_p)' ptr_lval=$define ;; *) ptr_lval=$d_stdio_ptr_lval;; esac case "$stdio_cnt" in '') stdio_cnt='((fp)->_r)' cnt_lval=$define ;; *) cnt_lval=$d_stdio_cnt_lval;; esac case "$stdio_base" in '') stdio_base='((fp)->_ub._base ? (fp)->_ub._base : (fp)->_bf._base)';; esac case "$stdio_bufsiz" in '') stdio_bufsiz='((fp)->_ub._base ? (fp)->_ub._size : (fp)->_bf._size)';; esac elif $contains '_IO_fpos_t' `./findhdr stdio.h` `./findhdr libio.h` >/dev/null 2>&1 ; then echo "(Looks like you have stdio.h from Linux.)" case "$stdio_ptr" in '') stdio_ptr='((fp)->_IO_read_ptr)' ptr_lval=$define ;; *) ptr_lval=$d_stdio_ptr_lval;; esac case "$stdio_cnt" in '') stdio_cnt='((fp)->_IO_read_end - (fp)->_IO_read_ptr)' cnt_lval=$undef ;; *) cnt_lval=$d_stdio_cnt_lval;; esac case "$stdio_base" in '') stdio_base='((fp)->_IO_read_base)';; esac case "$stdio_bufsiz" in '') stdio_bufsiz='((fp)->_IO_read_end - (fp)->_IO_read_base)';; esac else case "$stdio_ptr" in '') stdio_ptr='((fp)->_ptr)' ptr_lval=$define ;; *) ptr_lval=$d_stdio_ptr_lval;; esac case "$stdio_cnt" in '') stdio_cnt='((fp)->_cnt)' cnt_lval=$define ;; *) cnt_lval=$d_stdio_cnt_lval;; esac case "$stdio_base" in '') stdio_base='((fp)->_base)';; esac case "$stdio_bufsiz" in '') stdio_bufsiz='((fp)->_cnt + (fp)->_ptr - (fp)->_base)';; esac fi : test whether _ptr and _cnt really work echo "Checking how std your stdio is..." >&4 $cat >try.c < #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif #define FILE_ptr(fp) $stdio_ptr #define FILE_cnt(fp) $stdio_cnt int main() { FILE *fp = fopen("try.c", "r"); char c = getc(fp); if ( 18 <= FILE_cnt(fp) && strncmp(FILE_ptr(fp), "include \n", 18) == 0 ) exit(0); exit(1); } EOP val="$undef" set try if eval $compile && $to try.c; then if $run ./try; then echo "Your stdio acts pretty std." val="$define" else echo "Your stdio isn't very std." fi else echo "Your stdio doesn't appear very std." fi $rm_try # glibc 2.2.90 and above apparently change stdio streams so Perl's # direct buffer manipulation no longer works. The Configure tests # should be changed to correctly detect this, but until then, # the following check should at least let perl compile and run. # (This quick fix should be updated before 5.8.1.) # To be defensive, reject all unknown versions, and all versions > 2.2.9. # A. Dougherty, June 3, 2002. case "$d_gnulibc" in $define) case "$gnulibc_version" in 2.[01]*) ;; 2.2) ;; 2.2.[0-9]) ;; *) echo "But I will not snoop inside glibc $gnulibc_version stdio buffers." val="$undef" ;; esac ;; esac set d_stdstdio eval $setvar : Can _ptr be used as an lvalue? case "$d_stdstdio$ptr_lval" in $define$define) val=$define ;; *) val=$undef ;; esac set d_stdio_ptr_lval eval $setvar : Can _cnt be used as an lvalue? case "$d_stdstdio$cnt_lval" in $define$define) val=$define ;; *) val=$undef ;; esac set d_stdio_cnt_lval eval $setvar : test whether setting _ptr sets _cnt as a side effect d_stdio_ptr_lval_sets_cnt="$undef" d_stdio_ptr_lval_nochange_cnt="$undef" case "$d_stdio_ptr_lval$d_stdstdio" in $define$define) echo "Checking to see what happens if we set the stdio ptr..." >&4 $cat >try.c < /* Can we scream? */ /* Eat dust sed :-) */ /* In the buffer space, no one can hear you scream. */ #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif #define FILE_ptr(fp) $stdio_ptr #define FILE_cnt(fp) $stdio_cnt #include int main() { FILE *fp = fopen("try.c", "r"); int c; char *ptr; size_t cnt; if (!fp) { puts("Fail even to read"); exit(1); } c = getc(fp); /* Read away the first # */ if (c == EOF) { puts("Fail even to read"); exit(1); } if (!( 18 <= FILE_cnt(fp) && strncmp(FILE_ptr(fp), "include \n", 18) == 0 )) { puts("Fail even to read"); exit (1); } ptr = (char*) FILE_ptr(fp); cnt = (size_t)FILE_cnt(fp); FILE_ptr(fp) += 42; if ((char*)FILE_ptr(fp) != (ptr + 42)) { printf("Fail ptr check %p != %p", FILE_ptr(fp), (ptr + 42)); exit (1); } if (FILE_cnt(fp) <= 20) { printf ("Fail (<20 chars to test)"); exit (1); } if (strncmp(FILE_ptr(fp), "Eat dust sed :-) */\n", 20) != 0) { puts("Fail compare"); exit (1); } if (cnt == FILE_cnt(fp)) { puts("Pass_unchanged"); exit (0); } if (FILE_cnt(fp) == (cnt - 42)) { puts("Pass_changed"); exit (0); } printf("Fail count was %d now %d\n", cnt, FILE_cnt(fp)); return 1; } EOP set try if eval $compile && $to try.c; then case `$run ./try` in Pass_changed) echo "Increasing ptr in your stdio decreases cnt by the same amount. Good." >&4 d_stdio_ptr_lval_sets_cnt="$define" ;; Pass_unchanged) echo "Increasing ptr in your stdio leaves cnt unchanged. Good." >&4 d_stdio_ptr_lval_nochange_cnt="$define" ;; Fail*) echo "Increasing ptr in your stdio didn't do exactly what I expected. We'll not be doing that then." >&4 ;; *) echo "It appears attempting to set ptr in your stdio is a bad plan." >&4 ;; esac else echo "It seems we can't set ptr in your stdio. Nevermind." >&4 fi $rm_try ;; esac : see if _base is also standard val="$undef" case "$d_stdstdio" in $define) $cat >try.c < #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif #define FILE_base(fp) $stdio_base #define FILE_bufsiz(fp) $stdio_bufsiz int main() { FILE *fp = fopen("try.c", "r"); char c = getc(fp); if ( 19 <= FILE_bufsiz(fp) && strncmp(FILE_base(fp), "#include \n", 19) == 0 ) exit(0); exit(1); } EOP set try if eval $compile && $to try.c; then if $run ./try; then echo "And its _base field acts std." val="$define" else echo "But its _base field isn't std." fi else echo "However, it seems to be lacking the _base field." fi $rm_try ;; esac set d_stdiobase eval $setvar : see if fast_stdio exists val="$undef" case "$d_stdstdio:$d_stdio_ptr_lval" in "$define:$define") case "$d_stdio_cnt_lval$d_stdio_ptr_lval_sets_cnt" in *$define*) echo "You seem to have 'fast stdio' to directly manipulate the stdio buffers." >& 4 val="$define" ;; esac ;; esac set d_faststdio eval $setvar : see if fchdir exists set fchdir d_fchdir eval $inlibc : see if fchmod exists set fchmod d_fchmod eval $inlibc : see if fchown exists set fchown d_fchown eval $inlibc : see if this is an fcntl system set fcntl d_fcntl eval $inlibc : See if fcntl-based locking works. echo " " $cat >try.c < #endif #include #include #include $signal_t blech(int x) { exit(3); } int main() { #if defined(F_SETLK) && defined(F_SETLKW) struct flock flock; int retval, fd; fd = open("try.c", O_RDONLY); flock.l_type = F_RDLCK; flock.l_whence = SEEK_SET; flock.l_start = flock.l_len = 0; signal(SIGALRM, blech); alarm(10); retval = fcntl(fd, F_SETLK, &flock); close(fd); (retval < 0 ? exit(2) : exit(0)); #else exit(2); #endif } EOCP echo "Checking if fcntl-based file locking works... " case "$d_fcntl" in "$define") set try if eval $compile_ok; then if $run ./try; then echo "Yes, it seems to work." val="$define" else echo "Nope, it didn't work." val="$undef" case "$?" in 3) $cat >&4 <try.c < #endif #$i_systime I_SYS_TIME #$i_sysselct I_SYS_SELECT #$d_socket HAS_SOCKET #include #ifdef HAS_SOCKET #include /* Might include */ #endif #ifdef I_SYS_TIME #include #endif #ifdef I_SYS_SELECT #include #endif int main() { fd_set fds; #ifdef TRYBITS if(fds.fds_bits); #endif #if defined(FD_SET) && defined(FD_CLR) && defined(FD_ISSET) && defined(FD_ZERO) exit(0); #else exit(1); #endif } EOCP set try -DTRYBITS if eval $compile; then d_fds_bits="$define" d_fd_set="$define" echo "Well, your system knows about the normal fd_set typedef..." >&4 if $run ./try; then echo "and you have the normal fd_set macros (just as I'd expect)." >&4 d_fd_macros="$define" else $cat >&4 <<'EOM' but not the normal fd_set macros! Gaaack! I'll have to cover for you. EOM d_fd_macros="$undef" fi else $cat <<'EOM' Hmm, your compiler has some difficulty with fd_set. Checking further... EOM set try if eval $compile; then d_fds_bits="$undef" d_fd_set="$define" echo "Well, your system has some sort of fd_set available..." >&4 if $run ./try; then echo "and you have the normal fd_set macros." >&4 d_fd_macros="$define" else $cat <<'EOM' but not the normal fd_set macros! Gross! More work for me... EOM d_fd_macros="$undef" fi else echo "Well, you got zip. That's OK, I can roll my own fd_set stuff." >&4 d_fd_set="$undef" d_fds_bits="$undef" d_fd_macros="$undef" fi fi $rm_try : see if fgetpos exists set fgetpos d_fgetpos eval $inlibc : see if finite exists set finite d_finite eval $inlibc : see if finitel exists set finitel d_finitel eval $inlibc : see if flock exists set flock d_flock eval $inlibc : see if prototype for flock is available echo " " set d_flockproto flock $i_sysfile sys/file.h eval $hasproto : see if fp_class exists set fp_class d_fp_class eval $inlibc : see if pathconf exists set pathconf d_pathconf eval $inlibc : see if fpathconf exists set fpathconf d_fpathconf eval $inlibc : see if fpclass exists set fpclass d_fpclass eval $inlibc : see if fpclassify exists set fpclassify d_fpclassify eval $inlibc : see if fpclassl exists set fpclassl d_fpclassl eval $inlibc : check for fpos64_t echo " " echo "Checking to see if you have fpos64_t..." >&4 $cat >try.c < int main() { fpos64_t x = 7; } EOCP set try if eval $compile; then val="$define" echo "You have fpos64_t." else val="$undef" echo "You do not have fpos64_t." case "$fpossize" in 8) echo "(Your fpos_t is 64 bits, so you could use that.)" ;; esac fi $rm_try set d_fpos64_t eval $setvar : see if frexpl exists set frexpl d_frexpl eval $inlibc : see if this is a sys/param system set sys/param.h i_sysparam eval $inhdr : see if this is a sys/mount.h system set sys/mount.h i_sysmount eval $inhdr : Check for fs_data_s echo " " echo "Checking to see if your system supports struct fs_data..." >&4 set d_fs_data_s fs_data $i_systypes sys/types.h $i_sysparam sys/param.h $i_sysmount sys/mount.h eval $hasstruct case "$d_fs_data_s" in "$define") echo "Yes, it does." ;; *) echo "No, it doesn't." ;; esac : see if fseeko exists set fseeko d_fseeko eval $inlibc case "$longsize" in 8) echo "(Your long is 64 bits, so you could use fseek.)" ;; esac : see if fsetpos exists set fsetpos d_fsetpos eval $inlibc : see if fstatfs exists set fstatfs d_fstatfs eval $inlibc : see if statvfs exists set statvfs d_statvfs eval $inlibc : see if fstatvfs exists set fstatvfs d_fstatvfs eval $inlibc : see if fsync exists set fsync d_fsync eval $inlibc : see if ftello exists set ftello d_ftello eval $inlibc case "$longsize" in 8) echo "(Your long is 64 bits, so you could use ftell.)" ;; esac : check for a working futimes d_futimes="$undef" echo " " echo "Checking if you have a working futimes()" >&4 $cat >try.c < #include #include #include int main () { int fd, rv; fd = open ("try.c", O_RDWR); if (-1 == fd) exit (1); rv = futimes (fd, NULL); exit (rv == -1 ? errno : 0); } EOCP set try if eval $compile; then `$run ./try` rc=$? case "$rc" in 0) echo "Yes, you have" >&4 d_futimes="$define" ;; *) echo "No, you have futimes, but it isn't working ($rc) (probably harmless)" >&4 ;; esac else echo "No, it does not (probably harmless)" >&4 fi $rm_try : see if ndbm.h is available set ndbm.h i_ndbm eval $inhdr : Compatibility location for RedHat 7.1 set gdbm/ndbm.h i_gdbmndbm eval $inhdr : Compatibility location for Debian 4.0 set gdbm-ndbm.h i_gdbm_ndbm eval $inhdr val="$undef" if $test "$i_ndbm" = "$define" -o "$i_gdbmndbm" = "$define" -o "$i_gdbm_ndbm" = "$define"; then : see if dbm_open exists set dbm_open d_dbm_open eval $inlibc case "$d_dbm_open" in $undef) i_ndbm="$undef" i_gdbmndbm="$undef" i_gdbm_ndbm="$undef" echo "We won't be including " val="$undef" ;; *) val="$define" ;; esac fi set d_ndbm eval $setvar ndbm_hdr_protochk='name=$1; hdr=$2; eval "ihdr=\$""i_$name"; val="$undef"; if $test "$ihdr" = "$define"; then $echo "Checking if your <$hdr> uses prototypes..." >&4; case "$d_cplusplus" in $define) ./protochk "$extern_C void dbm_close(DBM *);" literal "extern \"C\" {" $ihdr $hdr literal "}" && val="$define" ;; *) ./protochk "$extern_C void dbm_close(int, int);" $ihdr $hdr || val="$define" ;; esac; case "$val" in $define) $echo "Your <$hdr> seems to have prototypes";; *) $echo "Your <$hdr> does not seem to have prototypes";; esac; fi; set "d_${name}_h_uses_prototypes"; eval $setvar' set ndbm ndbm.h eval $ndbm_hdr_protochk set gdbmndbm gdbm/ndbm.h eval $ndbm_hdr_protochk set gdbm_ndbm gdbm-ndbm.h eval $ndbm_hdr_protochk : see if getaddrinfo exists set getaddrinfo d_getaddrinfo eval $inlibc : see if getcwd exists set getcwd d_getcwd eval $inlibc : see if getespwnam exists set getespwnam d_getespwnam eval $inlibc : see if getfsstat exists set getfsstat d_getfsstat eval $inlibc : see if getgrent exists set getgrent d_getgrent eval $inlibc : see if getgrent_r exists set getgrent_r d_getgrent_r eval $inlibc case "$d_getgrent_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_grp grp.h" case "$d_getgrent_r_proto:$usethreads" in ":define") d_getgrent_r_proto=define set d_getgrent_r_proto getgrent_r $hdrs eval $hasproto ;; *) ;; esac case "$d_getgrent_r_proto" in define) case "$getgrent_r_proto" in ''|0) try='int getgrent_r(struct group*, char*, size_t, struct group**);' ./protochk "$extern_C $try" $hdrs && getgrent_r_proto=I_SBWR ;; esac case "$getgrent_r_proto" in ''|0) try='int getgrent_r(struct group*, char*, int, struct group**);' ./protochk "$extern_C $try" $hdrs && getgrent_r_proto=I_SBIR ;; esac case "$getgrent_r_proto" in ''|0) try='struct group* getgrent_r(struct group*, char*, size_t);' ./protochk "$extern_C $try" $hdrs && getgrent_r_proto=S_SBW ;; esac case "$getgrent_r_proto" in ''|0) try='struct group* getgrent_r(struct group*, char*, int);' ./protochk "$extern_C $try" $hdrs && getgrent_r_proto=S_SBI ;; esac case "$getgrent_r_proto" in ''|0) try='int getgrent_r(struct group*, char*, int);' ./protochk "$extern_C $try" $hdrs && getgrent_r_proto=I_SBI ;; esac case "$getgrent_r_proto" in ''|0) try='int getgrent_r(struct group*, char*, int, FILE**);' ./protochk "$extern_C $try" $hdrs && getgrent_r_proto=I_SBIH ;; esac case "$getgrent_r_proto" in ''|0) d_getgrent_r=undef getgrent_r_proto=0 echo "Disabling getgrent_r, cannot determine prototype." >&4 ;; * ) case "$getgrent_r_proto" in REENTRANT_PROTO*) ;; *) getgrent_r_proto="REENTRANT_PROTO_$getgrent_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "getgrent_r has no prototype, not using it." >&4 ;; esac d_getgrent_r=undef getgrent_r_proto=0 ;; esac ;; *) getgrent_r_proto=0 ;; esac : see if getgrgid_r exists set getgrgid_r d_getgrgid_r eval $inlibc case "$d_getgrgid_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_grp grp.h" case "$d_getgrgid_r_proto:$usethreads" in ":define") d_getgrgid_r_proto=define set d_getgrgid_r_proto getgrgid_r $hdrs eval $hasproto ;; *) ;; esac case "$d_getgrgid_r_proto" in define) case "$getgrgid_r_proto" in ''|0) try='int getgrgid_r(gid_t, struct group*, char*, size_t, struct group**);' ./protochk "$extern_C $try" $hdrs && getgrgid_r_proto=I_TSBWR ;; esac case "$getgrgid_r_proto" in ''|0) try='int getgrgid_r(gid_t, struct group*, char*, int, struct group**);' ./protochk "$extern_C $try" $hdrs && getgrgid_r_proto=I_TSBIR ;; esac case "$getgrgid_r_proto" in ''|0) try='int getgrgid_r(gid_t, struct group*, char*, int);' ./protochk "$extern_C $try" $hdrs && getgrgid_r_proto=I_TSBI ;; esac case "$getgrgid_r_proto" in ''|0) try='struct group* getgrgid_r(gid_t, struct group*, char*, int);' ./protochk "$extern_C $try" $hdrs && getgrgid_r_proto=S_TSBI ;; esac case "$getgrgid_r_proto" in ''|0) d_getgrgid_r=undef getgrgid_r_proto=0 echo "Disabling getgrgid_r, cannot determine prototype." >&4 ;; * ) case "$getgrgid_r_proto" in REENTRANT_PROTO*) ;; *) getgrgid_r_proto="REENTRANT_PROTO_$getgrgid_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "getgrgid_r has no prototype, not using it." >&4 ;; esac d_getgrgid_r=undef getgrgid_r_proto=0 ;; esac ;; *) getgrgid_r_proto=0 ;; esac : see if getgrnam_r exists set getgrnam_r d_getgrnam_r eval $inlibc case "$d_getgrnam_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_grp grp.h" case "$d_getgrnam_r_proto:$usethreads" in ":define") d_getgrnam_r_proto=define set d_getgrnam_r_proto getgrnam_r $hdrs eval $hasproto ;; *) ;; esac case "$d_getgrnam_r_proto" in define) case "$getgrnam_r_proto" in ''|0) try='int getgrnam_r(const char*, struct group*, char*, size_t, struct group**);' ./protochk "$extern_C $try" $hdrs && getgrnam_r_proto=I_CSBWR ;; esac case "$getgrnam_r_proto" in ''|0) try='int getgrnam_r(const char*, struct group*, char*, int, struct group**);' ./protochk "$extern_C $try" $hdrs && getgrnam_r_proto=I_CSBIR ;; esac case "$getgrnam_r_proto" in ''|0) try='struct group* getgrnam_r(const char*, char*, int);' ./protochk "$extern_C $try" $hdrs && getgrnam_r_proto=S_CBI ;; esac case "$getgrnam_r_proto" in ''|0) try='int getgrnam_r(const char*, struct group*, char*, int);' ./protochk "$extern_C $try" $hdrs && getgrnam_r_proto=I_CSBI ;; esac case "$getgrnam_r_proto" in ''|0) try='struct group* getgrnam_r(const char*, struct group*, char*, int);' ./protochk "$extern_C $try" $hdrs && getgrnam_r_proto=S_CSBI ;; esac case "$getgrnam_r_proto" in ''|0) d_getgrnam_r=undef getgrnam_r_proto=0 echo "Disabling getgrnam_r, cannot determine prototype." >&4 ;; * ) case "$getgrnam_r_proto" in REENTRANT_PROTO*) ;; *) getgrnam_r_proto="REENTRANT_PROTO_$getgrnam_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "getgrnam_r has no prototype, not using it." >&4 ;; esac d_getgrnam_r=undef getgrnam_r_proto=0 ;; esac ;; *) getgrnam_r_proto=0 ;; esac : see if gethostbyaddr exists set gethostbyaddr d_gethbyaddr eval $inlibc : see if gethostbyname exists set gethostbyname d_gethbyname eval $inlibc : see if gethostent exists set gethostent d_gethent eval $inlibc : see how we will look up host name echo " " call='' if set gethostname val -f d_gethname; eval $csym; $val; then echo 'gethostname() found.' >&4 d_gethname="$define" call=gethostname fi if set uname val -f d_uname; eval $csym; $val; then if ./xenix; then $cat <<'EOM' uname() was found, but you're running xenix, and older versions of xenix have a broken uname(). If you don't really know whether your xenix is old enough to have a broken system call, use the default answer. EOM dflt=y case "$d_uname" in "$define") dflt=n;; esac rp='Is your uname() broken?' . ./myread case "$ans" in n*) d_uname="$define"; call=uname;; esac else echo 'uname() found.' >&4 d_uname="$define" case "$call" in '') call=uname ;; esac fi fi case "$d_gethname" in '') d_gethname="$undef";; esac case "$d_uname" in '') d_uname="$undef";; esac case "$d_uname$d_gethname" in *define*) dflt=n cat <&4;; *) echo "I'll use 'popen("'"'$aphostname'", "r")'"' to get your hostname." >&4 ;; esac;; esac case "$d_phostname" in '') d_phostname="$undef";; esac : see if gethostbyaddr_r exists set gethostbyaddr_r d_gethostbyaddr_r eval $inlibc case "$d_gethostbyaddr_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_netdb netdb.h" case "$d_gethostbyaddr_r_proto:$usethreads" in ":define") d_gethostbyaddr_r_proto=define set d_gethostbyaddr_r_proto gethostbyaddr_r $hdrs eval $hasproto ;; *) ;; esac case "$d_gethostbyaddr_r_proto" in define) case "$gethostbyaddr_r_proto" in ''|0) try='int gethostbyaddr_r(const char*, size_t, int, struct hostent*, char*, size_t, struct hostent**, int*);' ./protochk "$extern_C $try" $hdrs && gethostbyaddr_r_proto=I_CWISBWRE ;; esac case "$gethostbyaddr_r_proto" in ''|0) try='struct hostent* gethostbyaddr_r(const char*, size_t, int, struct hostent*, char*, size_t, int, int*);' ./protochk "$extern_C $try" $hdrs && gethostbyaddr_r_proto=S_CWISBWIE ;; esac case "$gethostbyaddr_r_proto" in ''|0) try='struct hostent* gethostbyaddr_r(const char*, size_t, int, struct hostent*, char*, int, int*);' ./protochk "$extern_C $try" $hdrs && gethostbyaddr_r_proto=S_CWISBIE ;; esac case "$gethostbyaddr_r_proto" in ''|0) try='struct hostent* gethostbyaddr_r(const void*, size_t, int, struct hostent*, char*, int, int*);' ./protochk "$extern_C $try" $hdrs && gethostbyaddr_r_proto=S_TWISBIE ;; esac case "$gethostbyaddr_r_proto" in ''|0) try='struct hostent* gethostbyaddr_r(const char*, int, int, struct hostent*, char*, int, int*);' ./protochk "$extern_C $try" $hdrs && gethostbyaddr_r_proto=S_CIISBIE ;; esac case "$gethostbyaddr_r_proto" in ''|0) try='struct hostent* gethostbyaddr_r(const char*, struct hostent*, char*, int, int*);' ./protochk "$extern_C $try" $hdrs && gethostbyaddr_r_proto=S_CSBIE ;; esac case "$gethostbyaddr_r_proto" in ''|0) try='struct hostent* gethostbyaddr_r(const void*, struct hostent*, char*, int, int*);' ./protochk "$extern_C $try" $hdrs && gethostbyaddr_r_proto=S_TSBIE ;; esac case "$gethostbyaddr_r_proto" in ''|0) try='int gethostbyaddr_r(const char*, size_t, int, struct hostent*, struct hostent_data*);' ./protochk "$extern_C $try" $hdrs && gethostbyaddr_r_proto=I_CWISD ;; esac case "$gethostbyaddr_r_proto" in ''|0) try='int gethostbyaddr_r(const char*, int, int, struct hostent*, struct hostent_data*);' ./protochk "$extern_C $try" $hdrs && gethostbyaddr_r_proto=I_CIISD ;; esac case "$gethostbyaddr_r_proto" in ''|0) try='int gethostbyaddr_r(const char*, int, int);' ./protochk "$extern_C $try" $hdrs && gethostbyaddr_r_proto=I_CII ;; esac case "$gethostbyaddr_r_proto" in ''|0) try='int gethostbyaddr_r(const void*, socklen_t, int, struct hostent*, char*, size_t, struct hostent**, int*);' ./protochk "$extern_C $try" $hdrs && gethostbyaddr_r_proto=I_TsISBWRE ;; esac case "$gethostbyaddr_r_proto" in ''|0) d_gethostbyaddr_r=undef gethostbyaddr_r_proto=0 echo "Disabling gethostbyaddr_r, cannot determine prototype." >&4 ;; * ) case "$gethostbyaddr_r_proto" in REENTRANT_PROTO*) ;; *) gethostbyaddr_r_proto="REENTRANT_PROTO_$gethostbyaddr_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "gethostbyaddr_r has no prototype, not using it." >&4 ;; esac d_gethostbyaddr_r=undef gethostbyaddr_r_proto=0 ;; esac ;; *) gethostbyaddr_r_proto=0 ;; esac : see if gethostbyname_r exists set gethostbyname_r d_gethostbyname_r eval $inlibc case "$d_gethostbyname_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_netdb netdb.h" case "$d_gethostbyname_r_proto:$usethreads" in ":define") d_gethostbyname_r_proto=define set d_gethostbyname_r_proto gethostbyname_r $hdrs eval $hasproto ;; *) ;; esac case "$d_gethostbyname_r_proto" in define) case "$gethostbyname_r_proto" in ''|0) try='int gethostbyname_r(const char*, struct hostent*, char*, size_t, struct hostent**, int*);' ./protochk "$extern_C $try" $hdrs && gethostbyname_r_proto=I_CSBWRE ;; esac case "$gethostbyname_r_proto" in ''|0) try='struct hostent* gethostbyname_r(const char*, struct hostent*, char*, int, int*);' ./protochk "$extern_C $try" $hdrs && gethostbyname_r_proto=S_CSBIE ;; esac case "$gethostbyname_r_proto" in ''|0) try='int gethostbyname_r(const char*, struct hostent*, struct hostent_data*);' ./protochk "$extern_C $try" $hdrs && gethostbyname_r_proto=I_CSD ;; esac case "$gethostbyname_r_proto" in ''|0) d_gethostbyname_r=undef gethostbyname_r_proto=0 echo "Disabling gethostbyname_r, cannot determine prototype." >&4 ;; * ) case "$gethostbyname_r_proto" in REENTRANT_PROTO*) ;; *) gethostbyname_r_proto="REENTRANT_PROTO_$gethostbyname_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "gethostbyname_r has no prototype, not using it." >&4 ;; esac d_gethostbyname_r=undef gethostbyname_r_proto=0 ;; esac ;; *) gethostbyname_r_proto=0 ;; esac : see if gethostent_r exists set gethostent_r d_gethostent_r eval $inlibc case "$d_gethostent_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_netdb netdb.h" case "$d_gethostent_r_proto:$usethreads" in ":define") d_gethostent_r_proto=define set d_gethostent_r_proto gethostent_r $hdrs eval $hasproto ;; *) ;; esac case "$d_gethostent_r_proto" in define) case "$gethostent_r_proto" in ''|0) try='int gethostent_r(struct hostent*, char*, size_t, struct hostent**, int*);' ./protochk "$extern_C $try" $hdrs && gethostent_r_proto=I_SBWRE ;; esac case "$gethostent_r_proto" in ''|0) try='int gethostent_r(struct hostent*, char*, int, int*);' ./protochk "$extern_C $try" $hdrs && gethostent_r_proto=I_SBIE ;; esac case "$gethostent_r_proto" in ''|0) try='struct hostent* gethostent_r(struct hostent*, char*, int, int*);' ./protochk "$extern_C $try" $hdrs && gethostent_r_proto=S_SBIE ;; esac case "$gethostent_r_proto" in ''|0) try='struct hostent* gethostent_r(struct hostent*, char*, int);' ./protochk "$extern_C $try" $hdrs && gethostent_r_proto=S_SBI ;; esac case "$gethostent_r_proto" in ''|0) try='int gethostent_r(struct hostent*, char*, int);' ./protochk "$extern_C $try" $hdrs && gethostent_r_proto=I_SBI ;; esac case "$gethostent_r_proto" in ''|0) try='int gethostent_r(struct hostent*, struct hostent_data*);' ./protochk "$extern_C $try" $hdrs && gethostent_r_proto=I_SD ;; esac case "$gethostent_r_proto" in ''|0) d_gethostent_r=undef gethostent_r_proto=0 echo "Disabling gethostent_r, cannot determine prototype." >&4 ;; * ) case "$gethostent_r_proto" in REENTRANT_PROTO*) ;; *) gethostent_r_proto="REENTRANT_PROTO_$gethostent_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "gethostent_r has no prototype, not using it." >&4 ;; esac d_gethostent_r=undef gethostent_r_proto=0 ;; esac ;; *) gethostent_r_proto=0 ;; esac : see if prototypes for various gethostxxx netdb.h functions are available echo " " set d_gethostprotos gethostent $i_netdb netdb.h eval $hasproto : see if getitimer exists set getitimer d_getitimer eval $inlibc : see if getlogin exists set getlogin d_getlogin eval $inlibc : see if getlogin_r exists set getlogin_r d_getlogin_r eval $inlibc case "$d_getlogin_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_unistd unistd.h" case "$d_getlogin_r_proto:$usethreads" in ":define") d_getlogin_r_proto=define set d_getlogin_r_proto getlogin_r $hdrs eval $hasproto ;; *) ;; esac case "$d_getlogin_r_proto" in define) case "$getlogin_r_proto" in ''|0) try='int getlogin_r(char*, size_t);' ./protochk "$extern_C $try" $hdrs && getlogin_r_proto=I_BW ;; esac case "$getlogin_r_proto" in ''|0) try='int getlogin_r(char*, int);' ./protochk "$extern_C $try" $hdrs && getlogin_r_proto=I_BI ;; esac case "$getlogin_r_proto" in ''|0) try='char* getlogin_r(char*, size_t);' ./protochk "$extern_C $try" $hdrs && getlogin_r_proto=B_BW ;; esac case "$getlogin_r_proto" in ''|0) try='char* getlogin_r(char*, int);' ./protochk "$extern_C $try" $hdrs && getlogin_r_proto=B_BI ;; esac case "$getlogin_r_proto" in ''|0) d_getlogin_r=undef getlogin_r_proto=0 echo "Disabling getlogin_r, cannot determine prototype." >&4 ;; * ) case "$getlogin_r_proto" in REENTRANT_PROTO*) ;; *) getlogin_r_proto="REENTRANT_PROTO_$getlogin_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "getlogin_r has no prototype, not using it." >&4 ;; esac d_getlogin_r=undef getlogin_r_proto=0 ;; esac ;; *) getlogin_r_proto=0 ;; esac : see if getmnt exists set getmnt d_getmnt eval $inlibc : see if getmntent exists set getmntent d_getmntent eval $inlibc : see if getnameinfo exists set getnameinfo d_getnameinfo eval $inlibc : see if getnetbyaddr exists set getnetbyaddr d_getnbyaddr eval $inlibc : see if getnetbyname exists set getnetbyname d_getnbyname eval $inlibc : see if getnetent exists set getnetent d_getnent eval $inlibc : see if getnetbyaddr_r exists set getnetbyaddr_r d_getnetbyaddr_r eval $inlibc case "$d_getnetbyaddr_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_netdb netdb.h" case "$d_getnetbyaddr_r_proto:$usethreads" in ":define") d_getnetbyaddr_r_proto=define set d_getnetbyaddr_r_proto getnetbyaddr_r $hdrs eval $hasproto ;; *) ;; esac case "$d_getnetbyaddr_r_proto" in define) case "$getnetbyaddr_r_proto" in ''|0) try='int getnetbyaddr_r(unsigned long, int, struct netent*, char*, size_t, struct netent**, int*);' ./protochk "$extern_C $try" $hdrs && getnetbyaddr_r_proto=I_UISBWRE ;; esac case "$getnetbyaddr_r_proto" in ''|0) try='int getnetbyaddr_r(long, int, struct netent*, char*, int);' ./protochk "$extern_C $try" $hdrs && getnetbyaddr_r_proto=I_LISBI ;; esac case "$getnetbyaddr_r_proto" in ''|0) try='struct netent* getnetbyaddr_r(in_addr_t, int, struct netent*, char*, int);' ./protochk "$extern_C $try" $hdrs && getnetbyaddr_r_proto=S_TISBI ;; esac case "$getnetbyaddr_r_proto" in ''|0) try='struct netent* getnetbyaddr_r(long, int, struct netent*, char*, int);' ./protochk "$extern_C $try" $hdrs && getnetbyaddr_r_proto=S_LISBI ;; esac case "$getnetbyaddr_r_proto" in ''|0) try='int getnetbyaddr_r(in_addr_t, int, struct netent*, struct netent_data*);' ./protochk "$extern_C $try" $hdrs && getnetbyaddr_r_proto=I_TISD ;; esac case "$getnetbyaddr_r_proto" in ''|0) try='int getnetbyaddr_r(long, int, struct netent*, struct netent_data*);' ./protochk "$extern_C $try" $hdrs && getnetbyaddr_r_proto=I_LISD ;; esac case "$getnetbyaddr_r_proto" in ''|0) try='int getnetbyaddr_r(int, int, struct netent*, struct netent_data*);' ./protochk "$extern_C $try" $hdrs && getnetbyaddr_r_proto=I_IISD ;; esac case "$getnetbyaddr_r_proto" in ''|0) try='int getnetbyaddr_r(uint32_t, int, struct netent*, char*, size_t, struct netent**, int*);' ./protochk "$extern_C $try" $hdrs && getnetbyaddr_r_proto=I_uISBWRE ;; esac case "$getnetbyaddr_r_proto" in ''|0) d_getnetbyaddr_r=undef getnetbyaddr_r_proto=0 echo "Disabling getnetbyaddr_r, cannot determine prototype." >&4 ;; * ) case "$getnetbyaddr_r_proto" in REENTRANT_PROTO*) ;; *) getnetbyaddr_r_proto="REENTRANT_PROTO_$getnetbyaddr_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "getnetbyaddr_r has no prototype, not using it." >&4 ;; esac d_getnetbyaddr_r=undef getnetbyaddr_r_proto=0 ;; esac ;; *) getnetbyaddr_r_proto=0 ;; esac : see if getnetbyname_r exists set getnetbyname_r d_getnetbyname_r eval $inlibc case "$d_getnetbyname_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_netdb netdb.h" case "$d_getnetbyname_r_proto:$usethreads" in ":define") d_getnetbyname_r_proto=define set d_getnetbyname_r_proto getnetbyname_r $hdrs eval $hasproto ;; *) ;; esac case "$d_getnetbyname_r_proto" in define) case "$getnetbyname_r_proto" in ''|0) try='int getnetbyname_r(const char*, struct netent*, char*, size_t, struct netent**, int*);' ./protochk "$extern_C $try" $hdrs && getnetbyname_r_proto=I_CSBWRE ;; esac case "$getnetbyname_r_proto" in ''|0) try='int getnetbyname_r(const char*, struct netent*, char*, int);' ./protochk "$extern_C $try" $hdrs && getnetbyname_r_proto=I_CSBI ;; esac case "$getnetbyname_r_proto" in ''|0) try='struct netent* getnetbyname_r(const char*, struct netent*, char*, int);' ./protochk "$extern_C $try" $hdrs && getnetbyname_r_proto=S_CSBI ;; esac case "$getnetbyname_r_proto" in ''|0) try='int getnetbyname_r(const char*, struct netent*, struct netent_data*);' ./protochk "$extern_C $try" $hdrs && getnetbyname_r_proto=I_CSD ;; esac case "$getnetbyname_r_proto" in ''|0) d_getnetbyname_r=undef getnetbyname_r_proto=0 echo "Disabling getnetbyname_r, cannot determine prototype." >&4 ;; * ) case "$getnetbyname_r_proto" in REENTRANT_PROTO*) ;; *) getnetbyname_r_proto="REENTRANT_PROTO_$getnetbyname_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "getnetbyname_r has no prototype, not using it." >&4 ;; esac d_getnetbyname_r=undef getnetbyname_r_proto=0 ;; esac ;; *) getnetbyname_r_proto=0 ;; esac : see if getnetent_r exists set getnetent_r d_getnetent_r eval $inlibc case "$d_getnetent_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_netdb netdb.h" case "$d_getnetent_r_proto:$usethreads" in ":define") d_getnetent_r_proto=define set d_getnetent_r_proto getnetent_r $hdrs eval $hasproto ;; *) ;; esac case "$d_getnetent_r_proto" in define) case "$getnetent_r_proto" in ''|0) try='int getnetent_r(struct netent*, char*, size_t, struct netent**, int*);' ./protochk "$extern_C $try" $hdrs && getnetent_r_proto=I_SBWRE ;; esac case "$getnetent_r_proto" in ''|0) try='int getnetent_r(struct netent*, char*, int, int*);' ./protochk "$extern_C $try" $hdrs && getnetent_r_proto=I_SBIE ;; esac case "$getnetent_r_proto" in ''|0) try='struct netent* getnetent_r(struct netent*, char*, int, int*);' ./protochk "$extern_C $try" $hdrs && getnetent_r_proto=S_SBIE ;; esac case "$getnetent_r_proto" in ''|0) try='struct netent* getnetent_r(struct netent*, char*, int);' ./protochk "$extern_C $try" $hdrs && getnetent_r_proto=S_SBI ;; esac case "$getnetent_r_proto" in ''|0) try='int getnetent_r(struct netent*, char*, int);' ./protochk "$extern_C $try" $hdrs && getnetent_r_proto=I_SBI ;; esac case "$getnetent_r_proto" in ''|0) try='int getnetent_r(struct netent*, struct netent_data*);' ./protochk "$extern_C $try" $hdrs && getnetent_r_proto=I_SD ;; esac case "$getnetent_r_proto" in ''|0) d_getnetent_r=undef getnetent_r_proto=0 echo "Disabling getnetent_r, cannot determine prototype." >&4 ;; * ) case "$getnetent_r_proto" in REENTRANT_PROTO*) ;; *) getnetent_r_proto="REENTRANT_PROTO_$getnetent_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "getnetent_r has no prototype, not using it." >&4 ;; esac d_getnetent_r=undef getnetent_r_proto=0 ;; esac ;; *) getnetent_r_proto=0 ;; esac : see if prototypes for various getnetxxx netdb.h functions are available echo " " set d_getnetprotos getnetent $i_netdb netdb.h eval $hasproto : see if getpagesize exists set getpagesize d_getpagsz eval $inlibc : Optional checks for getprotobyname and getprotobynumber : see if getprotobyname exists set getprotobyname d_getpbyname eval $inlibc : see if getprotobynumber exists set getprotobynumber d_getpbynumber eval $inlibc : see if getprotoent exists set getprotoent d_getpent eval $inlibc : see if getpgid exists set getpgid d_getpgid eval $inlibc : see if getpgrp2 exists set getpgrp2 d_getpgrp2 eval $inlibc : see if getppid exists set getppid d_getppid eval $inlibc : see if getpriority exists set getpriority d_getprior eval $inlibc : see if getprotobyname_r exists set getprotobyname_r d_getprotobyname_r eval $inlibc case "$d_getprotobyname_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_netdb netdb.h" case "$d_getprotobyname_r_proto:$usethreads" in ":define") d_getprotobyname_r_proto=define set d_getprotobyname_r_proto getprotobyname_r $hdrs eval $hasproto ;; *) ;; esac case "$d_getprotobyname_r_proto" in define) case "$getprotobyname_r_proto" in ''|0) try='int getprotobyname_r(const char*, struct protoent*, char*, size_t, struct protoent**);' ./protochk "$extern_C $try" $hdrs && getprotobyname_r_proto=I_CSBWR ;; esac case "$getprotobyname_r_proto" in ''|0) try='struct protoent* getprotobyname_r(const char*, struct protoent*, char*, int);' ./protochk "$extern_C $try" $hdrs && getprotobyname_r_proto=S_CSBI ;; esac case "$getprotobyname_r_proto" in ''|0) try='int getprotobyname_r(const char*, struct protoent*, struct protoent_data*);' ./protochk "$extern_C $try" $hdrs && getprotobyname_r_proto=I_CSD ;; esac case "$getprotobyname_r_proto" in ''|0) d_getprotobyname_r=undef getprotobyname_r_proto=0 echo "Disabling getprotobyname_r, cannot determine prototype." >&4 ;; * ) case "$getprotobyname_r_proto" in REENTRANT_PROTO*) ;; *) getprotobyname_r_proto="REENTRANT_PROTO_$getprotobyname_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "getprotobyname_r has no prototype, not using it." >&4 ;; esac d_getprotobyname_r=undef getprotobyname_r_proto=0 ;; esac ;; *) getprotobyname_r_proto=0 ;; esac : see if getprotobynumber_r exists set getprotobynumber_r d_getprotobynumber_r eval $inlibc case "$d_getprotobynumber_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_netdb netdb.h" case "$d_getprotobynumber_r_proto:$usethreads" in ":define") d_getprotobynumber_r_proto=define set d_getprotobynumber_r_proto getprotobynumber_r $hdrs eval $hasproto ;; *) ;; esac case "$d_getprotobynumber_r_proto" in define) case "$getprotobynumber_r_proto" in ''|0) try='int getprotobynumber_r(int, struct protoent*, char*, size_t, struct protoent**);' ./protochk "$extern_C $try" $hdrs && getprotobynumber_r_proto=I_ISBWR ;; esac case "$getprotobynumber_r_proto" in ''|0) try='struct protoent* getprotobynumber_r(int, struct protoent*, char*, int);' ./protochk "$extern_C $try" $hdrs && getprotobynumber_r_proto=S_ISBI ;; esac case "$getprotobynumber_r_proto" in ''|0) try='int getprotobynumber_r(int, struct protoent*, struct protoent_data*);' ./protochk "$extern_C $try" $hdrs && getprotobynumber_r_proto=I_ISD ;; esac case "$getprotobynumber_r_proto" in ''|0) d_getprotobynumber_r=undef getprotobynumber_r_proto=0 echo "Disabling getprotobynumber_r, cannot determine prototype." >&4 ;; * ) case "$getprotobynumber_r_proto" in REENTRANT_PROTO*) ;; *) getprotobynumber_r_proto="REENTRANT_PROTO_$getprotobynumber_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "getprotobynumber_r has no prototype, not using it." >&4 ;; esac d_getprotobynumber_r=undef getprotobynumber_r_proto=0 ;; esac ;; *) getprotobynumber_r_proto=0 ;; esac : see if getprotoent_r exists set getprotoent_r d_getprotoent_r eval $inlibc case "$d_getprotoent_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_netdb netdb.h" case "$d_getprotoent_r_proto:$usethreads" in ":define") d_getprotoent_r_proto=define set d_getprotoent_r_proto getprotoent_r $hdrs eval $hasproto ;; *) ;; esac case "$d_getprotoent_r_proto" in define) case "$getprotoent_r_proto" in ''|0) try='int getprotoent_r(struct protoent*, char*, size_t, struct protoent**);' ./protochk "$extern_C $try" $hdrs && getprotoent_r_proto=I_SBWR ;; esac case "$getprotoent_r_proto" in ''|0) try='int getprotoent_r(struct protoent*, char*, int);' ./protochk "$extern_C $try" $hdrs && getprotoent_r_proto=I_SBI ;; esac case "$getprotoent_r_proto" in ''|0) try='struct protoent* getprotoent_r(struct protoent*, char*, int);' ./protochk "$extern_C $try" $hdrs && getprotoent_r_proto=S_SBI ;; esac case "$getprotoent_r_proto" in ''|0) try='int getprotoent_r(struct protoent*, struct protoent_data*);' ./protochk "$extern_C $try" $hdrs && getprotoent_r_proto=I_SD ;; esac case "$getprotoent_r_proto" in ''|0) d_getprotoent_r=undef getprotoent_r_proto=0 echo "Disabling getprotoent_r, cannot determine prototype." >&4 ;; * ) case "$getprotoent_r_proto" in REENTRANT_PROTO*) ;; *) getprotoent_r_proto="REENTRANT_PROTO_$getprotoent_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "getprotoent_r has no prototype, not using it." >&4 ;; esac d_getprotoent_r=undef getprotoent_r_proto=0 ;; esac ;; *) getprotoent_r_proto=0 ;; esac : see if prototypes for various getprotoxxx netdb.h functions are available echo " " set d_getprotoprotos getprotoent $i_netdb netdb.h eval $hasproto : see if getprpwnam exists set getprpwnam d_getprpwnam eval $inlibc : see if getpwent exists set getpwent d_getpwent eval $inlibc : see if getpwent_r exists set getpwent_r d_getpwent_r eval $inlibc case "$d_getpwent_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_pwd pwd.h" case "$d_getpwent_r_proto:$usethreads" in ":define") d_getpwent_r_proto=define set d_getpwent_r_proto getpwent_r $hdrs eval $hasproto ;; *) ;; esac case "$d_getpwent_r_proto" in define) case "$getpwent_r_proto" in ''|0) try='int getpwent_r(struct passwd*, char*, size_t, struct passwd**);' ./protochk "$extern_C $try" $hdrs && getpwent_r_proto=I_SBWR ;; esac case "$getpwent_r_proto" in ''|0) try='int getpwent_r(struct passwd*, char*, int, struct passwd**);' ./protochk "$extern_C $try" $hdrs && getpwent_r_proto=I_SBIR ;; esac case "$getpwent_r_proto" in ''|0) try='struct passwd* getpwent_r(struct passwd*, char*, size_t);' ./protochk "$extern_C $try" $hdrs && getpwent_r_proto=S_SBW ;; esac case "$getpwent_r_proto" in ''|0) try='struct passwd* getpwent_r(struct passwd*, char*, int);' ./protochk "$extern_C $try" $hdrs && getpwent_r_proto=S_SBI ;; esac case "$getpwent_r_proto" in ''|0) try='int getpwent_r(struct passwd*, char*, int);' ./protochk "$extern_C $try" $hdrs && getpwent_r_proto=I_SBI ;; esac case "$getpwent_r_proto" in ''|0) try='int getpwent_r(struct passwd*, char*, int, FILE**);' ./protochk "$extern_C $try" $hdrs && getpwent_r_proto=I_SBIH ;; esac case "$getpwent_r_proto" in ''|0) d_getpwent_r=undef getpwent_r_proto=0 echo "Disabling getpwent_r, cannot determine prototype." >&4 ;; * ) case "$getpwent_r_proto" in REENTRANT_PROTO*) ;; *) getpwent_r_proto="REENTRANT_PROTO_$getpwent_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "getpwent_r has no prototype, not using it." >&4 ;; esac d_getpwent_r=undef getpwent_r_proto=0 ;; esac ;; *) getpwent_r_proto=0 ;; esac : see if getpwnam_r exists set getpwnam_r d_getpwnam_r eval $inlibc case "$d_getpwnam_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_pwd pwd.h" case "$d_getpwnam_r_proto:$usethreads" in ":define") d_getpwnam_r_proto=define set d_getpwnam_r_proto getpwnam_r $hdrs eval $hasproto ;; *) ;; esac case "$d_getpwnam_r_proto" in define) case "$getpwnam_r_proto" in ''|0) try='int getpwnam_r(const char*, struct passwd*, char*, size_t, struct passwd**);' ./protochk "$extern_C $try" $hdrs && getpwnam_r_proto=I_CSBWR ;; esac case "$getpwnam_r_proto" in ''|0) try='int getpwnam_r(const char*, struct passwd*, char*, int, struct passwd**);' ./protochk "$extern_C $try" $hdrs && getpwnam_r_proto=I_CSBIR ;; esac case "$getpwnam_r_proto" in ''|0) try='struct passwd* getpwnam_r(const char*, struct passwd*, char*, int);' ./protochk "$extern_C $try" $hdrs && getpwnam_r_proto=S_CSBI ;; esac case "$getpwnam_r_proto" in ''|0) try='int getpwnam_r(const char*, struct passwd*, char*, int);' ./protochk "$extern_C $try" $hdrs && getpwnam_r_proto=I_CSBI ;; esac case "$getpwnam_r_proto" in ''|0) d_getpwnam_r=undef getpwnam_r_proto=0 echo "Disabling getpwnam_r, cannot determine prototype." >&4 ;; * ) case "$getpwnam_r_proto" in REENTRANT_PROTO*) ;; *) getpwnam_r_proto="REENTRANT_PROTO_$getpwnam_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "getpwnam_r has no prototype, not using it." >&4 ;; esac d_getpwnam_r=undef getpwnam_r_proto=0 ;; esac ;; *) getpwnam_r_proto=0 ;; esac : see if getpwuid_r exists set getpwuid_r d_getpwuid_r eval $inlibc case "$d_getpwuid_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_pwd pwd.h" case "$d_getpwuid_r_proto:$usethreads" in ":define") d_getpwuid_r_proto=define set d_getpwuid_r_proto getpwuid_r $hdrs eval $hasproto ;; *) ;; esac case "$d_getpwuid_r_proto" in define) case "$getpwuid_r_proto" in ''|0) try='int getpwuid_r(uid_t, struct passwd*, char*, size_t, struct passwd**);' ./protochk "$extern_C $try" $hdrs && getpwuid_r_proto=I_TSBWR ;; esac case "$getpwuid_r_proto" in ''|0) try='int getpwuid_r(uid_t, struct passwd*, char*, int, struct passwd**);' ./protochk "$extern_C $try" $hdrs && getpwuid_r_proto=I_TSBIR ;; esac case "$getpwuid_r_proto" in ''|0) try='int getpwuid_r(uid_t, struct passwd*, char*, int);' ./protochk "$extern_C $try" $hdrs && getpwuid_r_proto=I_TSBI ;; esac case "$getpwuid_r_proto" in ''|0) try='struct passwd* getpwuid_r(uid_t, struct passwd*, char*, int);' ./protochk "$extern_C $try" $hdrs && getpwuid_r_proto=S_TSBI ;; esac case "$getpwuid_r_proto" in ''|0) d_getpwuid_r=undef getpwuid_r_proto=0 echo "Disabling getpwuid_r, cannot determine prototype." >&4 ;; * ) case "$getpwuid_r_proto" in REENTRANT_PROTO*) ;; *) getpwuid_r_proto="REENTRANT_PROTO_$getpwuid_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "getpwuid_r has no prototype, not using it." >&4 ;; esac d_getpwuid_r=undef getpwuid_r_proto=0 ;; esac ;; *) getpwuid_r_proto=0 ;; esac : Optional checks for getsbyname and getsbyport : see if getservbyname exists set getservbyname d_getsbyname eval $inlibc : see if getservbyport exists set getservbyport d_getsbyport eval $inlibc : see if getservent exists set getservent d_getsent eval $inlibc : see if getservbyname_r exists set getservbyname_r d_getservbyname_r eval $inlibc case "$d_getservbyname_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_netdb netdb.h" case "$d_getservbyname_r_proto:$usethreads" in ":define") d_getservbyname_r_proto=define set d_getservbyname_r_proto getservbyname_r $hdrs eval $hasproto ;; *) ;; esac case "$d_getservbyname_r_proto" in define) case "$getservbyname_r_proto" in ''|0) try='int getservbyname_r(const char*, const char*, struct servent*, char*, size_t, struct servent**);' ./protochk "$extern_C $try" $hdrs && getservbyname_r_proto=I_CCSBWR ;; esac case "$getservbyname_r_proto" in ''|0) try='struct servent* getservbyname_r(const char*, const char*, struct servent*, char*, int);' ./protochk "$extern_C $try" $hdrs && getservbyname_r_proto=S_CCSBI ;; esac case "$getservbyname_r_proto" in ''|0) try='int getservbyname_r(const char*, const char*, struct servent*, struct servent_data*);' ./protochk "$extern_C $try" $hdrs && getservbyname_r_proto=I_CCSD ;; esac case "$getservbyname_r_proto" in ''|0) d_getservbyname_r=undef getservbyname_r_proto=0 echo "Disabling getservbyname_r, cannot determine prototype." >&4 ;; * ) case "$getservbyname_r_proto" in REENTRANT_PROTO*) ;; *) getservbyname_r_proto="REENTRANT_PROTO_$getservbyname_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "getservbyname_r has no prototype, not using it." >&4 ;; esac d_getservbyname_r=undef getservbyname_r_proto=0 ;; esac ;; *) getservbyname_r_proto=0 ;; esac : see if getservbyport_r exists set getservbyport_r d_getservbyport_r eval $inlibc case "$d_getservbyport_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_netdb netdb.h" case "$d_getservbyport_r_proto:$usethreads" in ":define") d_getservbyport_r_proto=define set d_getservbyport_r_proto getservbyport_r $hdrs eval $hasproto ;; *) ;; esac case "$d_getservbyport_r_proto" in define) case "$getservbyport_r_proto" in ''|0) try='int getservbyport_r(int, const char*, struct servent*, char*, size_t, struct servent**);' ./protochk "$extern_C $try" $hdrs && getservbyport_r_proto=I_ICSBWR ;; esac case "$getservbyport_r_proto" in ''|0) try='struct servent* getservbyport_r(int, const char*, struct servent*, char*, int);' ./protochk "$extern_C $try" $hdrs && getservbyport_r_proto=S_ICSBI ;; esac case "$getservbyport_r_proto" in ''|0) try='int getservbyport_r(int, const char*, struct servent*, struct servent_data*);' ./protochk "$extern_C $try" $hdrs && getservbyport_r_proto=I_ICSD ;; esac case "$getservbyport_r_proto" in ''|0) d_getservbyport_r=undef getservbyport_r_proto=0 echo "Disabling getservbyport_r, cannot determine prototype." >&4 ;; * ) case "$getservbyport_r_proto" in REENTRANT_PROTO*) ;; *) getservbyport_r_proto="REENTRANT_PROTO_$getservbyport_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "getservbyport_r has no prototype, not using it." >&4 ;; esac d_getservbyport_r=undef getservbyport_r_proto=0 ;; esac ;; *) getservbyport_r_proto=0 ;; esac : see if getservent_r exists set getservent_r d_getservent_r eval $inlibc case "$d_getservent_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_netdb netdb.h" case "$d_getservent_r_proto:$usethreads" in ":define") d_getservent_r_proto=define set d_getservent_r_proto getservent_r $hdrs eval $hasproto ;; *) ;; esac case "$d_getservent_r_proto" in define) case "$getservent_r_proto" in ''|0) try='int getservent_r(struct servent*, char*, size_t, struct servent**);' ./protochk "$extern_C $try" $hdrs && getservent_r_proto=I_SBWR ;; esac case "$getservent_r_proto" in ''|0) try='int getservent_r(struct servent*, char*, int);' ./protochk "$extern_C $try" $hdrs && getservent_r_proto=I_SBI ;; esac case "$getservent_r_proto" in ''|0) try='struct servent* getservent_r(struct servent*, char*, int);' ./protochk "$extern_C $try" $hdrs && getservent_r_proto=S_SBI ;; esac case "$getservent_r_proto" in ''|0) try='int getservent_r(struct servent*, struct servent_data*);' ./protochk "$extern_C $try" $hdrs && getservent_r_proto=I_SD ;; esac case "$getservent_r_proto" in ''|0) d_getservent_r=undef getservent_r_proto=0 echo "Disabling getservent_r, cannot determine prototype." >&4 ;; * ) case "$getservent_r_proto" in REENTRANT_PROTO*) ;; *) getservent_r_proto="REENTRANT_PROTO_$getservent_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "getservent_r has no prototype, not using it." >&4 ;; esac d_getservent_r=undef getservent_r_proto=0 ;; esac ;; *) getservent_r_proto=0 ;; esac : see if prototypes for various getservxxx netdb.h functions are available echo " " set d_getservprotos getservent $i_netdb netdb.h eval $hasproto : see if getspnam exists set getspnam d_getspnam eval $inlibc : see if this is a shadow.h system set shadow.h i_shadow eval $inhdr : see if getspnam_r exists set getspnam_r d_getspnam_r eval $inlibc case "$d_getspnam_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_shadow shadow.h" case "$d_getspnam_r_proto:$usethreads" in ":define") d_getspnam_r_proto=define set d_getspnam_r_proto getspnam_r $hdrs eval $hasproto ;; *) ;; esac case "$d_getspnam_r_proto" in define) case "$getspnam_r_proto" in ''|0) try='int getspnam_r(const char*, struct spwd*, char*, size_t, struct spwd**);' ./protochk "$extern_C $try" $hdrs && getspnam_r_proto=I_CSBWR ;; esac case "$getspnam_r_proto" in ''|0) try='struct spwd* getspnam_r(const char*, struct spwd*, char*, int);' ./protochk "$extern_C $try" $hdrs && getspnam_r_proto=S_CSBI ;; esac case "$getspnam_r_proto" in ''|0) d_getspnam_r=undef getspnam_r_proto=0 echo "Disabling getspnam_r, cannot determine prototype." >&4 ;; * ) case "$getspnam_r_proto" in REENTRANT_PROTO*) ;; *) getspnam_r_proto="REENTRANT_PROTO_$getspnam_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "getspnam_r has no prototype, not using it." >&4 ;; esac d_getspnam_r=undef getspnam_r_proto=0 ;; esac ;; *) getspnam_r_proto=0 ;; esac : see if gettimeofday or ftime exists set gettimeofday d_gettimeod eval $inlibc case "$d_gettimeod" in "$undef") set ftime d_ftime eval $inlibc ;; *) val="$undef"; set d_ftime; eval $setvar ;; esac case "$d_gettimeod$d_ftime" in "$undef$undef") echo " " echo 'No ftime() nor gettimeofday() -- timing may be less accurate.' >&4 ;; esac : see if gmtime_r exists set gmtime_r d_gmtime_r eval $inlibc case "$d_gmtime_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_time time.h $i_systime sys/time.h" case "$d_gmtime_r_proto:$usethreads" in ":define") d_gmtime_r_proto=define set d_gmtime_r_proto gmtime_r $hdrs eval $hasproto ;; *) ;; esac case "$d_gmtime_r_proto" in define) case "$gmtime_r_proto" in ''|0) try='struct tm* gmtime_r(const time_t*, struct tm*);' ./protochk "$extern_C $try" $hdrs && gmtime_r_proto=S_TS ;; esac case "$gmtime_r_proto" in ''|0) try='int gmtime_r(const time_t*, struct tm*);' ./protochk "$extern_C $try" $hdrs && gmtime_r_proto=I_TS ;; esac case "$gmtime_r_proto" in ''|0) d_gmtime_r=undef gmtime_r_proto=0 echo "Disabling gmtime_r, cannot determine prototype." >&4 ;; * ) case "$gmtime_r_proto" in REENTRANT_PROTO*) ;; *) gmtime_r_proto="REENTRANT_PROTO_$gmtime_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "gmtime_r has no prototype, not using it." >&4 ;; esac d_gmtime_r=undef gmtime_r_proto=0 ;; esac ;; *) gmtime_r_proto=0 ;; esac : see if hasmntopt exists set hasmntopt d_hasmntopt eval $inlibc : see if this is a netinet/in.h or sys/in.h system set netinet/in.h i_niin sys/in.h i_sysin eval $inhdr : see if arpa/inet.h has to be included set arpa/inet.h i_arpainet eval $inhdr : see if htonl --and friends-- exists val='' set htonl val eval $inlibc : Maybe they are macros. case "$val" in $undef) $cat >htonl.c < #include #$i_niin I_NETINET_IN #$i_sysin I_SYS_IN #$i_arpainet I_ARPA_INET #ifdef I_NETINET_IN #include #endif #ifdef I_SYS_IN #include #endif #ifdef I_ARPA_INET #include #endif #ifdef htonl printf("Defined as a macro."); #endif EOM $cppstdin $cppflags $cppminus < htonl.c >htonl.E 2>/dev/null if $contains 'Defined as a macro' htonl.E >/dev/null 2>&1; then val="$define" echo "But it seems to be defined as a macro." >&4 fi $rm -f htonl.? ;; esac set d_htonl eval $setvar : see if ilogbl exists set ilogbl d_ilogbl eval $inlibc : index or strchr echo " " if set index val -f; eval $csym; $val; then if set strchr val -f d_strchr; eval $csym; $val; then if $contains strchr "$strings" >/dev/null 2>&1 ; then val="$define" vali="$undef" echo "strchr() found." >&4 else val="$undef" vali="$define" echo "index() found." >&4 fi else val="$undef" vali="$define" echo "index() found." >&4 fi else if set strchr val -f d_strchr; eval $csym; $val; then val="$define" vali="$undef" echo "strchr() found." >&4 else echo "No index() or strchr() found!" >&4 val="$undef" vali="$undef" fi fi set d_strchr; eval $setvar val="$vali" set d_index; eval $setvar : check whether inet_aton exists set inet_aton d_inetaton eval $inlibc : see if inet_ntop exists set inet_ntop d_inetntop eval $inlibc : see if inet_pton exists set inet_pton d_inetpton eval $inlibc : Look for isascii echo " " $cat >isascii.c < #include #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif int main() { int c = 'A'; if (isascii(c)) exit(0); else exit(1); } EOCP set isascii if eval $compile; then echo "isascii() found." >&4 val="$define" else echo "isascii() NOT found." >&4 val="$undef" fi set d_isascii eval $setvar $rm -f isascii* : see if isfinite exists set isfinite d_isfinite eval $inlibc : see if isinf exists set isinf d_isinf eval $inlibc : see if isnan exists set isnan d_isnan eval $inlibc : see if isnanl exists set isnanl d_isnanl eval $inlibc : see if killpg exists set killpg d_killpg eval $inlibc : see if lchown exists echo " " $cat > try.c <<'EOCP' /* System header to define __stub macros and hopefully few prototypes, which can conflict with char lchown(); below. */ #include /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char lchown(); int main() { /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_lchown) || defined (__stub___lchown) choke me #else lchown(); #endif ; return 0; } EOCP set try if eval $compile; then $echo "lchown() found." >&4 val="$define" else $echo "lchown() NOT found." >&4 val="$undef" fi set d_lchown eval $setvar : See if number of significant digits in a double precision number is known echo " " $cat >ldbl_dig.c < #endif #ifdef I_FLOAT #include #endif #ifdef LDBL_DIG printf("Contains LDBL_DIG"); #endif EOM $cppstdin $cppflags $cppminus < ldbl_dig.c >ldbl_dig.E 2>/dev/null if $contains 'LDBL_DIG' ldbl_dig.E >/dev/null 2>&1; then echo "LDBL_DIG found." >&4 val="$define" else echo "LDBL_DIG NOT found." >&4 val="$undef" fi $rm -f ldbl_dig.? set d_ldbl_dig eval $setvar : see if this is a math.h system set math.h i_math eval $inhdr : check to see if math.h defines _LIB_VERSION d_libm_lib_version="$undef" case $i_math in $define) echo " " echo "Checking to see if your libm supports _LIB_VERSION..." >&4 $cat >try.c < #include int main (int argc, char *argv[]) { printf ("%d\n", _LIB_VERSION); return (0); } /* main */ EOCP set try if eval $compile; then foo=`$run ./try` echo "Yes, it does ($foo)" >&4 d_libm_lib_version="$define" else echo "No, it does not (probably harmless)" >&4 fi $rm_try ;; esac : see if link exists set link d_link eval $inlibc : see if localtime_r exists set localtime_r d_localtime_r eval $inlibc case "$d_localtime_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_time time.h $i_systime sys/time.h" case "$d_localtime_r_proto:$usethreads" in ":define") d_localtime_r_proto=define set d_localtime_r_proto localtime_r $hdrs eval $hasproto ;; *) ;; esac case "$d_localtime_r_proto" in define) case "$localtime_r_proto" in ''|0) try='struct tm* localtime_r(const time_t*, struct tm*);' ./protochk "$extern_C $try" $hdrs && localtime_r_proto=S_TS ;; esac case "$localtime_r_proto" in ''|0) try='int localtime_r(const time_t*, struct tm*);' ./protochk "$extern_C $try" $hdrs && localtime_r_proto=I_TS ;; esac case "$localtime_r_proto" in ''|0) d_localtime_r=undef localtime_r_proto=0 echo "Disabling localtime_r, cannot determine prototype." >&4 ;; * ) case "$localtime_r_proto" in REENTRANT_PROTO*) ;; *) localtime_r_proto="REENTRANT_PROTO_$localtime_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "localtime_r has no prototype, not using it." >&4 ;; esac d_localtime_r=undef localtime_r_proto=0 ;; esac ;; *) localtime_r_proto=0 ;; esac : see if localtime_r calls tzset case "$localtime_r_proto" in REENTRANT_PROTO*) $cat >try.c < #endif #ifdef I_UNISTD # include #endif #ifdef I_TIME # include #endif #ifdef I_STDLIB #include #endif #ifdef I_STRING # include #else # include #endif #ifdef I_MALLOC # include #endif int main() { time_t t = time(0L); char w_tz[]="TZ" "=GMT+5", e_tz[]="TZ" "=GMT-5", *tz_e = (char*)malloc(16), *tz_w = (char*)malloc(16); struct tm tm_e, tm_w; memset(&tm_e,'\0',sizeof(struct tm)); memset(&tm_w,'\0',sizeof(struct tm)); strcpy(tz_e,e_tz); strcpy(tz_w,w_tz); putenv(tz_e); localtime_r(&t, &tm_e); putenv(tz_w); localtime_r(&t, &tm_w); if( memcmp(&tm_e, &tm_w, sizeof(struct tm)) == 0 ) return 1; return 0; } EOCP set try if eval $compile; then if $run ./try; then d_localtime_r_needs_tzset=undef; else d_localtime_r_needs_tzset=define; fi; else d_localtime_r_needs_tzset=undef; fi; ;; *) d_localtime_r_needs_tzset=undef; ;; esac $rm_try : see if localeconv exists set localeconv d_locconv eval $inlibc : see if lockf exists set lockf d_lockf eval $inlibc : see if prototype for lseek is available echo " " set d_lseekproto lseek $i_systypes sys/types.h $i_unistd unistd.h eval $hasproto : see if lstat exists set lstat d_lstat eval $inlibc : see if madvise exists set madvise d_madvise eval $inlibc : see if malloc_size exists set malloc_size d_malloc_size eval $inlibc : see if malloc_size_good exists set malloc_good_size d_malloc_good_size eval $inlibc : see if mblen exists set mblen d_mblen eval $inlibc : see if mbstowcs exists set mbstowcs d_mbstowcs eval $inlibc : see if mbtowc exists set mbtowc d_mbtowc eval $inlibc : see if memchr exists set memchr d_memchr eval $inlibc : see if memcmp exists set memcmp d_memcmp eval $inlibc : see if memcpy exists set memcpy d_memcpy eval $inlibc : see if memmove exists set memmove d_memmove eval $inlibc : see if memset exists set memset d_memset eval $inlibc : see if mkdir exists set mkdir d_mkdir eval $inlibc : see if mkdtemp exists set mkdtemp d_mkdtemp eval $inlibc : see if mkfifo exists set mkfifo d_mkfifo eval $inlibc : see if mkstemp exists set mkstemp d_mkstemp eval $inlibc : see if mkstemps exists set mkstemps d_mkstemps eval $inlibc : see if mktime exists set mktime d_mktime eval $inlibc : see if this is a sys/mman.h system set sys/mman.h i_sysmman eval $inhdr : see if mmap exists set mmap d_mmap eval $inlibc : see what shmat returns : default to something harmless mmaptype='void *' case "$i_sysmman$d_mmap" in "$define$define") $cat >mmap.c <<'END' #include void *mmap(); END if $cc $ccflags -c mmap.c >/dev/null 2>&1; then mmaptype='void *' else mmaptype='caddr_t' fi echo "and it returns ($mmaptype)." >&4 ;; esac : see if sqrtl exists set sqrtl d_sqrtl eval $inlibc : see if scalbnl exists set scalbnl d_scalbnl eval $inlibc : see if modfl exists set modfl d_modfl eval $inlibc : see if prototype for modfl is available echo " " set d_modflproto modfl $i_math math.h eval $hasproto d_modfl_pow32_bug="$undef" case "$d_longdbl$d_modfl" in $define$define) $cat <try.c < #include EOCP if $test "X$d_modflproto" != "X$define"; then $cat >>try.c <>try.c <&4 "Your modfl() is broken for large values." d_modfl_pow32_bug="$define" case "$foo" in glibc) echo >&4 "You should upgrade your glibc to at least 2.2.2 to get a fixed modfl()." ;; esac ;; *" 4294967303.150000 0.150000 4294967303.000000") echo >&4 "Your modfl() seems okay for large values." ;; *) echo >&4 "I don't understand your modfl() at all." d_modfl="$undef" ;; esac $rm_try else echo "I cannot figure out whether your modfl() is okay, assuming it isn't." d_modfl="$undef" fi case "$osname:$gccversion" in aix:) ccflags="$saveccflags" ;; # restore esac ;; esac if $test "$uselongdouble" = "$define"; then message="" if $test "$d_sqrtl" != "$define"; then message="$message sqrtl" fi if $test "$d_modfl" != "$define"; then if $test "$d_aintl:$d_copysignl" = "$define:$define"; then echo "You have both aintl and copysignl, so I can emulate modfl." else message="$message modfl" fi fi if $test "$d_frexpl" != "$define"; then if $test "$d_ilogbl:$d_scalbnl" = "$define:$define"; then echo "You have both ilogbl and scalbnl, so I can emulate frexpl." else message="$message frexpl" fi fi if $test "$message" != ""; then $cat <&4 *** You requested the use of long doubles but you do not seem to have *** the following mathematical functions needed for long double support: *** $message *** Please rerun Configure without -Duselongdouble and/or -Dusemorebits. *** Cannot continue, aborting. EOM exit 1 fi fi : see if mprotect exists set mprotect d_mprotect eval $inlibc : see if msgctl exists set msgctl d_msgctl eval $inlibc : see if msgget exists set msgget d_msgget eval $inlibc : see if msgsnd exists set msgsnd d_msgsnd eval $inlibc : see if msgrcv exists set msgrcv d_msgrcv eval $inlibc : see how much of the 'msg*(2)' library is present. h_msg=true echo " " case "$d_msgctl$d_msgget$d_msgsnd$d_msgrcv" in *"$undef"*) h_msg=false;; esac case "$osname" in freebsd) case "`ipcs 2>&1`" in "SVID messages"*"not configured"*) echo "Your $osname does not have the msg*(2) configured." >&4 h_msg=false val="$undef" set msgctl d_msgctl eval $setvar set msgget d_msgget eval $setvar set msgsnd d_msgsnd eval $setvar set msgrcv d_msgrcv eval $setvar ;; esac ;; esac : we could also check for sys/ipc.h ... if $h_msg && $test `./findhdr sys/msg.h`; then echo "You have the full msg*(2) library." >&4 val="$define" else echo "You don't have the full msg*(2) library." >&4 val="$undef" fi set d_msg eval $setvar : Check for msghdr_s echo " " echo "Checking to see if your system supports struct msghdr..." >&4 set d_msghdr_s msghdr $i_systypes sys/types.h $d_socket sys/socket.h $i_sysuio sys/uio.h eval $hasstruct case "$d_msghdr_s" in "$define") echo "Yes, it does." ;; *) echo "No, it doesn't." ;; esac : see if msync exists set msync d_msync eval $inlibc : see if munmap exists set munmap d_munmap eval $inlibc : see if nice exists set nice d_nice eval $inlibc : see if this is a langinfo.h system set langinfo.h i_langinfo eval $inhdr : see if nl_langinfo exists set nl_langinfo d_nl_langinfo eval $inlibc : check for volatile keyword echo " " echo 'Checking to see if your C compiler knows about "volatile"...' >&4 $cat >try.c <<'EOCP' int main() { typedef struct _goo_struct goo_struct; goo_struct * volatile goo = ((goo_struct *)0); struct _goo_struct { long long_int; int reg_int; char char_var; }; typedef unsigned short foo_t; char *volatile foo; volatile int bar; volatile foo_t blech; foo = foo; } EOCP if $cc -c $ccflags try.c >/dev/null 2>&1 ; then val="$define" echo "Yup, it does." else val="$undef" echo "Nope, it doesn't." fi set d_volatile eval $setvar $rm_try : Check basic sizes echo " " $echo "Choosing the C types to be used for Perl's internal types..." >&4 case "$use64bitint:$d_quad:$quadtype" in define:define:?*) ivtype="$quadtype" uvtype="$uquadtype" ivsize=8 uvsize=8 ;; *) ivtype="long" uvtype="unsigned long" ivsize=$longsize uvsize=$longsize ;; esac case "$uselongdouble:$d_longdbl" in define:define) nvtype="long double" nvsize=$longdblsize ;; *) nvtype=double nvsize=$doublesize ;; esac $echo "(IV will be "$ivtype", $ivsize bytes)" $echo "(UV will be "$uvtype", $uvsize bytes)" $echo "(NV will be "$nvtype", $nvsize bytes)" $cat >try.c < #endif #include int main() { #ifdef INT8 int8_t i = INT8_MAX; uint8_t u = UINT8_MAX; printf("int8_t\n"); #endif #ifdef INT16 int16_t i = INT16_MAX; uint16_t i = UINT16_MAX; printf("int16_t\n"); #endif #ifdef INT32 int32_t i = INT32_MAX; uint32_t u = UINT32_MAX; printf("int32_t\n"); #endif } EOCP i8type="signed char" u8type="unsigned char" i8size=1 u8size=1 case "$i16type" in '') case "$shortsize" in 2) i16type=short u16type="unsigned short" i16size=$shortsize u16size=$shortsize ;; esac ;; esac case "$i16type" in '') set try -DINT16 if eval $compile; then case "`$run ./try`" in int16_t) i16type=int16_t u16type=uint16_t i16size=2 u16size=2 ;; esac fi ;; esac case "$i16type" in '') if $test $shortsize -ge 2; then i16type=short u16type="unsigned short" i16size=$shortsize u16size=$shortsize fi ;; esac case "$i32type" in '') case "$longsize" in 4) i32type=long u32type="unsigned long" i32size=$longsize u32size=$longsize ;; *) case "$intsize" in 4) i32type=int u32type="unsigned int" i32size=$intsize u32size=$intsize ;; esac ;; esac ;; esac case "$i32type" in '') set try -DINT32 if eval $compile; then case "`$run ./try`" in int32_t) i32type=int32_t u32type=uint32_t i32size=4 u32size=4 ;; esac fi ;; esac case "$i32type" in '') if $test $intsize -ge 4; then i32type=int u32type="unsigned int" i32size=$intsize u32size=$intsize fi ;; esac case "$i64type" in '') case "$d_quad:$quadtype" in define:?*) i64type="$quadtype" u64type="$uquadtype" i64size=8 u64size=8 ;; esac ;; esac $echo "Checking how many bits of your UVs your NVs can preserve..." >&4 : volatile so that the compiler has to store it out to memory. if test X"$d_volatile" = X"$define"; then volatile=volatile fi $cat <try.c #include #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif #include #include #ifdef SIGFPE $volatile int bletched = 0; $signal_t blech(int s) { bletched = 1; } #endif int main() { $uvtype u = 0; $nvtype d; int n = 8 * $uvsize; int i; #ifdef SIGFPE signal(SIGFPE, blech); #endif for (i = 0; i < n; i++) { u = u << 1 | ($uvtype)1; d = ($nvtype)u; if (($uvtype)d != u) break; if (d <= 0) break; d = ($nvtype)(u - 1); if (($uvtype)d != (u - 1)) break; #ifdef SIGFPE if (bletched) break; #endif } printf("%d\n", ((i == n) ? -n : i)); exit(0); } EOP set try d_nv_preserves_uv="$undef" if eval $compile; then nv_preserves_uv_bits="`$run ./try`" fi case "$nv_preserves_uv_bits" in \-[1-9]*) nv_preserves_uv_bits=`expr 0 - $nv_preserves_uv_bits` $echo "Your NVs can preserve all $nv_preserves_uv_bits bits of your UVs." 2>&1 d_nv_preserves_uv="$define" ;; [1-9]*) $echo "Your NVs can preserve only $nv_preserves_uv_bits bits of your UVs." 2>&1 d_nv_preserves_uv="$undef" ;; *) $echo "Can't figure out how many bits your NVs preserve." 2>&1 nv_preserves_uv_bits="0" ;; esac $rm_try $echo "Checking to find the largest integer value your NVs can hold..." >&4 : volatile so that the compiler has to store it out to memory. if test X"$d_volatile" = X"$define"; then volatile=volatile fi $cat <try.c #include typedef $nvtype NV; int main() { NV value = 2; int count = 1; while(count < 256) { $volatile NV up = value + 1.0; $volatile NV negated = -value; $volatile NV down = negated - 1.0; $volatile NV got_up = up - value; int up_good = got_up == 1.0; int got_down = down - negated; int down_good = got_down == -1.0; if (down_good != up_good) { fprintf(stderr, "Inconsistency - up %d %f; down %d %f; for 2**%d (%.20f)\n", up_good, (double) got_up, down_good, (double) got_down, count, (double) value); return 1; } if (!up_good) { while (1) { if (count > 8) { count -= 8; fputs("256.0", stdout); } else { count--; fputs("2.0", stdout); } if (!count) { puts(""); return 0; } fputs("*", stdout); } } value *= 2; ++count; } fprintf(stderr, "Cannot overflow integer range, even at 2**%d (%.20f)\n", count, (double) value); return 1; } EOP set try nv_overflows_integers_at='0' if eval $compile; then xxx="`$run ./try`" case "$?" in 0) case "$xxx" in 2*) cat >&4 <&4 <&4 <&4 : volatile so that the compiler has to store it out to memory. if test X"$d_volatile" = X"$define"; then volatile=volatile fi $cat <try.c #include #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif #$i_string I_STRING #ifdef I_STRING # include #else # include #endif #include #include #ifdef SIGFPE $volatile int bletched = 0; $signal_t blech(int s) { bletched = 1; } #endif int checkit($nvtype d, char *where) { unsigned char *p = (char *)&d; unsigned char *end = p + sizeof(d); int fail = 0; while (p < end) fail += *p++; if (!fail) return 0; p = (char *)&d; printf("No - %s: 0x", where); while (p < end) printf ("%02X", *p++); printf("\n"); return 1; } int main(int argc, char **argv) { $nvtype d = 0.0; int fail = 0; fail += checkit(d, "0.0"); /* The compiler shouldn't be assuming that bletched is 0 */ d = bletched; fail += checkit(d, "bleched"); #ifdef SIGFPE signal(SIGFPE, blech); #endif /* Paranoia - the compiler should have no way of knowing that ANSI says that argv[argc] will always be NULL. Actually, if it did assume this it would be buggy, as this is C and main() can be called from elsewhere in the program. */ d = argv[argc] ? 1 : 0; if (d) { printf("Odd argv[argc]=%p, d=%g\n", argv[argc], d); } fail += checkit(d, "ternary"); memset(&d, sizeof(d), argv[argc] ? 1 : 0); if (d != 0.0) { printf("No - memset doesn't give 0.0\n"); /* This might just blow up: */ printf("(gives %g)\n", d); return 1; } #ifdef SIGFPE if (bletched) { printf("No - something bleched\n"); return 1; } #endif if (fail) { printf("No - %d fail(s)\n", fail); return 1; } printf("Yes\n"); return 0; } EOP set try d_nv_zero_is_allbits_zero="$undef" if eval $compile; then xxx="`$run ./try`" case "$?" in 0) case "$xxx" in Yes) cat >&4 <&4 <&4 <&4 $cat >try.c < #include int main() { off64_t x = 7; } EOCP set try if eval $compile; then val="$define" echo "You have off64_t." else val="$undef" echo "You do not have off64_t." case "$lseeksize" in 8) echo "(Your off_t is 64 bits, so you could use that.)" ;; esac fi $rm_try set d_off64_t eval $setvar : how to create joinable pthreads if test "X$usethreads" = "X$define" -a "X$i_pthread" = "X$define"; then echo " " echo "Checking what constant to use for creating joinable pthreads..." >&4 $cat >try.c <<'EOCP' #include int main() { int detachstate = JOINABLE; } EOCP set try -DJOINABLE=PTHREAD_CREATE_JOINABLE if eval $compile; then echo "You seem to use PTHREAD_CREATE_JOINABLE." >&4 val="$undef" # Yes, undef. set d_old_pthread_create_joinable eval $setvar val="" set old_pthread_create_joinable eval $setvar else set try -DJOINABLE=PTHREAD_CREATE_UNDETACHED if eval $compile; then echo "You seem to use PTHREAD_CREATE_UNDETACHED." >&4 val="$define" set d_old_pthread_create_joinable eval $setvar val=PTHREAD_CREATE_UNDETACHED set old_pthread_create_joinable eval $setvar else set try -DJOINABLE=__UNDETACHED if eval $compile; then echo "You seem to use __UNDETACHED." >&4 val="$define" set d_old_pthread_create_joinable eval $setvar val=__UNDETACHED set old_pthread_create_joinable eval $setvar else echo "Egads, nothing obvious found. Guessing that you use 0." >&4 val="$define" set d_old_pthread_create_joinable eval $setvar val=0 set old_pthread_create_joinable eval $setvar fi fi fi $rm_try else d_old_pthread_create_joinable="$undef" old_pthread_create_joinable="" fi : see if pause exists set pause d_pause eval $inlibc : see if poll exists set poll d_poll eval $inlibc : see if readlink exists set readlink d_readlink eval $inlibc : Check if exe is symlink to abs path of executing program echo " " procselfexe='' val="$undef" case "$d_readlink" in "$define") if $issymlink /proc/self/exe ; then $ls -l /proc/self/exe > reflect if $contains /`basename $ls` reflect >/dev/null 2>&1; then echo "You have Linux-like /proc/self/exe." procselfexe='"/proc/self/exe"' val="$define" fi fi if $issymlink /proc/curproc/file ; then $ls -l /proc/curproc/file > reflect if $contains /`basename $ls` reflect >/dev/null 2>&1; then echo "You have BSD-like /proc/curproc/file." procselfexe='"/proc/curproc/file"' val="$define" fi fi ;; esac $rm -f reflect set d_procselfexe eval $setvar : backward compatibility for d_hvfork if test X$d_hvfork != X; then d_vfork="$d_hvfork" d_hvfork='' fi : see if there is a vfork val='' set vfork val eval $inlibc d_pseudofork=$undef : Ok, but do we want to use it. vfork is reportedly unreliable in : perl on Solaris 2.x, and probably elsewhere. case "$val" in $define) echo " " case "$usevfork" in false) dflt='n';; *) dflt='y';; esac cat <<'EOM' Perl can only use a vfork() that doesn't suffer from strict restrictions on calling functions or modifying global data in the child. For example, glibc-2.1 contains such a vfork() that is unsuitable. If your system provides a proper fork() call, chances are that you do NOT want perl to use vfork(). EOM rp="Do you still want to use vfork()?" . ./myread case "$ans" in y|Y) ;; *) echo "Ok, we won't use vfork()." val="$undef" ;; esac ;; esac set d_vfork eval $setvar case "$d_vfork" in $define) usevfork='true';; *) usevfork='false';; esac : see whether the pthread_atfork exists $cat >try.c < #include int main() { #ifdef PTHREAD_ATFORK pthread_atfork(NULL,NULL,NULL); #endif } EOP : see if pthread_atfork exists set try -DPTHREAD_ATFORK if eval $compile; then val="$define" else val="$undef" fi case "$usethreads" in $define) case "$val" in $define) echo 'pthread_atfork found.' >&4 ;; *) echo 'pthread_atfork NOT found.' >&4 ;; esac esac set d_pthread_atfork eval $setvar : see if pthread_attr_setscope exists set pthread_attr_setscope d_pthread_attr_setscope eval $inlibc : see whether the various POSIXish _yields exist $cat >try.c < #include int main() { #ifdef SCHED_YIELD sched_yield(); #else #ifdef PTHREAD_YIELD pthread_yield(); #else #ifdef PTHREAD_YIELD_NULL pthread_yield(NULL); #endif #endif #endif } EOP : see if sched_yield exists set try -DSCHED_YIELD if eval $compile; then val="$define" sched_yield='sched_yield()' else val="$undef" fi case "$usethreads" in $define) case "$val" in $define) echo 'sched_yield() found.' >&4 ;; *) echo 'sched_yield() NOT found.' >&4 ;; esac esac set d_sched_yield eval $setvar : see if pthread_yield exists set try -DPTHREAD_YIELD if eval $compile; then val="$define" case "$sched_yield" in '') sched_yield='pthread_yield()' ;; esac else set try -DPTHREAD_YIELD_NULL if eval $compile; then val="$define" case "$sched_yield" in '') sched_yield='pthread_yield(NULL)' ;; esac else val="$undef" fi fi case "$usethreads" in $define) case "$val" in $define) echo 'pthread_yield() found.' >&4 ;; *) echo 'pthread_yield() NOT found.' >&4 ;; esac ;; esac set d_pthread_yield eval $setvar case "$sched_yield" in '') sched_yield=undef ;; esac $rm_try : see if random_r exists set random_r d_random_r eval $inlibc case "$d_random_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_stdlib stdlib.h" case "$d_random_r_proto:$usethreads" in ":define") d_random_r_proto=define set d_random_r_proto random_r $hdrs eval $hasproto ;; *) ;; esac case "$d_random_r_proto" in define) case "$random_r_proto" in ''|0) try='int random_r(int*, struct random_data*);' ./protochk "$extern_C $try" $hdrs && random_r_proto=I_iS ;; esac case "$random_r_proto" in ''|0) try='int random_r(long*, struct random_data*);' ./protochk "$extern_C $try" $hdrs && random_r_proto=I_lS ;; esac case "$random_r_proto" in ''|0) try='int random_r(struct random_data*, int32_t*);' ./protochk "$extern_C $try" $hdrs && random_r_proto=I_St ;; esac case "$random_r_proto" in ''|0) d_random_r=undef random_r_proto=0 echo "Disabling random_r, cannot determine prototype." >&4 ;; * ) case "$random_r_proto" in REENTRANT_PROTO*) ;; *) random_r_proto="REENTRANT_PROTO_$random_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "random_r has no prototype, not using it." >&4 ;; esac d_random_r=undef random_r_proto=0 ;; esac ;; *) random_r_proto=0 ;; esac : see if readdir and friends exist set readdir d_readdir eval $inlibc set seekdir d_seekdir eval $inlibc set telldir d_telldir eval $inlibc set rewinddir d_rewinddir eval $inlibc : see if readdir64_r exists set readdir64_r d_readdir64_r eval $inlibc case "$d_readdir64_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_dirent dirent.h" case "$d_readdir64_r_proto:$usethreads" in ":define") d_readdir64_r_proto=define set d_readdir64_r_proto readdir64_r $hdrs eval $hasproto ;; *) ;; esac case "$d_readdir64_r_proto" in define) case "$readdir64_r_proto" in ''|0) try='int readdir64_r(DIR*, struct dirent64*, struct dirent64**);' ./protochk "$extern_C $try" $hdrs && readdir64_r_proto=I_TSR ;; esac case "$readdir64_r_proto" in ''|0) try='int readdir64_r(DIR*, struct dirent64*);' ./protochk "$extern_C $try" $hdrs && readdir64_r_proto=I_TS ;; esac case "$readdir64_r_proto" in ''|0) d_readdir64_r=undef readdir64_r_proto=0 echo "Disabling readdir64_r, cannot determine prototype." >&4 ;; * ) case "$readdir64_r_proto" in REENTRANT_PROTO*) ;; *) readdir64_r_proto="REENTRANT_PROTO_$readdir64_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "readdir64_r has no prototype, not using it." >&4 ;; esac d_readdir64_r=undef readdir64_r_proto=0 ;; esac ;; *) readdir64_r_proto=0 ;; esac : see if readdir_r exists set readdir_r d_readdir_r eval $inlibc case "$d_readdir_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_dirent dirent.h" case "$d_readdir_r_proto:$usethreads" in ":define") d_readdir_r_proto=define set d_readdir_r_proto readdir_r $hdrs eval $hasproto ;; *) ;; esac case "$d_readdir_r_proto" in define) case "$readdir_r_proto" in ''|0) try='int readdir_r(DIR*, struct dirent*, struct dirent**);' ./protochk "$extern_C $try" $hdrs && readdir_r_proto=I_TSR ;; esac case "$readdir_r_proto" in ''|0) try='int readdir_r(DIR*, struct dirent*);' ./protochk "$extern_C $try" $hdrs && readdir_r_proto=I_TS ;; esac case "$readdir_r_proto" in ''|0) d_readdir_r=undef readdir_r_proto=0 echo "Disabling readdir_r, cannot determine prototype." >&4 ;; * ) case "$readdir_r_proto" in REENTRANT_PROTO*) ;; *) readdir_r_proto="REENTRANT_PROTO_$readdir_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "readdir_r has no prototype, not using it." >&4 ;; esac d_readdir_r=undef readdir_r_proto=0 ;; esac ;; *) readdir_r_proto=0 ;; esac : see if readv exists set readv d_readv eval $inlibc : see if recvmsg exists set recvmsg d_recvmsg eval $inlibc : see if rename exists set rename d_rename eval $inlibc : see if rmdir exists set rmdir d_rmdir eval $inlibc : see if memory.h is available. val='' set memory.h val eval $inhdr : See if it conflicts with string.h case "$val" in $define) case "$strings" in '') ;; *) $cppstdin $cppflags $cppminus < $strings > mem.h if $contains 'memcpy' mem.h >/dev/null 2>&1; then echo " " echo "We won't be including ." val="$undef" fi $rm -f mem.h ;; esac esac set i_memory eval $setvar : can bcopy handle overlapping blocks? echo " " val="$undef" case "$d_memmove" in "$define") echo "I'll use memmove() instead of bcopy() for overlapping copies." ;; *) case "$d_bcopy" in "$define") echo "Checking to see if bcopy() can do overlapping copies..." >&4 $cat >try.c <>try.c <<'EOCP' #include #ifdef I_MEMORY # include #endif #ifdef I_STDLIB # include #endif #ifdef I_STRING # include #else # include #endif #ifdef I_UNISTD # include /* Needed for NetBSD */ #endif int main() { char buf[128], abc[128]; char *b; int len; int off; int align; /* Copy "abcde..." string to char abc[] so that gcc doesn't try to store the string in read-only memory. */ bcopy("abcdefghijklmnopqrstuvwxyz0123456789", abc, 36); for (align = 7; align >= 0; align--) { for (len = 36; len; len--) { b = buf+align; bcopy(abc, b, len); for (off = 1; off <= len; off++) { bcopy(b, b+off, len); bcopy(b+off, b, len); if (bcmp(b, abc, len)) exit(1); } } } exit(0); } EOCP set try if eval $compile_ok; then if $run ./try 2>/dev/null; then echo "Yes, it can." val="$define" else echo "It can't, sorry." fi else echo "(I can't compile the test program, so we'll assume not...)" fi ;; esac $rm_try ;; esac set d_safebcpy eval $setvar : can memcpy handle overlapping blocks? echo " " val="$undef" case "$d_memmove" in "$define") echo "I'll use memmove() instead of memcpy() for overlapping copies." ;; *) case "$d_memcpy" in "$define") echo "Checking to see if memcpy() can do overlapping copies..." >&4 $cat >try.c <>try.c <<'EOCP' #include #ifdef I_MEMORY # include #endif #ifdef I_STDLIB # include #endif #ifdef I_STRING # include #else # include #endif #ifdef I_UNISTD # include /* Needed for NetBSD */ #endif int main() { char buf[128], abc[128]; char *b; int len; int off; int align; /* Copy "abcde..." string to char abc[] so that gcc doesn't try to store the string in read-only memory. */ memcpy(abc, "abcdefghijklmnopqrstuvwxyz0123456789", 36); for (align = 7; align >= 0; align--) { for (len = 36; len; len--) { b = buf+align; memcpy(b, abc, len); for (off = 1; off <= len; off++) { memcpy(b+off, b, len); memcpy(b, b+off, len); if (memcmp(b, abc, len)) exit(1); } } } exit(0); } EOCP set try if eval $compile_ok; then if $run ./try 2>/dev/null; then echo "Yes, it can." val="$define" else echo "It can't, sorry." fi else echo "(I can't compile the test program, so we'll assume not...)" fi ;; esac $rm_try ;; esac set d_safemcpy eval $setvar : can memcmp be trusted to compare relative magnitude? val="$undef" case "$d_memcmp" in "$define") echo " " echo "Checking if your memcmp() can compare relative magnitude..." >&4 $cat >try.c <>try.c <<'EOCP' #include #ifdef I_MEMORY # include #endif #ifdef I_STDLIB # include #endif #ifdef I_STRING # include #else # include #endif #ifdef I_UNISTD # include /* Needed for NetBSD */ #endif int main() { char a = -1; char b = 0; if ((a < b) && memcmp(&a, &b, 1) < 0) exit(1); exit(0); } EOCP set try if eval $compile_ok; then if $run ./try 2>/dev/null; then echo "Yes, it can." val="$define" else echo "No, it can't (it uses signed chars)." fi else echo "(I can't compile the test program, so we'll assume not...)" fi ;; esac $rm_try set d_sanemcmp eval $setvar : see if prototype for sbrk is available echo " " set d_sbrkproto sbrk $i_unistd unistd.h eval $hasproto : see if select exists set select d_select eval $inlibc : see if semctl exists set semctl d_semctl eval $inlibc : see if semget exists set semget d_semget eval $inlibc : see if semop exists set semop d_semop eval $inlibc : see how much of the 'sem*(2)' library is present. h_sem=true echo " " case "$d_semctl$d_semget$d_semop" in *"$undef"*) h_sem=false;; esac case "$osname" in freebsd) case "`ipcs 2>&1`" in "SVID messages"*"not configured"*) echo "Your $osname does not have the sem*(2) configured." >&4 h_sem=false val="$undef" set semctl d_semctl eval $setvar set semget d_semget eval $setvar set semop d_semop eval $setvar ;; esac ;; esac : we could also check for sys/ipc.h ... if $h_sem && $test `./findhdr sys/sem.h`; then echo "You have the full sem*(2) library." >&4 val="$define" else echo "You don't have the full sem*(2) library." >&4 val="$undef" fi set d_sem eval $setvar : see whether sys/sem.h defines union semun echo " " $cat > try.c <<'END' #include #include #include int main () { union semun semun; semun.buf = 0; } END set try if eval $compile; then echo "You have union semun in ." >&4 val="$define" else echo "You do not have union semun in ." >&4 val="$undef" fi $rm_try set d_union_semun eval $setvar : see how to do semctl IPC_STAT case "$d_sem" in $define) echo " " $cat > tryh.h <>3) # define S_IWGRP (S_IWUSR>>3) # define S_IXGRP (S_IXUSR>>3) # define S_IROTH (S_IRUSR>>6) # define S_IWOTH (S_IWUSR>>6) # define S_IXOTH (S_IXUSR>>6) #endif #ifndef S_IRWXU # define S_IRWXU (S_IRUSR|S_IWUSR|S_IXUSR) # define S_IRWXG (S_IRGRP|S_IWGRP|S_IXGRP) # define S_IRWXO (S_IROTH|S_IWOTH|S_IXOTH) #endif END : see whether semctl IPC_STAT can use union semun case "$d_semctl_semun" in '') val="$undef" $cat > try.c < #include #include #include #include #include #include "tryh.h" #ifndef errno extern int errno; #endif #$d_union_semun HAS_UNION_SEMUN int main() { union semun #ifndef HAS_UNION_SEMUN { int val; struct semid_ds *buf; unsigned short *array; } #endif arg; int sem, st; #if defined(IPC_PRIVATE) && defined(S_IRWXU) && defined(S_IRWXG) && defined(S_IRWXO) && defined(IPC_CREAT) sem = semget(IPC_PRIVATE, 1, S_IRWXU|S_IRWXG|S_IRWXO|IPC_CREAT); if (sem > -1) { struct semid_ds argbuf; arg.buf = &argbuf; # ifdef IPC_STAT st = semctl(sem, 0, IPC_STAT, arg); if (st == 0) printf("semun\n"); else # endif /* IPC_STAT */ printf("semctl IPC_STAT failed: errno = %d\n", errno); # ifdef IPC_RMID if (semctl(sem, 0, IPC_RMID, arg) != 0) # endif /* IPC_RMID */ printf("semctl IPC_RMID failed: errno = %d\n", errno); } else #endif /* IPC_PRIVATE && ... */ printf("semget failed: errno = %d\n", errno); return 0; } END set try if eval $compile; then xxx=`$run ./try` case "$xxx" in semun) val="$define" ;; esac fi $rm_try set d_semctl_semun eval $setvar ;; esac case "$d_semctl_semun" in $define) echo "You can use union semun for semctl IPC_STAT." >&4 also='also' ;; *) echo "You cannot use union semun for semctl IPC_STAT." >&4 also='' ;; esac : see whether semctl IPC_STAT can use struct semid_ds pointer case "$d_semctl_semid_ds" in '') val="$undef" $cat > try.c <<'END' #include #include #include #include #include "tryh.h" #include #include #ifndef errno extern int errno; #endif int main() { struct semid_ds arg; int sem, st; #if defined(IPC_PRIVATE) && defined(S_IRWXU) && defined(S_IRWXG) && defined(S_IRWXO) && defined(IPC_CREAT) sem = semget(IPC_PRIVATE, 1, S_IRWXU|S_IRWXG|S_IRWXO|IPC_CREAT); if (sem > -1) { # ifdef IPC_STAT st = semctl(sem, 0, IPC_STAT, &arg); if (st == 0) printf("semid_ds\n"); else # endif /* IPC_STAT */ printf("semctl IPC_STAT failed: errno = %d\n", errno); # ifdef IPC_RMID if (semctl(sem, 0, IPC_RMID, &arg) != 0) # endif /* IPC_RMID */ printf("semctl IPC_RMID failed: errno = %d\n", errno); } else #endif /* IPC_PRIVATE && ... */ printf("semget failed: errno = %d\n", errno); return 0; } END set try if eval $compile; then xxx=`$run ./try` case "$xxx" in semid_ds) val="$define" ;; esac fi $rm_try set d_semctl_semid_ds eval $setvar ;; esac case "$d_semctl_semid_ds" in $define) echo "You can $also use struct semid_ds* for semctl IPC_STAT." >&4 ;; *) echo "You cannot use struct semid_ds* for semctl IPC_STAT." >&4 ;; esac ;; *) val="$undef" # We do not have the full sem*(2) library, so assume we can not # use either. set d_semctl_semun eval $setvar set d_semctl_semid_ds eval $setvar ;; esac $rm_try tryh.h : see if sendmsg exists set sendmsg d_sendmsg eval $inlibc : see if setegid exists set setegid d_setegid eval $inlibc : see if seteuid exists set seteuid d_seteuid eval $inlibc : see if setgrent exists set setgrent d_setgrent eval $inlibc : see if setgrent_r exists set setgrent_r d_setgrent_r eval $inlibc case "$d_setgrent_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_grp grp.h" case "$d_setgrent_r_proto:$usethreads" in ":define") d_setgrent_r_proto=define set d_setgrent_r_proto setgrent_r $hdrs eval $hasproto ;; *) ;; esac case "$d_setgrent_r_proto" in define) case "$setgrent_r_proto" in ''|0) try='int setgrent_r(FILE**);' ./protochk "$extern_C $try" $hdrs && setgrent_r_proto=I_H ;; esac case "$setgrent_r_proto" in ''|0) try='void setgrent_r(FILE**);' ./protochk "$extern_C $try" $hdrs && setgrent_r_proto=V_H ;; esac case "$setgrent_r_proto" in ''|0) d_setgrent_r=undef setgrent_r_proto=0 echo "Disabling setgrent_r, cannot determine prototype." >&4 ;; * ) case "$setgrent_r_proto" in REENTRANT_PROTO*) ;; *) setgrent_r_proto="REENTRANT_PROTO_$setgrent_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "setgrent_r has no prototype, not using it." >&4 ;; esac d_setgrent_r=undef setgrent_r_proto=0 ;; esac ;; *) setgrent_r_proto=0 ;; esac : see if sethostent exists set sethostent d_sethent eval $inlibc : see if sethostent_r exists set sethostent_r d_sethostent_r eval $inlibc case "$d_sethostent_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_netdb netdb.h" case "$d_sethostent_r_proto:$usethreads" in ":define") d_sethostent_r_proto=define set d_sethostent_r_proto sethostent_r $hdrs eval $hasproto ;; *) ;; esac case "$d_sethostent_r_proto" in define) case "$sethostent_r_proto" in ''|0) try='int sethostent_r(int, struct hostent_data*);' ./protochk "$extern_C $try" $hdrs && sethostent_r_proto=I_ID ;; esac case "$sethostent_r_proto" in ''|0) try='void sethostent_r(int, struct hostent_data*);' ./protochk "$extern_C $try" $hdrs && sethostent_r_proto=V_ID ;; esac case "$sethostent_r_proto" in ''|0) d_sethostent_r=undef sethostent_r_proto=0 echo "Disabling sethostent_r, cannot determine prototype." >&4 ;; * ) case "$sethostent_r_proto" in REENTRANT_PROTO*) ;; *) sethostent_r_proto="REENTRANT_PROTO_$sethostent_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "sethostent_r has no prototype, not using it." >&4 ;; esac d_sethostent_r=undef sethostent_r_proto=0 ;; esac ;; *) sethostent_r_proto=0 ;; esac : see if setitimer exists set setitimer d_setitimer eval $inlibc : see if setlinebuf exists set setlinebuf d_setlinebuf eval $inlibc : see if setlocale exists set setlocale d_setlocale eval $inlibc : see if locale.h is available set locale.h i_locale eval $inhdr : see if setlocale_r exists set setlocale_r d_setlocale_r eval $inlibc case "$d_setlocale_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_locale locale.h" case "$d_setlocale_r_proto:$usethreads" in ":define") d_setlocale_r_proto=define set d_setlocale_r_proto setlocale_r $hdrs eval $hasproto ;; *) ;; esac case "$d_setlocale_r_proto" in define) case "$setlocale_r_proto" in ''|0) try='int setlocale_r(int, const char*, char*, int);' ./protochk "$extern_C $try" $hdrs && setlocale_r_proto=I_ICBI ;; esac case "$setlocale_r_proto" in ''|0) d_setlocale_r=undef setlocale_r_proto=0 echo "Disabling setlocale_r, cannot determine prototype." >&4 ;; * ) case "$setlocale_r_proto" in REENTRANT_PROTO*) ;; *) setlocale_r_proto="REENTRANT_PROTO_$setlocale_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "setlocale_r has no prototype, not using it." >&4 ;; esac d_setlocale_r=undef setlocale_r_proto=0 ;; esac ;; *) setlocale_r_proto=0 ;; esac : see if setnetent exists set setnetent d_setnent eval $inlibc : see if setnetent_r exists set setnetent_r d_setnetent_r eval $inlibc case "$d_setnetent_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_netdb netdb.h" case "$d_setnetent_r_proto:$usethreads" in ":define") d_setnetent_r_proto=define set d_setnetent_r_proto setnetent_r $hdrs eval $hasproto ;; *) ;; esac case "$d_setnetent_r_proto" in define) case "$setnetent_r_proto" in ''|0) try='int setnetent_r(int, struct netent_data*);' ./protochk "$extern_C $try" $hdrs && setnetent_r_proto=I_ID ;; esac case "$setnetent_r_proto" in ''|0) try='void setnetent_r(int, struct netent_data*);' ./protochk "$extern_C $try" $hdrs && setnetent_r_proto=V_ID ;; esac case "$setnetent_r_proto" in ''|0) d_setnetent_r=undef setnetent_r_proto=0 echo "Disabling setnetent_r, cannot determine prototype." >&4 ;; * ) case "$setnetent_r_proto" in REENTRANT_PROTO*) ;; *) setnetent_r_proto="REENTRANT_PROTO_$setnetent_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "setnetent_r has no prototype, not using it." >&4 ;; esac d_setnetent_r=undef setnetent_r_proto=0 ;; esac ;; *) setnetent_r_proto=0 ;; esac : see if setprotoent exists set setprotoent d_setpent eval $inlibc : see if setpgid exists set setpgid d_setpgid eval $inlibc : see if setpgrp2 exists set setpgrp2 d_setpgrp2 eval $inlibc : see if setpriority exists set setpriority d_setprior eval $inlibc : see if setproctitle exists set setproctitle d_setproctitle eval $inlibc : see if setprotoent_r exists set setprotoent_r d_setprotoent_r eval $inlibc case "$d_setprotoent_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_netdb netdb.h" case "$d_setprotoent_r_proto:$usethreads" in ":define") d_setprotoent_r_proto=define set d_setprotoent_r_proto setprotoent_r $hdrs eval $hasproto ;; *) ;; esac case "$d_setprotoent_r_proto" in define) case "$setprotoent_r_proto" in ''|0) try='int setprotoent_r(int, struct protoent_data*);' ./protochk "$extern_C $try" $hdrs && setprotoent_r_proto=I_ID ;; esac case "$setprotoent_r_proto" in ''|0) try='void setprotoent_r(int, struct protoent_data*);' ./protochk "$extern_C $try" $hdrs && setprotoent_r_proto=V_ID ;; esac case "$setprotoent_r_proto" in ''|0) d_setprotoent_r=undef setprotoent_r_proto=0 echo "Disabling setprotoent_r, cannot determine prototype." >&4 ;; * ) case "$setprotoent_r_proto" in REENTRANT_PROTO*) ;; *) setprotoent_r_proto="REENTRANT_PROTO_$setprotoent_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "setprotoent_r has no prototype, not using it." >&4 ;; esac d_setprotoent_r=undef setprotoent_r_proto=0 ;; esac ;; *) setprotoent_r_proto=0 ;; esac : see if setpwent exists set setpwent d_setpwent eval $inlibc : see if setpwent_r exists set setpwent_r d_setpwent_r eval $inlibc case "$d_setpwent_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_pwd pwd.h" case "$d_setpwent_r_proto:$usethreads" in ":define") d_setpwent_r_proto=define set d_setpwent_r_proto setpwent_r $hdrs eval $hasproto ;; *) ;; esac case "$d_setpwent_r_proto" in define) case "$setpwent_r_proto" in ''|0) try='int setpwent_r(FILE**);' ./protochk "$extern_C $try" $hdrs && setpwent_r_proto=I_H ;; esac case "$setpwent_r_proto" in ''|0) try='void setpwent_r(FILE**);' ./protochk "$extern_C $try" $hdrs && setpwent_r_proto=V_H ;; esac case "$setpwent_r_proto" in ''|0) d_setpwent_r=undef setpwent_r_proto=0 echo "Disabling setpwent_r, cannot determine prototype." >&4 ;; * ) case "$setpwent_r_proto" in REENTRANT_PROTO*) ;; *) setpwent_r_proto="REENTRANT_PROTO_$setpwent_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "setpwent_r has no prototype, not using it." >&4 ;; esac d_setpwent_r=undef setpwent_r_proto=0 ;; esac ;; *) setpwent_r_proto=0 ;; esac : see if setregid exists set setregid d_setregid eval $inlibc set setresgid d_setresgid eval $inlibc : see if setreuid exists set setreuid d_setreuid eval $inlibc set setresuid d_setresuid eval $inlibc : see if setrgid exists set setrgid d_setrgid eval $inlibc : see if setruid exists set setruid d_setruid eval $inlibc : see if setservent exists set setservent d_setsent eval $inlibc : see if setservent_r exists set setservent_r d_setservent_r eval $inlibc case "$d_setservent_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_netdb netdb.h" case "$d_setservent_r_proto:$usethreads" in ":define") d_setservent_r_proto=define set d_setservent_r_proto setservent_r $hdrs eval $hasproto ;; *) ;; esac case "$d_setservent_r_proto" in define) case "$setservent_r_proto" in ''|0) try='int setservent_r(int, struct servent_data*);' ./protochk "$extern_C $try" $hdrs && setservent_r_proto=I_ID ;; esac case "$setservent_r_proto" in ''|0) try='void setservent_r(int, struct servent_data*);' ./protochk "$extern_C $try" $hdrs && setservent_r_proto=V_ID ;; esac case "$setservent_r_proto" in ''|0) d_setservent_r=undef setservent_r_proto=0 echo "Disabling setservent_r, cannot determine prototype." >&4 ;; * ) case "$setservent_r_proto" in REENTRANT_PROTO*) ;; *) setservent_r_proto="REENTRANT_PROTO_$setservent_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "setservent_r has no prototype, not using it." >&4 ;; esac d_setservent_r=undef setservent_r_proto=0 ;; esac ;; *) setservent_r_proto=0 ;; esac : see if setsid exists set setsid d_setsid eval $inlibc : see if setvbuf exists set setvbuf d_setvbuf eval $inlibc : see if sfio.h is available set sfio.h i_sfio eval $inhdr : see if sfio library is available case "$i_sfio" in $define) val='' set sfreserve val eval $inlibc ;; *) val="$undef" ;; esac : Ok, but do we want to use it. case "$val" in $define) case "$usesfio" in true|$define|[yY]*) dflt='y';; *) dflt='n';; esac echo "$package can use the sfio library, but it is experimental." case "$useperlio" in "$undef") echo "For sfio also the PerlIO abstraction layer is needed." echo "Earlier you said you wouldn't want that." ;; esac rp="You seem to have sfio available, do you want to try using it?" . ./myread case "$ans" in y|Y) echo "Ok, turning on both sfio and PerlIO, then." useperlio="$define" val="$define" ;; *) echo "Ok, avoiding sfio this time. I'll use stdio instead." val="$undef" ;; esac ;; *) case "$usesfio" in true|$define|[yY]*) echo "Sorry, cannot find sfio on this machine." >&4 echo "Ignoring your setting of usesfio=$usesfio." >&4 val="$undef" ;; esac ;; esac set d_sfio eval $setvar case "$d_sfio" in $define) usesfio='true';; *) usesfio='false';; esac case "$d_sfio" in $define) ;; *) : Remove sfio from list of libraries to use case "$libs" in *-lsfio*) echo "Removing unneeded -lsfio from library list" >&4 set `echo X $libs | $sed -e 's/-lsfio / /' -e 's/-lsfio$//'` shift libs="$*" echo "libs = $libs" >&4 ;; esac ;; esac : see if shmctl exists set shmctl d_shmctl eval $inlibc : see if shmget exists set shmget d_shmget eval $inlibc : see if shmat exists set shmat d_shmat eval $inlibc : see what shmat returns case "$d_shmat" in "$define") $cat >shmat.c <<'END' #include void *shmat(); END if $cc $ccflags -c shmat.c >/dev/null 2>&1; then shmattype='void *' else shmattype='char *' fi echo "and it returns ($shmattype)." >&4 : see if a prototype for shmat is available xxx=`./findhdr sys/shm.h` $cppstdin $cppflags $cppminus < $xxx > shmat.c 2>/dev/null if $contains 'shmat.*(' shmat.c >/dev/null 2>&1; then val="$define" else val="$undef" fi $rm -f shmat.[co] ;; *) val="$undef" ;; esac set d_shmatprototype eval $setvar : see if shmdt exists set shmdt d_shmdt eval $inlibc : see how much of the 'shm*(2)' library is present. h_shm=true echo " " case "$d_shmctl$d_shmget$d_shmat$d_shmdt" in *"$undef"*) h_shm=false;; esac case "$osname" in freebsd) case "`ipcs 2>&1`" in "SVID shared memory"*"not configured"*) echo "Your $osname does not have the shm*(2) configured." >&4 h_shm=false val="$undef" set shmctl d_shmctl evat $setvar set shmget d_shmget evat $setvar set shmat d_shmat evat $setvar set shmdt d_shmdt evat $setvar ;; esac ;; esac : we could also check for sys/ipc.h ... if $h_shm && $test `./findhdr sys/shm.h`; then echo "You have the full shm*(2) library." >&4 val="$define" else echo "You don't have the full shm*(2) library." >&4 val="$undef" fi set d_shm eval $setvar : see if we have sigaction echo " " if set sigaction val -f d_sigaction; eval $csym; $val; then echo 'sigaction() found.' >&4 $cat > try.c < #include #include #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif int main() { struct sigaction act, oact; act.sa_flags = 0; oact.sa_handler = 0; /* so that act and oact are used */ exit(act.sa_flags == 0 && oact.sa_handler == 0); } EOP set try if eval $compile_ok; then val="$define" else echo "But you don't seem to have a useable struct sigaction." >&4 val="$undef" fi else echo 'sigaction NOT found.' >&4 val="$undef" fi set d_sigaction; eval $setvar $rm_try : see if this is a sunmath.h system set sunmath.h i_sunmath eval $inhdr : see if signbit exists $echo $n "Checking to see if you have signbit() available to work on $nvtype... $c" >&4 $cat >try.c < #endif #ifdef I_SUNMATH /* Solaris special math library */ # include #endif #define NV $nvtype int main(int argc, char **argv) { NV x = 0.0; NV y = -0.0; if ((signbit(x) == 0) && (signbit(y) != 0)) return 0; else return 1; } EOCP val="$undef" set try if eval $compile; then if $run ./try; then $echo "Yes." >&4 val="$define" else $echo "Signbit seems to be available, but doesn't work as I expected." $echo "I won't use it." >&4 val="$undef" fi else $echo "Nope." >&4 dflt="$undef" fi set d_signbit eval $setvar $rm_try : see if sigprocmask exists set sigprocmask d_sigprocmask eval $inlibc : see if sigsetjmp exists echo " " case "$d_sigsetjmp" in '') $cat >try.c < #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif sigjmp_buf env; int set = 1; int main() { if (sigsetjmp(env,1)) exit(set); set = 0; siglongjmp(env, 1); exit(1); } EOP set try if eval $compile; then if $run ./try >/dev/null 2>&1; then echo "POSIX sigsetjmp found." >&4 val="$define" else $cat >&4 <&4 val="$undef" fi ;; *) val="$d_sigsetjmp" case "$d_sigsetjmp" in $define) echo "POSIX sigsetjmp found." >&4;; $undef) echo "sigsetjmp not found." >&4;; esac ;; esac set d_sigsetjmp eval $setvar $rm_try : see if snprintf exists set snprintf d_snprintf eval $inlibc : see if vsnprintf exists set vsnprintf d_vsnprintf eval $inlibc case "$d_snprintf-$d_vsnprintf" in "$define-$define") $cat <try.c <<'EOCP' /* v?snprintf testing logic courtesy of Russ Allbery. * According to C99: * - if the buffer is too short it still must be \0-terminated * - if the buffer is too short the potentially required length * must be returned and not -1 * - if the buffer is NULL the potentially required length * must be returned and not -1 or core dump */ #include #include char buf[2]; int test (char *format, ...) { va_list args; int count; va_start (args, format); count = vsnprintf (buf, sizeof buf, format, args); va_end (args); return count; } int main () { return ((test ("%s", "abcd") == 4 && buf[0] == 'a' && buf[1] == '\0' && snprintf (NULL, 0, "%s", "abcd") == 4) ? 0 : 1); } EOCP set try if eval $compile; then `$run ./try` case "$?" in 0) echo "Your snprintf() and vsnprintf() seem to be working okay." ;; *) cat <&4 Your snprintf() and snprintf() don't seem to be working okay. EOM d_snprintf="$undef" d_vsnprintf="$undef" ;; esac else echo "(I can't seem to compile the test program--assuming they don't)" d_snprintf="$undef" d_vsnprintf="$undef" fi $rm_try ;; esac : see if sockatmark exists set sockatmark d_sockatmark eval $inlibc : see if prototype for sockatmark is available echo " " set d_sockatmarkproto sockatmark $d_socket sys/socket.h eval $hasproto : see if socks5_init exists set socks5_init d_socks5_init eval $inlibc : see if sprintf returns the length of the string in the buffer as per ANSI $echo "Checking whether sprintf returns the length of the string..." >&4 $cat <try.c #include #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif #$i_string I_STRING #ifdef I_STRING # include #else # include #endif #$i_math I_MATH #ifdef I_MATH #include #endif char buffer[256]; int check (size_t expect, int test) { size_t got = strlen(buffer); if (expect == got) return 0; printf("expected %ld, got %ld in test %d '%s'\n", (long) expect, (long) got, test, buffer); exit (test); } int main(int argc, char **argv) { int test = 0; check(sprintf(buffer, ""), ++test); check(sprintf(buffer, "%s %s", "perl", "rules"), ++test); check(sprintf(buffer, "I like %g", atan2(0,-1)), ++test); return 0; } EOP set try if eval $compile; then xxx="`$run ./try`" case "$?" in 0) cat >&4 <&4 <&4 d_sprintf_returns_strlen="$undef" fi $rm_try : see if srand48_r exists set srand48_r d_srand48_r eval $inlibc case "$d_srand48_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_stdlib stdlib.h" case "$d_srand48_r_proto:$usethreads" in ":define") d_srand48_r_proto=define set d_srand48_r_proto srand48_r $hdrs eval $hasproto ;; *) ;; esac case "$d_srand48_r_proto" in define) case "$srand48_r_proto" in ''|0) try='int srand48_r(long, struct drand48_data*);' ./protochk "$extern_C $try" $hdrs && srand48_r_proto=I_LS ;; esac case "$srand48_r_proto" in ''|0) d_srand48_r=undef srand48_r_proto=0 echo "Disabling srand48_r, cannot determine prototype." >&4 ;; * ) case "$srand48_r_proto" in REENTRANT_PROTO*) ;; *) srand48_r_proto="REENTRANT_PROTO_$srand48_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "srand48_r has no prototype, not using it." >&4 ;; esac d_srand48_r=undef srand48_r_proto=0 ;; esac ;; *) srand48_r_proto=0 ;; esac : see if srandom_r exists set srandom_r d_srandom_r eval $inlibc case "$d_srandom_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_stdlib stdlib.h" case "$d_srandom_r_proto:$usethreads" in ":define") d_srandom_r_proto=define set d_srandom_r_proto srandom_r $hdrs eval $hasproto ;; *) ;; esac case "$d_srandom_r_proto" in define) case "$srandom_r_proto" in ''|0) try='int srandom_r(unsigned int, struct random_data*);' ./protochk "$extern_C $try" $hdrs && srandom_r_proto=I_TS ;; esac case "$srandom_r_proto" in ''|0) d_srandom_r=undef srandom_r_proto=0 echo "Disabling srandom_r, cannot determine prototype." >&4 ;; * ) case "$srandom_r_proto" in REENTRANT_PROTO*) ;; *) srandom_r_proto="REENTRANT_PROTO_$srandom_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "srandom_r has no prototype, not using it." >&4 ;; esac d_srandom_r=undef srandom_r_proto=0 ;; esac ;; *) srandom_r_proto=0 ;; esac : see if prototype for setresgid is available echo " " set d_sresgproto setresgid $i_unistd unistd.h eval $hasproto : see if prototype for setresuid is available echo " " set d_sresuproto setresuid $i_unistd unistd.h eval $hasproto : see if sys/stat.h is available set sys/stat.h i_sysstat eval $inhdr : see if stat knows about block sizes echo " " echo "Checking to see if your struct stat has st_blocks field..." >&4 set d_statblks stat st_blocks $i_sysstat sys/stat.h eval $hasfield : see if this is a sys/vfs.h system set sys/vfs.h i_sysvfs eval $inhdr : see if this is a sys/statfs.h system set sys/statfs.h i_sysstatfs eval $inhdr : Check for statfs_s echo " " echo "Checking to see if your system supports struct statfs..." >&4 set d_statfs_s statfs $i_systypes sys/types.h $i_sysparam sys/param.h $i_sysmount sys/mount.h $i_sysvfs sys/vfs.h $i_sysstatfs sys/statfs.h eval $hasstruct case "$d_statfs_s" in "$define") echo "Yes, it does." ;; *) echo "No, it doesn't." ;; esac : see if struct statfs knows about f_flags case "$d_statfs_s" in define) echo " " echo "Checking to see if your struct statfs has f_flags field..." >&4 set d_statfs_f_flags statfs f_flags $i_systypes sys/types.h $i_sysparam sys/param.h $i_sysmount sys/mount.h $i_sysvfs sys/vfs.h $i_sysstatfs sys/statfs.h eval $hasfield ;; *) val="$undef" set d_statfs_f_flags eval $setvar ;; esac case "$d_statfs_f_flags" in "$define") echo "Yes, it does." ;; *) echo "No, it doesn't." ;; esac : Check stream access $cat >&4 <try.c < int main() { if (&STDIO_STREAM_ARRAY[fileno(stdin)] == stdin) printf("yes\n"); } EOCP for s in _iob __iob __sF do set try -DSTDIO_STREAM_ARRAY=$s if eval $compile; then case "`$run ./try`" in yes) stdio_stream_array=$s; break ;; esac fi done $rm_try esac case "$stdio_stream_array" in '') $cat >&4 <&4 <&4 $cat >try.c <<'EOCP' int main() { struct blurfl { int dyick; } foo, bar; foo = bar; } EOCP if $cc -c try.c >/dev/null 2>&1 ; then val="$define" echo "Yup, it can." else val="$undef" echo "Nope, it can't." fi set d_strctcpy eval $setvar $rm_try : see if strerror and/or sys_errlist[] exist echo " " if test "X$d_strerror" = X -o "X$d_syserrlst" = X; then if set strerror val -f d_strerror; eval $csym; $val; then echo 'strerror() found.' >&4 d_strerror="$define" d_strerrm='strerror(e)' if set sys_errlist val -a d_syserrlst; eval $csym; $val; then echo "(You also have sys_errlist[], so we could roll our own strerror.)" d_syserrlst="$define" else echo "(Since you don't have sys_errlist[], sterror() is welcome.)" d_syserrlst="$undef" fi elif xxx=`./findhdr string.h`; test "$xxx" || xxx=`./findhdr strings.h`; \ $contains '#[ ]*define.*strerror' "$xxx" >/dev/null 2>&1; then echo 'strerror() found in string header.' >&4 d_strerror="$define" d_strerrm='strerror(e)' if set sys_errlist val -a d_syserrlst; eval $csym; $val; then echo "(Most probably, strerror() uses sys_errlist[] for descriptions.)" d_syserrlst="$define" else echo "(You don't appear to have any sys_errlist[], how can this be?)" d_syserrlst="$undef" fi elif set sys_errlist val -a d_syserrlst; eval $csym; $val; then echo "strerror() not found, but you have sys_errlist[] so we'll use that." >&4 d_strerror="$undef" d_syserrlst="$define" d_strerrm='((e)<0||(e)>=sys_nerr?"unknown":sys_errlist[e])' else echo 'strerror() and sys_errlist[] NOT found.' >&4 d_strerror="$undef" d_syserrlst="$undef" d_strerrm='"unknown"' fi fi : see if strerror_r exists set strerror_r d_strerror_r eval $inlibc case "$d_strerror_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_string string.h" case "$d_strerror_r_proto:$usethreads" in ":define") d_strerror_r_proto=define set d_strerror_r_proto strerror_r $hdrs eval $hasproto ;; *) ;; esac case "$d_strerror_r_proto" in define) case "$strerror_r_proto" in ''|0) try='int strerror_r(int, char*, size_t);' ./protochk "$extern_C $try" $hdrs && strerror_r_proto=I_IBW ;; esac case "$strerror_r_proto" in ''|0) try='int strerror_r(int, char*, int);' ./protochk "$extern_C $try" $hdrs && strerror_r_proto=I_IBI ;; esac case "$strerror_r_proto" in ''|0) try='char* strerror_r(int, char*, size_t);' ./protochk "$extern_C $try" $hdrs && strerror_r_proto=B_IBW ;; esac case "$strerror_r_proto" in ''|0) d_strerror_r=undef strerror_r_proto=0 echo "Disabling strerror_r, cannot determine prototype." >&4 ;; * ) case "$strerror_r_proto" in REENTRANT_PROTO*) ;; *) strerror_r_proto="REENTRANT_PROTO_$strerror_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "strerror_r has no prototype, not using it." >&4 ;; esac d_strerror_r=undef strerror_r_proto=0 ;; esac ;; *) strerror_r_proto=0 ;; esac : see if strftime exists set strftime d_strftime eval $inlibc : see if strlcat exists set strlcat d_strlcat eval $inlibc : see if strlcpy exists set strlcpy d_strlcpy eval $inlibc : see if strtod exists set strtod d_strtod eval $inlibc : see if strtol exists set strtol d_strtol eval $inlibc : see if strtold exists set strtold d_strtold eval $inlibc : see if strtoll exists set strtoll d_strtoll eval $inlibc case "$d_longlong-$d_strtoll" in "$define-$define") $cat <try.c <<'EOCP' #include #ifdef __hpux #define strtoll __strtoll #endif #ifdef __EMX__ #define strtoll _strtoll #endif #include extern long long int strtoll(char *s, char **, int); static int bad = 0; int check(char *s, long long ell, int een) { long long gll; errno = 0; gll = strtoll(s, 0, 10); if (!((gll == ell) && (errno == een))) bad++; } int main() { check(" 1", 1LL, 0); check(" 0", 0LL, 0); check("-1", -1LL, 0); check("-9223372036854775808", -9223372036854775808LL, 0); check("-9223372036854775808", -9223372036854775808LL, 0); check(" 9223372036854775807", 9223372036854775807LL, 0); check("-9223372036854775808", -9223372036854775808LL, 0); check(" 9223372036854775808", 9223372036854775807LL, ERANGE); check("-9223372036854775809", -9223372036854775808LL, ERANGE); if (!bad) printf("ok\n"); } EOCP set try if eval $compile; then yyy=`$run ./try` case "$yyy" in ok) echo "Your strtoll() seems to be working okay." ;; *) cat <&4 Your strtoll() doesn't seem to be working okay. EOM d_strtoll="$undef" ;; esac else echo "(I can't seem to compile the test program--assuming it doesn't)" d_strtoll="$undef" fi ;; esac : see if strtoq exists set strtoq d_strtoq eval $inlibc : see if strtoul exists set strtoul d_strtoul eval $inlibc case "$d_strtoul" in "$define") $cat <try.c <<'EOCP' #include #include extern unsigned long int strtoul(char *s, char **, int); static int bad = 0; void check(char *s, unsigned long eul, int een) { unsigned long gul; errno = 0; gul = strtoul(s, 0, 10); if (!((gul == eul) && (errno == een))) bad++; } int main() { check(" 1", 1L, 0); check(" 0", 0L, 0); EOCP case "$longsize" in 8) $cat >>try.c <<'EOCP' check("18446744073709551615", 18446744073709551615UL, 0); check("18446744073709551616", 18446744073709551615UL, ERANGE); #if 0 /* strtoul() for /^-/ strings is undefined. */ check("-1", 18446744073709551615UL, 0); check("-18446744073709551614", 2, 0); check("-18446744073709551615", 1, 0); check("-18446744073709551616", 18446744073709551615UL, ERANGE); check("-18446744073709551617", 18446744073709551615UL, ERANGE); #endif EOCP ;; 4) $cat >>try.c <<'EOCP' check("4294967295", 4294967295UL, 0); check("4294967296", 4294967295UL, ERANGE); #if 0 /* strtoul() for /^-/ strings is undefined. */ check("-1", 4294967295UL, 0); check("-4294967294", 2, 0); check("-4294967295", 1, 0); check("-4294967296", 4294967295UL, ERANGE); check("-4294967297", 4294967295UL, ERANGE); #endif EOCP ;; *) : Should we write these tests to be more portable by sprintf-ing : ~0 and then manipulating that char string as input for strtol? ;; esac $cat >>try.c <<'EOCP' if (!bad) printf("ok\n"); return 0; } EOCP set try if eval $compile; then case "`$run ./try`" in ok) echo "Your strtoul() seems to be working okay." ;; *) cat <&4 Your strtoul() doesn't seem to be working okay. EOM d_strtoul="$undef" ;; esac else echo "(I can't seem to compile the test program--assuming it doesn't)" d_strtoul="$undef" fi ;; esac : see if strtoull exists set strtoull d_strtoull eval $inlibc case "$d_longlong-$d_strtoull" in "$define-$define") $cat <try.c <<'EOCP' #include #ifdef __hpux #define strtoull __strtoull #endif #include extern unsigned long long int strtoull(char *s, char **, int); static int bad = 0; int check(char *s, long long eull, int een) { long long gull; errno = 0; gull = strtoull(s, 0, 10); if (!((gull == eull) && (errno == een))) bad++; } int main() { check(" 1", 1LL, 0); check(" 0", 0LL, 0); check("18446744073709551615", 18446744073709551615ULL, 0); check("18446744073709551616", 18446744073709551615ULL, ERANGE); #if 0 /* strtoull() for /^-/ strings is undefined. */ check("-1", 18446744073709551615ULL, 0); check("-18446744073709551614", 2LL, 0); check("-18446744073709551615", 1LL, 0); check("-18446744073709551616", 18446744073709551615ULL, ERANGE); check("-18446744073709551617", 18446744073709551615ULL, ERANGE); #endif if (!bad) printf("ok\n"); } EOCP set try if eval $compile; then case "`$run ./try`" in ok) echo "Your strtoull() seems to be working okay." ;; *) cat <&4 Your strtoull() doesn't seem to be working okay. EOM d_strtoull="$undef" ;; esac else echo "(I can't seem to compile the test program--assuming it doesn't)" d_strtoull="$undef" fi ;; esac : see if strtouq exists set strtouq d_strtouq eval $inlibc case "$d_strtouq" in "$define") $cat <try.c <<'EOCP' #include #include extern unsigned long long int strtouq(char *s, char **, int); static int bad = 0; void check(char *s, unsigned long long eull, int een) { unsigned long long gull; errno = 0; gull = strtouq(s, 0, 10); if (!((gull == eull) && (errno == een))) bad++; } int main() { check(" 1", 1LL, 0); check(" 0", 0LL, 0); check("18446744073709551615", 18446744073709551615ULL, 0); check("18446744073709551616", 18446744073709551615ULL, ERANGE); #if 0 /* strtouq() for /^-/ strings is undefined. */ check("-1", 18446744073709551615ULL, 0); check("-18446744073709551614", 2LL, 0); check("-18446744073709551615", 1LL, 0); check("-18446744073709551616", 18446744073709551615ULL, ERANGE); check("-18446744073709551617", 18446744073709551615ULL, ERANGE); #endif if (!bad) printf("ok\n"); return 0; } EOCP set try if eval $compile; then case "`$run ./try`" in ok) echo "Your strtouq() seems to be working okay." ;; *) cat <&4 Your strtouq() doesn't seem to be working okay. EOM d_strtouq="$undef" ;; esac else echo "(I can't seem to compile the test program--assuming it doesn't)" d_strtouq="$undef" fi ;; esac : see if strxfrm exists set strxfrm d_strxfrm eval $inlibc : see if symlink exists set symlink d_symlink eval $inlibc : see if syscall exists set syscall d_syscall eval $inlibc : see if prototype for syscall is available echo " " set d_syscallproto syscall $i_unistd unistd.h eval $hasproto : see if sysconf exists set sysconf d_sysconf eval $inlibc : see if system exists set system d_system eval $inlibc : see if tcgetpgrp exists set tcgetpgrp d_tcgetpgrp eval $inlibc : see if tcsetpgrp exists set tcsetpgrp d_tcsetpgrp eval $inlibc : see if prototype for telldir is available echo " " set d_telldirproto telldir $i_systypes sys/types.h $i_dirent dirent.h eval $hasproto : see if time exists echo " " if test "X$d_time" = X -o X"$timetype" = X; then if set time val -f d_time; eval $csym; $val; then echo 'time() found.' >&4 val="$define" rp="What is the type returned by time() on this system?" set time_t timetype long stdio.h sys/types.h eval $typedef_ask else echo 'time() not found, hope that will do.' >&4 val="$undef" timetype='int'; fi set d_time eval $setvar fi : see if timegm exists set timegm d_timegm eval $inlibc : see if this is a sys/times.h system set sys/times.h i_systimes eval $inhdr : see if times exists echo " " if set times val -f d_times; eval $csym; $val; then echo 'times() found.' >&4 d_times="$define" inc='' case "$i_systimes" in "$define") inc='sys/times.h';; esac rp="What is the type returned by times() on this system?" set clock_t clocktype long stdio.h sys/types.h $inc eval $typedef_ask else echo 'times() NOT found, hope that will do.' >&4 d_times="$undef" clocktype='int' fi : see if tmpnam_r exists set tmpnam_r d_tmpnam_r eval $inlibc case "$d_tmpnam_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h " case "$d_tmpnam_r_proto:$usethreads" in ":define") d_tmpnam_r_proto=define set d_tmpnam_r_proto tmpnam_r $hdrs eval $hasproto ;; *) ;; esac case "$d_tmpnam_r_proto" in define) case "$tmpnam_r_proto" in ''|0) try='char* tmpnam_r(char*);' ./protochk "$extern_C $try" $hdrs && tmpnam_r_proto=B_B ;; esac case "$tmpnam_r_proto" in ''|0) d_tmpnam_r=undef tmpnam_r_proto=0 echo "Disabling tmpnam_r, cannot determine prototype." >&4 ;; * ) case "$tmpnam_r_proto" in REENTRANT_PROTO*) ;; *) tmpnam_r_proto="REENTRANT_PROTO_$tmpnam_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "tmpnam_r has no prototype, not using it." >&4 ;; esac d_tmpnam_r=undef tmpnam_r_proto=0 ;; esac ;; *) tmpnam_r_proto=0 ;; esac : see if truncate exists set truncate d_truncate eval $inlibc : see if ttyname_r exists set ttyname_r d_ttyname_r eval $inlibc case "$d_ttyname_r" in "$define") hdrs="$i_systypes sys/types.h define stdio.h $i_unistd unistd.h" case "$d_ttyname_r_proto:$usethreads" in ":define") d_ttyname_r_proto=define set d_ttyname_r_proto ttyname_r $hdrs eval $hasproto ;; *) ;; esac case "$d_ttyname_r_proto" in define) case "$ttyname_r_proto" in ''|0) try='int ttyname_r(int, char*, size_t);' ./protochk "$extern_C $try" $hdrs && ttyname_r_proto=I_IBW ;; esac case "$ttyname_r_proto" in ''|0) try='int ttyname_r(int, char*, int);' ./protochk "$extern_C $try" $hdrs && ttyname_r_proto=I_IBI ;; esac case "$ttyname_r_proto" in ''|0) try='char* ttyname_r(int, char*, int);' ./protochk "$extern_C $try" $hdrs && ttyname_r_proto=B_IBI ;; esac case "$ttyname_r_proto" in ''|0) d_ttyname_r=undef ttyname_r_proto=0 echo "Disabling ttyname_r, cannot determine prototype." >&4 ;; * ) case "$ttyname_r_proto" in REENTRANT_PROTO*) ;; *) ttyname_r_proto="REENTRANT_PROTO_$ttyname_r_proto" ;; esac echo "Prototype: $try" ;; esac ;; *) case "$usethreads" in define) echo "ttyname_r has no prototype, not using it." >&4 ;; esac d_ttyname_r=undef ttyname_r_proto=0 ;; esac ;; *) ttyname_r_proto=0 ;; esac : see if tzname[] exists echo " " if set tzname val -a d_tzname; eval $csym; $val; then val="$define" echo 'tzname[] found.' >&4 else val="$undef" echo 'tzname[] NOT found.' >&4 fi set d_tzname eval $setvar : Check if is a multiplatform env case "$osname" in next|rhapsody|darwin) multiarch="$define" ;; esac case "$multiarch" in ''|[nN]*) multiarch="$undef" ;; esac : check for ordering of bytes in a UV echo " " case "$usecrosscompile$multiarch" in *$define*) $cat <try.c < #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif #include typedef $uvtype UV; int main() { int i; union { UV l; char c[$uvsize]; } u; if ($uvsize > 4) u.l = (((UV)0x08070605) << 32) | (UV)0x04030201; else u.l = (UV)0x04030201; for (i = 0; i < $uvsize; i++) printf("%c", u.c[i]+'0'); printf("\n"); exit(0); } EOCP xxx_prompt=y set try if eval $compile && $run ./try > /dev/null; then dflt=`$run ./try` case "$dflt" in [1-4][1-4][1-4][1-4]|12345678|87654321) echo "(The test program ran ok.)" echo "byteorder=$dflt" xxx_prompt=n ;; ????|????????) echo "(The test program ran ok.)" ;; *) echo "(The test program didn't run right for some reason.)" ;; esac else dflt='4321' cat <<'EOM' (I can't seem to compile the test program. Guessing big-endian...) EOM fi case "$xxx_prompt" in y) rp="What is the order of bytes in $uvtype?" . ./myread byteorder="$ans" ;; *) byteorder=$dflt ;; esac ;; esac $rm_try ;; esac : Checking 32bit aligndness $cat <try.c < #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif #define U32 $u32type #define BYTEORDER 0x$byteorder #define U8 $u8type #include #ifdef SIGBUS $signal_t bletch(int s) { exit(4); } #endif int main() { #if BYTEORDER == 0x1234 || BYTEORDER == 0x4321 U8 buf[8]; U32 *up; int i; if (sizeof(U32) != 4) { printf("sizeof(U32) is not 4, but %d\n", sizeof(U32)); exit(1); } fflush(stdout); #ifdef SIGBUS signal(SIGBUS, bletch); #endif buf[0] = 0; buf[1] = 0; buf[2] = 0; buf[3] = 1; buf[4] = 0; buf[5] = 0; buf[6] = 0; buf[7] = 1; for (i = 0; i < 4; i++) { up = (U32*)(buf + i); if (! ((*up == 1 << (8*i)) || /* big-endian */ (*up == 1 << (8*(3-i))) /* little-endian */ ) ) { printf("read failed (%x)\n", *up); exit(2); } } /* write test */ for (i = 0; i < 4; i++) { up = (U32*)(buf + i); *up = 0xBeef; if (*up != 0xBeef) { printf("write failed (%x)\n", *up); exit(3); } } exit(0); #else printf("1\n"); exit(1); #endif return 0; } EOCP set try if eval $compile_ok; then echo "(Testing for character data alignment may crash the test. That's okay.)" >&4 $run ./try 2>&1 >/dev/null case "$?" in 0) cat >&4 <&4 <&4 cat > try.c < #endif #if defined(I_DIRENT) #include #if defined(NeXT) && defined(I_SYS_DIR) /* NeXT needs dirent + sys/dir.h */ #include #endif #else #ifdef I_SYS_NDIR #include #else #ifdef I_SYS_DIR #ifdef hp9000s500 #include /* may be wrong in the future */ #else #include #endif #endif #endif #endif int main() { return closedir(opendir(".")); } EOM set try if eval $compile_ok; then if $run ./try > /dev/null 2>&1 ; then echo "Yes, it does." val="$undef" else echo "No, it doesn't." val="$define" fi else echo "(I can't seem to compile the test program--assuming it doesn't)" val="$define" fi ;; *) val="$undef"; ;; esac set d_void_closedir eval $setvar $rm_try : see if there is a wait4 set wait4 d_wait4 eval $inlibc : see if waitpid exists set waitpid d_waitpid eval $inlibc : see if wcstombs exists set wcstombs d_wcstombs eval $inlibc : see if wctomb exists set wctomb d_wctomb eval $inlibc : see if writev exists set writev d_writev eval $inlibc : preserve RCS keywords in files with variable substitution, grrr Date='$Date' Id='$Id' Log='$Log' RCSfile='$RCSfile' Revision='$Revision' : check for alignment requirements echo " " case "$usecrosscompile$multiarch" in *$define*) $cat <&4 if $test "X$uselongdouble" = Xdefine -a "X$d_longdbl" = Xdefine; then $cat >try.c <<'EOCP' typedef long double NV; EOCP else $cat >try.c <<'EOCP' typedef double NV; EOCP fi $cat >>try.c <<'EOCP' #include struct foobar { char foo; NV bar; } try_algn; int main() { printf("%d\n", (int)((char *)&try_algn.bar - (char *)&try_algn.foo)); return(0); } EOCP set try if eval $compile_ok; then dflt=`$run ./try` else dflt='8' echo "(I can't seem to compile the test program...)" fi ;; *) dflt="$alignbytes" ;; esac rp="Doubles must be aligned on a how-many-byte boundary?" . ./myread alignbytes="$ans" $rm_try ;; esac : set the base revision baserev=5.0 : check for length of character echo " " case "$charsize" in '') echo "Checking to see how big your characters are (hey, you never know)..." >&4 $cat >try.c < #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif int main() { printf("%d\n", (int)sizeof(char)); exit(0); } EOCP set try if eval $compile_ok; then dflt=`$run ./try` else dflt='1' echo "(I can't seem to compile the test program. Guessing...)" fi ;; *) dflt="$charsize" ;; esac rp="What is the size of a character (in bytes)?" . ./myread charsize="$ans" $rm_try : Check for the number of bits in a character case "$charbits" in '') echo "Checking how long a character is (in bits)..." >&4 $cat >try.c < int main () { int n; unsigned char c; for (c = 1, n = 0; c; c <<= 1, n++) ; printf ("%d\n", n); return (0); } EOCP set try if eval $compile_ok; then dflt=`$run ./try` else dflt='8' echo "(I can't seem to compile the test program. Guessing...)" fi ;; *) dflt="$charbits" ;; esac rp="What is the length of a character (in bits)?" . ./myread charbits="$ans" $rm_try case "$charbits" in 8) ;; *) cat >&4 << EOM Your system has an unsigned character size of $charbits bits, which is rather unusual (normally it is 8 bits). Perl likely will not work correctly on your system, with subtle bugs in various places. EOM rp='Do you really want to continue?' dflt='n' . ./myread case "$ans" in [yY]) echo >&4 "Okay, continuing." ;; *) exit 1 ;; esac esac : how do we concatenate cpp tokens here? echo " " echo "Checking to see how your cpp does stuff like concatenate tokens..." >&4 $cat >cpp_stuff.c <<'EOCP' #define RCAT(a,b)a/**/b #define ACAT(a,b)a ## b RCAT(Rei,ser) ACAT(Cir,cus) EOCP $cppstdin $cppflags $cppminus cpp_stuff.out 2>&1 if $contains 'Circus' cpp_stuff.out >/dev/null 2>&1; then echo "Oh! Smells like ANSI's been here." >&4 echo "We can catify or stringify, separately or together!" cpp_stuff=42 elif $contains 'Reiser' cpp_stuff.out >/dev/null 2>&1; then echo "Ah, yes! The good old days!" >&4 echo "However, in the good old days we don't know how to stringify and" echo "catify at the same time." cpp_stuff=1 else $cat >&4 <&4 $cat >try.c < #include #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif #include int main(int argc, char *argv[]) { #ifdef DB_VERSION_MAJOR /* DB version >= 2 */ int Major, Minor, Patch ; unsigned long Version ; (void)db_version(&Major, &Minor, &Patch) ; if (argc == 2) { printf("%d %d %d %d %d %d\n", DB_VERSION_MAJOR, DB_VERSION_MINOR, DB_VERSION_PATCH, Major, Minor, Patch); exit(0); } printf("You have Berkeley DB Version 2 or greater.\n"); printf("db.h is from Berkeley DB Version %d.%d.%d\n", DB_VERSION_MAJOR, DB_VERSION_MINOR, DB_VERSION_PATCH); printf("libdb is from Berkeley DB Version %d.%d.%d\n", Major, Minor, Patch) ; /* check that db.h & libdb are compatible */ if (DB_VERSION_MAJOR != Major || DB_VERSION_MINOR != Minor || DB_VERSION_PATCH != Patch) { printf("db.h and libdb are incompatible.\n") ; exit(3); } printf("db.h and libdb are compatible.\n") ; Version = DB_VERSION_MAJOR * 1000000 + DB_VERSION_MINOR * 1000 + DB_VERSION_PATCH ; /* needs to be >= 2.3.4 */ if (Version < 2003004) { /* if (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && DB_VERSION_PATCH < 5) { */ printf("Perl needs Berkeley DB 2.3.4 or greater.\n") ; exit(2); } exit(0); #else #if defined(_DB_H_) && defined(BTREEMAGIC) && defined(HASHMAGIC) if (argc == 2) { printf("1 0 0\n"); exit(0); } printf("You have Berkeley DB Version 1.\n"); exit(0); /* DB version < 2: the coast is clear. */ #else exit(1); /* not Berkeley DB? */ #endif #endif } EOCP set try if eval $compile_ok && $run ./try; then echo 'Looks OK.' >&4 set `$run ./try 1` db_version_major=$1 db_version_minor=$2 db_version_patch=$3 else echo "I can't use Berkeley DB with your . I'll disable Berkeley DB." >&4 i_db=$undef case " $libs " in *"-ldb "*) : Remove db from list of libraries to use echo "Removing unusable -ldb from library list" >&4 set `echo X $libs | $sed -e 's/-ldb / /' -e 's/-ldb$//'` shift libs="$*" echo "libs = $libs" >&4 ;; esac fi $rm_try ;; esac case "$i_db" in define) : Check the return type needed for hash echo " " echo "Checking return type needed for hash for Berkeley DB ..." >&4 $cat >try.c < #include #ifndef DB_VERSION_MAJOR u_int32_t hash_cb (ptr, size) const void *ptr; size_t size; { } HASHINFO info; int main() { info.hash = hash_cb; } #endif EOCP if $cc $ccflags -c try.c >try.out 2>&1 ; then if $contains warning try.out >>/dev/null 2>&1 ; then db_hashtype='int' else db_hashtype='u_int32_t' fi else : XXX Maybe we should just give up here. db_hashtype=u_int32_t $cat try.out >&4 echo "Help: I can't seem to compile the db test program." >&4 echo "Something's wrong, but I'll assume you use $db_hashtype." >&4 fi $rm_try echo "Your version of Berkeley DB uses $db_hashtype for hash." ;; *) db_hashtype=u_int32_t ;; esac case "$i_db" in define) : Check the return type needed for prefix echo " " echo "Checking return type needed for prefix for Berkeley DB ..." >&4 cat >try.c < #include #ifndef DB_VERSION_MAJOR size_t prefix_cb (key1, key2) const DBT *key1; const DBT *key2; { } BTREEINFO info; int main() { info.prefix = prefix_cb; } #endif EOCP if $cc $ccflags -c try.c >try.out 2>&1 ; then if $contains warning try.out >>/dev/null 2>&1 ; then db_prefixtype='int' else db_prefixtype='size_t' fi else db_prefixtype='size_t' : XXX Maybe we should just give up here. $cat try.out >&4 echo "Help: I can't seem to compile the db test program." >&4 echo "Something's wrong, but I'll assume you use $db_prefixtype." >&4 fi $rm_try echo "Your version of Berkeley DB uses $db_prefixtype for prefix." ;; *) db_prefixtype='size_t' ;; esac : How can we generate normalized random numbers ? echo " " echo "Looking for a random number function..." >&4 case "$randfunc" in '') if set drand48 val -f; eval $csym; $val; then dflt="drand48" echo "Good, found drand48()." >&4 elif set random val -f; eval $csym; $val; then dflt="random" echo "OK, found random()." >&4 else dflt="rand" echo "Yick, looks like I have to use rand()." >&4 fi echo " " ;; *) dflt="$randfunc" ;; esac cont=true case "$ccflags" in *-Dmy_rand=*|*-Dmy_srand=*) echo "Removing obsolete -Dmy_rand, -Dmy_srand, and -Drandbits from ccflags." >&4 ccflags="`echo $ccflags | sed -e 's/-Dmy_rand=random/ /'`" ccflags="`echo $ccflags | sed -e 's/-Dmy_srand=srandom/ /'`" ccflags="`echo $ccflags | sed -e 's/-Drandbits=[0-9][0-9]*/ /'`" ;; esac while $test "$cont"; do rp="Use which function to generate random numbers?" . ./myread if $test "$ans" = "$dflt"; then : null else randbits='' fi randfunc="$ans" if set $ans val -f; eval $csym; $val; then cont='' else dflt=y rp="I cannot find function $ans. Use that name anyway?" . ./myread dflt=rand case "$ans" in [yY]*) cont='';; esac fi case "$cont" in '') case "$randfunc" in drand48) drand01="drand48()" seedfunc="srand48" randbits=48 randseedtype=long ;; rand|random) case "$randbits" in '') echo "Checking to see how many bits your $randfunc() function produces..." >&4 $cat >try.c < #ifdef I_UNISTD # include #endif #ifdef I_STDLIB # include #endif int main() { register int i; register unsigned long tmp; register unsigned long max = 0L; for (i = 1000; i; i--) { tmp = (unsigned long) $randfunc(); if (tmp > max) max = tmp; } for (i = 0; max; i++) max /= 2; printf("%d\n",i); } EOCP set try if eval $compile_ok; then dflt=`try` else dflt='?' echo "(I can't seem to compile the test program...)" fi ;; *) dflt="$randbits" ;; esac rp="How many bits does your $randfunc() function produce?" . ./myread randbits="$ans" $rm_try drand01="($randfunc() / (double) ((unsigned long)1 << $randbits))" seedfunc="s$randfunc" randseedtype=unsigned ;; *) dflt="31" rp="How many bits does your $randfunc() function produce?" . ./myread randbits="$ans" seedfunc="s$randfunc" drand01="($randfunc() / (double) ((unsigned long)1 << $randbits))" if set $seedfunc val -f; eval $csym; $val; then echo "(Using $seedfunc() to seed random generator)" else echo "(Warning: no $seedfunc() to seed random generator)" seedfunc=rand fi randseedtype=unsigned ;; esac ;; esac done : Determine if this is an EBCDIC system echo " " echo "Determining whether or not we are on an EBCDIC system..." >&4 $cat >try.c <<'EOM' int main() { if ('M'==0xd4) return 0; return 1; } EOM val=$undef set try if eval $compile_ok; then if $run ./try; then echo "You seem to speak EBCDIC." >&4 val="$define" else echo "Nope, no EBCDIC, probably ASCII or some ISO Latin. Or UTF-8." >&4 fi else echo "I'm unable to compile the test program." >&4 echo "I'll assume ASCII or some ISO Latin. Or UTF8." >&4 fi $rm_try set ebcdic eval $setvar : Check how to flush echo " " $cat >&4 < try.c ;; esac $cat >>try.c < #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif #$i_unistd I_UNISTD #ifdef I_UNISTD # include #endif #$d_sysconf HAS_SYSCONF #$d_stdio_stream_array HAS_STDIO_STREAM_ARRAY #ifdef HAS_STDIO_STREAM_ARRAY # define STDIO_STREAM_ARRAY $stdio_stream_array #endif int main() { FILE* p; unlink("try.out"); p = fopen("try.out", "w"); #ifdef TRY_FPUTC fputc('x', p); #else # ifdef TRY_FPRINTF fprintf(p, "x"); # endif #endif #ifdef TRY_FFLUSH_NULL fflush(NULL); #endif #ifdef TRY_FFLUSH_ALL { long open_max = -1; # ifdef PERL_FFLUSH_ALL_FOPEN_MAX open_max = PERL_FFLUSH_ALL_FOPEN_MAX; # else # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX) open_max = sysconf(_SC_OPEN_MAX); # else # ifdef FOPEN_MAX open_max = FOPEN_MAX; # else # ifdef OPEN_MAX open_max = OPEN_MAX; # else # ifdef _NFILE open_max = _NFILE; # endif # endif # endif # endif # endif # ifdef HAS_STDIO_STREAM_ARRAY 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) fflush(&STDIO_STREAM_ARRAY[i]); } } # endif #endif _exit(42); } EOCP : first we have to find out how _not_ to flush $to try.c if $test "X$fflushNULL" = X -o "X$fflushall" = X; then output='' set try -DTRY_FPUTC if eval $compile; then $run ./try 2>/dev/null code="$?" $from try.out if $test ! -s try.out -a "X$code" = X42; then output=-DTRY_FPUTC fi fi case "$output" in '') set try -DTRY_FPRINTF if eval $compile; then $run ./try 2>/dev/null code="$?" $from try.out if $test ! -s try.out -a "X$code" = X42; then output=-DTRY_FPRINTF fi fi ;; esac fi : check for fflush NULL behaviour case "$fflushNULL" in '') set try -DTRY_FFLUSH_NULL $output if eval $compile; then $run ./try 2>/dev/null code="$?" $from try.out if $test -s try.out -a "X$code" = X42; then fflushNULL="`$cat try.out`" else if $test "X$code" != X42; then $cat >&4 <&4 <tryp.c < int main(int argc, char **argv) { char buf[1024]; int i; char *bp = buf; while (1) { while ((i = getc(stdin)) != -1 && (*bp++ = i) != '\n' && bp < &buf[1024]) /* DO NOTHING */ ; *bp = '\0'; fprintf(stdout, "%s", buf); fflush(NULL); if (i == -1) return 0; bp = buf; } } EOCP fflushNULL="$define" set tryp if eval $compile; then $rm -f tryp.out $cat tryp.c | $run ./tryp 2>/dev/null > tryp.out if cmp tryp.c tryp.out >/dev/null 2>&1; then $cat >&4 <&4 <&4 <&4 <tryp.c < int main(int argc, char **argv) { char buf[1024]; int i; char *bp = buf; while (1) { while ((i = getc(stdin)) != -1 && (*bp++ = i) != '\n' && bp < &buf[1024]) /* DO NOTHING */ ; *bp = '\0'; fprintf(stdout, "%s", buf); fflush(stdin); if (i == -1) return 0; bp = buf; } } EOCP set tryp if eval $compile; then $rm -f tryp.out $cat tryp.c | $run ./tryp 2>/dev/null > tryp.out if cmp tryp.c tryp.out >/dev/null 2>&1; then $cat >&4 <&4 </dev/null code=$? $from try.out if $test -s try.out -a "X$code" = X42; then fflushall="`$cat try.out`" fi fi $rm_try case "$fflushall" in x) $cat >&4 <&4 <&4 <&4 </dev/null` unsigned short case $1 in unsigned) dflt="$1 $2" ;; *) dflt="$1" ;; esac ;; *) dflt="$gidtype";; esac case "$gidtype" in gid_t) echo "gid_t found." ;; *) rp="What is the type for group ids returned by getgid()?" . ./myread gidtype="$ans" ;; esac : Check the size of GID echo " " case "$gidtype" in *_t) zzz="$gidtype" ;; *) zzz="gid" ;; esac echo "Checking the size of $zzz..." >&4 cat > try.c < #include #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif int main() { printf("%d\n", (int)sizeof($gidtype)); exit(0); } EOCP set try if eval $compile_ok; then yyy=`$run ./try` case "$yyy" in '') gidsize=4 echo "(I can't execute the test program--guessing $gidsize.)" >&4 ;; *) gidsize=$yyy echo "Your $zzz is $gidsize bytes long." ;; esac else gidsize=4 echo "(I can't compile the test program--guessing $gidsize.)" >&4 fi : Check if GID is signed echo " " case "$gidtype" in *_t) zzz="$gidtype" ;; *) zzz="gid" ;; esac echo "Checking the sign of $zzz..." >&4 cat > try.c < #include int main() { $gidtype foo = -1; if (foo < 0) printf("-1\n"); else printf("1\n"); } EOCP set try if eval $compile; then yyy=`$run ./try` case "$yyy" in '') gidsign=1 echo "(I can't execute the test program--guessing unsigned.)" >&4 ;; *) gidsign=$yyy case "$gidsign" in 1) echo "Your $zzz is unsigned." ;; -1) echo "Your $zzz is signed." ;; esac ;; esac else gidsign=1 echo "(I can't compile the test program--guessing unsigned.)" >&4 fi : Check 64bit sizes echo " " if $test X"$quadtype" != X; then echo "Checking how to print 64-bit integers..." >&4 if $test X"$sPRId64" = X -a X"$quadtype" = Xint; then $cat >try.c <<'EOCP' #include #include int main() { int q = 12345678901; printf("%ld\n", q); } EOCP set try if eval $compile; then yyy=`$run ./try` case "$yyy" in 12345678901) sPRId64='"d"'; sPRIi64='"i"'; sPRIu64='"u"'; sPRIo64='"o"'; sPRIx64='"x"'; sPRIXU64='"X"'; echo "We will use %d." ;; esac fi fi if $test X"$sPRId64" = X -a X"$quadtype" = Xlong; then $cat >try.c <<'EOCP' #include #include int main() { long q = 12345678901; printf("%ld\n", q); } EOCP set try if eval $compile; then yyy=`$run ./try` case "$yyy" in 12345678901) sPRId64='"ld"'; sPRIi64='"li"'; sPRIu64='"lu"'; sPRIo64='"lo"'; sPRIx64='"lx"'; sPRIXU64='"lX"'; echo "We will use %ld." ;; esac fi fi if $test X"$sPRId64" = X -a X"$i_inttypes" = X"$define" -a X"$quadtype" = Xint64_t; then $cat >try.c <<'EOCP' #include #include #include int main() { int64_t q = 12345678901; printf("%" PRId64 "\n", q); } EOCP set try if eval $compile; then yyy=`$run ./try` case "$yyy" in 12345678901) sPRId64=PRId64; sPRIi64=PRIi64; sPRIu64=PRIu64; sPRIo64=PRIo64; sPRIx64=PRIx64; sPRIXU64=PRIXU64; echo "We will use the C9X style." ;; esac fi fi if $test X"$sPRId64" = X -a X"$quadtype" != X; then $cat >try.c < #include int main() { $quadtype q = 12345678901; printf("%Ld\n", q); } EOCP set try if eval $compile; then yyy=`$run ./try` case "$yyy" in 12345678901) sPRId64='"Ld"'; sPRIi64='"Li"'; sPRIu64='"Lu"'; sPRIo64='"Lo"'; sPRIx64='"Lx"'; sPRIXU64='"LX"'; echo "We will use %Ld." ;; esac fi fi if $test X"$sPRId64" = X -a X"$quadtype" = X"long long"; then $cat >try.c <<'EOCP' #include #include int main() { long long q = 12345678901LL; /* AIX cc requires the LL suffix. */ printf("%lld\n", q); } EOCP set try if eval $compile; then yyy=`$run ./try` case "$yyy" in 12345678901) sPRId64='"lld"'; sPRIi64='"lli"'; sPRIu64='"llu"'; sPRIo64='"llo"'; sPRIx64='"llx"'; sPRIXU64='"llX"'; echo "We will use the %lld style." ;; esac fi fi if $test X"$sPRId64" = X -a X"$quadtype" != X; then $cat >try.c < #include int main() { $quadtype q = 12345678901; printf("%qd\n", q); } EOCP set try if eval $compile; then yyy=`$run ./try` case "$yyy" in 12345678901) sPRId64='"qd"'; sPRIi64='"qi"'; sPRIu64='"qu"'; sPRIo64='"qo"'; sPRIx64='"qx"'; sPRIXU64='"qX"'; echo "We will use %qd." ;; esac fi fi if $test X"$sPRId64" = X; then echo "Cannot figure out how to print 64-bit integers." >&4 fi $rm_try fi case "$sPRId64" in '') d_PRId64="$undef"; d_PRIi64="$undef"; d_PRIu64="$undef"; d_PRIo64="$undef"; d_PRIx64="$undef"; d_PRIXU64="$undef"; ;; *) d_PRId64="$define"; d_PRIi64="$define"; d_PRIu64="$define"; d_PRIo64="$define"; d_PRIx64="$define"; d_PRIXU64="$define"; ;; esac : Check format strings for internal types echo " " $echo "Checking the format strings to be used for Perl's internal types..." >&4 if $test X"$ivsize" = X8; then ivdformat="$sPRId64" uvuformat="$sPRIu64" uvoformat="$sPRIo64" uvxformat="$sPRIx64" uvXUformat="$sPRIXU64" else if $test X"$ivsize" = X"$longsize"; then ivdformat='"ld"' uvuformat='"lu"' uvoformat='"lo"' uvxformat='"lx"' uvXUformat='"lX"' else if $test X"$ivsize" = X"$intsize"; then ivdformat='"d"' uvuformat='"u"' uvoformat='"o"' uvxformat='"x"' uvXUformat='"X"' else : far out if $test X"$ivsize" = X"$shortsize"; then ivdformat='"hd"' uvuformat='"hu"' uvoformat='"ho"' uvxformat='"hx"' uvXUformat='"hX"' fi fi fi fi if $test X"$uselongdouble" = X"$define" -a X"$d_longdbl" = X"$define" -a X"$d_PRIgldbl" = X"$define"; then nveformat="$sPRIeldbl" nvfformat="$sPRIfldbl" nvgformat="$sPRIgldbl" nvEUformat="$sPRIEUldbl" nvFUformat="$sPRIFUldbl" nvGUformat="$sPRIGUldbl" else nveformat='"e"' nvfformat='"f"' nvgformat='"g"' nvEUformat='"E"' nvFUformat='"F"' nvGUformat='"G"' fi case "$ivdformat" in '') echo "$0: Fatal: failed to find format strings, cannot continue." >&4 exit 1 ;; esac : Check format string for GID echo " " $echo "Checking the format string to be used for gids..." >&4 case "$gidsign" in -1) if $test X"$gidsize" = X"$ivsize"; then gidformat="$ivdformat" else if $test X"$gidsize" = X"$longsize"; then gidformat='"ld"' else if $test X"$gidsize" = X"$intsize"; then gidformat='"d"' else if $test X"$gidsize" = X"$shortsize"; then gidformat='"hd"' fi fi fi fi ;; *) if $test X"$gidsize" = X"$uvsize"; then gidformat="$uvuformat" else if $test X"$gidsize" = X"$longsize"; then gidformat='"lu"' else if $test X"$gidsize" = X"$intsize"; then gidformat='"u"' else if $test X"$gidsize" = X"$shortsize"; then gidformat='"hu"' fi fi fi fi ;; esac : see if getgroups exists set getgroups d_getgrps eval $inlibc : see if setgroups exists set setgroups d_setgrps eval $inlibc : Find type of 2nd arg to 'getgroups()' and 'setgroups()' echo " " case "$d_getgrps$d_setgrps" in *define*) case "$groupstype" in '') dflt="$gidtype" ;; *) dflt="$groupstype" ;; esac $cat <&4 case "$make_set_make" in '') $sed 's/^X //' > testmake.mak << 'EOF' Xall: X @echo 'maketemp="$(MAKE)"' EOF case "`$make -f testmake.mak 2>/dev/null`" in *maketemp=*) make_set_make='#' ;; *) make_set_make="MAKE=$make" ;; esac $rm -f testmake.mak ;; esac case "$make_set_make" in '#') echo "Yup, it does.";; *) echo "Nope, it doesn't.";; esac : see what type is used for mode_t rp="What is the type used for file modes for system calls (e.g. fchmod())?" set mode_t modetype int stdio.h sys/types.h eval $typedef_ask : see if we need va_copy echo " " case "$i_stdarg" in "$define") $cat >try.c < #include #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif #include int ivfprintf(FILE *f, const char *fmt, va_list *valp) { return vfprintf(f, fmt, *valp); } int myvfprintf(FILE *f, const char *fmt, va_list val) { return ivfprintf(f, fmt, &val); } int myprintf(char *fmt, ...) { va_list val; va_start(val, fmt); return myvfprintf(stdout, fmt, val); } int main(int ac, char **av) { signal(SIGSEGV, exit); myprintf("%s%cs all right, then\n", "that", '\''); exit(0); } EOCP set try if eval $compile && $run ./try 2>&1 >/dev/null; then case "`$run ./try`" in "that's all right, then") okay=yes ;; esac fi case "$okay" in yes) echo "It seems that you don't need va_copy()." >&4 need_va_copy="$undef" ;; *) echo "It seems that va_copy() or similar will be needed." >&4 need_va_copy="$define" ;; esac $rm_try ;; *) echo "You don't have , not checking for va_copy()." >&4 ;; esac : see what type is used for size_t rp="What is the type used for the length parameter for string functions?" set size_t sizetype 'unsigned int' stdio.h sys/types.h eval $typedef_ask : check for type of arguments to gethostbyaddr. if test "X$netdb_host_type" = X -o "X$netdb_hlen_type" = X; then case "$d_gethbyaddr" in $define) $cat <&4 echo 'int bar1() { return bar2(); }' > bar1.c echo 'int bar2() { return 2; }' > bar2.c $cat > foo.c < #endif int main() { printf("%d\n", bar1()); exit(0); } EOP $cc $ccflags -c bar1.c >/dev/null 2>&1 $cc $ccflags -c bar2.c >/dev/null 2>&1 $cc $ccflags -c foo.c >/dev/null 2>&1 $ar rc bar$_a bar2$_o bar1$_o >/dev/null 2>&1 if $cc -o foobar $ccflags $ldflags foo$_o bar$_a $libs > /dev/null 2>&1 && $run ./foobar >/dev/null 2>&1; then echo "$ar appears to generate random libraries itself." orderlib=false if [ "X$ranlib" = "X" ]; then ranlib=":" fi elif $ar s bar$_a >/dev/null 2>&1 && $cc -o foobar $ccflags $ldflags foo$_o bar$_a $libs > /dev/null 2>&1 && $run ./foobar >/dev/null 2>&1; then echo "a table of contents needs to be added with '$ar s'." orderlib=false ranlib="$ar s" elif $ar ts bar$_a >/dev/null 2>&1 && $cc -o foobar $ccflags $ldflags foo$_o bar$_a $libs > /dev/null 2>&1 && $run ./foobar >/dev/null 2>&1; then echo "a table of contents needs to be added with '$ar ts'." orderlib=false ranlib="$ar ts" else case "$ranlib" in :) ranlib='';; '') ranlib=`./loc ranlib X /usr/bin /bin /usr/local/bin` $test -f $ranlib || ranlib='' ;; esac if $test -n "$ranlib"; then echo "your system has '$ranlib'; we'll use that." orderlib=false else echo "your system doesn't seem to support random libraries" echo "so we'll use lorder and tsort to order the libraries." orderlib=true ranlib=":" fi fi $rm -f foo* bar* : see if this is a values.h system set values.h i_values eval $inhdr : Check the max offset that gmtime and localtime accept echo "Checking max offsets that gmtime () accepts" case $i_values in define) yyy="#include " ;; *) yyy="" ;; esac case "$sGMTIME_min/$sGMTIME_max" in 0/0|/) $cat >try.c < #include #include $yyy int i; struct tm *tmp; time_t pt; 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) tmp = NULL; else pt = t; } /* gm_check */ int check_max () { tmp = NULL; pt = 0; #ifdef MAXLONG gm_check (MAXLONG, 69, 0x7fffffff); #endif 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); } } printf ("sGMTIME_max=%ld\n", pt); return (0); } /* check_max */ int check_min () { tmp = NULL; pt = 0; #ifdef MINLONG gm_check (MINLONG, -1900, 70); #endif 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); } } printf ("sGMTIME_min=%ld\n", pt); return (0); } /* check_min */ int main (int argc, char *argv[]) { fprintf (stderr, "Sizeof time_t = %ld\n", sizeof (time_t)); check_max (); check_min (); return (0); } /* main */ EOCP set try if eval $compile; then eval `$run ./try` else echo "Cannot determine sGMTIME_max and sGMTIME_min." >&4 fi $rm_try ;; esac echo "Checking max offsets that localtime () accepts" case "$sLOCALTIME_min/$sLOCALTIME_max" in 0/0|/) $cat >try.c < #include #include $yyy int i; struct tm *tmp; time_t pt; void local_check (time_t t, int min_year, int max_year) { if (sizeof (time_t) > 4 && t > 0x7ffffffffffff000LL) tmp = NULL; else tmp = localtime (&t); if ( tmp == NULL || /* Check tm_year overflow */ tmp->tm_year < min_year || tmp->tm_year > max_year) tmp = NULL; else pt = t; } /* local_check */ int check_max () { tmp = NULL; pt = 0; #ifdef MAXLONG local_check (MAXLONG, 69, 0x7fffffff); #endif 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; local_check (x, 69, 0x7fffffff); } } printf ("sLOCALTIME_max=%ld\n", pt); return (0); } /* check_max */ int check_min () { tmp = NULL; pt = 0; #ifdef MINLONG local_check (MINLONG, -1900, 70); #endif if (tmp == NULL) { for (i = 36; i >= 0; i--) { time_t x = pt - ((time_t)1 << i); if (x > 0) continue; local_check (x, -1900, 70); } } printf ("sLOCALTIME_min=%ld\n", pt); return (0); } /* check_min */ int main (int argc, char *argv[]) { check_max (); check_min (); return (0); } /* main */ EOCP set try if eval $compile; then eval `$run ./try` else echo "Cannot determine sLOCALTIME_max and sLOCALTIME_min." >&4 fi $rm_try ;; esac : check for type of arguments to select. case "$selecttype" in '') case "$d_select" in $define) echo " " $cat <try.c < #$i_time I_TIME #$i_systime I_SYS_TIME #$i_systimek I_SYS_TIME_KERNEL #ifdef I_TIME # include #endif #ifdef I_SYS_TIME # ifdef I_SYS_TIME_KERNEL # define KERNEL # endif # include # ifdef I_SYS_TIME_KERNEL # undef KERNEL # endif #endif #$i_sysselct I_SYS_SELECT #ifdef I_SYS_SELECT #include #endif #$d_socket HAS_SOCKET #ifdef HAS_SOCKET # include /* Might include */ #endif #include #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif $selecttype b; #define S sizeof(*(b)) #define MINBITS 64 #define NBYTES (S * 8 > MINBITS ? S : MINBITS/8) #define NBITS (NBYTES * 8) int main() { char *s = (char *)malloc(NBYTES); struct timeval t; int i; FILE* fp; int fd; if (!s) exit(1); fclose(stdin); fp = fopen("try.c", "r"); if (fp == 0) exit(2); fd = fileno(fp); if (fd < 0) exit(3); b = ($selecttype)s; for (i = 0; i < NBITS; i++) FD_SET(i, b); t.tv_sec = 0; t.tv_usec = 0; select(fd + 1, b, 0, 0, &t); for (i = NBITS - 1; i > fd && FD_ISSET(i, b); i--); free(s); printf("%d\n", i + 1); return 0; } EOCP set try if eval $compile_ok; then selectminbits=`$run ./try` case "$selectminbits" in '') cat >&4 <&4 else rp='What is the minimum number of bits your select() operates on?' case "$byteorder" in 12345678) dflt=64 ;; 1234) dflt=32 ;; *) dflt=1 ;; esac . ./myread val=$ans selectminbits="$val" fi $rm_try ;; *) : no select, so pick a harmless default selectminbits=$safebits ;; esac ;; esac : Trace out the files included by signal.h, then look for SIGxxx names. if [ "X$fieldn" = X ]; then : Just make some guesses. We check them later. xxx='/usr/include/signal.h /usr/include/sys/signal.h' else xxx=`echo '#include ' | $cppstdin $cppminus $cppflags 2>/dev/null | $grep '^[ ]*#.*include' | $awk "{print \\$$fieldn}" | $sed 's!"!!g' |\ $sed 's!\\\\\\\\!/!g' | $sort | $uniq` fi xxxfiles='' for xx in $xxx /dev/null ; do $test -f "$xx" && xxxfiles="$xxxfiles $xx" done case "$xxxfiles" in '') xxxfiles=`./findhdr signal.h` ;; esac xxx=`awk ' $1 ~ /^#define$/ && $2 ~ /^SIG[A-Z0-9]*$/ && $2 !~ /SIGARRAYSIZE/ && $2 !~ /SIGSTKSIZE/ && $2 !~ /SIGSTKSZ/ && $3 !~ /void/ { print substr($2, 4, 20) } $1 == "#" && $2 ~ /^define$/ && $3 ~ /^SIG[A-Z0-9]*$/ && $3 !~ /SIGARRAYSIZE/ && $4 !~ /void/ { print substr($3, 4, 20) }' $xxxfiles` : Append some common names just in case the awk scan failed. xxx="$xxx ABRT ALRM BUS CANCEL CHLD CLD CONT DIL EMT FPE" xxx="$xxx FREEZE HUP ILL INT IO IOT KILL LOST LWP PHONE" xxx="$xxx PIPE POLL PROF PWR QUIT RTMAX RTMIN SEGV STKFLT STOP" xxx="$xxx SYS TERM THAW TRAP TSTP TTIN TTOU URG USR1 USR2" xxx="$xxx USR3 USR4 VTALRM WAITING WINCH WIND WINDOW XCPU XFSZ" : generate a few handy files for later $cat > signal.c < #include #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif #include int main() { /* Strange style to avoid deeply-nested #if/#else/#endif */ #ifndef NSIG # ifdef _NSIG # define NSIG (_NSIG) # endif #endif #ifndef NSIG # ifdef SIGMAX # define NSIG (SIGMAX+1) # endif #endif #ifndef NSIG # ifdef SIG_MAX # define NSIG (SIG_MAX+1) # endif #endif #ifndef NSIG # ifdef _SIG_MAX # define NSIG (_SIG_MAX+1) # endif #endif #ifndef NSIG # ifdef MAXSIG # define NSIG (MAXSIG+1) # endif #endif #ifndef NSIG # ifdef MAX_SIG # define NSIG (MAX_SIG+1) # endif #endif #ifndef NSIG # ifdef SIGARRAYSIZE # define NSIG SIGARRAYSIZE /* Assume ary[SIGARRAYSIZE] */ # endif #endif #ifndef NSIG # ifdef _sys_nsig # define NSIG (_sys_nsig) /* Solaris 2.5 */ # endif #endif /* Default to some arbitrary number that's big enough to get most of the common signals. */ #ifndef NSIG # define NSIG 50 #endif printf("NSIG %d\n", NSIG); #ifndef JUST_NSIG EOCP echo $xxx | $tr ' ' $trnl | $sort | $uniq | $awk ' { printf "#ifdef SIG"; printf $1; printf "\n" printf "printf(\""; printf $1; printf " %%d\\n\",SIG"; printf $1; printf ");\n" printf "#endif\n" } END { printf "#endif /* JUST_NSIG */\n"; printf "exit(0);\n}\n"; } ' >>signal.c $cat >signal.awk <<'EOP' BEGIN { ndups = 0 } $1 ~ /^NSIG$/ { nsig = $2 } ($1 !~ /^NSIG$/) && (NF == 2) && ($2 ~ /^[0-9][0-9]*$/) { if ($2 > maxsig) { maxsig = $2 } if (sig_name[$2]) { dup_name[ndups] = $1 dup_num[ndups] = $2 ndups++ } else { sig_name[$2] = $1 sig_num[$2] = $2 } } END { if (nsig == 0) { nsig = maxsig + 1 } printf("NSIG %d\n", nsig); for (n = 1; n < nsig; n++) { if (sig_name[n]) { printf("%s %d\n", sig_name[n], sig_num[n]) } else { printf("NUM%d %d\n", n, n) } } for (n = 0; n < ndups; n++) { printf("%s %d\n", dup_name[n], dup_num[n]) } } EOP $cat >signal_cmd <>signal_cmd <<'EOS' set signal if eval $compile_ok; then $run ./signal$_exe | ($sort -n -k 2 2>/dev/null || $sort -n +1) |\ $uniq | $awk -f signal.awk >signal.lst else echo "(I can't seem be able to compile the whole test program)" >&4 echo "(I'll try it in little pieces.)" >&4 set signal -DJUST_NSIG if eval $compile_ok; then $run ./signal$_exe > signal.nsg $cat signal.nsg else echo "I can't seem to figure out how many signals you have." >&4 echo "Guessing 50." >&4 echo 'NSIG 50' > signal.nsg fi : Now look at all the signal names, one at a time. for xx in `echo $xxx | $tr ' ' $trnl | $sort | $uniq`; do $cat > signal.c < #include #include int main() { printf("$xx %d\n", SIG${xx}); return 0; } EOCP set signal if eval $compile; then echo "SIG${xx} found." $run ./signal$_exe >> signal.ls1 else echo "SIG${xx} NOT found." fi done if $test -s signal.ls1; then $cat signal.nsg signal.ls1 | $sort -n | $uniq | $awk -f signal.awk >signal.lst fi fi if $test -s signal.lst; then : else echo "(AAK! I can't compile the test programs -- Guessing)" >&4 echo 'kill -l' >signal set X `csh -f signal.lst fi $rm -f signal.c signal$_exe signal$_o signal.nsg signal.ls1 EOS chmod a+x signal_cmd $eunicefix signal_cmd : generate list of signal names echo " " case "$sig_name_init" in '') doinit=yes ;; *) case "$sig_num_init" in ''|*,*) doinit=yes ;; esac ;; esac case "$doinit" in yes) echo "Generating a list of signal names and numbers..." >&4 . ./signal_cmd sig_count=`$awk '/^NSIG/ { printf "%d", $2 }' signal.lst` sig_name=`$awk 'BEGIN { printf "ZERO " } !/^NSIG/ { printf "%s ", $1 }' signal.lst` sig_num=`$awk 'BEGIN { printf "0 " } !/^NSIG/ { printf "%d ", $2 }' signal.lst` sig_name_init=`$awk 'BEGIN { printf "\"ZERO\", " } !/^NSIG/ { printf "\"%s\", ", $1 } END { printf "0\n" }' signal.lst` sig_num_init=`$awk 'BEGIN { printf "0, " } !/^NSIG/ { printf "%d, ", $2} END { printf "0\n"}' signal.lst` ;; esac echo "The following $sig_count signals are available:" echo " " echo $sig_name | $awk \ 'BEGIN { linelen = 0 } { for (i = 1; i <= NF; i++) { name = "SIG" $i " " linelen = linelen + length(name) if (linelen > 70) { printf "\n" linelen = length(name) } printf "%s", name } printf "\n" }' sig_size=`echo $sig_name | awk '{print NF}'` $rm -f signal signal.c signal.awk signal.lst signal_cmd : Check size of size echo " " case "$sizetype" in *_t) zzz="$sizetype" ;; *) zzz="filesize" ;; esac echo "Checking the size of $zzz..." >&4 cat > try.c < #include #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif int main() { printf("%d\n", (int)sizeof($sizetype)); exit(0); } EOCP set try if eval $compile_ok; then yyy=`$run ./try` case "$yyy" in '') sizesize=4 echo "(I can't execute the test program--guessing $sizesize.)" >&4 ;; *) sizesize=$yyy echo "Your $zzz size is $sizesize bytes." ;; esac else sizesize=4 echo "(I can't compile the test program--guessing $sizesize.)" >&4 fi : check for socklen_t echo " " echo "Checking to see if you have socklen_t..." >&4 $cat >try.c < #$d_socket HAS_SOCKET #ifdef HAS_SOCKET #include #endif int main() { socklen_t x = 16; } EOCP set try if eval $compile; then val="$define" echo "You have socklen_t." else val="$undef" echo "You do not have socklen_t." case "$sizetype" in size_t) echo "(You do have size_t, that might work. Some people are happy with just an int.)" ;; esac fi $rm_try set d_socklen_t eval $setvar : see if this is a socks.h system set socks.h i_socks eval $inhdr : check for type of the size argument to socket calls case "$d_socket" in "$define") $cat < try.c < #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif #include #define Size_t $sizetype #define SSize_t $dflt int main() { if (sizeof(Size_t) == sizeof(SSize_t)) printf("$dflt\n"); else if (sizeof(Size_t) == sizeof(int)) printf("int\n"); else printf("long\n"); exit(0); } EOM echo " " set try if eval $compile_ok && $run ./try > /dev/null; then ssizetype=`$run ./try` echo "I'll be using $ssizetype for functions returning a byte count." >&4 else $cat >&4 <' | $cppstdin $cppminus > stdioh if $contains 'unsigned.*char.*_ptr;' stdioh >/dev/null 2>&1 ; then echo "Your stdio uses unsigned chars." >&4 stdchar="unsigned char" else echo "Your stdio uses signed chars." >&4 stdchar="char" fi $rm -f stdioh : see what type uids are declared as in the kernel echo " " echo "Looking for the type for user ids returned by getuid()." set uid_t uidtype xxx stdio.h sys/types.h eval $typedef case "$uidtype" in xxx) xxx=`./findhdr sys/user.h` set `grep '_ruid;' "$xxx" 2>/dev/null` unsigned short case $1 in unsigned) dflt="$1 $2" ;; *) dflt="$1" ;; esac ;; *) dflt="$uidtype";; esac case "$uidtype" in uid_t) echo "uid_t found." ;; *) rp="What is the type for user ids returned by getuid()?" . ./myread uidtype="$ans" ;; esac : Check size of UID echo " " case "$uidtype" in *_t) zzz="$uidtype" ;; *) zzz="uid" ;; esac echo "Checking the size of $zzz..." >&4 cat > try.c < #include #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif int main() { printf("%d\n", (int)sizeof($uidtype)); exit(0); } EOCP set try if eval $compile_ok; then yyy=`$run ./try` case "$yyy" in '') uidsize=4 echo "(I can't execute the test program--guessing $uidsize.)" >&4 ;; *) uidsize=$yyy echo "Your $zzz is $uidsize bytes long." ;; esac else uidsize=4 echo "(I can't compile the test program--guessing $uidsize.)" >&4 fi : Check if UID is signed echo " " case "$uidtype" in *_t) zzz="$uidtype" ;; *) zzz="uid" ;; esac echo "Checking the sign of $zzz..." >&4 cat > try.c < #include int main() { $uidtype foo = -1; if (foo < 0) printf("-1\n"); else printf("1\n"); } EOCP set try if eval $compile; then yyy=`$run ./try` case "$yyy" in '') uidsign=1 echo "(I can't execute the test program--guessing unsigned.)" >&4 ;; *) uidsign=$yyy case "$uidsign" in 1) echo "Your $zzz is unsigned." ;; -1) echo "Your $zzz is signed." ;; esac ;; esac else uidsign=1 echo "(I can't compile the test program--guessing unsigned.)" >&4 fi : Check format string for UID echo " " $echo "Checking the format string to be used for uids..." >&4 case "$uidsign" in -1) if $test X"$uidsize" = X"$ivsize"; then uidformat="$ivdformat" else if $test X"$uidsize" = X"$longsize"; then uidformat='"ld"' else if $test X"$uidsize" = X"$intsize"; then uidformat='"d"' else if $test X"$uidsize" = X"$shortsize"; then uidformat='"hd"' fi fi fi fi ;; *) if $test X"$uidsize" = X"$uvsize"; then uidformat="$uvuformat" else if $test X"$uidsize" = X"$longsize"; then uidformat='"lu"' else if $test X"$uidsize" = X"$intsize"; then uidformat='"u"' else if $test X"$uidsize" = X"$shortsize"; then uidformat='"hu"' fi fi fi fi ;; esac : Check if site customization support was requested case "$usesitecustomize" in $define|true|[Yy]*) usesitecustomize="$define" ;; *) usesitecustomize="$undef" ;; esac : see if prototypes support variable argument declarations echo " " case "$prototype$i_stdarg" in $define$define) echo "It appears we'll be able to prototype varargs functions." >&4 val="$define" ;; *) echo "Too bad... We won't be using prototyped varargs functions..." >&4 val="$undef" ;; esac set vaproto eval $setvar : determine compiler compiler case "$yacc" in '') dflt=yacc;; *) dflt="$yacc";; esac echo " " comp='yacc' if $test -f "$byacc$_exe"; then dflt="$byacc" comp="byacc or $comp" fi if $test -f "$bison$_exe"; then comp="$comp or bison -y" fi rp="Which compiler compiler ($comp) shall I use?" . ./myread yacc="$ans" case "$yacc" in *bis*) case "$yacc" in *-y*) ;; *) yacc="$yacc -y" echo "(Adding -y option to bison to get yacc-compatible behaviour.)" ;; esac ;; esac : see if this is a assert.h system set assert.h i_assert eval $inhdr : see if this is a fp.h system set fp.h i_fp eval $inhdr : see if this is a fp_class.h system set fp_class.h i_fp_class eval $inhdr : see if gdbm.h is available set gdbm.h t_gdbm eval $inhdr case "$t_gdbm" in $define) : see if gdbm_open exists set gdbm_open d_gdbm_open eval $inlibc case "$d_gdbm_open" in $undef) t_gdbm="$undef" echo "We won't be including " ;; esac ;; esac val="$t_gdbm" set i_gdbm eval $setvar : see if this is a ieeefp.h system case "$i_ieeefp" in '' ) set ieeefp.h i_ieeefp eval $inhdr ;; esac : see if this is a libutil.h system set libutil.h i_libutil eval $inhdr : see if mach cthreads are available if test "X$usethreads" = "X$define"; then set mach/cthreads.h i_machcthr eval $inhdr else i_machcthr="$undef" fi : see if this is a mntent.h system set mntent.h i_mntent eval $inhdr : see if net/errno.h is available val='' set net/errno.h val eval $inhdr : Unfortunately, it causes problems on some systems. Arrgh. case "$val" in $define) cat > try.c <<'EOM' #include #include #include int func() { return ENOTSOCK; } EOM if $cc $ccflags -c try.c >/dev/null 2>&1; then echo "We'll be including ." >&4 else echo "We won't be including ." >&4 val="$undef" fi $rm_try ;; esac set i_neterrno eval $setvar : see if netinet/tcp.h is available set netinet/tcp.h i_netinettcp eval $inhdr : see if this is a poll.h system set poll.h i_poll eval $inhdr : see if this is a prot.h system set prot.h i_prot eval $inhdr : Preprocessor symbols echo " " $echo "Guessing which symbols your C compiler and preprocessor define..." >&4 $cat <<'EOSH' > Cppsym.know a29k ABI64 aegis AES_SOURCE AIX AIX32 AIX370 AIX41 AIX42 AIX43 AIX_SOURCE aixpc ALL_SOURCE alliant alpha am29000 AM29000 AMD64 amd64 amiga AMIGAOS AMIX ansi ANSI_C_SOURCE apollo ardent ARM32 atarist att386 att3b BeOS BIG_ENDIAN BIT_MSF bsd BSD bsd43 bsd4_2 bsd4_3 BSD4_3 bsd4_4 BSD_4_3 BSD_4_4 BSD_NET2 BSD_TIME BSD_TYPES BSDCOMPAT bsdi bull c cadmus clipper CMU COFF COMPILER_VERSION concurrent convex cpu cray CRAY CRAYMPP ctix CX_UX CYGWIN DECC DGUX DGUX_SOURCE DJGPP dmert DOLPHIN DPX2 DSO Dynix DynixPTX ELF encore EPI EXTENSIONS FAVOR_BSD FILE_OFFSET_BITS FreeBSD GCC_NEW_VARARGS gcos gcx gimpel GLIBC GLIBC_MINOR GNU_SOURCE GNUC GNUC_MINOR GNU_LIBRARY GO32 gould GOULD_PN H3050R H3050RX hbullx20 hcx host_mips hp200 hp300 hp700 HP700 hp800 hp9000 hp9000s200 hp9000s300 hp9000s400 hp9000s500 hp9000s700 hp9000s800 hp9k8 hp_osf hppa hpux HPUX_SOURCE i186 i286 i386 i486 i586 i686 i8086 i80960 i860 I960 IA64 iAPX286 ibm ibm032 ibmesa IBMR2 ibmrt ILP32 ILP64 INLINE_INTRINSICS INTRINSICS INT64 interdata is68k ksr1 LANGUAGE_C LARGE_FILE_API LARGEFILE64_SOURCE LARGEFILE_SOURCE LFS64_LARGEFILE LFS_LARGEFILE LIBCATAMOUNT Linux LITTLE_ENDIAN LONG64 LONG_DOUBLE LONG_LONG LONGDOUBLE LONGLONG LP64 luna luna88k Lynx M68000 m68k m88100 m88k M88KBCS_TARGET M_COFF M_I186 M_I286 M_I386 M_I8086 M_I86 M_I86SM M_SYS3 M_SYS5 M_SYSIII M_SYSV M_UNIX M_XENIX MACH machine MachTen MATH_HAS_NO_SIDE_EFFECTS mc300 mc500 mc68000 mc68010 mc68020 mc68030 mc68040 mc68060 mc68k mc68k32 mc700 mc88000 mc88100 merlin mert MiNT mips MIPS_FPSET MIPS_ISA MIPS_SIM MIPS_SZINT MIPS_SZLONG MIPS_SZPTR MIPSEB MIPSEL MODERN_C motorola mpeix MSDOS MTXINU MULTIMAX mvs MVS n16 ncl_el ncl_mr NetBSD news1500 news1700 news1800 news1900 news3700 news700 news800 news900 NeXT NLS nonstopux ns16000 ns32000 ns32016 ns32332 ns32k nsc32000 OCS88 OEMVS OpenBSD os OS2 OS390 osf OSF1 OSF_SOURCE pa_risc PA_RISC1_1 PA_RISC2_0 PARAGON parisc pc532 pdp11 PGC PIC plexus PORTAR posix POSIX1B_SOURCE POSIX2_SOURCE POSIX4_SOURCE POSIX_C_SOURCE POSIX_SOURCE POWER PROTOTYPES PWB pyr QNX QK_USER R3000 REENTRANT RES Rhapsody RISC6000 riscix riscos RT S390 SA110 scs SCO sequent sgi SGI_SOURCE SH3 sinix SIZE_INT SIZE_LONG SIZE_PTR SOCKET_SOURCE SOCKETS_SOURCE sony sony_news sonyrisc sparc sparclite spectrum stardent stdc STDC_EXT stratos sun sun3 sun386 Sun386i svr3 svr4 SVR4_2 SVR4_SOURCE svr5 SX system SYSTYPE_BSD SYSTYPE_BSD43 SYSTYPE_BSD44 SYSTYPE_SVR4 SYSTYPE_SVR5 SYSTYPE_SYSV SYSV SYSV3 SYSV4 SYSV5 sysV68 sysV88 Tek4132 Tek4300 titan TM3200 TM5400 TM5600 tower tower32 tower32_200 tower32_600 tower32_700 tower32_800 tower32_850 tss u370 u3b u3b2 u3b20 u3b200 u3b20d u3b5 ultrix UMAXV UnicomPBB UnicomPBD UNICOS UNICOSMK unix UNIX95 UNIX99 unixpc unos USE_BSD USE_FILE_OFFSET64 USE_GNU USE_ISOC9X USE_LARGEFILE USE_LARGEFILE64 USE_MISC USE_POSIX USE_POSIX199309 USE_POSIX199506 USE_POSIX2 USE_REENTRANT USE_SVID USE_UNIX98 USE_XOPEN USE_XOPEN_EXTENDED USGr4 USGr4_2 Utek UTek UTS UWIN uxpm uxps vax venix VMESA vms x86_64 xenix Xenix286 XOPEN_SOURCE XOPEN_SOURCE_EXTENDED XPG2 XPG2_EXTENDED XPG3 XPG3_EXTENDED XPG4 XPG4_EXTENDED z8000 EOSH # Maybe put other stuff here too. cat <>Cppsym.know $osname EOSH ./tr '[a-z]' '[A-Z]' < Cppsym.know > Cppsym.a ./tr '[A-Z]' '[a-z]' < Cppsym.know > Cppsym.b $cat Cppsym.know > Cppsym.c $cat Cppsym.a Cppsym.b Cppsym.c | $tr ' ' $trnl | $sort | $uniq > Cppsym.know $rm -f Cppsym.a Cppsym.b Cppsym.c cat < Cppsym $startsh if $test \$# -gt 0; then echo \$* | $tr " " "$trnl" | ./Cppsym.try > Cppsym.got if $test -s Cppsym.got; then $rm -f Cppsym.got exit 0 fi $rm -f Cppsym.got exit 1 else $tr " " "$trnl" | ./Cppsym.try exit 0 fi EOSH chmod +x Cppsym $eunicefix Cppsym cat < Cppsym.try $startsh cat <<'EOCP' > try.c #include #if cpp_stuff == 1 #define STRINGIFY(a) "a" #endif #if cpp_stuff == 42 #define StGiFy(a) #a #define STRINGIFY(a) StGiFy(a) #endif #if $cpp_stuff != 1 && $cpp_stuff != 42 # include "Bletch: How does this C preprocessor stringify macros?" #endif int main() { EOCP $awk \\ EOSH cat <<'EOSH' >> Cppsym.try 'length($1) > 0 { printf "#ifdef %s\nprintf(\"%s=%%s\\n\", STRINGIFY(%s));\n#endif\n", $1, $1, $1 printf "#ifdef _%s\nprintf(\"_%s=%%s\\n\", STRINGIFY(_%s));\n#endif\n", $1, $1, $1 printf "#ifdef __%s\nprintf(\"__%s=%%s\\n\", STRINGIFY(__%s));\n#endif\n", $1, $1, $1 printf "#ifdef __%s__\nprintf(\"__%s__=%%s\\n\", STRINGIFY(__%s__));\n#endif\n", $1, $1, $1 }' >> try.c echo 'return 0;}' >> try.c EOSH cat <> Cppsym.try ccflags="$ccflags" case "$osname-$gccversion" in irix-) ccflags="\$ccflags -woff 1178" ;; os2-*) ccflags="\$ccflags -Zlinker /PM:VIO" ;; esac $cc -o try -Dcpp_stuff=$cpp_stuff $optimize \$ccflags $ldflags try.c $libs && $run ./try | $sed 's/ /\\\\ /g' EOSH chmod +x Cppsym.try $eunicefix Cppsym.try ./Cppsym < Cppsym.know > Cppsym.true : Add in any linux cpp "predefined macros": case "$osname::$gccversion" in *linux*::*.*|*gnukfreebsd*::*.*|gnu::*.*) tHdrH=_tmpHdr rm -f $tHdrH'.h' $tHdrH touch $tHdrH'.h' if $cpp -dM $tHdrH'.h' > $tHdrH'_cppsym.h' && [ -s $tHdrH'_cppsym.h' ]; then sed 's/#define[\ \ ]*//;s/[\ \ ].*$//' <$tHdrH'_cppsym.h' >$tHdrH'_cppsym.real' if [ -s $tHdrH'_cppsym.real' ]; then cat $tHdrH'_cppsym.real' Cppsym.know | sort | uniq | ./Cppsym | sort | uniq > Cppsym.true fi fi rm -f $tHdrH'.h' $tHdrH'_cppsym.h' $tHdrH'_cppsym.real' ;; esac : now check the C compiler for additional symbols postprocess_cc_v='' case "$osname" in aix) postprocess_cc_v="|$tr , ' '" ;; esac $cat >ccsym <tmp.c <&1 $postprocess_cc_v\` do case "\$i" in -D*) echo "\$i" | $sed 's/^-D//';; -A*) $test "$gccversion" && echo "\$i" | $sed 's/^-A//' | $sed 's/\(.*\)(\(.*\))/\1=\2/';; esac done $rm_try EOS postprocess_cc_v='' chmod +x ccsym $eunicefix ccsym ./ccsym > ccsym1.raw if $test -s ccsym1.raw; then $sort ccsym1.raw | $uniq >ccsym.raw else mv ccsym1.raw ccsym.raw fi $awk '/\=/ { print $0; next } { print $0"=1" }' ccsym.raw >ccsym.list $comm -13 Cppsym.true ccsym.list >ccsym.own $comm -12 Cppsym.true ccsym.list >ccsym.com $comm -23 Cppsym.true ccsym.list >ccsym.cpp also='' if $test -z ccsym.raw; then echo "Your C compiler doesn't seem to define any symbols!" >&4 echo " " echo "However, your C preprocessor defines the following symbols:" $cat Cppsym.true ccsymbols='' cppsymbols=`$cat Cppsym.true` cppsymbols=`echo $cppsymbols` cppccsymbols="$cppsymbols" else if $test -s ccsym.com; then echo "Your C compiler and pre-processor define these symbols:" $sed -e 's/\(..*\)=.*/\1/' ccsym.com also='also ' symbols='ones' cppccsymbols=`$cat ccsym.com` cppccsymbols=`echo $cppccsymbols` $test "$silent" || sleep 1 fi if $test -s ccsym.cpp; then $test "$also" && echo " " echo "Your C pre-processor ${also}defines the following symbols:" $sed -e 's/\(..*\)=.*/\1/' ccsym.cpp also='further ' cppsymbols=`$cat ccsym.cpp` cppsymbols=`echo $cppsymbols` $test "$silent" || sleep 1 fi if $test -s ccsym.own; then $test "$also" && echo " " echo "Your C compiler ${also}defines the following cpp symbols:" $sed -e 's/\(..*\)=1/\1/' ccsym.own $sed -e 's/\(..*\)=.*/\1/' ccsym.own | $uniq >>Cppsym.true ccsymbols=`$cat ccsym.own` ccsymbols=`echo $ccsymbols` $test "$silent" || sleep 1 fi fi : see if this is a termio system val="$undef" val2="$undef" val3="$undef" if $test `./findhdr termios.h`; then set tcsetattr i_termios eval $inlibc val3="$i_termios" fi echo " " case "$val3" in "$define") echo "You have POSIX termios.h... good!" >&4;; *) if ./Cppsym pyr; then case "`/bin/universe`" in ucb) if $test `./findhdr sgtty.h`; then val2="$define" echo " found." >&4 else echo "System is pyramid with BSD universe." ./warn " not found--you could have problems." fi;; *) if $test `./findhdr termio.h`; then val="$define" echo " found." >&4 else echo "System is pyramid with USG universe." ./warn " not found--you could have problems." fi;; esac elif ./usg; then if $test `./findhdr termio.h`; then echo " found." >&4 val="$define" elif $test `./findhdr sgtty.h`; then echo " found." >&4 val2="$define" else ./warn "Neither nor found--cross fingers!" fi else if $test `./findhdr sgtty.h`; then echo " found." >&4 val2="$define" elif $test `./findhdr termio.h`; then echo " found." >&4 val="$define" else ./warn "Neither nor found--cross fingers!" fi fi;; esac set i_termio; eval $setvar val=$val2; set i_sgtty; eval $setvar val=$val3; set i_termios; eval $setvar : see if stddef is available set stddef.h i_stddef eval $inhdr : see if sys/access.h is available set sys/access.h i_sysaccess eval $inhdr : see if ioctl defs are in sgtty, termio, sys/filio or sys/ioctl set sys/filio.h i_sysfilio eval $inhdr echo " " if $test `./findhdr sys/ioctl.h`; then val="$define" echo ' found.' >&4 else val="$undef" if $test $i_sysfilio = "$define"; then echo ' NOT found.' >&4 else $test $i_sgtty = "$define" && xxx="sgtty.h" $test $i_termio = "$define" && xxx="termio.h" $test $i_termios = "$define" && xxx="termios.h" echo "No found, assuming ioctl args are defined in <$xxx>." >&4 fi fi set i_sysioctl eval $setvar : see if socket ioctl defs are in sys/sockio.h echo " " xxx=`./findhdr sys/sockio.h` if $test "$xxx"; then if $contains SIOCATMARK $xxx >/dev/null 2>&1; then val="$define" echo "You have socket ioctls defined in ." >&4 else val="$undef" echo "No socket ioctls found in ." >&4 fi else val="$undef" $cat < not found, assuming socket ioctls are in . EOM fi set i_syssockio eval $setvar : see if this is a syslog.h system set syslog.h i_syslog eval $inhdr : see if this is a sys/mode.h system set sys/mode.h i_sysmode eval $inhdr : see if there is a sys/poll.h file set sys/poll.h i_syspoll eval $inhdr : see if sys/resource.h has to be included set sys/resource.h i_sysresrc eval $inhdr : see if sys/security.h is available set sys/security.h i_syssecrt eval $inhdr : see if this is a sys/statvfs.h system set sys/statvfs.h i_sysstatvfs eval $inhdr : see if this is a sys/un.h system set sys/un.h i_sysun eval $inhdr : see if this is a sys/utsname.h system set sys/utsname.h i_sysutsname eval $inhdr : see if this is a syswait system set sys/wait.h i_syswait eval $inhdr : see if this is a ustat.h system set ustat.h i_ustat eval $inhdr : see if this is an utime system set utime.h i_utime eval $inhdr : see if this is a vfork system case "$d_vfork" in "$define") set vfork.h i_vfork eval $inhdr ;; *) i_vfork="$undef" ;; esac : Check extensions echo " " echo "Looking for extensions..." >&4 : If we are using the old config.sh, known_extensions may contain : old or inaccurate or duplicate values. known_extensions='' nonxs_extensions='' : We do not use find because it might not be available. : We do not just use MANIFEST because the user may have dropped : some additional extensions into the source tree and expect them : to be built. : Function to recursively find available extensions, ignoring DynaLoader : NOTE: recursion limit of 10 to prevent runaway in case of symlink madness : In 5.10.1 and later, extensions are stored in directories : like File-Glob instead of the older File/Glob/. find_extensions=' for xxx in *; do case "$xxx" in DynaLoader|dynaload) ;; *) this_ext=`echo $xxx | $sed -e s/-/\\\//g`; leaf=`echo $xxx | $sed -e s/.*-//`; if $test -d File; then if $test -f $xxx/$leaf.xs -o -f $xxx/$leaf.c; then known_extensions="$known_extensions $1$this_ext"; elif $test -f $xxx/Makefile.PL; then nonxs_extensions="$nonxs_extensions $1$this_ext"; else if $test -d $xxx -a $# -lt 10; then set $1$xxx/ $*; cd "$xxx"; eval $find_extensions; cd ..; shift; fi; fi; else $ls -1 $xxx > $$.tmp; if $contains "\.xs$" $$.tmp > /dev/null 2>&1; then known_extensions="$known_extensions $this_ext"; elif $contains "\.c$" $$.tmp > /dev/null 2>&1; then known_extensions="$known_extensions $this_ext"; elif $test -d $xxx; then nonxs_extensions="$nonxs_extensions $this_ext"; fi; $rm -f $$.tmp; fi ;; esac; done' tdir=`pwd` cd "$rsrc/cpan" set X shift eval $find_extensions cd "$rsrc/dist" set X shift eval $find_extensions cd "$rsrc/ext" set X shift eval $find_extensions if $test -d File-Glob; then : All ext/ flattened else # Special case: Add in modules that nest beyond the first level. # Currently threads/shared and Hash/Util/FieldHash, since they are # not picked up by the recursive find above (and adding in general # recursive finding breaks SDBM_File/sdbm). # A.D. 20011025 (SDBM), ajgough 20071008 (FieldHash) known_extensions="$known_extensions threads/shared Hash/Util/FieldHash" fi set X $known_extensions shift known_extensions=`echo "$*" | tr ' ' $trnl | $sort | tr $trnl ' '` set X $nonxs_extensions shift nonxs_extensions=`echo "$*" | tr ' ' $trnl | $sort | tr $trnl ' '` cd "$tdir" : Now see which are supported on this system. avail_ext='' for xxx in $known_extensions ; do case "$xxx" in DB_File|db_file) case "$i_db" in $define) avail_ext="$avail_ext $xxx" ;; esac ;; GDBM_File|gdbm_fil) case "$i_gdbm" in $define) avail_ext="$avail_ext $xxx" ;; esac ;; I18N/Langinfo|i18n_lan) case "$i_langinfo$d_nl_langinfo" in $define$define) avail_ext="$avail_ext $xxx" ;; esac ;; IPC/SysV|ipc/sysv) : XXX Do we need a useipcsysv variable here case "${d_msg}${d_sem}${d_shm}" in *"${define}"*) avail_ext="$avail_ext $xxx" ;; esac ;; NDBM_File|ndbm_fil) case "$d_ndbm" in $define) case "$osname-$use64bitint" in hpux-define) case "$libs" in *-lndbm*) avail_ext="$avail_ext $xxx" ;; esac ;; *) avail_ext="$avail_ext $xxx" ;; esac ;; esac ;; ODBM_File|odbm_fil) case "${i_dbm}${i_rpcsvcdbm}" in *"${define}"*) case "$d_cplusplus" in define) ;; # delete as a function name will not work *) case "$osname-$use64bitint" in hpux-define) case "$libs" in *-ldbm*) avail_ext="$avail_ext $xxx" ;; esac ;; *) avail_ext="$avail_ext $xxx" ;; esac ;; esac ;; esac ;; Opcode|opcode) case "$useopcode" in true|define|y) avail_ext="$avail_ext $xxx" ;; esac ;; POSIX|posix) case "$useposix" in true|define|y) avail_ext="$avail_ext $xxx" ;; esac ;; Socket|socket) case "$d_socket" in true|$define|y) case "$osname" in beos) ;; # not unless BONE *) avail_ext="$avail_ext $xxx" ;; esac ;; esac ;; Sys/Syslog|sys/syslog) : XXX syslog requires socket case "$d_socket" in true|$define|y) avail_ext="$avail_ext $xxx" ;; esac ;; Thread|thread) case "$usethreads" in true|$define|y) case "$use5005threads" in $define|true|[yY]*) avail_ext="$avail_ext $xxx" ;; esac esac ;; threads|threads/shared) # threads and threads::shared are special cases. # To stop people from asking "Perl 5.8.0 was supposed # to have this new fancy threads implementation but my # perl doesn't have it" and from people trying to # (re)install the threads module using CPAN.pm and # CPAN.pm then offering to reinstall Perl 5.8.0, # the threads.pm and threads/shared.pm will always be # there, croaking informatively ("you need to rebuild # all of Perl with threads, sorry") when threads haven't # been compiled in. # --jhi avail_ext="$avail_ext $xxx" ;; VMS*) ;; Win32*) case "$osname" in cygwin) avail_ext="$avail_ext $xxx" ;; esac ;; XS/APItest|xs/apitest) # This is just for testing. Skip it unless we have dynamic loading. case "$usedl" in $define) avail_ext="$avail_ext $xxx" ;; esac ;; XS/APItest/KeywordRPN|xs/apitest/keywordrpn) # This is just for testing. Skip it unless we have dynamic loading. case "$usedl" in $define) avail_ext="$avail_ext $xxx" ;; esac ;; XS/Typemap|xs/typemap) # This is just for testing. Skip it unless we have dynamic loading. case "$usedl" in $define) avail_ext="$avail_ext $xxx" ;; esac ;; *) avail_ext="$avail_ext $xxx" ;; esac done set X $avail_ext shift avail_ext="$*" case "$onlyextensions" in '') ;; *) keepextensions='' echo "You have requested that only certains extensions be included..." >&4 for i in $onlyextensions; do case " $avail_ext " in *" $i "*) echo "Keeping extension $i." keepextensions="$keepextensions $i" ;; *) echo "Ignoring extension $i." ;; esac done avail_ext="$keepextensions" ;; esac case "$noextensions" in '') ;; *) keepextensions='' echo "You have requested that certain extensions be ignored..." >&4 for i in $avail_ext; do case " $noextensions " in *" $i "*) echo "Ignoring extension $i." ;; *) echo "Keeping extension $i."; keepextensions="$keepextensions $i" ;; esac done avail_ext="$keepextensions" ;; esac : Now see which nonxs extensions are supported on this system. : For now assume all are. nonxs_ext='' for xxx in $nonxs_extensions ; do case "$xxx" in *) nonxs_ext="$nonxs_ext $xxx" ;; esac done set X $nonxs_ext shift nonxs_ext="$*" case $usedl in $define) $cat <&4 echo "WARNING: The Perl you are building will be quite crippled." >& 4 ;; esac : Remove libraries needed only for extensions : The appropriate ext/Foo/Makefile.PL will add them back in, if necessary. : The exception is SunOS 4.x, which needs them. case "${osname}X${osvers}" in sunos*X4*) perllibs="$libs" ;; *) case "$usedl" in $define|true|[yY]*) set X `echo " $libs " | sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -lgdbm_compat @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` shift perllibs="$*" ;; *) perllibs="$libs" ;; esac ;; esac : Remove build directory name from cppstdin so it can be used from : either the present location or the final installed location. echo " " : Get out of the UU directory to get correct path name. cd .. case "$cppstdin" in `pwd`/cppstdin) echo "Stripping down cppstdin path name" cppstdin=cppstdin ;; esac cd UU : end of configuration questions echo " " echo "End of configuration questions." echo " " : back to where it started if test -d ../UU; then cd .. fi : configuration may be unconditionally patched via a 'config.arch' file if $test -f config.arch; then echo "I see a config.arch file, loading it." >&4 . ./config.arch fi : configuration may be patched via a 'config.over' file if $test -f config.over; then echo " " dflt=y rp='I see a config.over file. Do you wish to load it?' . UU/myread case "$ans" in n*) echo "OK, I'll ignore it.";; *) . ./config.over echo "Configuration override changes have been loaded." ;; esac fi : in case they want portability, strip down executable paths case "$d_portable" in "$define") echo " " echo "Stripping down executable paths..." >&4 for file in $loclist $trylist; do eval temp=\$$file eval $file=`basename $temp` done ;; esac : create config.sh file echo " " echo "Creating config.sh..." >&4 $spitshell <config.sh $startsh # # This file was produced by running the Configure script. It holds all the # definitions figured out by Configure. Should you modify one of these values, # do not forget to propagate your changes by running "Configure -der". You may # instead choose to run each of the .SH files by yourself, or "Configure -S". # # Package name : $package # Source directory : $src # Configuration time: $cf_time # Configured by : $cf_by # Target system : $myuname EOT : Add in command line options if available $test -f UU/cmdline.opt && $cat UU/cmdline.opt >> config.sh $spitshell <>config.sh Author='$Author' Date='$Date' Header='$Header' Id='$Id' Locker='$Locker' Log='$Log' RCSfile='$RCSfile' Revision='$Revision' Source='$Source' State='$State' _a='$_a' _exe='$_exe' _o='$_o' afs='$afs' afsroot='$afsroot' alignbytes='$alignbytes' ansi2knr='$ansi2knr' aphostname='$aphostname' api_revision='$api_revision' api_subversion='$api_subversion' api_version='$api_version' api_versionstring='$api_versionstring' ar='$ar' archlib='$archlib' archlibexp='$archlibexp' archname64='$archname64' archname='$archname' archobjs='$archobjs' asctime_r_proto='$asctime_r_proto' awk='$awk' baserev='$baserev' bash='$bash' bin='$bin' bin_ELF='$bin_ELF' binexp='$binexp' bison='$bison' byacc='$byacc' byteorder='$byteorder' c='$c' castflags='$castflags' cat='$cat' cc='$cc' cccdlflags='$cccdlflags' ccdlflags='$ccdlflags' ccflags='$ccflags' ccflags_uselargefiles='$ccflags_uselargefiles' ccname='$ccname' ccsymbols='$ccsymbols' ccversion='$ccversion' cf_by='$cf_by' cf_email='$cf_email' cf_time='$cf_time' charbits='$charbits' charsize='$charsize' chgrp='$chgrp' chmod='$chmod' chown='$chown' clocktype='$clocktype' comm='$comm' compress='$compress' contains='$contains' cp='$cp' cpio='$cpio' cpp='$cpp' cpp_stuff='$cpp_stuff' cppccsymbols='$cppccsymbols' cppflags='$cppflags' cpplast='$cpplast' cppminus='$cppminus' cpprun='$cpprun' cppstdin='$cppstdin' cppsymbols='$cppsymbols' crypt_r_proto='$crypt_r_proto' cryptlib='$cryptlib' csh='$csh' ctermid_r_proto='$ctermid_r_proto' ctime_r_proto='$ctime_r_proto' d_Gconvert='$d_Gconvert' d_PRIEUldbl='$d_PRIEUldbl' d_PRIFUldbl='$d_PRIFUldbl' d_PRIGUldbl='$d_PRIGUldbl' d_PRIXU64='$d_PRIXU64' d_PRId64='$d_PRId64' d_PRIeldbl='$d_PRIeldbl' d_PRIfldbl='$d_PRIfldbl' d_PRIgldbl='$d_PRIgldbl' d_PRIi64='$d_PRIi64' d_PRIo64='$d_PRIo64' d_PRIu64='$d_PRIu64' d_PRIx64='$d_PRIx64' d_SCNfldbl='$d_SCNfldbl' d__fwalk='$d__fwalk' d_access='$d_access' d_accessx='$d_accessx' d_aintl='$d_aintl' d_alarm='$d_alarm' d_archlib='$d_archlib' d_asctime64='$d_asctime64' d_asctime_r='$d_asctime_r' d_atolf='$d_atolf' d_atoll='$d_atoll' d_attribute_deprecated='$d_attribute_deprecated' d_attribute_format='$d_attribute_format' d_attribute_malloc='$d_attribute_malloc' d_attribute_nonnull='$d_attribute_nonnull' d_attribute_noreturn='$d_attribute_noreturn' d_attribute_pure='$d_attribute_pure' d_attribute_unused='$d_attribute_unused' d_attribute_warn_unused_result='$d_attribute_warn_unused_result' d_bcmp='$d_bcmp' d_bcopy='$d_bcopy' d_bsd='$d_bsd' d_bsdgetpgrp='$d_bsdgetpgrp' d_bsdsetpgrp='$d_bsdsetpgrp' d_builtin_choose_expr='$d_builtin_choose_expr' d_builtin_expect='$d_builtin_expect' d_bzero='$d_bzero' d_c99_variadic_macros='$d_c99_variadic_macros' d_casti32='$d_casti32' d_castneg='$d_castneg' d_charvspr='$d_charvspr' d_chown='$d_chown' d_chroot='$d_chroot' d_chsize='$d_chsize' d_class='$d_class' d_clearenv='$d_clearenv' d_closedir='$d_closedir' d_cmsghdr_s='$d_cmsghdr_s' d_const='$d_const' d_copysignl='$d_copysignl' d_cplusplus='$d_cplusplus' d_crypt='$d_crypt' d_crypt_r='$d_crypt_r' d_csh='$d_csh' d_ctermid='$d_ctermid' d_ctermid_r='$d_ctermid_r' d_ctime64='$d_ctime64' d_ctime_r='$d_ctime_r' d_cuserid='$d_cuserid' d_dbl_dig='$d_dbl_dig' d_dbminitproto='$d_dbminitproto' d_difftime64='$d_difftime64' d_difftime='$d_difftime' d_dir_dd_fd='$d_dir_dd_fd' d_dirfd='$d_dirfd' d_dirnamlen='$d_dirnamlen' d_dlerror='$d_dlerror' d_dlopen='$d_dlopen' d_dlsymun='$d_dlsymun' d_dosuid='$d_dosuid' d_drand48_r='$d_drand48_r' d_drand48proto='$d_drand48proto' d_dup2='$d_dup2' d_eaccess='$d_eaccess' d_endgrent='$d_endgrent' d_endgrent_r='$d_endgrent_r' d_endhent='$d_endhent' d_endhostent_r='$d_endhostent_r' d_endnent='$d_endnent' d_endnetent_r='$d_endnetent_r' d_endpent='$d_endpent' d_endprotoent_r='$d_endprotoent_r' d_endpwent='$d_endpwent' d_endpwent_r='$d_endpwent_r' d_endsent='$d_endsent' d_endservent_r='$d_endservent_r' d_eofnblk='$d_eofnblk' d_eunice='$d_eunice' d_faststdio='$d_faststdio' d_fchdir='$d_fchdir' d_fchmod='$d_fchmod' d_fchown='$d_fchown' d_fcntl='$d_fcntl' d_fcntl_can_lock='$d_fcntl_can_lock' d_fd_macros='$d_fd_macros' d_fd_set='$d_fd_set' d_fds_bits='$d_fds_bits' d_fgetpos='$d_fgetpos' d_finite='$d_finite' d_finitel='$d_finitel' d_flexfnam='$d_flexfnam' d_flock='$d_flock' d_flockproto='$d_flockproto' d_fork='$d_fork' d_fp_class='$d_fp_class' d_fpathconf='$d_fpathconf' d_fpclass='$d_fpclass' d_fpclassify='$d_fpclassify' d_fpclassl='$d_fpclassl' d_fpos64_t='$d_fpos64_t' d_frexpl='$d_frexpl' d_fs_data_s='$d_fs_data_s' d_fseeko='$d_fseeko' d_fsetpos='$d_fsetpos' d_fstatfs='$d_fstatfs' d_fstatvfs='$d_fstatvfs' d_fsync='$d_fsync' d_ftello='$d_ftello' d_ftime='$d_ftime' d_futimes='$d_futimes' d_gdbm_ndbm_h_uses_prototypes='$d_gdbm_ndbm_h_uses_prototypes' d_gdbmndbm_h_uses_prototypes='$d_gdbmndbm_h_uses_prototypes' d_getaddrinfo='$d_getaddrinfo' d_getcwd='$d_getcwd' d_getespwnam='$d_getespwnam' d_getfsstat='$d_getfsstat' d_getgrent='$d_getgrent' d_getgrent_r='$d_getgrent_r' d_getgrgid_r='$d_getgrgid_r' d_getgrnam_r='$d_getgrnam_r' d_getgrps='$d_getgrps' d_gethbyaddr='$d_gethbyaddr' d_gethbyname='$d_gethbyname' d_gethent='$d_gethent' d_gethname='$d_gethname' d_gethostbyaddr_r='$d_gethostbyaddr_r' d_gethostbyname_r='$d_gethostbyname_r' d_gethostent_r='$d_gethostent_r' d_gethostprotos='$d_gethostprotos' d_getitimer='$d_getitimer' d_getlogin='$d_getlogin' d_getlogin_r='$d_getlogin_r' d_getmnt='$d_getmnt' d_getmntent='$d_getmntent' d_getnameinfo='$d_getnameinfo' d_getnbyaddr='$d_getnbyaddr' d_getnbyname='$d_getnbyname' d_getnent='$d_getnent' d_getnetbyaddr_r='$d_getnetbyaddr_r' d_getnetbyname_r='$d_getnetbyname_r' d_getnetent_r='$d_getnetent_r' d_getnetprotos='$d_getnetprotos' d_getpagsz='$d_getpagsz' d_getpbyname='$d_getpbyname' d_getpbynumber='$d_getpbynumber' d_getpent='$d_getpent' d_getpgid='$d_getpgid' d_getpgrp2='$d_getpgrp2' d_getpgrp='$d_getpgrp' d_getppid='$d_getppid' d_getprior='$d_getprior' d_getprotobyname_r='$d_getprotobyname_r' d_getprotobynumber_r='$d_getprotobynumber_r' d_getprotoent_r='$d_getprotoent_r' d_getprotoprotos='$d_getprotoprotos' d_getprpwnam='$d_getprpwnam' d_getpwent='$d_getpwent' d_getpwent_r='$d_getpwent_r' d_getpwnam_r='$d_getpwnam_r' d_getpwuid_r='$d_getpwuid_r' d_getsbyname='$d_getsbyname' d_getsbyport='$d_getsbyport' d_getsent='$d_getsent' d_getservbyname_r='$d_getservbyname_r' d_getservbyport_r='$d_getservbyport_r' d_getservent_r='$d_getservent_r' d_getservprotos='$d_getservprotos' d_getspnam='$d_getspnam' d_getspnam_r='$d_getspnam_r' d_gettimeod='$d_gettimeod' d_gmtime64='$d_gmtime64' d_gmtime_r='$d_gmtime_r' d_gnulibc='$d_gnulibc' d_grpasswd='$d_grpasswd' d_hasmntopt='$d_hasmntopt' d_htonl='$d_htonl' d_ilogbl='$d_ilogbl' d_inc_version_list='$d_inc_version_list' d_index='$d_index' d_inetaton='$d_inetaton' d_inetntop='$d_inetntop' d_inetpton='$d_inetpton' d_int64_t='$d_int64_t' d_isascii='$d_isascii' d_isfinite='$d_isfinite' d_isinf='$d_isinf' d_isnan='$d_isnan' d_isnanl='$d_isnanl' d_killpg='$d_killpg' d_lchown='$d_lchown' d_ldbl_dig='$d_ldbl_dig' d_libm_lib_version='$d_libm_lib_version' d_link='$d_link' d_localtime64='$d_localtime64' d_localtime_r='$d_localtime_r' d_localtime_r_needs_tzset='$d_localtime_r_needs_tzset' d_locconv='$d_locconv' d_lockf='$d_lockf' d_longdbl='$d_longdbl' d_longlong='$d_longlong' d_lseekproto='$d_lseekproto' d_lstat='$d_lstat' d_madvise='$d_madvise' d_malloc_good_size='$d_malloc_good_size' d_malloc_size='$d_malloc_size' d_mblen='$d_mblen' d_mbstowcs='$d_mbstowcs' d_mbtowc='$d_mbtowc' d_memchr='$d_memchr' d_memcmp='$d_memcmp' d_memcpy='$d_memcpy' d_memmove='$d_memmove' d_memset='$d_memset' d_mkdir='$d_mkdir' d_mkdtemp='$d_mkdtemp' d_mkfifo='$d_mkfifo' d_mkstemp='$d_mkstemp' d_mkstemps='$d_mkstemps' d_mktime64='$d_mktime64' d_mktime='$d_mktime' d_mmap='$d_mmap' d_modfl='$d_modfl' d_modfl_pow32_bug='$d_modfl_pow32_bug' d_modflproto='$d_modflproto' d_mprotect='$d_mprotect' d_msg='$d_msg' d_msg_ctrunc='$d_msg_ctrunc' d_msg_dontroute='$d_msg_dontroute' d_msg_oob='$d_msg_oob' d_msg_peek='$d_msg_peek' d_msg_proxy='$d_msg_proxy' d_msgctl='$d_msgctl' d_msgget='$d_msgget' d_msghdr_s='$d_msghdr_s' d_msgrcv='$d_msgrcv' d_msgsnd='$d_msgsnd' d_msync='$d_msync' d_munmap='$d_munmap' d_mymalloc='$d_mymalloc' d_ndbm='$d_ndbm' d_ndbm_h_uses_prototypes='$d_ndbm_h_uses_prototypes' d_nice='$d_nice' d_nl_langinfo='$d_nl_langinfo' d_nv_preserves_uv='$d_nv_preserves_uv' d_nv_zero_is_allbits_zero='$d_nv_zero_is_allbits_zero' d_off64_t='$d_off64_t' d_old_pthread_create_joinable='$d_old_pthread_create_joinable' d_oldpthreads='$d_oldpthreads' d_oldsock='$d_oldsock' d_open3='$d_open3' d_pathconf='$d_pathconf' d_pause='$d_pause' d_perl_otherlibdirs='$d_perl_otherlibdirs' d_phostname='$d_phostname' d_pipe='$d_pipe' d_poll='$d_poll' d_portable='$d_portable' d_printf_format_null='$d_printf_format_null' d_procselfexe='$d_procselfexe' d_pseudofork='$d_pseudofork' d_pthread_atfork='$d_pthread_atfork' d_pthread_attr_setscope='$d_pthread_attr_setscope' d_pthread_yield='$d_pthread_yield' d_pwage='$d_pwage' d_pwchange='$d_pwchange' d_pwclass='$d_pwclass' d_pwcomment='$d_pwcomment' d_pwexpire='$d_pwexpire' d_pwgecos='$d_pwgecos' d_pwpasswd='$d_pwpasswd' d_pwquota='$d_pwquota' d_qgcvt='$d_qgcvt' d_quad='$d_quad' d_random_r='$d_random_r' d_readdir64_r='$d_readdir64_r' d_readdir='$d_readdir' d_readdir_r='$d_readdir_r' d_readlink='$d_readlink' d_readv='$d_readv' d_recvmsg='$d_recvmsg' d_rename='$d_rename' d_rewinddir='$d_rewinddir' d_rmdir='$d_rmdir' d_safebcpy='$d_safebcpy' d_safemcpy='$d_safemcpy' d_sanemcmp='$d_sanemcmp' d_sbrkproto='$d_sbrkproto' d_scalbnl='$d_scalbnl' d_sched_yield='$d_sched_yield' d_scm_rights='$d_scm_rights' d_seekdir='$d_seekdir' d_select='$d_select' d_sem='$d_sem' d_semctl='$d_semctl' d_semctl_semid_ds='$d_semctl_semid_ds' d_semctl_semun='$d_semctl_semun' d_semget='$d_semget' d_semop='$d_semop' d_sendmsg='$d_sendmsg' d_setegid='$d_setegid' d_seteuid='$d_seteuid' d_setgrent='$d_setgrent' d_setgrent_r='$d_setgrent_r' d_setgrps='$d_setgrps' d_sethent='$d_sethent' d_sethostent_r='$d_sethostent_r' d_setitimer='$d_setitimer' d_setlinebuf='$d_setlinebuf' d_setlocale='$d_setlocale' d_setlocale_r='$d_setlocale_r' d_setnent='$d_setnent' d_setnetent_r='$d_setnetent_r' d_setpent='$d_setpent' d_setpgid='$d_setpgid' d_setpgrp2='$d_setpgrp2' d_setpgrp='$d_setpgrp' d_setprior='$d_setprior' d_setproctitle='$d_setproctitle' d_setprotoent_r='$d_setprotoent_r' d_setpwent='$d_setpwent' d_setpwent_r='$d_setpwent_r' d_setregid='$d_setregid' d_setresgid='$d_setresgid' d_setresuid='$d_setresuid' d_setreuid='$d_setreuid' d_setrgid='$d_setrgid' d_setruid='$d_setruid' d_setsent='$d_setsent' d_setservent_r='$d_setservent_r' d_setsid='$d_setsid' d_setvbuf='$d_setvbuf' d_sfio='$d_sfio' d_shm='$d_shm' d_shmat='$d_shmat' d_shmatprototype='$d_shmatprototype' d_shmctl='$d_shmctl' d_shmdt='$d_shmdt' d_shmget='$d_shmget' d_sigaction='$d_sigaction' d_signbit='$d_signbit' d_sigprocmask='$d_sigprocmask' d_sigsetjmp='$d_sigsetjmp' d_sitearch='$d_sitearch' d_snprintf='$d_snprintf' d_sockatmark='$d_sockatmark' d_sockatmarkproto='$d_sockatmarkproto' d_socket='$d_socket' d_socklen_t='$d_socklen_t' d_sockpair='$d_sockpair' d_socks5_init='$d_socks5_init' d_sprintf_returns_strlen='$d_sprintf_returns_strlen' d_sqrtl='$d_sqrtl' d_srand48_r='$d_srand48_r' d_srandom_r='$d_srandom_r' d_sresgproto='$d_sresgproto' d_sresuproto='$d_sresuproto' d_statblks='$d_statblks' d_statfs_f_flags='$d_statfs_f_flags' d_statfs_s='$d_statfs_s' d_statvfs='$d_statvfs' d_stdio_cnt_lval='$d_stdio_cnt_lval' d_stdio_ptr_lval='$d_stdio_ptr_lval' d_stdio_ptr_lval_nochange_cnt='$d_stdio_ptr_lval_nochange_cnt' d_stdio_ptr_lval_sets_cnt='$d_stdio_ptr_lval_sets_cnt' d_stdio_stream_array='$d_stdio_stream_array' d_stdiobase='$d_stdiobase' d_stdstdio='$d_stdstdio' d_strchr='$d_strchr' d_strcoll='$d_strcoll' d_strctcpy='$d_strctcpy' d_strerrm='$d_strerrm' d_strerror='$d_strerror' d_strerror_r='$d_strerror_r' d_strftime='$d_strftime' d_strlcat='$d_strlcat' d_strlcpy='$d_strlcpy' d_strtod='$d_strtod' d_strtol='$d_strtol' d_strtold='$d_strtold' d_strtoll='$d_strtoll' d_strtoq='$d_strtoq' d_strtoul='$d_strtoul' d_strtoull='$d_strtoull' d_strtouq='$d_strtouq' d_strxfrm='$d_strxfrm' d_suidsafe='$d_suidsafe' d_symlink='$d_symlink' d_syscall='$d_syscall' d_syscallproto='$d_syscallproto' d_sysconf='$d_sysconf' d_sysernlst='$d_sysernlst' d_syserrlst='$d_syserrlst' d_system='$d_system' d_tcgetpgrp='$d_tcgetpgrp' d_tcsetpgrp='$d_tcsetpgrp' d_telldir='$d_telldir' d_telldirproto='$d_telldirproto' d_time='$d_time' d_timegm='$d_timegm' d_times='$d_times' d_tm_tm_gmtoff='$d_tm_tm_gmtoff' d_tm_tm_zone='$d_tm_tm_zone' d_tmpnam_r='$d_tmpnam_r' d_truncate='$d_truncate' d_ttyname_r='$d_ttyname_r' d_tzname='$d_tzname' d_u32align='$d_u32align' d_ualarm='$d_ualarm' d_umask='$d_umask' d_uname='$d_uname' d_union_semun='$d_union_semun' d_unordered='$d_unordered' d_unsetenv='$d_unsetenv' d_usleep='$d_usleep' d_usleepproto='$d_usleepproto' d_ustat='$d_ustat' d_vendorarch='$d_vendorarch' d_vendorbin='$d_vendorbin' d_vendorlib='$d_vendorlib' d_vendorscript='$d_vendorscript' d_vfork='$d_vfork' d_void_closedir='$d_void_closedir' d_voidsig='$d_voidsig' d_voidtty='$d_voidtty' d_volatile='$d_volatile' d_vprintf='$d_vprintf' d_vsnprintf='$d_vsnprintf' d_wait4='$d_wait4' d_waitpid='$d_waitpid' d_wcstombs='$d_wcstombs' d_wctomb='$d_wctomb' d_writev='$d_writev' d_xenix='$d_xenix' date='$date' db_hashtype='$db_hashtype' db_prefixtype='$db_prefixtype' db_version_major='$db_version_major' db_version_minor='$db_version_minor' db_version_patch='$db_version_patch' defvoidused='$defvoidused' direntrytype='$direntrytype' dlext='$dlext' dlsrc='$dlsrc' doublesize='$doublesize' drand01='$drand01' drand48_r_proto='$drand48_r_proto' dtrace='$dtrace' dynamic_ext='$dynamic_ext' eagain='$eagain' ebcdic='$ebcdic' echo='$echo' egrep='$egrep' emacs='$emacs' endgrent_r_proto='$endgrent_r_proto' endhostent_r_proto='$endhostent_r_proto' endnetent_r_proto='$endnetent_r_proto' endprotoent_r_proto='$endprotoent_r_proto' endpwent_r_proto='$endpwent_r_proto' endservent_r_proto='$endservent_r_proto' eunicefix='$eunicefix' exe_ext='$exe_ext' expr='$expr' extensions='$extensions' extern_C='$extern_C' extras='$extras' fflushNULL='$fflushNULL' fflushall='$fflushall' find='$find' firstmakefile='$firstmakefile' flex='$flex' fpossize='$fpossize' fpostype='$fpostype' freetype='$freetype' from='$from' full_ar='$full_ar' full_csh='$full_csh' full_sed='$full_sed' gccansipedantic='$gccansipedantic' gccosandvers='$gccosandvers' gccversion='$gccversion' getgrent_r_proto='$getgrent_r_proto' getgrgid_r_proto='$getgrgid_r_proto' getgrnam_r_proto='$getgrnam_r_proto' gethostbyaddr_r_proto='$gethostbyaddr_r_proto' gethostbyname_r_proto='$gethostbyname_r_proto' gethostent_r_proto='$gethostent_r_proto' getlogin_r_proto='$getlogin_r_proto' getnetbyaddr_r_proto='$getnetbyaddr_r_proto' getnetbyname_r_proto='$getnetbyname_r_proto' getnetent_r_proto='$getnetent_r_proto' getprotobyname_r_proto='$getprotobyname_r_proto' getprotobynumber_r_proto='$getprotobynumber_r_proto' getprotoent_r_proto='$getprotoent_r_proto' getpwent_r_proto='$getpwent_r_proto' getpwnam_r_proto='$getpwnam_r_proto' getpwuid_r_proto='$getpwuid_r_proto' getservbyname_r_proto='$getservbyname_r_proto' getservbyport_r_proto='$getservbyport_r_proto' getservent_r_proto='$getservent_r_proto' getspnam_r_proto='$getspnam_r_proto' gidformat='$gidformat' gidsign='$gidsign' gidsize='$gidsize' gidtype='$gidtype' glibpth='$glibpth' gmake='$gmake' gmtime_r_proto='$gmtime_r_proto' gnulibc_version='$gnulibc_version' grep='$grep' groupcat='$groupcat' groupstype='$groupstype' gzip='$gzip' h_fcntl='$h_fcntl' h_sysfile='$h_sysfile' hint='$hint' hostcat='$hostcat' html1dir='$html1dir' html1direxp='$html1direxp' html3dir='$html3dir' html3direxp='$html3direxp' i16size='$i16size' i16type='$i16type' i32size='$i32size' i32type='$i32type' i64size='$i64size' i64type='$i64type' i8size='$i8size' i8type='$i8type' i_arpainet='$i_arpainet' i_assert='$i_assert' i_bsdioctl='$i_bsdioctl' i_crypt='$i_crypt' i_db='$i_db' i_dbm='$i_dbm' i_dirent='$i_dirent' i_dld='$i_dld' i_dlfcn='$i_dlfcn' i_fcntl='$i_fcntl' i_float='$i_float' i_fp='$i_fp' i_fp_class='$i_fp_class' i_gdbm='$i_gdbm' i_gdbm_ndbm='$i_gdbm_ndbm' i_gdbmndbm='$i_gdbmndbm' i_grp='$i_grp' i_ieeefp='$i_ieeefp' i_inttypes='$i_inttypes' i_langinfo='$i_langinfo' i_libutil='$i_libutil' i_limits='$i_limits' i_locale='$i_locale' i_machcthr='$i_machcthr' i_malloc='$i_malloc' i_mallocmalloc='$i_mallocmalloc' i_math='$i_math' i_memory='$i_memory' i_mntent='$i_mntent' i_ndbm='$i_ndbm' i_netdb='$i_netdb' i_neterrno='$i_neterrno' i_netinettcp='$i_netinettcp' i_niin='$i_niin' i_poll='$i_poll' i_prot='$i_prot' i_pthread='$i_pthread' i_pwd='$i_pwd' i_rpcsvcdbm='$i_rpcsvcdbm' i_sfio='$i_sfio' i_sgtty='$i_sgtty' i_shadow='$i_shadow' i_socks='$i_socks' i_stdarg='$i_stdarg' i_stddef='$i_stddef' i_stdlib='$i_stdlib' i_string='$i_string' i_sunmath='$i_sunmath' i_sysaccess='$i_sysaccess' i_sysdir='$i_sysdir' i_sysfile='$i_sysfile' i_sysfilio='$i_sysfilio' i_sysin='$i_sysin' i_sysioctl='$i_sysioctl' i_syslog='$i_syslog' i_sysmman='$i_sysmman' i_sysmode='$i_sysmode' i_sysmount='$i_sysmount' i_sysndir='$i_sysndir' i_sysparam='$i_sysparam' i_syspoll='$i_syspoll' i_sysresrc='$i_sysresrc' i_syssecrt='$i_syssecrt' i_sysselct='$i_sysselct' i_syssockio='$i_syssockio' i_sysstat='$i_sysstat' i_sysstatfs='$i_sysstatfs' i_sysstatvfs='$i_sysstatvfs' i_systime='$i_systime' i_systimek='$i_systimek' i_systimes='$i_systimes' i_systypes='$i_systypes' i_sysuio='$i_sysuio' i_sysun='$i_sysun' i_sysutsname='$i_sysutsname' i_sysvfs='$i_sysvfs' i_syswait='$i_syswait' i_termio='$i_termio' i_termios='$i_termios' i_time='$i_time' i_unistd='$i_unistd' i_ustat='$i_ustat' i_utime='$i_utime' i_values='$i_values' i_varargs='$i_varargs' i_varhdr='$i_varhdr' i_vfork='$i_vfork' ignore_versioned_solibs='$ignore_versioned_solibs' inc_version_list='$inc_version_list' inc_version_list_init='$inc_version_list_init' incpath='$incpath' inews='$inews' initialinstalllocation='$initialinstalllocation' installarchlib='$installarchlib' installbin='$installbin' installhtml1dir='$installhtml1dir' installhtml3dir='$installhtml3dir' installman1dir='$installman1dir' installman3dir='$installman3dir' installprefix='$installprefix' installprefixexp='$installprefixexp' installprivlib='$installprivlib' installscript='$installscript' installsitearch='$installsitearch' installsitebin='$installsitebin' installsitehtml1dir='$installsitehtml1dir' installsitehtml3dir='$installsitehtml3dir' installsitelib='$installsitelib' installsiteman1dir='$installsiteman1dir' installsiteman3dir='$installsiteman3dir' installsitescript='$installsitescript' installstyle='$installstyle' installusrbinperl='$installusrbinperl' installvendorarch='$installvendorarch' installvendorbin='$installvendorbin' installvendorhtml1dir='$installvendorhtml1dir' installvendorhtml3dir='$installvendorhtml3dir' installvendorlib='$installvendorlib' installvendorman1dir='$installvendorman1dir' installvendorman3dir='$installvendorman3dir' installvendorscript='$installvendorscript' intsize='$intsize' issymlink='$issymlink' ivdformat='$ivdformat' ivsize='$ivsize' ivtype='$ivtype' known_extensions='$known_extensions' ksh='$ksh' ld='$ld' lddlflags='$lddlflags' ldflags='$ldflags' ldflags_uselargefiles='$ldflags_uselargefiles' ldlibpthname='$ldlibpthname' less='$less' lib_ext='$lib_ext' libc='$libc' libperl='$libperl' libpth='$libpth' libs='$libs' libsdirs='$libsdirs' libsfiles='$libsfiles' libsfound='$libsfound' libspath='$libspath' libswanted='$libswanted' libswanted_uselargefiles='$libswanted_uselargefiles' line='$line' lint='$lint' lkflags='$lkflags' ln='$ln' lns='$lns' localtime_r_proto='$localtime_r_proto' locincpth='$locincpth' loclibpth='$loclibpth' longdblsize='$longdblsize' longlongsize='$longlongsize' longsize='$longsize' lp='$lp' lpr='$lpr' ls='$ls' lseeksize='$lseeksize' lseektype='$lseektype' mad='$mad' madlyh='$madlyh' madlyobj='$madlyobj' madlysrc='$madlysrc' mail='$mail' mailx='$mailx' make='$make' make_set_make='$make_set_make' mallocobj='$mallocobj' mallocsrc='$mallocsrc' malloctype='$malloctype' man1dir='$man1dir' man1direxp='$man1direxp' man1ext='$man1ext' man3dir='$man3dir' man3direxp='$man3direxp' man3ext='$man3ext' mips_type='$mips_type' mistrustnm='$mistrustnm' mkdir='$mkdir' mmaptype='$mmaptype' modetype='$modetype' more='$more' multiarch='$multiarch' mv='$mv' myarchname='$myarchname' mydomain='$mydomain' myhostname='$myhostname' myuname='$myuname' n='$n' need_va_copy='$need_va_copy' netdb_hlen_type='$netdb_hlen_type' netdb_host_type='$netdb_host_type' netdb_name_type='$netdb_name_type' netdb_net_type='$netdb_net_type' nm='$nm' nm_opt='$nm_opt' nm_so_opt='$nm_so_opt' nonxs_ext='$nonxs_ext' nroff='$nroff' nvEUformat='$nvEUformat' nvFUformat='$nvFUformat' nvGUformat='$nvGUformat' nv_overflows_integers_at='$nv_overflows_integers_at' nv_preserves_uv_bits='$nv_preserves_uv_bits' nveformat='$nveformat' nvfformat='$nvfformat' nvgformat='$nvgformat' nvsize='$nvsize' nvtype='$nvtype' o_nonblock='$o_nonblock' obj_ext='$obj_ext' old_pthread_create_joinable='$old_pthread_create_joinable' optimize='$optimize' orderlib='$orderlib' osname='$osname' osvers='$osvers' otherlibdirs='$otherlibdirs' package='$package' pager='$pager' passcat='$passcat' patchlevel='$patchlevel' path_sep='$path_sep' perl5='$perl5' perl='$perl' perl_patchlevel='$perl_patchlevel' perladmin='$perladmin' perllibs='$perllibs' perlpath='$perlpath' pg='$pg' phostname='$phostname' pidtype='$pidtype' plibpth='$plibpth' pmake='$pmake' pr='$pr' prefix='$prefix' prefixexp='$prefixexp' privlib='$privlib' privlibexp='$privlibexp' procselfexe='$procselfexe' prototype='$prototype' ptrsize='$ptrsize' quadkind='$quadkind' quadtype='$quadtype' randbits='$randbits' randfunc='$randfunc' random_r_proto='$random_r_proto' randseedtype='$randseedtype' ranlib='$ranlib' rd_nodata='$rd_nodata' readdir64_r_proto='$readdir64_r_proto' readdir_r_proto='$readdir_r_proto' revision='$revision' rm='$rm' rm_try='$rm_try' rmail='$rmail' run='$run' runnm='$runnm' sGMTIME_max='$sGMTIME_max' sGMTIME_min='$sGMTIME_min' sLOCALTIME_max='$sLOCALTIME_max' sLOCALTIME_min='$sLOCALTIME_min' sPRIEUldbl='$sPRIEUldbl' sPRIFUldbl='$sPRIFUldbl' sPRIGUldbl='$sPRIGUldbl' sPRIXU64='$sPRIXU64' sPRId64='$sPRId64' sPRIeldbl='$sPRIeldbl' sPRIfldbl='$sPRIfldbl' sPRIgldbl='$sPRIgldbl' sPRIi64='$sPRIi64' sPRIo64='$sPRIo64' sPRIu64='$sPRIu64' sPRIx64='$sPRIx64' sSCNfldbl='$sSCNfldbl' sched_yield='$sched_yield' scriptdir='$scriptdir' scriptdirexp='$scriptdirexp' sed='$sed' seedfunc='$seedfunc' selectminbits='$selectminbits' selecttype='$selecttype' sendmail='$sendmail' setgrent_r_proto='$setgrent_r_proto' sethostent_r_proto='$sethostent_r_proto' setlocale_r_proto='$setlocale_r_proto' setnetent_r_proto='$setnetent_r_proto' setprotoent_r_proto='$setprotoent_r_proto' setpwent_r_proto='$setpwent_r_proto' setservent_r_proto='$setservent_r_proto' sh='$sh' shar='$shar' sharpbang='$sharpbang' shmattype='$shmattype' shortsize='$shortsize' shrpenv='$shrpenv' shsharp='$shsharp' sig_count='$sig_count' sig_name='$sig_name' sig_name_init='$sig_name_init' sig_num='$sig_num' sig_num_init='$sig_num_init' sig_size='$sig_size' signal_t='$signal_t' sitearch='$sitearch' sitearchexp='$sitearchexp' sitebin='$sitebin' sitebinexp='$sitebinexp' sitehtml1dir='$sitehtml1dir' sitehtml1direxp='$sitehtml1direxp' sitehtml3dir='$sitehtml3dir' sitehtml3direxp='$sitehtml3direxp' sitelib='$sitelib' sitelib_stem='$sitelib_stem' sitelibexp='$sitelibexp' siteman1dir='$siteman1dir' siteman1direxp='$siteman1direxp' siteman3dir='$siteman3dir' siteman3direxp='$siteman3direxp' siteprefix='$siteprefix' siteprefixexp='$siteprefixexp' sitescript='$sitescript' sitescriptexp='$sitescriptexp' sizesize='$sizesize' sizetype='$sizetype' sleep='$sleep' smail='$smail' so='$so' sockethdr='$sockethdr' socketlib='$socketlib' socksizetype='$socksizetype' sort='$sort' spackage='$spackage' spitshell='$spitshell' srand48_r_proto='$srand48_r_proto' srandom_r_proto='$srandom_r_proto' src='$src' ssizetype='$ssizetype' startperl='$startperl' startsh='$startsh' static_ext='$static_ext' stdchar='$stdchar' stdio_base='$stdio_base' stdio_bufsiz='$stdio_bufsiz' stdio_cnt='$stdio_cnt' stdio_filbuf='$stdio_filbuf' stdio_ptr='$stdio_ptr' stdio_stream_array='$stdio_stream_array' strerror_r_proto='$strerror_r_proto' strings='$strings' submit='$submit' subversion='$subversion' sysman='$sysman' tail='$tail' tar='$tar' targetarch='$targetarch' tbl='$tbl' tee='$tee' test='$test' timeincl='$timeincl' timetype='$timetype' tmpnam_r_proto='$tmpnam_r_proto' to='$to' touch='$touch' tr='$tr' trnl='$trnl' troff='$troff' ttyname_r_proto='$ttyname_r_proto' u16size='$u16size' u16type='$u16type' u32size='$u32size' u32type='$u32type' u64size='$u64size' u64type='$u64type' u8size='$u8size' u8type='$u8type' uidformat='$uidformat' uidsign='$uidsign' uidsize='$uidsize' uidtype='$uidtype' uname='$uname' uniq='$uniq' uquadtype='$uquadtype' use5005threads='$use5005threads' use64bitall='$use64bitall' use64bitint='$use64bitint' usecrosscompile='$usecrosscompile' usedevel='$usedevel' usedl='$usedl' usedtrace='$usedtrace' usefaststdio='$usefaststdio' useithreads='$useithreads' uselargefiles='$uselargefiles' uselongdouble='$uselongdouble' usemallocwrap='$usemallocwrap' usemorebits='$usemorebits' usemultiplicity='$usemultiplicity' usemymalloc='$usemymalloc' usenm='$usenm' useopcode='$useopcode' useperlio='$useperlio' useposix='$useposix' usereentrant='$usereentrant' userelocatableinc='$userelocatableinc' usesfio='$usesfio' useshrplib='$useshrplib' usesitecustomize='$usesitecustomize' usesocks='$usesocks' usethreads='$usethreads' usevendorprefix='$usevendorprefix' usevfork='$usevfork' usrinc='$usrinc' uuname='$uuname' uvXUformat='$uvXUformat' uvoformat='$uvoformat' uvsize='$uvsize' uvtype='$uvtype' uvuformat='$uvuformat' uvxformat='$uvxformat' vaproto='$vaproto' vendorarch='$vendorarch' vendorarchexp='$vendorarchexp' vendorbin='$vendorbin' vendorbinexp='$vendorbinexp' vendorhtml1dir='$vendorhtml1dir' vendorhtml1direxp='$vendorhtml1direxp' vendorhtml3dir='$vendorhtml3dir' vendorhtml3direxp='$vendorhtml3direxp' vendorlib='$vendorlib' vendorlib_stem='$vendorlib_stem' vendorlibexp='$vendorlibexp' vendorman1dir='$vendorman1dir' vendorman1direxp='$vendorman1direxp' vendorman3dir='$vendorman3dir' vendorman3direxp='$vendorman3direxp' vendorprefix='$vendorprefix' vendorprefixexp='$vendorprefixexp' vendorscript='$vendorscript' vendorscriptexp='$vendorscriptexp' version='$version' version_patchlevel_string='$version_patchlevel_string' versiononly='$versiononly' vi='$vi' voidflags='$voidflags' xlibpth='$xlibpth' yacc='$yacc' yaccflags='$yaccflags' zcat='$zcat' zip='$zip' EOT : add special variables $test -f $src/patchlevel.h && \ awk '/^#define[ ]+PERL_/ {printf "%s=%s\n",$2,$3}' $src/patchlevel.h >>config.sh echo "PERL_PATCHLEVEL='$perl_patchlevel'" >>config.sh echo "PERL_CONFIG_SH=true" >>config.sh : propagate old symbols if $test -f UU/config.sh; then UU/oldconfig.sh $sed -n 's/^\([a-zA-Z_0-9]*\)=.*/\1/p' \ config.sh config.sh UU/oldconfig.sh |\ $sort | $uniq -u >UU/oldsyms set X `cat UU/oldsyms` shift case $# in 0) ;; *) cat <>config.sh for sym in `cat UU/oldsyms`; do echo " Propagating $hint variable "'$'"$sym..." eval 'tmp="$'"${sym}"'"' echo "$tmp" | \ sed -e "s/'/'\"'\"'/g" -e "s/^/$sym='/" -e "s/$/'/" >>config.sh done ;; esac fi : Finish up by extracting the .SH files case "$alldone" in exit) $rm -rf UU echo "Extraction done." exit 0 ;; cont) ;; '') dflt='' nostick=true $cat <&4 -c "$ans";; esac ;; esac : if this fails, just run all the .SH files by hand . ./config.sh echo " " exec 1>&4 pwd=`pwd` . ./UU/extract cd "$pwd" if $contains '^depend:' [Mm]akefile >/dev/null 2>&1; then dflt=y case "$silent" in true) ;; *) $cat < makedepend.out &" It can take a while, so you might not want to run it right now. EOM ;; esac rp="Run $make depend now?" . UU/myread case "$ans" in y*) $make depend && echo "Now you must run '$make'." ;; *) echo "You must run '$make depend' then '$make'." ;; esac elif test -f [Mm]akefile; then echo " " echo "Now you must run a $make." else echo "Configure done." fi if $test -f Policy.sh; then $cat <&4 $rm -f config.msg fi $rm -f kit*isdone ark*isdone $rm -rf UU : End of Configure perl-5.12.0-RC0/perliol.h0000444000175000017500000003334611325125742013757 0ustar jessejesse#ifndef _PERLIOL_H #define _PERLIOL_H typedef struct { PerlIO_funcs *funcs; SV *arg; } PerlIO_pair_t; struct PerlIO_list_s { IV refcnt; IV cur; IV len; PerlIO_pair_t *array; }; struct _PerlIO_funcs { Size_t fsize; const char *name; Size_t size; U32 kind; 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); IV (*Binmode)(pTHX_ PerlIO *f); SV *(*Getarg) (pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags); IV (*Fileno) (pTHX_ PerlIO *f); PerlIO *(*Dup) (pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags); /* Unix-like functions - cf sfio line disciplines */ SSize_t(*Read) (pTHX_ PerlIO *f, void *vbuf, Size_t count); SSize_t(*Unread) (pTHX_ PerlIO *f, const void *vbuf, Size_t count); SSize_t(*Write) (pTHX_ PerlIO *f, const void *vbuf, Size_t count); IV (*Seek) (pTHX_ PerlIO *f, Off_t offset, int whence); Off_t(*Tell) (pTHX_ PerlIO *f); IV (*Close) (pTHX_ PerlIO *f); /* Stdio-like buffered IO functions */ IV (*Flush) (pTHX_ PerlIO *f); IV (*Fill) (pTHX_ PerlIO *f); IV (*Eof) (pTHX_ PerlIO *f); IV (*Error) (pTHX_ PerlIO *f); void (*Clearerr) (pTHX_ PerlIO *f); void (*Setlinebuf) (pTHX_ PerlIO *f); /* Perl's snooping functions */ STDCHAR *(*Get_base) (pTHX_ PerlIO *f); Size_t(*Get_bufsiz) (pTHX_ PerlIO *f); STDCHAR *(*Get_ptr) (pTHX_ PerlIO *f); SSize_t(*Get_cnt) (pTHX_ PerlIO *f); void (*Set_ptrcnt) (pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt); }; /*--------------------------------------------------------------------------------------*/ /* Kind values */ #define PERLIO_K_RAW 0x00000001 #define PERLIO_K_BUFFERED 0x00000002 #define PERLIO_K_CANCRLF 0x00000004 #define PERLIO_K_FASTGETS 0x00000008 #define PERLIO_K_DUMMY 0x00000010 #define PERLIO_K_UTF8 0x00008000 #define PERLIO_K_DESTRUCT 0x00010000 #define PERLIO_K_MULTIARG 0x00020000 /*--------------------------------------------------------------------------------------*/ struct _PerlIO { PerlIOl *next; /* Lower layer */ PerlIO_funcs *tab; /* Functions for this layer */ U32 flags; /* Various flags for state */ }; /*--------------------------------------------------------------------------------------*/ /* Flag values */ #define PERLIO_F_EOF 0x00000100 #define PERLIO_F_CANWRITE 0x00000200 #define PERLIO_F_CANREAD 0x00000400 #define PERLIO_F_ERROR 0x00000800 #define PERLIO_F_TRUNCATE 0x00001000 #define PERLIO_F_APPEND 0x00002000 #define PERLIO_F_CRLF 0x00004000 #define PERLIO_F_UTF8 0x00008000 #define PERLIO_F_UNBUF 0x00010000 #define PERLIO_F_WRBUF 0x00020000 #define PERLIO_F_RDBUF 0x00040000 #define PERLIO_F_LINEBUF 0x00080000 #define PERLIO_F_TEMP 0x00100000 #define PERLIO_F_OPEN 0x00200000 #define PERLIO_F_FASTGETS 0x00400000 #define PERLIO_F_TTY 0x00800000 #define PERLIO_F_NOTREG 0x01000000 #define PerlIOBase(f) (*(f)) #define PerlIOSelf(f,type) ((type *)PerlIOBase(f)) #define PerlIONext(f) (&(PerlIOBase(f)->next)) #define PerlIOValid(f) ((f) && *(f)) /*--------------------------------------------------------------------------------------*/ /* Data exports - EXTCONST rather than extern is needed for Cygwin */ #undef EXTPERLIO #ifdef PERLIO_FUNCS_CONST #define EXTPERLIO EXTCONST #else #define EXTPERLIO EXT #endif EXTPERLIO PerlIO_funcs PerlIO_unix; EXTPERLIO PerlIO_funcs PerlIO_perlio; EXTPERLIO PerlIO_funcs PerlIO_stdio; EXTPERLIO PerlIO_funcs PerlIO_crlf; EXTPERLIO PerlIO_funcs PerlIO_utf8; EXTPERLIO PerlIO_funcs PerlIO_byte; EXTPERLIO PerlIO_funcs PerlIO_raw; EXTPERLIO PerlIO_funcs PerlIO_pending; #ifdef HAS_MMAP EXTPERLIO PerlIO_funcs PerlIO_mmap; #endif #ifdef WIN32 EXTPERLIO PerlIO_funcs PerlIO_win32; #endif PERL_EXPORT_C PerlIO *PerlIO_allocate(pTHX); PERL_EXPORT_C SV *PerlIO_arg_fetch(PerlIO_list_t *av, IV n); #define PerlIOArg PerlIO_arg_fetch(layers,n) #ifdef PERLIO_USING_CRLF #define PERLIO_STDTEXT "t" #else #define PERLIO_STDTEXT "" #endif /*--------------------------------------------------------------------------------------*/ /* perlio buffer layer As this is reasonably generic its struct and "methods" are declared here so they can be used to "inherit" from it. */ typedef struct { struct _PerlIO base; /* Base "class" info */ STDCHAR *buf; /* Start of buffer */ STDCHAR *end; /* End of valid part of buffer */ STDCHAR *ptr; /* Current position in buffer */ Off_t posn; /* Offset of buf into the file */ Size_t bufsiz; /* Real size of buffer */ IV oneword; /* Emergency buffer */ } PerlIOBuf; PERL_EXPORT_C int PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, PerlIO_list_t *layers, IV n, IV max); PERL_EXPORT_C int PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names); PERL_EXPORT_C PerlIO_funcs *PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def); PERL_EXPORT_C SV *PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param); PERL_EXPORT_C void PerlIO_cleantable(pTHX_ PerlIO **tablep); PERL_EXPORT_C SV * PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab); PERL_EXPORT_C void PerlIO_default_buffer(pTHX_ PerlIO_list_t *av); PERL_EXPORT_C void PerlIO_stdstreams(pTHX); PERL_EXPORT_C int PerlIO__close(pTHX_ PerlIO *f); PERL_EXPORT_C PerlIO_list_t * PerlIO_resolve_layers(pTHX_ const char *layers, const char *mode, int narg, SV **args); PERL_EXPORT_C PerlIO_funcs * PerlIO_default_layer(pTHX_ I32 n); PERL_EXPORT_C PerlIO_list_t * PerlIO_default_layers(pTHX); PERL_EXPORT_C PerlIO * PerlIO_reopen(const char *path, const char *mode, PerlIO *f); PERL_EXPORT_C int PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap) __attribute__format__(__printf__,3,0); PERL_EXPORT_C PerlIO_list_t *PerlIO_list_alloc(pTHX); PERL_EXPORT_C PerlIO_list_t *PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param); PERL_EXPORT_C void PerlIO_list_free(pTHX_ PerlIO_list_t *list); PERL_EXPORT_C void PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg); PERL_EXPORT_C void PerlIO_list_free(pTHX_ PerlIO_list_t *list); /* PerlIO_teardown doesn't need exporting, but the EXTERN_C is needed * for compiling as C++. Must also match with what perl.h says. */ EXTERN_C void PerlIO_teardown(void); /*--------------------------------------------------------------------------------------*/ /* Generic, or stub layer functions */ PERL_EXPORT_C IV PerlIOBase_binmode(pTHX_ PerlIO *f); PERL_EXPORT_C void PerlIOBase_clearerr(pTHX_ PerlIO *f); PERL_EXPORT_C IV PerlIOBase_close(pTHX_ PerlIO *f); PERL_EXPORT_C PerlIO * PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags); PERL_EXPORT_C IV PerlIOBase_eof(pTHX_ PerlIO *f); PERL_EXPORT_C IV PerlIOBase_error(pTHX_ PerlIO *f); PERL_EXPORT_C IV PerlIOBase_fileno(pTHX_ PerlIO *f); PERL_EXPORT_C void PerlIOBase_flush_linebuf(pTHX); PERL_EXPORT_C IV PerlIOBase_noop_fail(pTHX_ PerlIO *f); PERL_EXPORT_C IV PerlIOBase_noop_ok(pTHX_ PerlIO *f); PERL_EXPORT_C IV PerlIOBase_popped(pTHX_ PerlIO *f); PERL_EXPORT_C IV PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab); PERL_EXPORT_C SSize_t PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count); PERL_EXPORT_C void PerlIOBase_setlinebuf(pTHX_ PerlIO *f); PERL_EXPORT_C SSize_t PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count); /* Buf */ PERL_EXPORT_C Size_t PerlIOBuf_bufsiz(pTHX_ PerlIO *f); PERL_EXPORT_C IV PerlIOBuf_close(pTHX_ PerlIO *f); PERL_EXPORT_C PerlIO * PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags); PERL_EXPORT_C IV PerlIOBuf_fill(pTHX_ PerlIO *f); PERL_EXPORT_C IV PerlIOBuf_flush(pTHX_ PerlIO *f); PERL_EXPORT_C STDCHAR * PerlIOBuf_get_base(pTHX_ PerlIO *f); PERL_EXPORT_C SSize_t PerlIOBuf_get_cnt(pTHX_ PerlIO *f); PERL_EXPORT_C STDCHAR * PerlIOBuf_get_ptr(pTHX_ PerlIO *f); PERL_EXPORT_C PerlIO * PerlIOBuf_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); PERL_EXPORT_C IV PerlIOBuf_popped(pTHX_ PerlIO *f); PERL_EXPORT_C IV PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab); PERL_EXPORT_C SSize_t PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count); PERL_EXPORT_C IV PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence); PERL_EXPORT_C void PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt); PERL_EXPORT_C Off_t PerlIOBuf_tell(pTHX_ PerlIO *f); PERL_EXPORT_C SSize_t PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count); PERL_EXPORT_C SSize_t PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count); /* Crlf */ PERL_EXPORT_C IV PerlIOCrlf_binmode(pTHX_ PerlIO *f); PERL_EXPORT_C IV PerlIOCrlf_flush(pTHX_ PerlIO *f); PERL_EXPORT_C SSize_t PerlIOCrlf_get_cnt(pTHX_ PerlIO *f); PERL_EXPORT_C IV PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab); PERL_EXPORT_C void PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt); PERL_EXPORT_C SSize_t PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count); PERL_EXPORT_C SSize_t PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count); PERL_EXPORT_C SSize_t PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count); /* Mmap */ PERL_EXPORT_C IV PerlIOMmap_close(pTHX_ PerlIO *f); PERL_EXPORT_C PerlIO * PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags); PERL_EXPORT_C IV PerlIOMmap_fill(pTHX_ PerlIO *f); PERL_EXPORT_C IV PerlIOMmap_flush(pTHX_ PerlIO *f); PERL_EXPORT_C STDCHAR * PerlIOMmap_get_base(pTHX_ PerlIO *f); PERL_EXPORT_C IV PerlIOMmap_map(pTHX_ PerlIO *f); PERL_EXPORT_C IV PerlIOMmap_unmap(pTHX_ PerlIO *f); PERL_EXPORT_C SSize_t PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count); PERL_EXPORT_C SSize_t PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count); /* Pending */ PERL_EXPORT_C IV PerlIOPending_close(pTHX_ PerlIO *f); PERL_EXPORT_C IV PerlIOPending_fill(pTHX_ PerlIO *f); PERL_EXPORT_C IV PerlIOPending_flush(pTHX_ PerlIO *f); PERL_EXPORT_C IV PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab); PERL_EXPORT_C SSize_t PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count); PERL_EXPORT_C IV PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence); PERL_EXPORT_C void PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt); /* Pop */ PERL_EXPORT_C IV PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab); /* Raw */ PERL_EXPORT_C PerlIO * PerlIORaw_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); PERL_EXPORT_C IV PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab); /* Stdio */ PERL_EXPORT_C void PerlIOStdio_clearerr(pTHX_ PerlIO *f); PERL_EXPORT_C IV PerlIOStdio_close(pTHX_ PerlIO *f); PERL_EXPORT_C PerlIO * PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags); PERL_EXPORT_C IV PerlIOStdio_eof(pTHX_ PerlIO *f); PERL_EXPORT_C IV PerlIOStdio_error(pTHX_ PerlIO *f); PERL_EXPORT_C IV PerlIOStdio_fileno(pTHX_ PerlIO *f); PERL_EXPORT_C IV PerlIOStdio_fill(pTHX_ PerlIO *f); PERL_EXPORT_C IV PerlIOStdio_flush(pTHX_ PerlIO *f); PERL_EXPORT_C STDCHAR * PerlIOStdio_get_base(pTHX_ PerlIO *f); PERL_EXPORT_C char * PerlIOStdio_mode(const char *mode, char *tmode); PERL_EXPORT_C 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); PERL_EXPORT_C IV PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab); PERL_EXPORT_C SSize_t PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count); PERL_EXPORT_C IV PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence); PERL_EXPORT_C void PerlIOStdio_setlinebuf(pTHX_ PerlIO *f); PERL_EXPORT_C Off_t PerlIOStdio_tell(pTHX_ PerlIO *f); PERL_EXPORT_C SSize_t PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count); PERL_EXPORT_C SSize_t PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count); /* Unix */ PERL_EXPORT_C IV PerlIOUnix_close(pTHX_ PerlIO *f); PERL_EXPORT_C PerlIO * PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags); PERL_EXPORT_C IV PerlIOUnix_fileno(pTHX_ PerlIO *f); PERL_EXPORT_C int PerlIOUnix_oflags(const char *mode); PERL_EXPORT_C 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); PERL_EXPORT_C IV PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab); PERL_EXPORT_C SSize_t PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count); PERL_EXPORT_C int PerlIOUnix_refcnt_dec(int fd); PERL_EXPORT_C void PerlIOUnix_refcnt_inc(int fd); PERL_EXPORT_C IV PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence); PERL_EXPORT_C Off_t PerlIOUnix_tell(pTHX_ PerlIO *f); PERL_EXPORT_C SSize_t PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count); /* Utf8 */ PERL_EXPORT_C IV PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab); #endif /* _PERLIOL_H */ /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */ perl-5.12.0-RC0/minimod.pl0000444000175000017500000000656011325125742014127 0ustar jessejesse#./miniperl -w # minimod.pl writes the contents of miniperlmain.c into the module # ExtUtils::Miniperl for later perusal (when the perl source is # deleted) # # It also writes the subroutine writemain(), which takes as its # arguments module names that shall be statically linked into perl. # # Authors: Andreas Koenig , Tim Bunce # # # Version 1.0, Feb 2nd 1995 by Andreas Koenig BEGIN { unshift @INC, "lib" } use strict; print <<'END'; # This File keeps the contents of miniperlmain.c. # # It was generated automatically by minimod.PL from the contents # of miniperlmain.c. Don't edit this file! # # ANY CHANGES MADE HERE WILL BE LOST! # package ExtUtils::Miniperl; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(&writemain); $head= <<'EOF!HEAD'; END open MINI, "miniperlmain.c"; while () { last if /Do not delete this line--writemain depends on it/; print; /#include "perl.h"/ and print qq/#include "XSUB.h"\n/; } print <<'END'; EOF!HEAD $tail=<<'EOF!TAIL'; END while () { print unless /dXSUB_SYS/; } close MINI; print <<'END'; EOF!TAIL sub writemain{ my(@exts) = @_; my($pname); my($dl) = canon('/','DynaLoader'); print $head; foreach $_ (@exts){ my($pname) = canon('/', $_); my($mname, $cname); ($mname = $pname) =~ s!/!::!g; ($cname = $pname) =~ s!/!__!g; print "EXTERN_C void boot_${cname} (pTHX_ CV* cv);\n"; } my ($tail1,$tail2,$tail3) = ( $tail =~ /\A(.*{\s*\n)(.*\n)(\s*\}.*)\Z/s ); print $tail1; print "\tconst char file[] = __FILE__;\n"; print "\tdXSUB_SYS;\n" if $] > 5.002; print $tail2; foreach $_ (@exts){ my($pname) = canon('/', $_); my($mname, $cname, $ccode); ($mname = $pname) =~ s!/!::!g; ($cname = $pname) =~ s!/!__!g; print "\t{\n"; if ($pname eq $dl){ # Must NOT install 'DynaLoader::boot_DynaLoader' as 'bootstrap'! # boot_DynaLoader is called directly in DynaLoader.pm $ccode = "\t/* DynaLoader is a special case */\n \tnewXS(\"${mname}::boot_${cname}\", boot_${cname}, file);\n"; print $ccode unless $SEEN{$ccode}++; } else { $ccode = "\tnewXS(\"${mname}::bootstrap\", boot_${cname}, file);\n"; print $ccode unless $SEEN{$ccode}++; } print "\t}\n"; } print $tail3; } sub canon{ my($as, @ext) = @_; foreach(@ext){ # might be X::Y or lib/auto/X/Y/Y.a next if s!::!/!g; s:^(lib|ext)/(auto/)?::; s:/\w+\.\w+$::; } grep(s:/:$as:, @ext) if ($as ne '/'); @ext; } 1; __END__ =head1 NAME ExtUtils::Miniperl, writemain - write the C code for perlmain.c =head1 SYNOPSIS C C =head1 DESCRIPTION This whole module is written when perl itself is built from a script called minimod.PL. In case you want to patch it, please patch minimod.PL in the perl distribution instead. writemain() takes an argument list of directories containing archive libraries that relate to perl modules and should be linked into a new perl binary. It writes to STDOUT a corresponding perlmain.c file that is a plain C file containing all the bootstrap code to make the modules associated with the libraries available from within perl. The typical usage is from within a Makefile generated by ExtUtils::MakeMaker. So under normal circumstances you won't have to deal with this module directly. =head1 SEE ALSO L =cut END perl-5.12.0-RC0/keywords.pl0000555000175000017500000000601311325125741014335 0ustar jessejesse#!/usr/bin/perl -w # # Regenerate (overwriting only if changed): # # keywords.h # # from information stored in the DATA section of this file. # # Accepts the standard regen_lib -q and -v args. # # This script is normally invoked from regen.pl. use strict; require 'regen_lib.pl'; my $kw = safer_open("keywords.h-new"); select $kw; print <) { chop; next unless $_; next if /^#/; my ($keyword) = split; print &tab(5, "#define KEY_$keyword"), $keynum++, "\n"; } print $kw "\n/* ex: set ro: */\n"; safer_close($kw); rename_if_different("keywords.h-new", "keywords.h"); ########################################################################### sub tab { my ($l, $t) = @_; $t .= "\t" x ($l - (length($t) + 1) / 8); $t; } ########################################################################### __END__ NULL __FILE__ __LINE__ __PACKAGE__ __DATA__ __END__ AUTOLOAD BEGIN UNITCHECK CORE DESTROY END INIT CHECK abs accept alarm and atan2 bind binmode bless break caller chdir chmod chomp chop chown chr chroot close closedir cmp connect continue cos crypt dbmclose dbmopen default defined delete die do dump each else elsif endgrent endhostent endnetent endprotoent endpwent endservent eof eq eval exec exists exit exp fcntl fileno flock for foreach fork format formline ge getc getgrent getgrgid getgrnam gethostbyaddr gethostbyname gethostent getlogin getnetbyaddr getnetbyname getnetent getpeername getpgrp getppid getpriority getprotobyname getprotobynumber getprotoent getpwent getpwnam getpwuid getservbyname getservbyport getservent getsockname getsockopt given glob gmtime goto grep gt hex if index int ioctl join keys kill last lc lcfirst le length link listen local localtime lock log lstat lt m map mkdir msgctl msgget msgrcv msgsnd my ne next no not oct open opendir or ord our pack package pipe pop pos print printf prototype push q qq qr quotemeta qw qx rand read readdir readline readlink readpipe recv redo ref rename require reset return reverse rewinddir rindex rmdir s say scalar seek seekdir select semctl semget semop send setgrent sethostent setnetent setpgrp setpriority setprotoent setpwent setservent setsockopt shift shmctl shmget shmread shmwrite shutdown sin sleep socket socketpair sort splice split sprintf sqrt srand stat state study sub substr symlink syscall sysopen sysread sysseek system syswrite tell telldir tie tied time times tr truncate uc ucfirst umask undef unless unlink unpack unshift untie until use utime values vec wait waitpid wantarray warn when while write x xor y perl-5.12.0-RC0/README.win320000444000175000017500000012105311347250766013763 0ustar jessejesseIf you read this file _as_is_, just ignore the funny characters you see. It is written in the POD format (see pod/perlpod.pod) which is specially designed to be readable as is. =head1 NAME perlwin32 - Perl under Windows =head1 SYNOPSIS These are instructions for building Perl under Windows 9x/NT/2000/XP on the Intel x86 and Itanium architectures. =head1 DESCRIPTION Before you start, you should glance through the README file found in the top-level directory to which the Perl distribution was extracted. Make sure you read and understand the terms under which this software is being distributed. Also make sure you read L below for the known limitations of this port. The INSTALL file in the perl top-level has much information that is only relevant to people building Perl on Unix-like systems. In particular, you can safely ignore any information that talks about "Configure". You may also want to look at two other options for building a perl that will work on Windows NT: the README.cygwin and README.os2 files, each of which give a different set of rules to build a Perl that will work on Win32 platforms. Those two methods will probably enable you to build a more Unix-compatible perl, but you will also need to download and use various other build-time and run-time support software described in those files. This set of instructions is meant to describe a so-called "native" port of Perl to Win32 platforms. This includes both 32-bit and 64-bit Windows operating systems. The resulting Perl requires no additional software to run (other than what came with your operating system). Currently, this port is capable of using one of the following compilers on the Intel x86 architecture: Borland C++ version 5.02 or later Microsoft Visual C++ version 2.0 or later MinGW with gcc gcc version 2.95.2 or later Gcc by mingw.org gcc version 2.95.2 or later Gcc by mingw-w64.sf.net gcc version 4.4.3 or later Note that the last two of these are actually competing projects both delivering complete gcc toolchain for MS Windows: - http://mingw.org - delivers gcc toolchain targeting 32-bit Windows platform. Use version 3.2.x or later for the best results with this compiler. - http://mingw-w64.sf.net - delivers gcc toolchain targeting both 64-bit Windows and 32-bit Windows platforms (despite the project name "mingw-w64" they are not only 64-bit oriented). They deliver the native gcc compilers + cross-compilers that are also supported by perl's makefile. The Borland C++ and Microsoft Visual C++ compilers are also now being given away free. The Borland compiler is available as "Borland C++ Compiler Free Command Line Tools" and is the same compiler that ships with the full "Borland C++ Builder" product. The Microsoft compiler is available as "Visual C++ Toolkit 2003" or "Visual C++ 2005/2008 Express Edition" (and also as part of the ".NET Framework SDK") and is the same compiler that ships with "Visual C++ .NET 2003 Professional" or "Visual C++ 2005/2008 Professional" respectively. This port can also be built on IA64/AMD64 using: Microsoft Platform SDK Nov 2001 (64-bit compiler and tools) MinGW64 compiler (gcc version 4.4.3 or later) The MS Platform SDK can be downloaded from http://www.microsoft.com/. The MinGW64 compiler is available at http://sourceforge.net/projects/mingw-w64. The latter is actually a cross-compiler targeting Win64. There's also a trimmed down compiler (no java, or gfortran) suitable for building perl available at: http://svn.ali.as/cpan/users/kmx/strawberry_gcc-toolchain/ NOTE: If you're using a 32-bit compiler to build perl on a 64-bit Windows operating system, then you should set the WIN64 environment variable to "undef". This port fully supports MakeMaker (the set of modules that is used to build extensions to perl). Therefore, you should be able to build and install most extensions found in the CPAN sites. See L below for general hints about this. =head2 Setting Up Perl on Win32 =over 4 =item Make You need a "make" program to build the sources. If you are using Visual C++ or the Platform SDK tools under Windows NT/2000/XP, nmake will work. All other builds need dmake. dmake is a freely available make that has very nice macro features and parallelability. A port of dmake for Windows is available from: http://search.cpan.org/dist/dmake/ Fetch and install dmake somewhere on your path. There exists a minor coexistence problem with dmake and Borland C++ compilers. Namely, if a distribution has C files named with mixed case letters, they will be compiled into appropriate .obj-files named with all lowercase letters, and every time dmake is invoked to bring files up to date, it will try to recompile such files again. For example, Tk distribution has a lot of such files, resulting in needless recompiles every time dmake is invoked. To avoid this, you may use the script "sync_ext.pl" after a successful build. It is available in the win32 subdirectory of the Perl source distribution. =item Command Shell Use the default "cmd" shell that comes with NT. Some versions of the popular 4DOS/NT shell have incompatibilities that may cause you trouble. If the build fails under that shell, try building again with the cmd shell. The nmake Makefile also has known incompatibilities with the "command.com" shell that comes with Windows 9x. You will need to use dmake and makefile.mk to build under Windows 9x. The surest way to build it is on Windows NT/2000/XP, using the cmd shell. Make sure the path to the build directory does not contain spaces. The build usually works in this circumstance, but some tests will fail. =item Borland C++ If you are using the Borland compiler, you will need dmake. (The make that Borland supplies is seriously crippled and will not work for MakeMaker builds.) See L above. =item Microsoft Visual C++ The nmake that comes with Visual C++ will suffice for building. You will need to run the VCVARS32.BAT file, usually found somewhere like C:\MSDEV4.2\BIN or C:\Program Files\Microsoft Visual Studio\VC98\Bin. This will set your build environment. You can also use dmake to build using Visual C++; provided, however, you set OSRELEASE to "microsft" (or whatever the directory name under which the Visual C dmake configuration lives) in your environment and edit win32/config.vc to change "make=nmake" into "make=dmake". The latter step is only essential if you want to use dmake as your default make for building extensions using MakeMaker. =item Microsoft Visual C++ 2008 Express Edition This free version of Visual C++ 2008 Professional contains the same compiler and linker that ship with the full version, and also contains everything necessary to build Perl, rather than requiring a separate download of the Platform SDK like previous versions did. This package can be downloaded by searching for "Visual Studio 2008 Express Edition" in the Download Center at http://www.microsoft.com/downloads/search.aspx?displaylang=en. (Providing exact links to these packages has proven a pointless task because the links keep on changing so often.) Install Visual C++ 2008, then setup your environment using C:\Program Files\Microsoft Visual Studio 9.0\Common7\Tools\vsvars32.bat (assuming the default installation location was chosen). Perl should now build using the win32/Makefile. You will need to edit that file to set CCTYPE = MSVC90FREE first. =item Microsoft Visual C++ 2005 Express Edition This free version of Visual C++ 2005 Professional contains the same compiler and linker that ship with the full version, but doesn't contain everything necessary to build Perl. You will also need to download the "Platform SDK" (the "Core SDK" and "MDAC SDK" components are required) for more header files and libraries. These packages can both be downloaded by searching in the Download Center at http://www.microsoft.com/downloads/search.aspx?displaylang=en. (Providing exact links to these packages has proven a pointless task because the links keep on changing so often.) Try to obtain the latest version of the Platform SDK. Sometimes these packages contain a particular Windows OS version in their name, but actually work on other OS versions too. For example, the "Windows Server 2003 R2 Platform SDK" also runs on Windows XP SP2 and Windows 2000. According to the download pages these packages are only supported on Windows 2000/XP/2003, so trying to use these tools on Windows 95/98/ME and even Windows NT probably won't work. Install Visual C++ 2005 first, then the Platform SDK. Setup your environment as follows (assuming default installation locations were chosen): SET PlatformSDKDir=C:\Program Files\Microsoft Platform SDK SET PATH=%SystemRoot%\system32;%SystemRoot%;C:\Program Files\Microsoft Visual Studio 8\Common7\IDE;C:\Program Files\Microsoft Visual Studio 8\VC\BIN;C:\Program Files\Microsoft Visual Studio 8\Common7\Tools;C:\Program Files\Microsoft Visual Studio 8\SDK\v2.0\bin;C:\WINDOWS\Microsoft.NET\Framework\v2.0.50727;C:\Program Files\Microsoft Visual Studio 8\VC\VCPackages;%PlatformSDKDir%\Bin SET INCLUDE=C:\Program Files\Microsoft Visual Studio 8\VC\INCLUDE;%PlatformSDKDir%\include SET LIB=C:\Program Files\Microsoft Visual Studio 8\VC\LIB;C:\Program Files\Microsoft Visual Studio 8\SDK\v2.0\lib;%PlatformSDKDir%\lib SET LIBPATH=C:\WINDOWS\Microsoft.NET\Framework\v2.0.50727 (The PlatformSDKDir might need to be set differently depending on which version you are using. Earlier versions installed into "C:\Program Files\Microsoft SDK", while the latest versions install into version-specific locations such as "C:\Program Files\Microsoft Platform SDK for Windows Server 2003 R2".) Perl should now build using the win32/Makefile. You will need to edit that file to set CCTYPE = MSVC80FREE and to set CCHOME, CCINCDIR and CCLIBDIR as per the environment setup above. =item Microsoft Visual C++ Toolkit 2003 This free toolkit contains the same compiler and linker that ship with Visual C++ .NET 2003 Professional, but doesn't contain everything necessary to build Perl. You will also need to download the "Platform SDK" (the "Core SDK" and "MDAC SDK" components are required) for header files, libraries and rc.exe, and ".NET Framework SDK" for more libraries and nmake.exe. Note that the latter (which also includes the free compiler and linker) requires the ".NET Framework Redistributable" to be installed first. This can be downloaded and installed separately, but is included in the "Visual C++ Toolkit 2003" anyway. These packages can all be downloaded by searching in the Download Center at http://www.microsoft.com/downloads/search.aspx?displaylang=en. (Providing exact links to these packages has proven a pointless task because the links keep on changing so often.) Try to obtain the latest version of the Platform SDK. Sometimes these packages contain a particular Windows OS version in their name, but actually work on other OS versions too. For example, the "Windows Server 2003 R2 Platform SDK" also runs on Windows XP SP2 and Windows 2000. According to the download pages these packages are only supported on Windows 2000/XP/2003, so trying to use these tools on Windows 95/98/ME and even Windows NT probably won't work. Install the Toolkit first, then the Platform SDK, then the .NET Framework SDK. Setup your environment as follows (assuming default installation locations were chosen): SET PlatformSDKDir=C:\Program Files\Microsoft Platform SDK SET PATH=%SystemRoot%\system32;%SystemRoot%;C:\Program Files\Microsoft Visual C++ Toolkit 2003\bin;%PlatformSDKDir%\Bin;C:\Program Files\Microsoft.NET\SDK\v1.1\Bin SET INCLUDE=C:\Program Files\Microsoft Visual C++ Toolkit 2003\include;%PlatformSDKDir%\include;C:\Program Files\Microsoft Visual Studio .NET 2003\Vc7\include SET LIB=C:\Program Files\Microsoft Visual C++ Toolkit 2003\lib;%PlatformSDKDir%\lib;C:\Program Files\Microsoft Visual Studio .NET 2003\Vc7\lib (The PlatformSDKDir might need to be set differently depending on which version you are using. Earlier versions installed into "C:\Program Files\Microsoft SDK", while the latest versions install into version-specific locations such as "C:\Program Files\Microsoft Platform SDK for Windows Server 2003 R2".) Several required files will still be missing: =over 4 =item * cvtres.exe is required by link.exe when using a .res file. It is actually installed by the .NET Framework SDK, but into a location such as the following: C:\WINDOWS\Microsoft.NET\Framework\v1.1.4322 Copy it from there to %PlatformSDKDir%\Bin =item * lib.exe is normally used to build libraries, but link.exe with the /lib option also works, so change win32/config.vc to use it instead: Change the line reading: ar='lib' to: ar='link /lib' It may also be useful to create a batch file called lib.bat in C:\Program Files\Microsoft Visual C++ Toolkit 2003\bin containing: @echo off link /lib %* for the benefit of any naughty C extension modules that you might want to build later which explicitly reference "lib" rather than taking their value from $Config{ar}. =item * setargv.obj is required to build perlglob.exe (and perl.exe if the USE_SETARGV option is enabled). The Platform SDK supplies this object file in source form in %PlatformSDKDir%\src\crt. Copy setargv.c, cruntime.h and internal.h from there to some temporary location and build setargv.obj using cl.exe /c /I. /D_CRTBLD setargv.c Then copy setargv.obj to %PlatformSDKDir%\lib Alternatively, if you don't need perlglob.exe and don't need to enable the USE_SETARGV option then you can safely just remove all mention of $(GLOBEXE) from win32/Makefile and setargv.obj won't be required anyway. =back Perl should now build using the win32/Makefile. You will need to edit that file to set CCTYPE = MSVC70FREE and to set CCHOME, CCINCDIR and CCLIBDIR as per the environment setup above. =item Microsoft Platform SDK 64-bit Compiler The nmake that comes with the Platform SDK will suffice for building Perl. Make sure you are building within one of the "Build Environment" shells available after you install the Platform SDK from the Start Menu. =item MinGW release 3 with gcc The latest release of MinGW at the time of writing is 3.1.0, which contains gcc-3.2.3. It can be downloaded here: http://www.mingw.org/ Perl also compiles with earlier releases of gcc (2.95.2 and up). See below for notes about using earlier versions of MinGW/gcc. And perl also compiles with gcc-4.3.0 and up, and perhaps even some of the earlier 4.x.x versions. You also need dmake. See L above on how to get it. =item MinGW release 1 with gcc The MinGW-1.1 bundle contains gcc-2.95.3. Make sure you install the binaries that work with MSVCRT.DLL as indicated in the README for the GCC bundle. You may need to set up a few environment variables (usually ran from a batch file). There are a couple of problems with the version of gcc-2.95.2-msvcrt.exe released 7 November 1999: =over =item * It left out a fix for certain command line quotes. To fix this, be sure to download and install the file fixes/quote-fix-msvcrt.exe from the above ftp location. =item * The definition of the fpos_t type in stdio.h may be wrong. If your stdio.h has this problem, you will see an exception when running the test t/lib/io_xs.t. To fix this, change the typedef for fpos_t from "long" to "long long" in the file i386-mingw32msvc/include/stdio.h, and rebuild. =back A potentially simpler to install (but probably soon-to-be-outdated) bundle of the above package with the mentioned fixes already applied is available here: http://downloads.ActiveState.com/pub/staff/gsar/gcc-2.95.2-msvcrt.zip ftp://ftp.ActiveState.com/pub/staff/gsar/gcc-2.95.2-msvcrt.zip =back =head2 Building =over 4 =item * Make sure you are in the "win32" subdirectory under the perl toplevel. This directory contains a "Makefile" that will work with versions of nmake that come with Visual C++ or the Platform SDK, and a dmake "makefile.mk" that will work for all supported compilers. The defaults in the dmake makefile are setup to build using MinGW/gcc. =item * Edit the makefile.mk (or Makefile, if you're using nmake) and change the values of INST_DRV and INST_TOP. You can also enable various build flags. These are explained in the makefiles. Note that it is generally not a good idea to try to build a perl with INST_DRV and INST_TOP set to a path that already exists from a previous build. In particular, this may cause problems with the lib/ExtUtils/t/Embed.t test, which attempts to build a test program and may end up building against the installed perl's lib/CORE directory rather than the one being tested. You will have to make sure that CCTYPE is set correctly and that CCHOME points to wherever you installed your compiler. If building with gcc-4.x.x, you'll also need to uncomment the assignment to GCC_4XX and uncomment the assignment to the appropriate GCCHELPERDLL in the makefile.mk. If building with the cross-compiler provided by mingw-w64.sourceforge.net you'll need to uncomment the line that sets GCCCROSS in the makefile.mk. Do this only if it's the cross-compiler - ie only if the bin folder doesn't contain a gcc.exe. (The cross-compiler does not provide a gcc.exe, g++.exe, ar.exe, etc. Instead, all of these executables are prefixed with 'x86_64-w64-mingw32-'.) The default value for CCHOME in the makefiles for Visual C++ may not be correct for some versions. Make sure the default exists and is valid. You may also need to comment out the C line in the Makefile if you're using VC++ 6.0 without the latest service pack and the linker reports an internal error. If you are using VC++ 4.2 or earlier then you'll have to change the /EHsc option in the CXX_FLAG macro to the equivalent /GX option. If you have either the source or a library that contains des_fcrypt(), enable the appropriate option in the makefile. A ready-to-use version of fcrypt.c, based on the version originally written by Eric Young at ftp://ftp.funet.fi/pub/crypt/mirrors/dsi/libdes/, is bundled with the distribution and CRYPT_SRC is set to use it. Alternatively, if you have built a library that contains des_fcrypt(), you can set CRYPT_LIB to point to the library name. Perl will also build without des_fcrypt(), but the crypt() builtin will fail at run time. If you want build some core extensions statically into perl's dll, specify them in the STATIC_EXT macro. Be sure to read the instructions near the top of the makefiles carefully. =item * Type "dmake" (or "nmake" if you are using that make). This should build everything. Specifically, it will create perl.exe, perl512.dll at the perl toplevel, and various other extension dll's under the lib\auto directory. If the build fails for any reason, make sure you have done the previous steps correctly. =back =head2 Testing Perl on Win32 Type "dmake test" (or "nmake test"). This will run most of the tests from the testsuite (many tests will be skipped). There should be no test failures when running under Windows NT/2000/XP. Many tests I fail under Windows 9x due to the inferior command shell. Some test failures may occur if you use a command shell other than the native "cmd.exe", or if you are building from a path that contains spaces. So don't do that. If you are running the tests from a emacs shell window, you may see failures in op/stat.t. Run "dmake test-notty" in that case. If you're using the Borland compiler, you may see a failure in op/taint.t arising from the inability to find the Borland Runtime DLLs on the system default path. You will need to copy the DLLs reported by the messages from where Borland chose to install it, into the Windows system directory (usually somewhere like C:\WINNT\SYSTEM32) and rerun the test. If you're using Borland compiler versions 5.2 and below, you may run into problems finding the correct header files when building extensions. For example, building the "Tk" extension may fail because both perl and Tk contain a header file called "patchlevel.h". The latest Borland compiler (v5.5) is free of this misbehaviour, and it even supports an option -VI- for backward (bugward) compatibility for using the old Borland search algorithm to locate header files. If you run the tests on a FAT partition, you may see some failures for C related tests (I, I ...). Testing on NTFS avoids these errors. Furthermore, you should make sure that during C you do not have any GNU tool packages in your path: some toolkits like Unixutils include some tools (C for instance) which override the Windows ones and makes tests fail. Remove them from your path while testing to avoid these errors. Please report any other failures as described under L. =head2 Installation of Perl on Win32 Type "dmake install" (or "nmake install"). This will put the newly built perl and the libraries under whatever C points to in the Makefile. It will also install the pod documentation under C<$INST_TOP\$INST_VER\lib\pod> and HTML versions of the same under C<$INST_TOP\$INST_VER\lib\pod\html>. To use the Perl you just installed you will need to add a new entry to your PATH environment variable: C<$INST_TOP\bin>, e.g. set PATH=c:\perl\bin;%PATH% If you opted to uncomment C and C in the makefile then the installation structure is a little more complicated and you will need to add two new PATH components instead: C<$INST_TOP\$INST_VER\bin> and C<$INST_TOP\$INST_VER\bin\$ARCHNAME>, e.g. set PATH=c:\perl\5.6.0\bin;c:\perl\5.6.0\bin\MSWin32-x86;%PATH% =head2 Usage Hints for Perl on Win32 =over 4 =item Environment Variables The installation paths that you set during the build get compiled into perl, so you don't have to do anything additional to start using that perl (except add its location to your PATH variable). If you put extensions in unusual places, you can set PERL5LIB to a list of paths separated by semicolons where you want perl to look for libraries. Look for descriptions of other environment variables you can set in L. You can also control the shell that perl uses to run system() and backtick commands via PERL5SHELL. See L. Perl does not depend on the registry, but it can look up certain default values if you choose to put them there. Perl attempts to read entries from C and C. Entries in the former override entries in the latter. One or more of the following entries (of type REG_SZ or REG_EXPAND_SZ) may be set: lib-$] version-specific standard library path to add to @INC lib standard library path to add to @INC sitelib-$] version-specific site library path to add to @INC sitelib site library path to add to @INC vendorlib-$] version-specific vendor library path to add to @INC vendorlib vendor library path to add to @INC PERL* fallback for all %ENV lookups that begin with "PERL" Note the C<$]> in the above is not literal. Substitute whatever version of perl you want to honor that entry, e.g. C<5.6.0>. Paths must be separated with semicolons, as usual on win32. =item File Globbing By default, perl handles file globbing using the File::Glob extension, which provides portable globbing. If you want perl to use globbing that emulates the quirks of DOS filename conventions, you might want to consider using File::DosGlob to override the internal glob() implementation. See L for details. =item Using perl from the command line If you are accustomed to using perl from various command-line shells found in UNIX environments, you will be less than pleased with what Windows offers by way of a command shell. The crucial thing to understand about the Windows environment is that the command line you type in is processed twice before Perl sees it. First, your command shell (usually CMD.EXE on Windows NT, and COMMAND.COM on Windows 9x) preprocesses the command line, to handle redirection, environment variable expansion, and location of the executable to run. Then, the perl executable splits the remaining command line into individual arguments, using the C runtime library upon which Perl was built. It is particularly important to note that neither the shell nor the C runtime do any wildcard expansions of command-line arguments (so wildcards need not be quoted). Also, the quoting behaviours of the shell and the C runtime are rudimentary at best (and may, if you are using a non-standard shell, be inconsistent). The only (useful) quote character is the double quote ("). It can be used to protect spaces and other special characters in arguments. The Windows NT documentation has almost no description of how the quoting rules are implemented, but here are some general observations based on experiments: The C runtime breaks arguments at spaces and passes them to programs in argc/argv. Double quotes can be used to prevent arguments with spaces in them from being split up. You can put a double quote in an argument by escaping it with a backslash and enclosing the whole argument within double quotes. The backslash and the pair of double quotes surrounding the argument will be stripped by the C runtime. The file redirection characters "E", "E", and "|" can be quoted by double quotes (although there are suggestions that this may not always be true). Single quotes are not treated as quotes by the shell or the C runtime, they don't get stripped by the shell (just to make this type of quoting completely useless). The caret "^" has also been observed to behave as a quoting character, but this appears to be a shell feature, and the caret is not stripped from the command line, so Perl still sees it (and the C runtime phase does not treat the caret as a quote character). Here are some examples of usage of the "cmd" shell: This prints two doublequotes: perl -e "print '\"\"' " This does the same: perl -e "print \"\\\"\\\"\" " This prints "bar" and writes "foo" to the file "blurch": perl -e "print 'foo'; print STDERR 'bar'" > blurch This prints "foo" ("bar" disappears into nowhereland): perl -e "print 'foo'; print STDERR 'bar'" 2> nul This prints "bar" and writes "foo" into the file "blurch": perl -e "print 'foo'; print STDERR 'bar'" 1> blurch This pipes "foo" to the "less" pager and prints "bar" on the console: perl -e "print 'foo'; print STDERR 'bar'" | less This pipes "foo\nbar\n" to the less pager: perl -le "print 'foo'; print STDERR 'bar'" 2>&1 | less This pipes "foo" to the pager and writes "bar" in the file "blurch": perl -e "print 'foo'; print STDERR 'bar'" 2> blurch | less Discovering the usefulness of the "command.com" shell on Windows 9x is left as an exercise to the reader :) One particularly pernicious problem with the 4NT command shell for Windows NT is that it (nearly) always treats a % character as indicating that environment variable expansion is needed. Under this shell, it is therefore important to always double any % characters which you want Perl to see (for example, for hash variables), even when they are quoted. =item Building Extensions The Comprehensive Perl Archive Network (CPAN) offers a wealth of extensions, some of which require a C compiler to build. Look in http://www.cpan.org/ for more information on CPAN. Note that not all of the extensions available from CPAN may work in the Win32 environment; you should check the information at http://testers.cpan.org/ before investing too much effort into porting modules that don't readily build. Most extensions (whether they require a C compiler or not) can be built, tested and installed with the standard mantra: perl Makefile.PL $MAKE $MAKE test $MAKE install where $MAKE is whatever 'make' program you have configured perl to use. Use "perl -V:make" to find out what this is. Some extensions may not provide a testsuite (so "$MAKE test" may not do anything or fail), but most serious ones do. It is important that you use a supported 'make' program, and ensure Config.pm knows about it. If you don't have nmake, you can either get dmake from the location mentioned earlier or get an old version of nmake reportedly available from: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/nmake15.exe Another option is to use the make written in Perl, available from CPAN. http://www.cpan.org/modules/by-module/Make/ You may also use dmake. See L above on how to get it. Note that MakeMaker actually emits makefiles with different syntax depending on what 'make' it thinks you are using. Therefore, it is important that one of the following values appears in Config.pm: make='nmake' # MakeMaker emits nmake syntax make='dmake' # MakeMaker emits dmake syntax any other value # MakeMaker emits generic make syntax (e.g GNU make, or Perl make) If the value doesn't match the 'make' program you want to use, edit Config.pm to fix it. If a module implements XSUBs, you will need one of the supported C compilers. You must make sure you have set up the environment for the compiler for command-line compilation. If a module does not build for some reason, look carefully for why it failed, and report problems to the module author. If it looks like the extension building support is at fault, report that with full details of how the build failed using the perlbug utility. =item Command-line Wildcard Expansion The default command shells on DOS descendant operating systems (such as they are) usually do not expand wildcard arguments supplied to programs. They consider it the application's job to handle that. This is commonly achieved by linking the application (in our case, perl) with startup code that the C runtime libraries usually provide. However, doing that results in incompatible perl versions (since the behavior of the argv expansion code differs depending on the compiler, and it is even buggy on some compilers). Besides, it may be a source of frustration if you use such a perl binary with an alternate shell that *does* expand wildcards. Instead, the following solution works rather well. The nice things about it are 1) you can start using it right away; 2) it is more powerful, because it will do the right thing with a pattern like */*/*.c; 3) you can decide whether you do/don't want to use it; and 4) you can extend the method to add any customizations (or even entirely different kinds of wildcard expansion). C:\> copy con c:\perl\lib\Wild.pm # Wild.pm - emulate shell @ARGV expansion on shells that don't use File::DosGlob; @ARGV = map { my @g = File::DosGlob::glob($_) if /[*?]/; @g ? @g : $_; } @ARGV; 1; ^Z C:\> set PERL5OPT=-MWild C:\> perl -le "for (@ARGV) { print }" */*/perl*.c p4view/perl/perl.c p4view/perl/perlio.c p4view/perl/perly.c perl5.005/win32/perlglob.c perl5.005/win32/perllib.c perl5.005/win32/perlglob.c perl5.005/win32/perllib.c perl5.005/win32/perlglob.c perl5.005/win32/perllib.c Note there are two distinct steps there: 1) You'll have to create Wild.pm and put it in your perl lib directory. 2) You'll need to set the PERL5OPT environment variable. If you want argv expansion to be the default, just set PERL5OPT in your default startup environment. If you are using the Visual C compiler, you can get the C runtime's command line wildcard expansion built into perl binary. The resulting binary will always expand unquoted command lines, which may not be what you want if you use a shell that does that for you. The expansion done is also somewhat less powerful than the approach suggested above. =item Win32 Specific Extensions A number of extensions specific to the Win32 platform are available from CPAN. You may find that many of these extensions are meant to be used under the Activeware port of Perl, which used to be the only native port for the Win32 platform. Since the Activeware port does not have adequate support for Perl's extension building tools, these extensions typically do not support those tools either and, therefore, cannot be built using the generic steps shown in the previous section. To ensure smooth transitioning of existing code that uses the ActiveState port, there is a bundle of Win32 extensions that contains all of the ActiveState extensions and several other Win32 extensions from CPAN in source form, along with many added bugfixes, and with MakeMaker support. The latest version of this bundle is available at: http://search.cpan.org/dist/libwin32/ See the README in that distribution for building and installation instructions. =item Notes on 64-bit Windows Windows .NET Server supports the LLP64 data model on the Intel Itanium architecture. The LLP64 data model is different from the LP64 data model that is the norm on 64-bit Unix platforms. In the former, C and C are both 32-bit data types, while pointers are 64 bits wide. In addition, there is a separate 64-bit wide integral type, C<__int64>. In contrast, the LP64 data model that is pervasive on Unix platforms provides C as the 32-bit type, while both the C type and pointers are of 64-bit precision. Note that both models provide for 64-bits of addressability. 64-bit Windows running on Itanium is capable of running 32-bit x86 binaries transparently. This means that you could use a 32-bit build of Perl on a 64-bit system. Given this, why would one want to build a 64-bit build of Perl? Here are some reasons why you would bother: =over =item * A 64-bit native application will run much more efficiently on Itanium hardware. =item * There is no 2GB limit on process size. =item * Perl automatically provides large file support when built under 64-bit Windows. =item * Embedding Perl inside a 64-bit application. =back =back =head2 Running Perl Scripts Perl scripts on UNIX use the "#!" (a.k.a "shebang") line to indicate to the OS that it should execute the file using perl. Win32 has no comparable means to indicate arbitrary files are executables. Instead, all available methods to execute plain text files on Win32 rely on the file "extension". There are three methods to use this to execute perl scripts: =over 8 =item 1 There is a facility called "file extension associations" that will work in Windows NT 4.0. This can be manipulated via the two commands "assoc" and "ftype" that come standard with Windows NT 4.0. Type "ftype /?" for a complete example of how to set this up for perl scripts (Say what? You thought Windows NT wasn't perl-ready? :). =item 2 Since file associations don't work everywhere, and there are reportedly bugs with file associations where it does work, the old method of wrapping the perl script to make it look like a regular batch file to the OS, may be used. The install process makes available the "pl2bat.bat" script which can be used to wrap perl scripts into batch files. For example: pl2bat foo.pl will create the file "FOO.BAT". Note "pl2bat" strips any .pl suffix and adds a .bat suffix to the generated file. If you use the 4DOS/NT or similar command shell, note that "pl2bat" uses the "%*" variable in the generated batch file to refer to all the command line arguments, so you may need to make sure that construct works in batch files. As of this writing, 4DOS/NT users will need a "ParameterChar = *" statement in their 4NT.INI file or will need to execute "setdos /p*" in the 4DOS/NT startup file to enable this to work. =item 3 Using "pl2bat" has a few problems: the file name gets changed, so scripts that rely on C<$0> to find what they must do may not run properly; running "pl2bat" replicates the contents of the original script, and so this process can be maintenance intensive if the originals get updated often. A different approach that avoids both problems is possible. A script called "runperl.bat" is available that can be copied to any filename (along with the .bat suffix). For example, if you call it "foo.bat", it will run the file "foo" when it is executed. Since you can run batch files on Win32 platforms simply by typing the name (without the extension), this effectively runs the file "foo", when you type either "foo" or "foo.bat". With this method, "foo.bat" can even be in a different location than the file "foo", as long as "foo" is available somewhere on the PATH. If your scripts are on a filesystem that allows symbolic links, you can even avoid copying "runperl.bat". Here's a diversion: copy "runperl.bat" to "runperl", and type "runperl". Explain the observed behavior, or lack thereof. :) Hint: .gnidnats llits er'uoy fi ,"lrepnur" eteled :tniH =back =head2 Miscellaneous Things A full set of HTML documentation is installed, so you should be able to use it if you have a web browser installed on your system. C is also a useful tool for browsing information contained in the documentation, especially in conjunction with a pager like C (recent versions of which have Win32 support). You may have to set the PAGER environment variable to use a specific pager. "perldoc -f foo" will print information about the perl operator "foo". One common mistake when using this port with a GUI library like C is assuming that Perl's normal behavior of opening a command-line window will go away. This isn't the case. If you want to start a copy of C without opening a command-line window, use the C executable built during the installation process. Usage is exactly the same as normal C on Win32, except that options like C<-h> don't work (since they need a command-line window to print to). If you find bugs in perl, you can run C to create a bug report (you may have to send it manually if C cannot find a mailer on your system). =head1 BUGS AND CAVEATS Norton AntiVirus interferes with the build process, particularly if set to "AutoProtect, All Files, when Opened". Unlike large applications the perl build process opens and modifies a lot of files. Having the the AntiVirus scan each and every one slows build the process significantly. Worse, with PERLIO=stdio the build process fails with peculiar messages as the virus checker interacts badly with miniperl.exe writing configure files (it seems to either catch file part written and treat it as suspicious, or virus checker may have it "locked" in a way which inhibits miniperl updating it). The build does complete with set PERLIO=perlio but that may be just luck. Other AntiVirus software may have similar issues. Some of the built-in functions do not act exactly as documented in L, and a few are not implemented at all. To avoid surprises, particularly if you have had prior exposure to Perl in other operating environments or if you intend to write code that will be portable to other environments, see L for a reasonably definitive list of these differences. Not all extensions available from CPAN may build or work properly in the Win32 environment. See L. Most C related calls are supported, but they may not behave as on Unix platforms. See L for the full list. Perl requires Winsock2 to be installed on the system. If you're running Win95, you can download Winsock upgrade from here: http://www.microsoft.com/windows95/downloads/contents/WUAdminTools/S_WUNetworkingTools/W95Sockets2/Default.asp Later OS versions already include Winsock2 support. Signal handling may not behave as on Unix platforms (where it doesn't exactly "behave", either :). For instance, calling C or C from signal handlers will cause an exception, since most implementations of C on Win32 are severely crippled. Thus, signals may work only for simple things like setting a flag variable in the handler. Using signals under this port should currently be considered unsupported. Please send detailed descriptions of any problems and solutions that you may find to EFE, along with the output produced by C. =head1 ACKNOWLEDGEMENTS The use of a camel with the topic of Perl is a trademark of O'Reilly and Associates, Inc. Used with permission. =head1 AUTHORS =over 4 =item Gary Ng E71564.1743@CompuServe.COME =item Gurusamy Sarathy Egsar@activestate.comE =item Nick Ing-Simmons Enick@ing-simmons.netE =item Jan Dubois Ejand@activestate.comE =item Steve Hay Esteve.hay@uk.radan.comE =back This document is maintained by Jan Dubois. =head1 SEE ALSO L =head1 HISTORY This port was originally contributed by Gary Ng around 5.003_24, and borrowed from the Hip Communications port that was available at the time. Various people have made numerous and sundry hacks since then. Borland support was added in 5.004_01 (Gurusamy Sarathy). GCC/mingw32 support was added in 5.005 (Nick Ing-Simmons). Support for PERL_OBJECT was added in 5.005 (ActiveState Tool Corp). Support for fork() emulation was added in 5.6 (ActiveState Tool Corp). Win9x support was added in 5.6 (Benjamin Stuhl). Support for 64-bit Windows added in 5.8 (ActiveState Corp). Last updated: 29 August 2007 =cut perl-5.12.0-RC0/configure.com0000444000175000017500000064376611325127001014624 0ustar jessejesse$! OpenVMS configuration procedure for Perl -- do not attempt to run under DOS $ sav_ver = 'F$VERIFY(0)' $ on control_y then goto clean_up $! SET VERIFY $! $! For example, if you unpacked perl into: [USER.PERL-5n...] then you will $! want to cd into the tree and execute Configure: $! $! $ SET DEFAULT [USER.PERL5_xxx] $! $ @Configure $! $! or $! $! $ SET DEFAULT [USER.PERL5_xxx] $! $ @Configure "-des" $! $! That's it. If you get into a bind trying to build perl on VMS then $! definitely read through the README.VMS file. $! Beyond that send email to vmsperl@perl.org $! $! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ $! $! send suggestions to: $! Dan Sugalski $! Thank you!!!! $! $! Adapted and converted from Larry Wall & Andy Dougherty's $! "Configure generated by metaconfig 3.0 PL60." by Peter Prymmer $! (a Bourne sh[ell] script for configuring the installation of perl $! on non-VMS systems) in the perl5.002|3 epoch (spring/summer 1996) $! with much valuable help from Charles Bailey & $! the whole VMSPerl crew. $! Extended and messed about with by Dan Sugalski $! $! VMS-isms we will need: $ echo = "write sys$output " $ cat = "type" $ delete := delete ! local symbol overrides globals with qualifiers $ gcc_symbol = "gcc" $ ld = "Link/nodebug" $ ans = "" $ macros = "" $ extra_flags = "" $ user_c_flags = "" $ use_ieee_math = "y" $ be_case_sensitive = "n" $ unlink_all_versions = "n" $ builder = "MMK" $ use_vmsdebug_perl = "n" $ use64bitall = "n" $ use64bitint = "n" $ uselongdouble = "n" $ uselargefiles = "y" $ usestdstat = "n" $ usesitecustomize = "n" $ C_Compiler_Replace = "CC=" $ thread_upcalls = "MTU=" $ thread_kernel = "MTK=" $ use_two_pot_malloc = "N" $ use_pack_malloc = "N" $ use_debugmalloc = "N" $ ccflags = "" $ static_ext = "" $ dynamic_ext = "" $ nonxs_ext = "" $ vms_default_directory_name = F$ENVIRONMENT("DEFAULT") $ max_allowed_dir_depth = 3 ! e.g. [A.B.PERLxxx] not [A.B.C.PERLxxx] $! max_allowed_dir_depth = 2 ! e.g. [A.PERLxxx] not [A.B.PERLxxx] $! $! Sebastian Bazley's request: close the CONFIG handle with /NOLOG $! qualifier "just in case" (configure.com is re @ed in a bad state). $! This construct was tested to be not a problem as far back as $! VMS V5.5-2, hopefully earlier versions are OK as well. $! $ CLOSE/NOLOG CONFIG $! $! Now keep track of open files $! $ vms_filcnt = F$GETJPI ("","FILCNT") $! $!: compute my invocation name $ me = F$ENVIRONMENT("PROCEDURE") $! $! Many null statements (begin with colon ':') in the Bourne shell version of $! this script serve as comments/placeholders. I have retained some of the ones $! that will help you compare this .COM file to the sh version - as well as $! leave placeholders for future improvements to this .COM file. $! sfn = VMS "skipped for now" $! $!: Proper PATH separator !sfn $!: Proper PATH setting !sfn $!: Sanity checks !sfn "Say '@''$me''" $!: On HP-UX, large Configure scripts may exercise a bug in /bin/sh !sfn $!: Configure runs within the UU subdirectory !->after find MANIFEST $! $!: We must find out about Eunice early !(?) $!: list of known cpp symbols, sorted alphabetically !sfn $! al = al + "..." $!: default library list !sfn $! $!: Extra object files, if any, needed on this platform. !sfn $!: Possible local include directories to search. !sfn $!: Set locincpth to "" in a hint file to defeat local include searches. !sfn $!locincpth="/usr/local/include /opt/local/include /usr/gnu/include" !sfn $!locincpth="$locincpth /opt/gnu/include /usr/GNU/include /opt/GNU/include" $!: no include file wanted by default !sfn $!inclwanted='' !sfn $!: Possible local library directories to search. !sfn $!loclibpth="/usr/local/lib /opt/local/lib /usr/gnu/lib" !sfn $!loclibpth="$loclibpth /opt/gnu/lib /usr/GNU/lib /opt/GNU/lib" !sfn $!: general looking path for locating libraries !sfn $!glibpth="/lib/pa1.1 /usr/shlib /usr/lib/large /lib /usr/lib" !sfn $!glibpth="$glibpth $xlibpth /lib/large /usr/lib/small /lib/small" !sfn $!glibpth="$glibpth /usr/ccs/lib /usr/ucblib /usr/shlib" !sfn $!: Private path used by Configure to find libraries. Its value !sfn $!: is prepended to libpth. This variable takes care of special !sfn $!: machines, like the mips. Usually, it should be empty. !sfn $!plibpth='' !sfn $!: full support for void wanted by default !sfn $!defvoidused=15 !sfn $!: List of libraries we want. !sfn $!libswanted='net socket inet nsl nm ndbm gdbm dbm db malloc dl' !sfn $!libswanted="$libswanted dld ld sun m c cposix posix ndir dir crypt" !sfn $!libswanted="$libswanted ucb bsd BSD PW x" !sfn $!: We probably want to search /usr/shlib before most other libraries. !sfn $!: This is only used by the lib/ExtUtils/MakeMaker.pm routine extliblist. !sfn $!glibpth=`echo " $glibpth " | sed -e 's! /usr/shlib ! !'` !sfn $!glibpth="/usr/shlib $glibpth" !sfn $!: Do not use vfork unless overridden by a hint file. !sfn $!usevfork=false !sfn $!: script used to extract .SH files with variable substitutions !sfn $!: produce awk script to parse command line options !sfn $!sfn (assume no sed awk) see below $!: process the command line options $! $!: set up default values $ fastread="" $ reuseval="false" $ maniskip = "false" $ IF F$TYPE(config_sh) .EQS. "" THEN config_sh="" $ alldone="" $ error="" $ silent="" $ extractsh="" $ override="" $ knowitall="" $ ccname="VAX" $ Dec_C_Version = "" $ cxxversion = "" $ use_threads = "F" $ use_5005_threads = "N" $ use_ithreads = "N" $! $!: option parsing $ config_args = "" $ IF (P1 .NES. "") $ THEN !one or more switches was thrown $ i = 1 $ bang = 0 $Param_loop: $ IF (P'i'.NES."") $ THEN $ bang = bang + 1 $ config_args = config_args + F$FAO(" !AS",P'i') $ ENDIF $ i = i + 1 $ IF (i.LT.9) THEN GOTO Param_loop !DCL allows P1..P8 $! $ i = 1 $Opt_loop: $ IF (F$EXTRACT(0,1,P'i') .EQS. "-") THEN P'i' = P'i' - "-" $ IF (F$EXTRACT(0,1,P'i') .EQS. "/") THEN P'i' = P'i' - "/" $Remove_quotation_mark: $ P'i' = P'i' - """" $ IF F$LOCATE("""",P'i') .LT. F$LENGTH(P'i') THEN GOTO Remove_quotation_mark $ gotopt = "f" !"alse" $ gotshortopt = "f" !"alse" $ IF (F$EXTRACT(0,1,P'i') .EQS. "d") $ THEN $ fastread = "yes" $ gotopt = "t" !"rue" $ P'i' = P'i' - "d" $ gotshortopt = "t" !"rue" $ ENDIF $ IF (F$EXTRACT(0,1,P'i') .EQS. "e") $ THEN $ alldone = "cont" $ gotopt = "t" $ P'i' = P'i' - "e" $ gotshortopt = "t" $ ENDIF $ IF (F$EXTRACT(0,1,P'i') .EQS. "f") ! "-f" $ THEN $ P'i' = P'i' - "f" $ config_sh = P'i' $ IF (F$SEARCH(config_sh).NES."") $ THEN $ test_config_sh = F$FILE_ATTRIBUTES(config_sh,"PRO") $ IF (F$LOCATE("R",test_config_sh).NE.F$LENGTH(test_config_sh)) $ THEN $ config_dflt = "y" $ CONTINUE !at this point check UIC && if test allows... $ !to be continued ? $ ELSE $ echo "''me': cannot read config file ''config_sh'." $ error="true" $ ENDIF $ ELSE $ echo "''me': cannot read config file ''config_sh'." $ error="true" $ ENDIF $ gotopt = "t" $ ENDIF $ IF (F$EXTRACT(0,1,P'i') .EQS. "h") ! "-h" $ THEN $ error = "true" $ gotopt = "t" $ P'i' = P'i' - "h" $ gotshortopt = "t" $ ENDIF $ IF (F$EXTRACT(0,1,P'i') .EQS. "m") ! "-m" $ THEN $ maniskip = "true" $ gotopt = "t" $ P'i' = P'i' - "m" $ gotshortopt = "t" $ ENDIF $ IF (F$EXTRACT(0,1,P'i') .EQS. "r") ! "-r" $ THEN $ reuseval = "true" $ gotopt = "t" $ P'i' = P'i' - "r" $ gotshortopt = "t" $ ENDIF $ IF (F$EXTRACT(0,1,P'i') .EQS. "s") ! "-s" $ THEN $ silent = "true" $ gotopt = "t" $ P'i' = P'i' - "s" $ gotshortopt = "t" $ ENDIF $ IF (F$EXTRACT(0,1,P'i') .EQS. "E") ! "-E" $ THEN $ alldone = "exit" $ gotopt = "t" $ ENDIF $ IF (F$EXTRACT(0,1,P'i') .EQS. "K") ! "-K" $ THEN $ knowitall = "true" $ gotopt = "t" $ P'i' = P'i' - "K" $ gotshortopt = "t" $ ENDIF $ IF (F$EXTRACT(0,1,P'i') .EQS. "O") ! "-O" $ THEN $ override = "true" $ gotopt = "t" $ P'i' = P'i' - "O" $ gotshortopt = "t" $ ENDIF $ IF (F$EXTRACT(0,1,P'i') .EQS. "S") ! "-S" $ THEN $ extractsh = "true" !VMS? Yes with munchconfig $ gotopt = "t" $ P'i' = P'i' - "S" $ gotshortopt = "t" $ ENDIF $ IF (F$EXTRACT(0,1,P'i') .EQS. "D") ! "-D" $ THEN $ P'i' = P'i' - "D" $ IF (F$LOCATE("=",P'i') .EQ. F$LENGTH(P'i')) $ THEN $ tmp = P'i' + "=""define""" $ 'tmp' $ DELETE/SYMBOL tmp $ ELSE $ IF (F$LOCATE("=",P'i') .EQ. (F$LENGTH(P'i') - 1)) $ THEN $ me = F$PARSE(me,,,"NAME") + F$PARSE(me,,,"TYPE") $ echo "''me': use ""-Usymbol=val"" not ""-Dsymbol=""." $ echo "''me': ignoring -D",P'i' $ ELSE $ tmp = F$EXTRACT(0,F$LOCATE("=",P'i'),P'i') $ tmp = tmp + "=""" + F$EXTRACT(F$LOCATE("=",P'i')+1,F$LENGTH(P'i'),P'i') + """" $ 'tmp' $ DELETE/SYMBOL tmp $ ENDIF $ ENDIF $ gotopt = "t" $ ENDIF $ IF (F$EXTRACT(0,1,P'i') .EQS. "U") ! "-U" $ THEN $ P'i' = P'i' - "U" $ IF (F$LOCATE("=",P'i') .EQ. F$LENGTH(P'i')) $ THEN $ tmp = P'i' + "=""""" $ 'tmp' $ DELETE/SYMBOL tmp $ ELSE $ IF (F$LOCATE("=",P'i') .LT. (F$LENGTH(P'i') - 1)) $ THEN $ me = F$PARSE(me,,,"NAME") + F$PARSE(me,,,"TYPE") $ echo "''me': use ""-Dsymbol=val"" not ""-Usymbol=val""." $ echo "''me': ignoring -U",P'i' $ ELSE $ tmp = P'i' + "=""undef""" $ 'tmp' $ DELETE/SYMBOL tmp $ ENDIF $ ENDIF $ gotopt = "t" $ ENDIF $ IF (F$EXTRACT(0,1,P'i') .EQS. "V") $ THEN $ me = F$PARSE(me,,,"NAME") + F$PARSE(me,,,"TYPE") $ echo "''me' generated by an unknown version of EDT." $ STOP $ EXIT $ ENDIF $ IF .NOT.gotopt $ THEN $ echo "''me': unknown option ",P'i' $ error = "true" $ ENDIF $ IF (F$LENGTH(P'i').GT.0).AND.(gotshortopt) THEN i = i - 1 !clustered switch $ i = i + 1 $ IF (i .LT. (bang + 1)) THEN GOTO Opt_loop $! $ ENDIF ! (P1 .NES. "") $ config_args = F$EDIT(config_args,"TRIM") $! $ IF (error) $ THEN $ me = F$PARSE(me,,,"DIRECTORY")+ F$PARSE(me,,,"NAME") $ echo "Usage: @''me' [-dehmr""EKOSV""] [-fconfig.sh] [""-Dsymbol""] [""-Dsymbol=value""]" $ echo " [-Usymbol] [-Usymbol=]" $ TYPE SYS$INPUT: $ DECK "-d" : use defaults for all answers. "-e" : go on without questioning past the production of config.sh. * "-f" : specify an alternate default configuration file. "-h" : print this help message and exit (with an error status). "-m" : skip the MANIFEST check to see that all files are present "-r" : reuse C symbols value if possible (skips costly nm extraction).* "-s" : silent mode, only echoes questions and essential information. -"D" : define symbol to have some value: * -"Dsymbol" symbol gets the value 'define' -"Dsymbol=value" symbol gets the value 'value' -E : stop at the end of questions, after having produced config.sh. * -K : do not use unless you know what you are doing. -O : let -D and -U override definitions from loaded configuration file. * -S : perform variable substitutions on all .SH files (can mix with -f) * -"U" : undefine symbol: * -"Usymbol" symbol gets the value 'undef' -"Usymbol=" symbol gets completely empty -V : print version number and exit (with a zero status). $ EOD $ echo "%Config-I-VMS, lower case switches must be enclosed" $ echo "-Config-I-VMS, in double quotation marks, e.g.:" $ echo "-Config-I-VMS, @Configure ""-des""" $ echo "-Config-I-VMS, * indicates switch may not be fully implemented for VMS." $ SET DEFAULT 'vms_default_directory_name' !be kind rewind $ STOP $ EXIT 3 ! $STATUS = "%X00000003" (informational) $ ENDIF $! $ GOTO Check_silence $! $Shut_up: $ IF F$Mode() .eqs. "BATCH" $ THEN $ x = F$GETQUI("CANCEL_OPERATION") ! clear the deck $ x = "THIS_JOB" $ bproc_queue = f$getqui("DISPLAY_QUEUE","QUEUE_NAME","*",x) $ bproc_entry = f$getqui("DISPLAY_JOB","ENTRY_NUMBER",,x) $ bproc_name = f$getqui("DISPLAY_JOB","JOB_NAME",,x) $ bproc_log_spec = f$getqui("DISPLAY_JOB","LOG_SPECIFICATION",,x) $ STDOUT = F$PARSE(bproc_name, bproc_log_spec, ".LOG") $ WRITE SYS$OUTPUT "Writing output of entry ''bproc_entry' in queue ''bproc_queue' to a new version of: " $ WRITE SYS$OUTPUT STDOUT $ DELETE_/SYMBOL x $ DELETE_/SYMBOL bproc_queue $ DELETE_/SYMBOL bproc_entry $ DELETE_/SYMBOL bproc_name $ DELETE_/SYMBOL bproc_log_spec $ ELSE $ STDOUT = F$TRNLNM("SYS$OUTPUT") $ ENDIF $ DEFINE SYS$OUTPUT "_NLA0:" $ echo4 = "write STDOUT " $ cat4 = "TYPE/OUTPUT=''STDOUT'" $ open/write/share=read STDOUT 'STDOUT' $ RETURN $! $Check_silence: $ IF (silent) $ THEN $ GOSUB Shut_up $ ELSE $ echo4 = "write SYS$OUTPUT " $ cat4 = "TYPE" $ ENDIF $! $!: run the defines and the undefines, if any, but leave the file out there... $! Unfortunately Configure.COM in DCL is not yet set up to do this - $! maybe someday $! $!: set package name $ package = "perl5" $ packageup = F$EDIT((package - "5"),"UPCASE") $! $!: Eunice requires " " instead of "", can you believe it $ echo "" $!: Here we go... $ echo "Beginning of configuration questions for ''package'." $ echo "" $! $!: Some greps do not return status, grrr. $ contains = "SEARCH" $! $!: first determine how to suppress newline on echo command !cant DCL is record oriented $! echo "Checking ''echo' to see how to suppress newlines..." $! echo "giving up..." $! echo "The star should be here-->*" $! $!: Now test for existence of everything in MANIFEST $ echo "" $ echo4 "First let's make sure your kit is complete. Checking..." $ manifestfound = "" $ miss_list = "" $! Here I assume we are in the [foo.PERLxxx...] tree $! because the search routine simply does set def [-] if necessary. $ file_2_find = "MANIFEST" !I hope this one is not in [foo.PERL5xxx.VMS...] $Research_manifest: $ manifestfound = F$SEARCH(file_2_find) $ IF (manifestfound .EQS. "") $ THEN $ IF F$PARSE(F$ENVIRONMENT("DEFAULT"),,,"DIRECTORY",).NES."[000000]" $ THEN $ SET DEFAULT [-] $ GOTO Research_manifest $ ELSE $ echo "" $ echo "There is no MANIFEST file. I hope your kit is complete !" $ miss_list = "" $ GOTO Beyond_manifest $ ENDIF $ ELSE $! MANIFEST. has been found and we have set def'ed there. $! Time to bail out before it's too late, i.e. too deep. $! Depth check is unnecessary on Alpha VMS V7.2++ (even for ODS-2). $ tmp = f$extract(1,3,f$edit(f$getsyi("VERSION"),"TRIM,COLLAPSE")) $ IF (tmp .GES. "7.2") .AND. (F$GETSYI("HW_MODEL") .GE. 1024) THEN GOTO Beyond_depth_check $! Depth check also unnecessary on ODS 5 (or later) file systems. $ tmp = F$INTEGER(F$GETDVI(F$ENVIRONMENT("DEFAULT"),"ACPTYPE") - "F11V") $ IF (tmp .GE. 5) THEN GOTO Beyond_depth_check $ IF (F$ELEMENT(max_allowed_dir_depth,".",F$ENVIRONMENT("DEFAULT")).nes.".") $ THEN $ TYPE SYS$INPUT: $ DECK %Config-E-VMS, ERROR: Sorry! It apears as though your perl build sub-directory is already too deep into the VMS file system. Please try moving stuff into a shallower directory (or altering the "max_allowed_dir_depth" parameter). $ EOD $ echo4 "ABORTING..." $ SET DEFAULT 'vms_default_directory_name' !be kind rewind $ STOP $ EXIT !2 !$STATUS = "%X00000002" (error) $ ENDIF $Beyond_depth_check: $! $! after finding MANIFEST let's create (but not yet enter) the UU subdirectory $! $ IF (manifestfound .NES. "") $ THEN $ IF ( F$SEARCH("UU.DIR").EQS."" ) $ THEN $ CREATE/DIRECTORY [.UU] $ ELSE $ IF ( F$SEARCH("[.UU]*.*").NES."" ) THEN DELETE/NOLOG/NOCONFIRM [.UU]*.*;* $ ENDIF $!: Configure runs within the UU subdirectory $ SET DEFAULT [.UU] $! $! a little redundancy never hurt anybody? $ file_2_find = "[-]" + file_2_find $ manifestfound = F$SEARCH(file_2_find) $! $ OPEN/WRITE MISSING MISSING. $!change to "FALSE" if you wish to skip the manifest search $!(which after all is rather slow in DCL :-) $ IF (maniskip) $ THEN $ echo "Skipping MANIFEST check as requested" $ ELSE $! $ OPEN/READ CONFIG 'manifestfound' $Read_loop_manifest: $ READ/END_OF_FILE = Done_manifest CONFIG line $! This algorithm turns "foo/bar/baz.c" into "[.foo.bar]baz.c" $! pvhp@lns62.lns.cornell.edu 10-JUN-1996 20:31:46 $! 2-MAR-1998 15:46:11 Improved to turn "foo/bar/baz.c.buz" $! into "[.foo.bar]baz.c_buz as happens with vmstar and unzip $ line = F$EDIT(line,"TRIM, COMPRESS") $ file_2_find = F$EXTRACT(0,F$LOCATE(" ",line),line) $ IF F$LOCATE("/",file_2_find) .NE. F$LENGTH(file_2_find) $ THEN $Re_strip_line_manifest: $ loca = F$LOCATE("/",file_2_find) $ ante = F$EXTRACT(0,loca,file_2_find) $ post = F$EXTRACT(loca,F$LENGTH(file_2_find),file_2_find) $ test_this = ante + "." + (post - "/") $ IF F$LOCATE("/",test_this) .NE. F$LENGTH(test_this) $ THEN $ file_2_find = ante + "." + (post - "/") $ GOTO Re_strip_line_manifest $ ELSE $ file_2_find = ante + "]" + (post - "/") $ ENDIF $ file_2_find = "[-."+file_2_find $ ELSE $ file_2_find = "[-]" + file_2_find $ ENDIF $! $ tmp = F$PARSE(file_2_find + ";",,,,"SYNTAX_ONLY") $ IF F$SEARCH(tmp) .NES. "" THEN file_2_find = tmp $ dirname = F$EXTRACT(0,F$LOCATE("]",file_2_find),file_2_find) + "]" $ file_2_find = file_2_find - dirname $! $! may not need double dot check on ODS-5 volumes $ found = F$SEARCH(dirname + file_2_find) $ IF found .NES. "" THEN GOTO Read_loop_manifest $! $ dots = 0 $Dot_loop: $ dot_ele = F$ELEMENT(dots,".",file_2_find) $ IF dot_ele .EQS. "." THEN GOTO Eo_dot_loop $ IF dots .eq. 0 $ THEN basename = f$extract(0,f$locate(".",file_2_find),file_2_find) + "." $ ELSE basename = basename + dot_ele + "_" $ ENDIF $ dots = dots + 1 $ GOTO dot_loop $Eo_dot_loop: $ IF (((f$length(file_2_find)+1) .eq. f$length(basename)) .and. - (f$extract(f$length(basename)-1,1,basename) .eqs. "_")) THEN - basename = f$extract(0,f$length(basename)-1,basename) $ file_2_find = dirname + basename $! $ found = F$SEARCH(file_2_find) $ IF (found .EQS. "" .AND. dots .GT. 2) $ THEN $! 17-DEC-1999 Improved to turn "[.foo.bar]baz.c_buz" into $! "[.foo.bar]baz_c.buz" to cover unzipped archives and put $! "[.foo.bar]baz.c_buz,baz_c.buz" into missing list if neither is found. $ dotloc = f$locate(".",basename) $ basename[dotloc,1] := "_" $ dot_ele = F$ELEMENT(dots - 1,"_",f$extract(dotloc,f$length(basename),basename)) $ basename = - f$extract(0,f$length(basename)-(f$length(dot_ele)+1),basename) - + "." + dot_ele $ found = F$SEARCH(dirname + basename) $ file_2_find = file_2_find + "," + basename $ ENDIF $ tildeloc = f$locate("~",basename) $ IF (found .EQS. "" .AND. tildeloc .LT. f$length(basename)) $ THEN $ basename[tildeloc,1] := "_" $ found = F$SEARCH(dirname + basename) $ file_2_find = file_2_find + "," + basename $ ENDIF $ IF (found .EQS. "") $ THEN $ WRITE MISSING file_2_find $ IF ((F$LENGTH(miss_list)+F$LENGTH(file_2_find)).LT.250) $ THEN $ miss_list = miss_list + "," + file_2_find $ ENDIF $ ENDIF $ GOTO Read_loop_manifest $Done_manifest: $ CLOSE CONFIG $ ENDIF !"TRUE" $ CLOSE MISSING $ ENDIF ! (manifestfound .NES. "") $Beyond_manifest: $ IF (miss_list .NES. "") $ THEN $ echo "Some of the files not found include:" $ cat4 MISSING. $ ENDIF $ IF ((miss_list .NES. "").OR.(manifestfound .EQS. "")) $ THEN $ TYPE SYS$INPUT: $ DECK THIS PACKAGE SEEMS TO BE INCOMPLETE. You have the option of continuing the configuration process, despite the distinct possibility that your kit is damaged, by typing 'y'es. If you do, don't blame me if something goes wrong. I advise you to type 'n'o and contact the author (dan@sidhe.org) $ EOD $ READ SYS$COMMAND/PROMPT="Continue? [n] " ans $ IF ans $ THEN $ echo4 "Continuing..." $ ELSE $ echo4 "ABORTING..." $ GOTO Clean_up $ ENDIF $ ELSE $ echo4 "Looks good..." $ DELETE/NOLOG/NOCONFIRM MISSING.; $ ENDIF ! (miss_list .NES. "") $ ENDIF ! (manifestfound .EQS. "") ELSE $! $! after finding MANIFEST (see above) $!: Configure runs within the UU subdirectory $! $!: compute the number of columns on the terminal for proper question formatting $ IF F$MODE() .EQS. "BATCH" $! else it winds up being 512 in batch $ THEN COLUMNS = 80 $ ELSE COLUMNS = F$GETDVI("SYS$OUTPUT","DEVBUFSIZ") $ ENDIF $! "-des" sets SYS$OUTPUT to NL: with a DEVBUFSIZ too large (512 again) $ IF COLUMNS .GT. 210 THEN COLUMNS = 80 $! not sure if this would actually be needed - it hopefully will not hurt $ IF COLUMNS .LT. 40 THEN COLUMNS = 40 $! $!: set up the echo used in my read !sfn $!: now set up to do reads with possible shell escape and default assignment !sfn $ GOTO Beyond_myread $! $! The sub_rp splitting is intended to handle long symbols such as the dflt for $! extensions. $! $myread: $ ans = "" $ len_rp = F$LENGTH(rp) $ If (.NOT. silent) Then echo "" $ IF len_rp .GT. 210 $ THEN $ i_rp = 0 $ rp_loop: $ sub_rp = F$EXTRACT(i_rp,COLUMNS,rp) $ i_rp = i_rp + COLUMNS $ if i_rp .LT. len_rp THEN echo4 "''sub_rp'" $ IF i_rp .LT. len_rp THEN GOTO rp_loop $ ELSE $ sub_rp = rp $ ENDIF $ if (fastread) $ then $ echo4 "''sub_rp'" $ else $ READ SYS$COMMAND/PROMPT="''sub_rp'" ans $ endif $ IF (ans .EQS. "&-d") $ THEN $ echo4 "(OK, I will run with -d after this question.)" $ echo "" $ deferred_fastread =1 $ goto myread $ ENDIF $ IF (ans .EQS. "&-s") $ THEN $ echo4 "(OK, I will run with -s after this question.)" $ echo "" $ deferred_silent = 1 $ goto myread $ ENDIF $ if (bool_dflt .nes. "") $ then $ if (ans .eqs. "") then ans = bool_dflt $ ans = f$extract(0,1,f$edit(ans,"collapse,upcase")) $ if (ans .eqs. "Y" .or. ans .eqs. "1" .or. ans .eqs. "T") $ then $ ans = "Y" $ else $ if (ans .eqs. "N" .or. ans .eqs. "0" .or. ans .eqs. "F") $ then $ ans = "N" $ else $ echo4 "Input not understood please answer 'Yes' or 'No'" $ goto myread $ endif $ endif $ bool_dflt = "" $ else $ ans = f$edit(ans,"trim,compress") $ if (ans .eqs. "") then ans = dflt $ if (f$edit(ans,"upcase") .eqs. "NONE") then ans = "" $ endif $ if f$type(deferred_silent) .nes. "" $ then $ silent := true $ GOSUB Shut_up $ delete/symbol deferred_silent $ ENDIF $ if f$type(deferred_fastread) .nes. "" $ then $ fastread = 1 $ delete/symbol deferred_fastread $ endif $ RETURN $! $Beyond_myread: $! $!: create .config dir to save info across Configure sessions $ IF ( F$SEARCH("[-]CONFIG.DIR").EQS."" ) $ THEN $ CREATE/DIRECTORY [-.CONFIG] $ OPEN/WRITE CONFIG [-.CONFIG]README. $ WRITE CONFIG - "This directory created by Configure to save information that should" $ WRITE CONFIG - "persist across sessions." $ WRITE CONFIG "" $ WRITE CONFIG - "You may safely delete it if you wish." $ CLOSE CONFIG $ ENDIF $! $ IF F$TYPE(usedevel) .EQS. "" THEN usedevel := n $ patchlevel_h = F$SEARCH("[-]patchlevel.h") $ IF (patchlevel_h.NES."") $ THEN $ SEARCH 'patchlevel_h' "define","PERL_VERSION","epoch"/match=and/out=[]ver.out $ IF .NOT. usedevel .AND. usedevel .NES. "define" $ THEN $ OPEN/READ CONFIG []ver.out $ READ CONFIG line $ CLOSE CONFIG $ tmp = F$EDIT(line,"TRIM,COMPRESS") $ xpatchlevel = F$INTEGER(F$ELEMENT(2," ",tmp)) $ line = xpatchlevel / 2 $ tmp = xpatchlevel - ( line * 2 ) $ IF tmp .NE. 0 $ THEN $ echo4 "patchlevel is " + F$STRING(xpatchlevel) $ cat4 SYS$INPUT: $ DECK *** WHOA THERE!!! *** This is an UNSTABLE DEVELOPMENT release. (The patchlevel, is odd--as opposed to even, and that signifies a development release. If you want a maintenance release, you want an even-numbered release.) Do ***NOT*** install this into production use. Data corruption and crashes are possible. It is most seriously suggested that you do not continue any further unless you want to help in developing and debugging Perl. $ EOD $ bool_dflt="n" $ rp="Do you really want to continue? [''bool_dflt'] " $ fastread_save = fastread $ fastread := FALSE $ GOSUB myread $ fastread = fastread_save $ delete/symbol fastread_save $ IF ans $ THEN $ echo4 "Okay, continuing." $ ELSE $ echo4 "Okay, bye." $ DELETE/NOLOG/NOCONFIRM []ver.out; $ GOTO Clean_up $ ENDIF $ ENDIF $ DELETE/SYMBOL line $ DELETE/SYMBOL tmp $ ENDIF $ DELETE/NOLOG/NOCONFIRM []ver.out; $ ENDIF $!: general instructions $ needman = "true" $ firsttime = "true" $ user = F$EDIT(F$GETJPI("","USERNAME"),"TRIM,COLLAPSE") $ IF .NOT.(F$SEARCH("[-.CONFIG]INSTRUCT.").EQS."") $ THEN $ messages = F$ENVIRONMENT("MESSAGE") $ SET MESSAGE/NOFAC/NOSEV/NOIDENT/NOTEXT $ contains /NOOUTPUT [-.CONFIG]INSTRUCT. 'user' $ IF .NOT.($status.EQ.%X08D78053) $ THEN $ firsttime="" $ bool_dflt = "n" $ rp = "Would you like to see the instructions? [''bool_dflt'] " $ GOSUB myread $ if .NOT.ans THEN needman="" $ ENDIF $ SET MESSAGE 'messages' $ ENDIF $ if (fastread.AND.silent.AND.(alldone.eqs."cont")) THEN needman="" $! $ IF (needman) $ THEN $ TYPE SYS$INPUT: $ DECK This installation shell script will examine your system and ask you questions to determine how the perl5 package should be installed. If you get stuck on a question, you may use a ^C or ^Y shell escape to STOP this process, edit something, then restart this process as you just did. Many of the questions will have default answers in square brackets; typing carriage return will give you the default. $ EOD $ if (fastread) $ then $ echo4 "" $ else $ READ SYS$COMMAND/PROMPT="Type carriage return to continue " ans $ endif $ TYPE SYS$INPUT: $ DECK In a hurry? You may run '@Configure "-d"'. This will bypass nearly all the questions and use the computed defaults (or the previous answers provided there was already a config.sh file). Type '@Configure "-h"' for a list of options. $ EOD $ if (fastread) $ then $ echo4 "" $ else $ READ SYS$COMMAND/PROMPT="Type carriage return to continue " ans $ endif $ TYPE SYS$INPUT: $ DECK Much effort has been expended to ensure that this shell script will run on any VMS system. If despite that it blows up on yours, your best bet is to edit Configure.com and @ it again. Whatever problems you have with Configure.com, let me (dan@sidhe.org) know how I blew it. $ EOD $!This installation script affects things in two ways: $! $!1) it may do direct variable substitutions on some of the files included $! in this kit. $!2) it builds a config.h file for inclusion in C programs. You may edit $! any of these files as the need arises after running this script. $! $!If you make a mistake on a question, there is no easy way to back up to it $!currently. $! $ if (fastread) $ then $ echo4 "" $ else $ READ SYS$COMMAND/PROMPT="Type carriage return to continue " ans $ endif $ IF (F$SEARCH("[-.CONFIG]INSTRUCT.").EQS."") $ THEN $ OPEN/WRITE CONFIG [-.CONFIG]INSTRUCT. $ WRITE CONFIG user $ CLOSE CONFIG $ ENDIF $ ENDIF !(needman .EQS. "true") $! $!: see if sh knows # comments !sfn $!: figure out how to guarantee sh startup !sfn $!: find out where common programs are !sfn $!loclist="awk/cat/comm/cp/echo/expr/find/grep/ln/ls/mkdir/rm/sed/sort/touch/tr/uniq" $!trylist="byacc/cpp/csh/date/egrep/less/line/more/nroff/perl/pg/sendmail/test/uname" $! echo "I don't know where '$file' is, and my life depends on it." $! echo "Go find a public domain implementation or fix your PATH setting!" $! echo "" $! echo "Don't worry if any of the following aren't found..." $!: determine whether symbolic links are supported !sfn !jem- further down $!: see whether [:lower:] and [:upper:] are supported character classes !sfn $!: set up the translation script tr, must be called with ./tr of course !sfn $! $!: Try to determine whether config.sh was made on this system $!: Get old answers from old config file if Configure was run on the $!: same system, otherwise use the hints. $ config_sh_es = "''config_sh'/[-]config.sh/" $ i = 0 $ max = 3 $Config_sh_look: $ config_sh = F$ELEMENT(i,"/",config_sh_es) $ i = i + 1 $ IF (config_sh.NES."/").AND.(config_sh.NES."") $ THEN $ configshfound = F$SEARCH(config_sh) $ IF (configshfound.NES."") THEN GOTO Config_sh_found $ ENDIF $ IF (i.LT.max) THEN GOTO Config_sh_look $ osname = F$EDIT(F$GETSYI("NODE_SWTYPE"),"COLLAPSE") $ IF (configshfound.EQS."") $ THEN $ config_sh = "[-]config.sh" ! the fallback default $ GOTO Beyond_config_sh $ ENDIF $Config_sh_found: $ IF F$TYPE(osname) .EQS. "" THEN osname = F$EDIT(F$GETSYI("NODE_SWTYPE"),"COLLAPSE") $ bool_dflt = "n" $ IF F$TYPE(config_dflt) .NES. "" THEN bool_dflt = config_dflt $ rp = "Shall I use ''config_sh' for default answers? [''bool_dflt'] " $ GOSUB myread $ IF ans $ THEN $ echo "" $ echo "Fetching default answers from ''config_sh'..." $! $! we do our own parsing of the shell-script stuff $! ...and only accept symbols if they're in the | delimited list below $! $ config_symbols0 ="|archlib|archlibexp|bin|binexp|builddir|cf_email|config_sh|installarchlib|installbin|installman1dir|installman3dir|" $ config_symbols1 ="|installprivlib|installscript|installsitearch|installsitelib|most|oldarchlib|oldarchlibexp|osname|pager|perl_symbol|perl_verb|" $ config_symbols2 ="|prefix|privlib|privlibexp|scriptdir|sitearch|sitearchexp|sitebin|sitelib|sitelib_stem|sitelibexp|try_cxx|use64bitall|use64bitint|" $ config_symbols3 ="|usecasesensitive|usedefaulttypes|usedevel|useieee|useithreads|uselongdouble|usemultiplicity|usemymalloc|usedebugging_perl|" $ config_symbols4 ="|useperlio|usesecurelog|usethreads|usevmsdebug|usefaststdio|usemallocwrap|unlink_all_versions|uselargefiles|usesitecustomize|" $ config_symbols5 ="|buildmake|builder|usethreadupcalls|usekernelthread" $! $ open/read CONFIG 'config_sh' $ rd_conf_loop: $ read/end=erd_conf_loop CONFIG line $ line = f$edit(line,"trim") $ if line .eqs. "" .or. f$extract(0,1,line) .eqs. "#" then goto rd_conf_loop $ sym = f$element(0,"=",line) $ if sym .eqs. "=" then goto rd_conf_loop $ dsym = "|"+sym+"|" $ k = 0 $ rd_ck_loop: $ syms = config_symbols'k' $ j = f$locate(dsym, syms) $ if j .lt. f$length(syms) then goto erd_ck_loop $ k = k + 1 $ if k .lt. 6 then goto rd_ck_loop $ goto rd_conf_loop $ erd_ck_loop: $ val = f$element(1,"=",line) $ val = f$extract(1,f$length(val)-2,val) $ write sys$output "''sym' = ""''val'""" $ 'sym' = "''val'" $ goto rd_conf_loop $ erd_conf_loop: $ close CONFIG $ delete/symbol config_symbols0 $ delete/symbol config_symbols1 $ delete/symbol config_symbols2 $ delete/symbol config_symbols3 $ delete/symbol config_symbols4 $ delete/symbol config_symbols5 $ delete/symbol sym $ delete/symbol val $ delete/symbol dsym $ if f$type(usedebugging_perl) .nes. "" $ then $ DEBUGGING = usedebugging_perl $ delete/symbol usedebugging_perl $ endif $! $ ENDIF $ if f$type(config_dflt) .nes. "" then DELETE/SYMBOL config_dflt $! $!we actually do not have "hints/" for VMS $! TYPE SYS$INPUT: $! DECK $! $!First time through, eh? I have some defaults handy for the following systems: $! $! EOD $! echo " ","VMS_VAX" $! echo " ","VMS_AXP" $! echo " ","VMS_IA64" $! : Now look for a hint file osname_osvers, unless one has been $! : specified already. $! TYPE SYS$INPUT: $! $!You may give one or more space-separated answers, or "none" if appropriate. $!If your OS version has no hints, DO NOT give a wrong version -- say "none". $! $! READ SYS$COMMAND/PROMPT="Which of these apply, if any? " ans $! $Beyond_config_sh: $! $!: Restore computed paths !sfn $! $! %Config-I-VMS, a necessary error trap (could be PC running VCL) $! $ IF (osname .NES. "VMS") $ THEN $ echo4 "Hmm.. I wonder what ''osname' is (?)" $ TYPE SYS$INPUT: $ DECK %Config-E-VMS, ERROR: Err, you do not appear to be running VMS! This procedure is intended to Configure the building of Perl for VMS. $ EOD $ bool_dflt = "n" $ GOSUB myread $ IF ans $ THEN $ echo4 "Continuing..." $ ELSE $ echo4 "ABORTING..." $ SET DEFAULT 'vms_default_directory_name' !be kind rewind $ STOP $ EXIT 2 !$STATUS = "%X00000002" (error) $ ENDIF $ ENDIF !(osname .NES./.EQS. "VMS") $! $!: who configured the system $ cf_by = F$EDIT(user,"LOWERCASE") $ osvers = F$EDIT(F$GETSYI("VERSION"),"TRIM") $! $! Peter Prymmer has seen: $! "SYS$TIMEZONE_DIFFERENTIAL" = "-46800" (sic) $! "SYS$TIME_ZONE" = "EDT" $! $! Charles Lane recommended: $! "SYS$TIMEZONE_DIFFERENTIAL" = "-14400" $! "NEWS_TIMEZONE" = "-0500" $! "ST_TIMEZONE" = "EDT" $! "JAN_TIME_ZONE" = "EST " $! "MULTINET_TIMEZONE" = "EST" $! "DAYLIGHT_SAVINGS" = "1" $! $! Charles Bailey recommends (in ANU NEWS Doc Jan 1995): $! "PMDF_Timezone" $! "Multinet_Timezone" $! "TCPware_Timezone" $! "WIN$Time_Zone" $! $! This snippet o' DCL returns a string in default Unix `date` format, $! and it will prompt to set SYS$TIMEZONE_DIFFERENTIAL. $! $ MIN_TZO = -840 !units are minutes here $ MAX_TZO = 840 $! $ wkday = F$EXTRACT(0,3,F$CVTIME(,,"WEEKDAY")) $ monn = F$CVTIME(,,"MONTH") $ mday = F$EXTRACT(8,2,F$CVTIME(,,"DATE")) $ hour = F$CVTIME(,,"HOUR") $ min = F$CVTIME(,,"MINUTE") $ sec = F$CVTIME(,,"SECOND") $ year = F$CVTIME(,,"YEAR") $! $ months = "/Jan/Feb/Mar/Apr/May/Jun/Jul/Aug/Sep/Oct/Nov/Dec/" $ i = 0 $Mon_loop: $ i = i + 1 $ mon = F$ELEMENT(i,"/",months) $ IF i.LT.monn THEN GOTO Mon_loop $! $ tzneedset = "t" $ systz = F$TRNLNM("SYS$TIMEZONE_DIFFERENTIAL") $ IF systz.NES."" $ THEN $ tzhour = F$INTEGER(systz)/3600 $ tzmins = F$INTEGER(systz)/60 $ tzminrem = tzmins - tzhour*60 $ IF tzminrem.lt.0 THEN tzminrem = -1*tzminrem !keeps !2ZL happy $ IF tzhour.ge.0 $ THEN signothetime = "+" $ IF tzhour.EQ.0.AND.tzminrem.EQ.0 $ THEN direction = "on GMT/" $ ELSE direction = "east of " $ ENDIF $ ELSE signothetime = "-" $ tzhour = -1*tzhour !keeps !UL happy $ direction = "west of " $ ENDIF $ echo "" $ echo "According to the setting of your ""SYS$TIMEZONE_DIFFERENTIAL"" (= ''systz')" $ IF tzminrem.ne.0 $ THEN $ tzspan = "''tzhour' hours & ''tzminrem' minutes" $ ELSE $ tzspan = "''tzhour' hours" $ ENDIF $ bool_dflt = "y" $ echo "Your system is ''tzspan' ''direction'UTC in England." $ rp = "(''systz') Is this UTC Time Zone Offset correct? [''bool_dflt'] " $ GOSUB myread $ IF ans $ THEN $ tzneedset = "f" $ tzd = systz $ GOTO Beyond_TimeZone $ ENDIF $ ELSE $ echo "" $ echo4 """SYS$TIMEZONE_DIFFERENTIAL"" does not appear to be DEFINEd on your system" $ ENDIF $! $TZSet: $ echo "" $ echo "Please tell me in hh:mm form what time offset from GMT/UTC in England" $ echo "you are. As an example Eastern (US) Standard Time is -5:00 offset, but" $ echo "Eastern Daylight Time (summer) is -4:00 offset." $ dflt = "0:00" $ rp = "Enter the Time Zone offset: [''dflt'] " $ GOSUB myread $ ans = F$Edit(ans,"collapse,trim,uncomment,upcase") $ IF ans.EQS."" THEN ans = dflt $ tzhour = F$ELEMENT(0,":","''ans'") !first $ IF tzhour.EQS."" THEN tzhour = 0 $ tzhour = F$INTEGER(tzhour) $ tzminrem = F$ELEMENT(1,":","''ans'") !second $ IF tzminrem.NES."" $ THEN $ tzminrem = F$INTEGER(tzminrem) $ IF F$EXTRACT(0,1,"''ans'") .EQS. "-" THEN tzminrem = tzminrem * -1 $ ELSE $ tzminrem = 0 $ ENDIF $ tzmins = tzhour*60 + tzminrem $ tzd = F$STRING(tzmins*60) $ IF tzhour .GE. 0 $ THEN $ signothetime = "+" $ ELSE $ tzhour = -1*tzhour !keeps !UL happy $ signothetime = "-" $ ENDIF $ IF (tzmins.GT.MAX_TZO).OR.(tzmins.LT.MIN_TZO) $ THEN $ echo "" $ echo "%Config-W-VMS-TIMERANGE, Response must be in the range -14:00 to 14:00." $ goto TZSet $ ENDIF $! $Beyond_TimeZone: $ tz = f$fao("UTC!AS!UL:!2ZL",signothetime,tzhour,tzminrem) $ cf_time = "''wkday' ''mon' ''mday' ''hour':''min':''sec' ''tz' ''year'" $! $!: determine the architecture name $! Note that DCL in VMS V5.4 does not have F$GETSYI("ARCH_NAME") $! but does have F$GETSYI("HW_MODEL"). $! Please try to use either archname .EQS. "VMS_VAX" or archname .EQS. $! "VMS_AXP" from here on to allow cross-platform configuration (e.g. $! configure a VAX build on an Alpha). $! $ IF (F$GETSYI("HW_MODEL") .LT. 1024 .AND. F$GETSYI("HW_MODEL") .GT. 0) $ THEN $ archname = "VMS_VAX" $ otherarch = "an Alpha or IA64" $ alignbytes="8" $ arch_type = "ARCH-TYPE=__VAX__" $ ELSE $ IF (F$GETSYI("ARCH_TYPE") .EQ. 2) $ THEN $ archname = "VMS_AXP" $ otherarch = "a VAX or IA64" $ arch_type = "ARCH-TYPE=__AXP__" $ ELSE $ archname = "VMS_IA64" $ otherarch = "a VAX or Alpha" $ arch_type = "ARCH-TYPE=__IA64__" $ ENDIF $ alignbytes="8" $ ENDIF $ dflt = archname $ rp = "What is your architecture name? [''archname'] " $ GOSUB myread $ IF ans.NES."" $ THEN $ ans = F$EDIT(ans,"COLLAPSE, UPCASE") $ IF (ans.NES.archname) !.AND.knowitall $ THEN $ echo4 "I'll go with ''archname' anyway..." $ ENDIF $ ENDIF $ bool_dflt = "n" $ vms_prefix = "perl_root" $ vms_prefixup = F$EDIT(vms_prefix,"UPCASE") $ rp = "Will you be sharing your ''vms_prefixup' with ''otherarch'? [''bool_dflt'] " $ GOSUB myread $ IF .NOT. ans $ THEN $ sharedperl = "N" $ ELSE $ sharedperl = "Y" $ IF (archname.EQS."VMS_AXP") $ THEN $ macros = macros + """AXE=1""," $ ENDIF $ IF (archname.EQS."VMS_IA64") $ THEN $ macros = macros + """IXE=1""," $ ENDIF $ ENDIF $! $!: is AFS running? !sfn $!: decide how portable to be. Allow command line overrides. !sfn $!: set up shell script to do ~ expansion !sfn $!: expand filename !sfn $!: now set up to get a file name !sfn $! $ IF F$TYPE(prefix) .EQS. "" $ THEN $ prefix = F$ENVIRONMENT("DEFAULT") - ".UU]" + "]" $ prefix = F$PARSE(prefix,,,,"NO_CONCEAL") - "][" - "000000." - ".000000" - ".;" $ prefixbase = prefix - "]" $! Add _ROOT to make install PERL_ROOT differ from build directory. $ prefix = prefixbase + "_ROOT.]" $ ENDIF $ ! more redundant scrubbing of values $ prefix = prefix - "000000." $ IF F$LOCATE(".]",prefix) .EQ. F$LENGTH(prefix) THEN prefix = prefix - "]" + ".]" $ src = prefix $!: determine root of directory hierarchy where package will be installed. $ dflt = prefix $ IF .NOT.silent $ THEN $ echo "" $ echo "By default, ''package' will be installed in ''dflt', pod" $ echo "pages under ''prefixbase'.LIB.POD], etc..., i.e. with ''dflt' as prefix for" $ echo "all installation directories." $ echo "On ''osname' the prefix is used to DEFINE the ''vms_prefixup' prior to installation" $ echo "as well as during subsequent use of ''package' via ''packageup'_SETUP.COM." $ ENDIF $ rp = "Installation prefix to use (for ''vms_prefixup')? [ ''dflt' ] " $ GOSUB myread $ IF ans.NES."" $ THEN $ prefix = ans $ IF F$LOCATE(".]",ans) .EQ. F$LENGTH(ans) THEN prefix = prefix - "]" + ".]" $ ELSE $ prefix = dflt $ ENDIF $ perl_root = prefix $! $! Check here for pre-existing PERL_ROOT. $! -> ask if removal desired. $! Check here for writability of requested PERL_ROOT if it is not the default (cwd). $! -> recommend letting PERL_ROOT be PERL_SRC if requested PERL_ROOT is not writable. $! $ tmp = perl_root - ".]" + "]" $ dflt = f$parse(tmp,,,,) $ IF dflt .eqs. "" $ THEN $ echo4 "''tmp' does not yet exist." $! create/directory 'tmp' $ ELSE $ echo4 "''tmp' already exists." $ ENDIF $! $ vms_skip_install = "true" $ bool_dflt = "y" $! echo "" $ rp = "Skip the remaining """"where install"""" questions? [''bool_dflt'] " $ GOSUB myread $ IF (.NOT.ans) THEN vms_skip_install = "false" $ IF (.NOT.vms_skip_install) $ THEN $! $!: set the prefixit variable, to compute a suitable default value $! $!: determine where private library files go $!: Usual default is /usr/local/lib/perl5. Also allow things like $!: /opt/perl/lib, since /opt/perl/lib/perl5 would be redundant. $ IF .NOT.silent $ THEN $ TYPE SYS$INPUT: $ DECK There are some auxiliary files for perl5 that need to be put into a private library directory that is accessible by everyone. $ EOD $ ENDIF $ IF F$TYPE(privlib) .NES. "" $ THEN dflt = privlib $ ELSE dflt = "''vms_prefix':[lib]" $ ENDIF $ rp = "Pathname where the private library files will reside? " $ rp = F$FAO("!AS!/!AS",rp,"[ ''dflt' ] ") $ GOSUB myread $ privlib = ans $! $ ENDIF !%Config-I-VMS, skip remaining "where install" questions $! $ IF F$TYPE(perl_symbol) .EQS. "" THEN perl_symbol := true $ IF F$TYPE(perl_verb) .EQS. "" THEN perl_verb = "" $ IF perl_symbol $ THEN bool_dflt = "y" $ ELSE bool_dflt = "n" $ ENDIF $ IF .NOT.silent $ THEN $ echo "" $ echo "You may choose to write ''packageup'_SETUP.COM to assign a foreign" $ echo "symbol to invoke ''package', which is the usual method." $ echO "If you do not do so then you would need a DCL command verb at the" $ echo "process or the system wide level." $ ENDIF $ rp = "Invoke perl as a global symbol foreign command? [''bool_dflt'] " $ GOSUB myread $ IF (.NOT.ans) THEN perl_symbol = "false" $! $ IF (.NOT.perl_symbol) $ THEN $ IF perl_verb .EQS. "DCLTABLES" $ THEN bool_dflt = "n" $ ELSE bool_dflt = "y" $ ENDIF $ IF .NOT.silent $ THEN $ echo "" $ echo "Since you won't be using a symbol you must choose to put the ''packageup'" $ echo "verb in a per-process table or in the system wide DCLTABLES (which" $ echo "would require write privilege)." $ ENDIF $ rp = "Invoke perl as a per process command verb? [ ''bool_dflt' ] " $ GOSUB myread $ IF (.NOT.ans) $ THEN perl_verb = "DCLTABLES" $ ELSE perl_verb = "PROCESS" $ ENDIF $ ENDIF ! (.NOT.perl_symbol) $! $!: set the base revision $ baserev="5.0" $ revision = baserev - ".0" $!: get the patchlevel $ echo "" $ echo4 "Getting the current patchlevel..." $ patchlevel="0" $ subversion="0" $ api_revision="0" $ api_version="0" $ api_subversion="0" $ perl_patchlevel="0" $ patchlevel_h = F$SEARCH("[-]patchlevel.h") $ IF (patchlevel_h.NES."") $ THEN $ got_patch = "false" $ got_sub = "false" $ got_api_revision = "false" $ got_api_version = "false" $ got_api_subversion = "false" $ got_perl_patchlevel= "false" $ OPEN/READONLY CONFIG 'patchlevel_h' $Patchlevel_h_loop: $ READ/END_Of_File=Close_patch/ERROR=Close_patch CONFIG line $ IF ((F$LOCATE("#define PERL_VERSION",line).NE.F$LENGTH(line)).AND.(.NOT.got_patch)) $ THEN $ line = F$EDIT(line,"COMPRESS, TRIM") $ patchlevel = F$ELEMENT(2," ",line) $ got_patch = "true" $ ENDIF $ IF ((F$LOCATE("#define PERL_SUBVERSION",line).NE.F$LENGTH(line)).AND.(.NOT.got_sub)) $ THEN $ line = F$EDIT(line,"COMPRESS, TRIM") $ subversion = F$ELEMENT(2," ",line) $ got_sub = "true" $ ENDIF $ IF ((F$LOCATE("#define PERL_API_REVISION",line).NE.F$LENGTH(line)).AND.(.NOT.got_api_revision)) $ THEN $ line = F$EDIT(line,"COMPRESS, TRIM") $ api_revision = F$ELEMENT(2," ",line) $ got_api_revision = "true" $ ENDIF $ IF ((F$LOCATE("#define PERL_API_VERSION",line).NE.F$LENGTH(line)).AND.(.NOT.got_api_version)) $ THEN $ line = F$EDIT(line,"COMPRESS, TRIM") $ api_version = F$ELEMENT(2," ",line) $ got_api_version = "true" $ ENDIF $ IF ((F$LOCATE("#define PERL_API_SUBVERSION",line).NE.F$LENGTH(line)).AND.(.NOT.got_api_subversion)) $ THEN $ line = F$EDIT(line,"COMPRESS, TRIM") $ api_subversion = F$ELEMENT(2," ",line) $ got_api_subversion = "true" $ ENDIF $ IF ((F$LOCATE("""DEVEL",line).NE.F$LENGTH(line)).AND.(.NOT.got_perl_patchlevel)) $ THEN $ line = F$EDIT(line,"COMPRESS, TRIM") $ perl_patchlevel = F$ELEMENT(1,"""",line) $ perl_patchlevel = perl_patchlevel - "DEVEL" $ got_perl_patchlevel = "true" $ ENDIF $ IF ((F$LOCATE("""SMOKE",line).NE.F$LENGTH(line)).AND.(.NOT.got_perl_patchlevel)) $ THEN $ line = F$EDIT(line,"COMPRESS, TRIM") $ perl_patchlevel = F$ELEMENT(1,"""",line) $ perl_patchlevel = perl_patchlevel - "SMOKE" $ got_perl_patchlevel = "true" $ ENDIF $ IF ((F$LOCATE("""MAINT",line).NE.F$LENGTH(line)).AND.(.NOT.got_perl_patchlevel)) $ THEN $ line = F$EDIT(line,"COMPRESS, TRIM") $ perl_patchlevel = F$ELEMENT(1,"""",line) $ perl_patchlevel = perl_patchlevel - "MAINT" $ got_perl_patchlevel = "true" $ ENDIF $ IF (.NOT. got_patch) .OR. - (.NOT. got_sub) .OR. - (.NOT. got_api_revision) .OR. - (.NOT. got_api_version) .OR. - (.NOT. got_api_subversion) .OR. - (.NOT. got_perl_patchlevel) - THEN GOTO Patchlevel_h_loop $Close_patch: $ CLOSE CONFIG $ ENDIF $! $ IF F$SEARCH("[-].patch") .NES. "" $ THEN $ SET NOON $ OPEN/READ PATCH [-].patch $ READ PATCH line $ CLOSE PATCH $ tmp = F$EDIT(line,"TRIM,COMPRESS") $ IF F$ELEMENT(3, " ", tmp) .NES. "" THEN tmp = F$ELEMENT(3, " ", tmp) $ SET ON $ IF tmp .NES. "" THEN perl_patchlevel = tmp $ ENDIF $! $ version_patchlevel_string = "version ''patchlevel' subversion ''subversion'" $ IF got_perl_patchlevel .AND. perl_patchlevel .NES. "0" $ THEN $ version_patchlevel_string = "''version_patchlevel_string' patch ''perl_patchlevel'" $ ENDIF $ echo "(You have ''package' ''version_patchlevel_string'.)" $! $ version = revision + "_" + patchlevel + "_" + subversion $! $ IF (.NOT.vms_skip_install) $ THEN $!: set the prefixup variable, to restore leading tilde escape !sfn $! $!: determine where public architecture dependent libraries go $ IF (.NOT.silent) $ THEN $ echo "" $ echo "''package' contains architecture-dependent library files. If you are" $ ENDIF $ IF (.NOT.silent) $ THEN $ TYPE SYS$INPUT: $ DECK sharing libraries in a heterogeneous environment, you might store these files in a separate location. Otherwise, you can just include them with the rest of the public library files. $ EOD $ ENDIF $ IF F$TYPE(archlib) .NES. "" $ THEN dflt = archlib $ ELSE dflt = privlib - "]" + "." + archname + "." + version + "]" $ ENDIF $ rp = "Where do you want to put the public architecture-dependent libraries? " $ rp = F$FAO("!AS!/!AS",rp,"[ ''dflt' ] ") $ GOSUB myread $ archlib = ans $! $ ENDIF !%Config-I-VMS, skip "where install" questions $! $! This quotation from Configure has to be included on VMS: $! $ TYPE SYS$INPUT: $ DECK There is, however, a strange, musty smell in the air that reminds me of something...hmm...yes...I've got it...there's a VMS nearby, or I'm a Blit. $ EOD $ IF (.NOT.vms_skip_install) $ THEN $!: it so happens the Eunice I know will not run shell scripts in Unix format $! $!: see if setuid scripts can be secure !sfn $!: now see if they want to do setuid emulation !sfn $! $!: determine where site specific libraries go. $ IF .NOT.silent $ THEN $ TYPE SYS$INPUT: $ DECK The installation process will also create a directory for site-specific extensions and modules. Some users find it convenient to place all local files in this directory rather than in the main distribution directory. $ EOD $ ENDIF $ IF F$TYPE(sitelib) .NES. "" $ THEN dflt = sitelib $ ELSE dflt = privlib - "]" + ".SITE_PERL]" $ ENDIF $ rp = "Pathname for the site-specific library files? " $ rp = F$FAO("!AS!/!AS",rp,"[ ''dflt' ] ") $ GOSUB myread $ sitelib = ans $! $!: determine where site specific architecture-dependent libraries go. $ IF .NOT.silent $ THEN TYPE SYS$INPUT: $ DECK The installation process will also create a directory for architecture-dependent site-specific extensions and modules. $ EOD $ ENDIF $ IF F$TYPE(sitearch) .NES. "" $ THEN dflt = sitearch $ ELSE dflt = sitelib - "]" + "." + archname + "]" $ ENDIF $ rp = "Pathname for the site-specific architecture-dependent library files? " $ rp = F$FAO("!AS!/!AS",rp,"[ ''dflt' ] ") $ GOSUB myread $ sitearch = ans $! $!: determine where old public architecture dependent libraries might be $! $!: determine where public executables go $ IF F$TYPE(bin) .NES. "" $ THEN dflt = bin $! ELSE dflt = prefix - ".]" + ".BIN]" $ ELSE dflt = "/''vms_prefix'" $ ENDIF $ rp = "Pathname where the public executables will reside? " $ rp = F$FAO("!AS!/!AS",rp,"[ ''dflt' ] ") $ GOSUB myread $ bin = ans $! $!: determine where add-on public executables go $ IF F$TYPE(sitebin) .NES. "" $ THEN dflt = sitebin $ ELSE dflt = "''vms_prefix':[bin.''archname']" $ ENDIF $ rp = "Pathname where the add-on public executables should be installed? " $ rp = F$FAO("!AS!/!AS",rp,"[ ''dflt' ] ") $ GOSUB myread $ sitebin = ans $! $!: determine where manual pages are on this system $!: What suffix to use on installed man pages $!: see if we can have long filenames $!: determine where library module manual pages go $!: What suffix to use on installed man pages $!: see what memory models we can support $! $ ELSE ! skipping "where install" questions, we must set some symbols $ IF F$TYPE(archlib).EQS."" THEN - archlib="''vms_prefix':[lib.''archname'.''version']" $ IF F$TYPE(bin) .EQS. "" THEN - bin="/''vms_prefix'" $ IF F$TYPE(privlib) .EQS. "" THEN - privlib ="''vms_prefix':[lib]" $ IF F$TYPE(sitearch) .EQS. "" THEN - sitearch="''vms_prefix':[lib.site_perl.''archname']" $ IF F$TYPE(sitelib) .EQS. "" THEN - sitelib ="''vms_prefix':[lib.site_perl]" $ IF F$TYPE(sitebin) .EQS. "" THEN - sitebin="''vms_prefix':[bin.''archname']" $ ENDIF !%Config-I-VMS, skip "where install" questions $! $! These derived locations can be set whether we've opted to $! skip the where install questions or not. $! $ IF F$TYPE(archlibexp) .EQS. "" THEN - archlibexp="''vms_prefix':[lib.''archname'.''version']" $ IF F$TYPE(binexp) .EQS. "" THEN - binexp ="''vms_prefix':[000000]" $ IF F$TYPE(builddir) .EQS. "" THEN - builddir ="''vms_prefix':[000000]" $ IF F$TYPE(installarchlib) .EQS. "" THEN - installarchlib="''vms_prefix':[lib.''archname'.''version']" $ IF F$TYPE(installbin) .EQS. "" THEN - installbin ="''vms_prefix':[000000]" $ IF F$TYPE(installscript) .EQS. "" THEN - installscript ="''vms_prefix':[utils]" $ IF F$TYPE(installman1dir) .EQS. "" THEN - installman1dir ="''vms_prefix':[man.man1]" $ IF F$TYPE(installman3dir) .EQS. "" THEN - installman3dir ="''vms_prefix':[man.man3]" $ IF F$TYPE(installprivlib) .EQS. "" THEN - installprivlib ="''vms_prefix':[lib]" $ IF F$TYPE(installsitearch) .EQS. "" THEN - installsitearch="''vms_prefix':[lib.site_perl.''archname']" $ IF F$TYPE(installsitelib) .EQS. "" THEN - installsitelib ="''vms_prefix':[lib.site_perl]" $ IF F$TYPE(oldarchlib) .EQS. "" THEN - oldarchlib="''vms_prefix':[lib.''archname']" $ IF F$TYPE(oldarchlibexp) .EQS. "" THEN - oldarchlibexp="''vms_prefix':[lib.''archname']" $ IF F$TYPE(privlibexp) .EQS. "" THEN - privlibexp ="''vms_prefix':[lib]" $ IF F$TYPE(scriptdir) .EQS. "" THEN - scriptdir ="''vms_prefix':[utils]" $ IF F$TYPE(sitearchexp) .EQS. "" THEN - sitearchexp ="''vms_prefix':[lib.site_perl.''archname']" $ IF F$TYPE(sitelib_stem) .EQS. "" THEN - sitelib_stem ="''vms_prefix':[lib.site_perl]" $ IF F$TYPE(sitelibexp) .EQS. "" THEN - sitelibexp ="''vms_prefix':[lib.site_perl]" $! $!: see if we need a special compiler $! cc_list = "cc/decc|gcc" !%Config-I-VMS, compiler symbols/commands $! $ nocc = "f" $ vms_cc_dflt = "" $ vms_cc_available = "" $! $ OPEN/WRITE CONFIG ccvms.c $ WRITE CONFIG "#ifdef __DECC" $ WRITE CONFIG "#include " !DECC is sooo picky $ WRITE CONFIG "#endif" $ WRITE CONFIG "#include " $ WRITE CONFIG "int main() {" $ WRITE CONFIG "#ifdef __DECC" $ WRITE CONFIG " printf(""/DECC\n"");" $ WRITE CONFIG "#else" $ WRITE CONFIG " printf(""/VAXC\n"");" $ WRITE CONFIG "#endif" $ WRITE CONFIG " exit(0);" $ WRITE CONFIG "}" $ CLOSE CONFIG $! $ SET NOON $ DEFINE/USER_MODE SYS$ERROR _NLA0: $ DEFINE/USER_MODE SYS$OUTPUT _NLA0: $ cc/NoObj/list=ccvms.lis ccvms.c $ tmp = $status $ SET ON $ IF (silent) THEN GOSUB Shut_up $ IF tmp.NE.%X10B90001 $ THEN $ IF tmp.NE.%X10000001 $ THEN $ nocc = "t" !%X10000001 is return from gcc $ GOTO Gcc_initial_check $ ENDIF $ ENDIF $! $ GOSUB List_Parse $ IF .NOT.silent THEN echo "" $ echo "Default ""cc"" is ''line' ''archsufx' ''F$GETSYI("VERSION")'" $ IF F$LOCATE("VAX",line).NE.F$LENGTH(line) $ THEN $ IF .NOT.silent $ THEN $ echo "Will try cc/decc..." $ ENDIF $ SET NOON $ DEFINE/USER_MODE SYS$ERROR NL: $ DEFINE/USER_MODE SYS$OUTPUT NL: $ cc/decc/NoObj/list=ccvms.lis ccvms.c $ tmp = $status $ SET ON $ IF (silent) THEN GOSUB Shut_up $ IF tmp.NE.%X10B90001 $ THEN $ echo "Apparently you don't have that one." $ ELSE $ GOSUB List_parse $ echo "You also have: ''line' ''archsufx' ''F$GETSYI("VERSION")'" $ vms_cc_available = vms_cc_available + "cc/decc " $ ENDIF $ ELSE $ IF (F$LOCATE("DEC",line).NE.F$LENGTH(line)).or.(F$LOCATE("Compaq",line).NE.F$LENGTH(line)) - .or.(F$LOCATE("HP",F$EDIT(line,"UPCASE")).NE.F$LENGTH(line)) $ THEN $ vms_cc_dflt = "/decc" $ vms_cc_available = vms_cc_available + "cc/decc " $ ENDIF $ ENDIF $! $Gcc_initial_check: $ echo "Checking for gcc" $ OPEN/WRITE CONFIG gccvers.lis $ SET NOON $ DEFINE/USER_MODE SYS$ERROR CONFIG $ DEFINE/USER_MODE SYS$OUTPUT CONFIG $ 'gcc_symbol'/noobj/version _nla0: $ tmp = $status $ SET ON $ IF (silent) THEN GOSUB Shut_up $ CLOSE CONFIG $ IF (tmp.NE.%X10000001).and.(tmp.ne.%X00030001) $ THEN $ echo "Symbol ""''gcc_symbol'"" is not defined. I guess you do not have it." $ DELETE/NOLOG/NOCONFIRM gccvers.lis; $ GOTO Cxx_initial_check $ ENDIF $ OPEN/READ CONFIG gccvers.lis $GCC_List_Read: $ READ/END_OF_FILE=GCC_List_End CONFIG line $ GOTO GCC_List_Read $GCC_List_End: $ CLOSE CONFIG $ echo line $ vms_cc_available = vms_cc_available + "''gcc_symbol' " $ DELETE/NOLOG/NOCONFIRM gccvers.lis; $! $Cxx_initial_check: $! $! Do note that [vms]perl source files have a ways to go before they will $! compile under CXX. $! In order to test Configure.com with CXX invoke it with "-Dtry_cxx" on $! the command line. $! $ IF F$TYPE(try_cxx) .EQS. "" THEN try_cxx := n $ IF try_cxx .OR. try_cxx .EQS. "define" $! $ THEN $! $ echo "Checking for CXX..." $ OPEN/WRITE CONFIG ccvms.c $ WRITE CONFIG "#include " $ WRITE CONFIG "int main() {" $ WRITE CONFIG "#ifdef __DECCXX" $ WRITE CONFIG " cout << __DECCXX, endl;" $ WRITE CONFIG "#else" $ WRITE CONFIG " cout << 0,endl;" $ WRITE CONFIG "#endif" $! Todo: add G++ identifier check ?? $ WRITE CONFIG " return(0);" $ WRITE CONFIG "}" $ CLOSE CONFIG $ SET NOON $ DEFINE/USER_MODE SYS$OUTPUT NL: $ DEFINE/USER_MODE SYS$ERROR NL: $ cxx ccvms.c $ tmp = $status $ SET ON $! success $status with: $! DEC C++ V1.1-001 on VMS VAX V5.5-2 $! DEC C++ V5.6-013 on OpenVMS VAX V7.1 $! DEC C++ V6.1-003 on OpenVMS Alpha V7.1 $! Compaq C++ V6.2-016 for OpenVMS Alpha V7.2-1 $ IF tmp .eq. %X15F60001 $ THEN $! Which linker? $ SET NOON $ DEFINE/USER_MODE SYS$OUTPUT NL: $ DEFINE/USER_MODE SYS$ERROR NL: $ link/nodebug ccvms.obj $ tmp = $status $ SET ON $ ! success $status with: $ ! link && DEC C++ V1.1-001 on VMS VAX V5.5-2 $ ! link && DEC C++ V5.6-013 on OpenVMS VAX V7.1 $ IF tmp .eq. %X10000001 $ THEN $ ld_try = "Link" $ vms_cc_available = vms_cc_available + "cxx " $ echo "CXX and LINK are available." $ ELSE $ IF F$SEARCH("ccvms.exe") .NES. "" THEN DELETE/NOLOG/NOCONFIRM ccvms.exe; $ SET NOON $ DEFINE/USER_MODE SYS$OUTPUT NL: $ DEFINE/USER_MODE SYS$ERROR NL: $ cxxlink ccvms.obj $ tmp = $status $ SET ON $ ! success $status with: $ ! cxxlink && DEC C++ V6.1-003 on OpenVMS Alpha V7.1 $ ! cxxlink && Compaq C++ V6.2-016 for OpenVMS Alpha V7.2-1 $ IF tmp .eq. %X10000001 $ THEN $ ld_try = "cxxlink" $ vms_cc_available = vms_cc_available + "cxx " $ echo "CXX and CXXLINK are available." $ ENDIF $ ENDIF $ IF F$SEARCH("ccvms.exe") .NES. "" THEN DELETE/NOLOG/NOCONFIRM ccvms.exe; $ ELSE $ echo "Nope." $ ENDIF $ DELETE/NOLOG/NOCONFIRM ccvms.c; $ IF F$SEARCH("ccvms.obj") .NES. "" THEN DELETE/NOLOG/NOCONFIRM ccvms.obj; $ CALL Cxx_demangler_cleanup $! $ ENDIF ! 1 .eq. 0 or 1 .eq. 1 $! $CC_Cleanup: $ DELETE/NOLOG/NOCONFIRM ccvms.*; $CC_Desired: $!: see if we need a special compiler $! echo "" $ echo "Available compiler(s):" $ echo "( ''vms_cc_available')" $ IF .NOT.nocc $ THEN $ dflt = "cc''vms_cc_dflt'" !-> "cc" in case first compile went OK $ ELSE $ dflt = gcc_symbol $ ENDIF $ rp = "Use which C compiler? [''dflt'] " $ GOSUB myread $ IF ans.NES."" $ THEN $ ans = F$EDIT(ans,"TRIM, COMPRESS, LOWERCASE") $ Mcc = ans $ IF (F$LOCATE("dec",ans).NE.F$LENGTH(ans)).or.(F$LOCATE("compaq",ans).NE.F$LENGTH(ans)) - .or.(F$LOCATE("hp",ans).NE.F$LENGTH(ans)) $ THEN $ Mcc = "cc/decc" $! CPQ ? $ ccname := DEC $ C_COMPILER_Replace = "CC=cc=''Mcc'" $ ENDIF $ IF F$LOCATE("cxx",F$EDIT(ans,"COLLAPSE,LOWERCASE")) .NE. F$LENGTH(ans) $ THEN $ Mcc = "cxx" $ ccname := CXX $ ld = ld_try $ C_COMPILER_Replace = "CC=cc=''Mcc'" $ ELSE ! Not_cxx $ IF Mcc.NES.dflt $ THEN $ IF F$LOCATE("dec",dflt) .NE. F$LENGTH(dflt) .or. - F$LOCATE("compaq",dflt) .NE. F$LENGTH(dflt) $ THEN $ C_COMPILER_Replace = "CC=cc=''Mcc'" $ ELSE $ ccname := DEC $ ENDIF $ ELSE $ IF Mcc .EQS. "cc/decc" $ THEN $ ccname := DEC $ C_COMPILER_Replace = "CC=cc=''Mcc'" $ ENDIF $ ENDIF $ ENDIF $ ELSE $ Mcc = dflt $ IF Mcc .EQS. "cc/decc" $ THEN $ ccname := DEC $ C_COMPILER_Replace = "CC=cc=''Mcc'" $ ENDIF $ IF Mcc .EQS. "gcc" $ THEN $ ccname := GCC $ C_COMPILER_Replace = "CC=cc=''Mcc'" $ ENDIF $ ENDIF $Decc_Version_check: $ ccversion="" $ IF ccname .EQS. "DEC" $ THEN $ echo "" $ echo4 "Checking for the Dec C version number..." $ OPEN/WRITE CONFIG deccvers.c $ WRITE CONFIG "#include " !DECC is sooo picky $ WRITE CONFIG "#include " $ WRITE CONFIG "int main() {" $ WRITE CONFIG "#ifdef __DECC" $ WRITE CONFIG "#ifdef __DECC_VER" $ WRITE CONFIG " printf(""%i\n"", __DECC_VER);" $ WRITE CONFIG "#else" $ WRITE CONFIG " printf(""%i\n"", ""1"");" $ WRITE CONFIG "#endif" $ WRITE CONFIG "#endif" $ WRITE CONFIG " exit(0);" $ WRITE CONFIG "}" $ CLOSE CONFIG $ SET NOON $ DEFINE/USER_MODE SYS$ERROR NL: $ DEFINE/USER_MODE SYS$OUTPUT NL: $ 'Mcc' deccvers.c $ tmp = $status $ IF (silent) THEN GOSUB Shut_up $ DEFINE/USER_MODE SYS$ERROR NL: $ DEFINE/USER_MODE SYS$OUTPUT NL: $ link/nodebug deccvers.obj $ tmp = $status $ IF (silent) THEN GOSUB Shut_up $ OPEN/WRITE CONFIG deccvers.out $ DEFINE/USER_MODE SYS$ERROR CONFIG $ DEFINE/USER_MODE SYS$OUTPUT CONFIG $ mcr []deccvers.exe $ tmp = $status $ SET ON $ CLOSE CONFIG $ IF (silent) THEN GOSUB Shut_up $ OPEN/READ CONFIG deccvers.out $ READ/END_OF_FILE=Dec_c_cleanup CONFIG line $Dec_c_cleanup: $ CLOSE CONFIG $ echo "You are using Dec C ''line'" $ ccversion = line $ Dec_C_Version = F$INTEGER(line) $ IF Dec_C_Version .GE. 60200000 .AND. archname .NES. "VMS_VAX" $ THEN $ echo4 "adding /NOANSI_ALIAS qualifier to ccflags." $ ccflags = ccflags + "/NOANSI_ALIAS" $ ENDIF $ DELETE/NOLOG/NOCONFIRM deccvers.*; $ ENDIF $Gcc_check: $ gccversion = "" $ IF ccname .EQS. "GCC" $ THEN $ vaxcrtl_olb = F$SEARCH("SYS$LIBRARY:VAXCRTL.OLB") $ vaxcrtl_exe = F$SEARCH("SYS$SHARE:VAXCRTL.EXE") $ gcclib_olb = F$SEARCH("GNU_CC:[000000]GCCLIB.OLB") $ IF gcclib_olb .EQS. "" $ THEN $! These objects/libs come w/ gcc 2.7.2 for AXP: $ tmp = F$SEARCH("GNU_CC:[000000]libgcc2.olb") $ IF tmp .NES. "" then gcclib_olb = tmp $ tmp = F$SEARCH("GNU_CC:[000000]libgcclib.olb") $ IF tmp .NES. "" $ THEN $ IF gcclib_olb .EQS. "" $ THEN gcclib_olb = tmp $ ELSE gcclib_olb = gcclib_olb + "/lib," + tmp $ ENDIF $ ENDIF $ tmp = F$SEARCH("SYS$LIBRARY:VAXCRTL.OLB") $ IF tmp .NES. "" $ THEN $ IF gcclib_olb .EQS. "" $ THEN gcclib_olb = tmp $ ELSE gcclib_olb = gcclib_olb + "/lib," + tmp $ ENDIF $ ENDIF $ tmp = F$SEARCH("GNU_CC:[000000]crt0.obj") $ IF tmp .NES. "" $ THEN $ IF gcclib_olb .EQS. "" $ THEN gcclib_olb = tmp $ ELSE gcclib_olb = gcclib_olb + "/lib," + tmp $ ENDIF $ ENDIF $ IF gcclib_olb .EQS. vaxcrtl_olb THEN gcclib_olb = "" !goofy order of axplibs $ ELSE $ gcclib_olb = gcclib_olb + "/lib" $ ENDIF $ IF gcclib_olb .NES. "" .AND. - (vaxcrtl_olb .NES. "" .OR. - vaxcrtl_exe .NES. "" ) $ THEN $ echo "" $ echo4 "Checking for GNU cc in disguise and/or its version number..." !>&4 $ OPEN/WRITE CONFIG gccvers.c $ WRITE CONFIG "#include " $ WRITE CONFIG "int main() {" $ WRITE CONFIG "#ifdef __GNUC__" $ WRITE CONFIG "#ifdef __VERSION__" $ WRITE CONFIG " printf(""%s\n"", __VERSION__);" $ WRITE CONFIG "#else" $ WRITE CONFIG " printf(""%s\n"", ""1"");" $ WRITE CONFIG "#endif" $ WRITE CONFIG "#endif" $ WRITE CONFIG " exit(0);" $ WRITE CONFIG "}" $ CLOSE CONFIG $ DEFINE SYS$ERROR _NLA0: $ DEFINE SYS$OUTPUT _NLA0: $ 'Mcc' gccvers.c $ tmp = $status $ DEASSIGN SYS$ERROR _NLA0: $ DEASSIGN SYS$OUTPUT _NLA0: $ IF (silent) THEN GOSUB Shut_up $ DEFINE SYS$ERROR _NLA0: $ DEFINE SYS$OUTPUT _NLA0: $ IF vaxcrtl_exe .EQS. "" $ THEN $ IF F$LOCATE("VAXCRTL",gcclib_olb).NE.F$LENGTH(gcclib_olb) $ THEN $ link/nodebug gccvers.obj,'gcclib_olb',SYS$LIBRARY:VAXCRTL/Library $ tmp = $status $ ELSE $ link/nodebug gccvers.obj,'gcclib_olb' $ tmp = $status $ ENDIF $ ELSE $ OPEN/WRITE CONFIG GCCVERS.OPT $ WRITE CONFIG "SYS$SHARE:VAXCRTL/SHARE" $ CLOSE CONFIG $ link/nodebug gccvers.obj,GCCVERS.OPT/OPT,'gcclib_olb' $ tmp = $status $ ENDIF $ DEASSIGN SYS$ERROR $ DEASSIGN SYS$OUTPUT $ IF (silent) THEN GOSUB Shut_up $ OPEN/WRITE CONFIG gccvers.out $ DEFINE SYS$ERROR CONFIG $ DEFINE SYS$OUTPUT CONFIG $ mcr []gccvers.exe $ tmp = $status $ CLOSE CONFIG $ DEASSIGN SYS$OUTPUT $ DEASSIGN SYS$ERROR $ IF (silent) THEN GOSUB Shut_up $ OPEN/READ CONFIG gccvers.out $ READ/END_OF_FILE=Gcc_cleanup CONFIG line $Gcc_cleanup: $ CLOSE CONFIG $ DELETE/NOLOG/NOCONFIRM gccvers.*; $ IF F$LOCATE("GNU C version ",line).NE.F$LENGTH(line) $ THEN $ echo "You are not using GNU cc." $ GOTO Host_name $ ELSE $ echo "You are using GNU cc ''line'" $ gccversion = line $ ccname := "GCC" $ C_COMPILER_Replace = "CC=cc=''Mcc'" $ GOTO Include_dirs $ ENDIF $ ENDIF $ ENDIF $Cxx_Version_check: $ IF ccname .EQS. "CXX" $ THEN $ OPEN/WRITE CONFIG cxxvers.c $ WRITE CONFIG "#include " $ WRITE CONFIG "int main() {" $ WRITE CONFIG "#ifdef __DECCXX_VER" $ WRITE CONFIG " printf(""%i\n"", __DECCXX_VER);" $ WRITE CONFIG "#else" $ WRITE CONFIG " printf(""%i\n"", ""0"");" $ WRITE CONFIG "#endif" $ WRITE CONFIG " return(0);" $ WRITE CONFIG "}" $ CLOSE CONFIG $ SET NOON $ DEFINE/USER_MODE SYS$ERROR NL: $ DEFINE/USER_MODE SYS$OUTPUT NL: $ 'Mcc' cxxvers.c $ tmp = $status $ SET ON $ IF (silent) THEN GOSUB Shut_up $ SET NOON $ DEFINE/USER_MODE SYS$ERROR NL: $ DEFINE/USER_MODE SYS$OUTPUT NL: $ 'ld' cxxvers.obj $ tmp = $status $ SET ON $ IF (silent) THEN GOSUB Shut_up $ OPEN/WRITE CONFIG cxxvers.out $ SET NOON $ DEFINE/USER_MODE SYS$ERROR CONFIG $ DEFINE/USER_MODE SYS$OUTPUT CONFIG $ mcr []cxxvers.exe $ tmp = $status $ SET ON $ CLOSE CONFIG $ IF (silent) THEN GOSUB Shut_up $ OPEN/READ CONFIG cxxvers.out $ READ/END_OF_FILE=Cxx_cleanup CONFIG line $Cxx_cleanup: $ CLOSE CONFIG $ DELETE/NOLOG/NOCONFIRM cxxvers.*; $ echo "You are using CXX ''line'" $ cxxversion = line $ ccversion = line $ d_cplusplus = "define" $ CALL Cxx_demangler_cleanup $ ELSE $ d_cplusplus = "undef" $ ENDIF $! $Cxx_demangler_cleanup: SUBROUTINE $! $! If we do build with CXX these demangler Dbs will be left all over. $! However, configure.com does try to remove the [.UU] sub directory. $! Be sure to set default to the correct place before calling this sub. $! $ SET NOON $ IF F$SEARCH("[.CXX_REPOSITORY]*.*") .NES. "" THEN DELETE/NOLOG/NOCONFIRM [.CXX_REPOSITORY]*.*;* $ IF F$SEARCH("CXX_REPOSITORY.DIR") .NES. "" $ THEN $ SET PROTECTION=(SYSTEM:RWED,OWNER:RWED) CXX_REPOSITORY.DIR $ DELETE/NOLOG/NOCONFIRM CXX_REPOSITORY.DIR; $ ENDIF $ SET ON $ EXIT $ ENDSUBROUTINE ! Cxx_demangler_cleanup $! $ GOTO Host_name $! $List_Parse: $ OPEN/READ CONFIG ccvms.lis $ READ CONFIG line $ IF archname .EQS. "VMS_VAX" $ THEN $ read CONFIG line $ archsufx = "VAX" $ ELSE $ IF archname .EQS. "VMS_AXP" $ THEN $ archsufx = "AXP" $ ELSE $ archsufx = "IA64" $ ENDIF $ ENDIF $ CLOSE CONFIG $ line = F$EDIT(line,"TRIM,COMPRESS") $ line = line - "Page 1" ! occurs at end all compilers $ line = line - "CCVMS " ! filename appears w/ VAXC $ line = line - "Source Listing " ! Seen w/ AXP DECC $ tmp = F$EXTRACT(0,20,line) !timestamp, e.g. "30-JUL-1996 21:12:54 " $ line = line - tmp $ line = F$EDIT(line,"TRIM") !bit redundant but we're in no big hurry $ DELETE/NOLOG/NOCONFIRM ccvms.lis; $ RETURN $! $Include_dirs: $!: What should the include directory be ? (.TLB text libraries) $ dflt = gcclib_olb $ rp = "Where are the include files you want to use? " $ IF f$length( rp + "[''dflt'] " ) .GT. 76 $ THEN rp = F$FAO("!AS!/!AS",rp,"[''dflt'] ") $ ELSE rp = rp + "[''dflt'] " $ ENDIF $ GOSUB myread $ usrinc = ans $! $!: see if we have to deal with yellow pages, now NIS. $!: now get the host name $Host_name: $ echo "" $ echo4 "Figuring out host name..." !>&4 $ myhostname = "" $ IF myhostname.eqs."" THEN myhostname = F$TRNLNM("ARPANET_HOST_NAME") $ IF myhostname.eqs."" THEN myhostname = F$TRNLNM("INTERNET_HOST_NAME") $ IF myhostname.eqs."" THEN myhostname = F$TRNLNM("MULTINET_HOST_NAME") $ IF myhostname.eqs."" THEN myhostname = F$TRNLNM("UCX$INET_HOST_NAME") $ IF myhostname.eqs."".and. - F$TRNLNM("UCX$INET_HOST") .nes. "" .and. - F$TRNLNM("UCX$INET_DOMAIN") .nes. "" THEN - myhostname = F$TRNLNM("UCX$INET_HOST") + "." + F$TRNLNM("UCX$INET_DOMAIN") $ IF myhostname.eqs."".and. - F$TRNLNM("TCPIP$INET_HOST") .nes. "" .and. - F$TRNLNM("TCPIP$INET_DOMAIN") .nes. "" THEN - myhostname = F$TRNLNM("TCPIP$INET_HOST") + "." + F$TRNLNM("TCPIP$INET_DOMAIN") $ IF myhostname.eqs."" THEN myhostname = F$TRNLNM("TCPWARE_DOMAINNAME") $ IF myhostname.eqs."" THEN myhostname = F$TRNLNM("NEWS_ADDRESS") $ IF myhostname.eqs."" THEN myhostname = F$TRNLNM("SYS$NODE") - "::" $ IF myhostname.eqs."" THEN myhostname = F$EDIT(F$GETSYI("SCSNODE"),"TRIM") $!: you do not want to know about this $!: verify guess $ rp = "Your host name appears to be """"''myhostname'"""". Right? " $ bool_dflt = "y" $ GOSUB myread $ IF (.not.ans) $ THEN $ READ SYS$COMMAND/PROMPT= - "Please type the (one word) name of your host: " ans $ myhostname = ans $ ENDIF $!: translate upper to lower if necessary $ myhostname = F$EDIT(myhostname,"COLLAPSE") $ mylowhostname = F$EDIT(myhostname," LOWERCASE") $ IF mylowhostname.NES.myhostname $ THEN $ echo "(Normalizing case in your host name)" $ myhostname = mylowhostname $ ENDIF $! $ fp = F$LOCATE(".",myhostname) $ mydomain = F$EXTRACT(fp,(F$LENGTH(myhostname)-fp)+1,myhostname) $ IF mydomain.NES."" !no periods in DECnet names like "MYDECNODE::" $ THEN $ rp = "What is your domain name? [''mydomain'] " $ dflt = mydomain $ GOSUB myread $ mydomain = ans $!: translate upper to lower if necessary $ mydomain = F$EDIT(mydomain,"COLLAPSE") $ mylowdomain = F$EDIT(mydomain," LOWERCASE") $ IF mylowdomain.NES.mydomain $ THEN $ echo "(Normalizing case in your domain name)" $ mydomain = mylowdomain $ ENDIF $ ENDIF $ myhostname = myhostname - mydomain $ echo "(Trimming domain name from host name--host name is now ''myhostname')" $ IF .NOT.silent $ THEN $ TYPE SYS$INPUT: $ DECK I need to get your e-mail address in Internet format if possible, i.e. something like user@host.domain. Please answer accurately since I have no easy means to double check it. The default value provided below is most probably close to the reality but may not be valid from outside your organization... $ EOD $ ENDIF $ IF F$TYPE(cf_email) .EQS. "" $ THEN $ dflt = "''cf_by'@''myhostname'"+"''mydomain'" $ rp = "What is your e-mail address? [''dflt'] " $ GOSUB myread $ cf_email = ans $ ENDIF $! $ IF .NOT.silent $ THEN $ TYPE SYS$INPUT: $ DECK If you or somebody else will be maintaining perl at your site, please fill in the correct e-mail address here so that they may be contacted if necessary. Currently, the "perlbug" program included with perl will send mail to this address in addition to perlbug@perl.com. You may enter "none" for no administrator. $ EOD $ ENDIF $ dflt = "''cf_email'" $ rp = "Perl administrator e-mail address [''dflt'] " $ GOSUB myread $ perladmin = ans $! $!: determine where public executable scripts go $!: determine perl absolute location $!: figure out how to guarantee perl startup $! $!: see how we invoke the C preprocessor $! echo "" $! echo4 "Now, how can we feed standard input to your C preprocessor..." !>&4 $!: Set private lib path $!: Now check and see which directories actually exist, avoiding duplicates $!: determine optimize, if desired, or use for debug flag also $!: We will not override a previous value, but we might want to $!: augment a hint file $!: the following weeds options from ccflags that are of no interest to cpp $!: flags used in final linking phase $!: Try to guess additional flags to pick up local libraries. $!: coherency check $! echo "" $! echo4 "Checking your choice of C compiler and flags for coherency..." !>&4 $!: compute shared library extension $!: Looking for optional libraries $!: see if nm is to be used to determine whether a symbol is defined or not $!: get list of predefined functions in a handy place $!: see if we have sigaction or sigprocmask $!: see whether socketshr exists $ IF (F$SEARCH(F$PARSE("SocketShr","Sys$Share:.Exe")).NES."") $ THEN $ Has_socketshr = "T" $ echo "" $ echo4 "Hmm... Looks like you have SOCKETSHR Berkeley networking support." $ ELSE $ Has_socketshr = "F" $ ENDIF $ IF (ccname .EQS. "DEC" .AND. Dec_C_Version .GE. 50200000) .OR. (ccname .EQS. "CXX") $ THEN $ Has_Dec_C_Sockets = "T" $ echo "" $ echo4 "Hmm... Looks like you have Dec C Berkeley networking support." $ ELSE $ Has_Dec_C_Sockets = "F" $ ENDIF $ ! Hey, we've got both. Default to Dec C, then, since it's better $ IF Has_socketshr .OR. Has_Dec_C_Sockets $ THEN $ echo "" $ echo "You have sockets available. Which socket stack do you want to" $ echo "build into Perl?" $ IF Has_Dec_C_Sockets $ THEN $ dflt = "DECC" $ ELSE $ dflt = "SOCKETSHR" $ ENDIF $ rp = "Choose socket stack (NONE" $ IF Has_socketshr THEN rp = rp + ",SOCKETSHR" $ IF Has_Dec_C_Sockets THEN rp = rp + ",DECC" $ rp = rp + ") [''dflt'] " $ GOSUB myread $ Has_Dec_C_Sockets = "F" $ Has_socketshr = "F" $ ans = F$EDIT(ans,"TRIM,COMPRESS,LOWERCASE") $ IF ans.eqs."decc" THEN Has_Dec_C_Sockets = "T" $ IF ans.eqs."socketshr" THEN Has_socketshr = "T" $ ENDIF $! $! $! Ask if they want to build with VMS_DEBUG perl $ echo "" $ echo "Perl can be built to run under the VMS debugger." $ echo "You should only select this option if you are debugging" $ echo "perl itself. This can be a useful feature if you are " $ echo "embedding perl in a program." $ bool_dflt = "n" $ if f$type(usevmsdebug) .nes. "" $ then $ if usevmsdebug .or. usevmsdebug .eqs. "define" then bool_dflt="y" $ endif $ rp = "Build a VMS-DEBUG version of Perl? [''bool_dflt'] " $ GOSUB myread $ use_vmsdebug_perl = ans $ IF use_vmsdebug_perl $ THEN $ usevmsdebug = "define" $ macros = macros + """__DEBUG__=1""," $ ELSE $ usevmsdebug = "undef" $ ENDIF $! $! Ask if they want to build with DEBUGGING $ echo "" $ echo "Perl can be built with extra runtime debugging enabled. This" $ echo "enables the -D switch, at the cost of some performance. It" $ echo "was mandatory on perl 5.005 and before on VMS, but is now" $ echo "optional. If you do not generally use it you should probably" $ echo "leave this off and gain a bit of extra speed." $ bool_dflt = "n" $ if f$type(DEBUGGING) .nes. "" $ then $ if f$extract(0,1,f$edit(DEBUGGING,"collapse,upcase")).eqs."Y" .or. DEBUGGING .eqs. "define" then bool_dflt="y" $ endif $ rp = "Build a DEBUGGING version of Perl? [''bool_dflt'] " $ GOSUB myread $ use_debugging_perl = ans $! $! Ask if they want to build with MULTIPLICITY $ echo "" $ echo "Perl can be built so that multiple Perl interpreters can coexist" $ echo "within the same Perl executable." $ echo "There is some performance overhead, however, so you" $ echo "probably do not want to choose this unless you are going to be" $ echo "doing things with embedded perl." $ bool_dflt = "n" $ if f$type(usemultiplicity) .nes. "" $ then $ if usemultiplicity .or. usemultiplicity .eqs. "define" then bool_dflt = "y" $ endif $ rp = "Build Perl for multiplicity? [''bool_dflt'] " $ GOSUB myread $ IF ans $ THEN $ usemultiplicity="define" $ ELSE $ usemultiplicity="undef" $ ENDIF $! $! Ask if they want to build with 64-bit support $ IF (archname.NES."VMS_VAX").and.("''f$extract(1,3, f$getsyi(""version""))'".ges."7.1") $ THEN $ bool_dflt = "n" $ IF F$TYPE(use64bitint) .NES. "" $ THEN $ IF use64bitint .OR. use64bitint .eqs. "define" THEN bool_dflt = "y" $ ENDIF $ echo "" $ echo "You have natively 64-bit long integers." $ echo "" $ echo "Perl can be built to take advantage of 64-bit integer types" $ echo "on some systems, To do so, Configure can be run with -Duse64bitint." $ echo "Choosing this option will most probably introduce binary incompatibilities." $ echo "" $ echo "If this does not make any sense to you, just accept the default '" + bool_dflt + "'." $ rp = "Try to use 64-bit integers, if available? [''bool_dflt'] " $ GOSUB myread $ use64bitint = ans $! $ bool_dflt = "n" $ IF F$TYPE(use64bitall) .NES. "" $ THEN $ IF use64bitall .OR. use64bitall .eqs. "define" THEN bool_dflt = "y" $ ENDIF $ echo "" $ echo "You may also choose to try maximal 64-bitness. It means using as much" $ echo "64-bitness as possible on the platform. This in turn means even more" $ echo "binary incompatibilities. On the other hand, your platform may not" $ echo "have any more 64-bitness available than what you already have chosen." $ echo "" $ echo "If this does not make any sense to you, just accept the default '" + bool_dflt + "'." $ rp = "Try to use maximal 64-bit support, if available? [''bool_dflt'] " $ GOSUB myread $ use64bitall=ans $ IF use64bitall .AND. .NOT. use64bitint $ THEN $ echo "" $ echo "Since you have chosen a maximally 64-bit build, I'm also turning on" $ echo "the use of 64-bit integers." $ use64bitint="Y" $ ENDIF $! $ bool_dflt = use64bitall $ IF F$TYPE(uselargefiles) .NES. "" $ THEN $ IF uselargefiles .OR. uselargefiles .eqs. "define" THEN bool_dflt = "y" $ ENDIF $ echo "" $ echo "Perl can be built to understand large files (files larger than 2 gigabytes)" $ echo "on some systems. To do so, Configure can be run with -Duselargefiles." $ echo "" $ echo "If this does not make any sense to you, just accept the default '" + bool_dflt + "'." $ rp = "Try to understand large files, if available? [''bool_dflt'] " $ GOSUB myread $ uselargefiles=ans $! $ bool_dflt = "n" $ IF F$TYPE(uselongdouble) .NES. "" $ THEN $ IF uselongdouble .OR. uselongdouble .eqs. "define" THEN bool_dflt = "y" $ ENDIF $ echo "" $ echo "Perl can be built to take advantage of long doubles which" $ echo "(if available) may give more accuracy and range for floating point numbers." $ echo "" $ echo "If this does not make any sense to you, just accept the default '" + bool_dflt + "'." $ rp = "Try to use long doubles, if available? [''bool_dflt'] " $ GOSUB myread $ uselongdouble = ans $! $ ENDIF ! not VAX && >= 7.1 $! $ IF usesitecustomize .OR. usesitecustomize .eqs. "define" $ THEN $ usesitecustomize = "define" $ ELSE $ usesitecustomize = "undef" $ ENDIF $! $! Ask about threads, if appropriate $ IF ccname .EQS. "DEC" .OR. ccname .EQS. "CXX" $ THEN $ echo "" $ echo "Perl can be built to take advantage of threads on some systems." $ echo "To do so, configure.com can be run with -""Dusethreads""." $ echo "" $ echo "Note that Perl built with threading support runs slightly slower" $ echo "and uses more memory than plain Perl. The current implementation" $ echo "is believed to be stable, but it is fairly new, and so should be" $ echo "treated with caution." $ echo "" $ bool_dflt = "n" $ if f$type(usethreads) .nes. "" $ then $ if usethreads .or. usethreads .eqs. "define" then bool_dflt="y" $ endif $! Catch cases where user specified ithreads or 5005threads but $! forgot -Dusethreads $ if f$type(useithreads) .nes. "" $ then $ if useithreads .or. useithreads .eqs. "define" then bool_dflt="y" $ endif $ if f$type(use5005threads) .nes. "" $ then $ if use5005threads .or. use5005threads .eqs. "define" then bool_dflt="y" $ endif $ echo "If this doesn't make any sense to you, just accept the default '" + bool_dflt + "'." $ rp = "Build a threading Perl? [''bool_dflt'] " $ GOSUB myread $ if ans $ THEN $ use_threads="T" $ ! Shall we do the 5.005-type threads, or IThreads? $ echo "Since release 5.6, Perl has had two different threading implementations," $ echo "the newer interpreter-based version (ithreads) with one interpreter per" $ echo "thread, and the older 5.005 version (5005threads)." $ echo "The 5005threads version is effectively unmaintained and will probably be" $ echo "removed in Perl 5.10, so there should be no need to build a Perl using it" $ echo "unless needed for backwards compatibility with some existing 5.005threads" $ echo "code." $ echo "" $ bool_dflt = "y" $ if f$type(useithreads) .nes. "" $ then $ if useithreads .eqs. "undef" then bool_dflt="n" $ endif $ if f$type(use5005threads) .nes. "" $ then $ if use5005threads .or. use5005threads .eqs. "define" then bool_dflt="n" $ endif $ rp = "Use the newer intepreter-based ithreads? [''bool_dflt'] " $ GOSUB myread $ use_ithreads=ans $ if use_ithreads $ THEN $ use_5005_threads="N" $ ELSE $ use_5005_threads="Y" $ ENDIF $ ! Are they on VMS 7.1 or greater? $ IF "''f$extract(1,3, f$getsyi(""version""))'" .GES. "7.1" $ THEN $ echo "" $ echo "Threaded Perl can be linked to use system upcalls on your system. This feature" $ echo "allows the thread scheduler to be made aware of system events (such as I/O)" $ echo "so as to prevent a single thread from blocking all the threads in a program," $ echo "even on a single-processor machine." $ bool_dflt = "y" $ IF f$type(usethreadupcalls) .NES. "" $ THEN $ if .not. usethreadupcalls .or. usethreadupcalls .eqs. "undef" then bool_dflt="n" $ ENDIF $ rp = "Enable thread upcalls? [''bool_dflt'] " $ gosub myread $ IF ans $ THEN $ thread_upcalls = "MTU=MTU=1" $ usethreadupcalls = "define" $ ! Are they on alpha or itanium? $ IF (archname .NES. "VMS_VAX") .AND. ("''f$extract(1,3, f$getsyi(""version""))'" .GES. "7.2") $ THEN $ echo "" $ echo "Threaded Perl can be linked to use multiple kernel threads on your system." $ echo "This feature allows multiple user threads to make use of multiple CPUs on" $ echo "a multi-processor machine." $ bool_dflt = "n" $ IF f$type(usekernelthreads) .nes. "" $ THEN $ if usekernelthreads .or. usekernelthreads .eqs. "define" then bool_dflt="y" $ ENDIF $ rp = "Enable multiple kernel threads? [''bool_dflt'] " $ gosub myread $ IF ans $ THEN $ thread_kernel = "MTK=MTK=1" $ usekernelthreads = "define" $ ENDIF $ ENDIF $ ENDIF $ ENDIF $ ENDIF $ ENDIF $ IF F$TYPE(usethreadupcalls) .EQS. "" THEN usethreadupcalls = "undef" $ IF F$TYPE(usekernelthreads) .EQS. "" THEN usekernelthreads = "undef" $ IF archname .NES. "VMS_VAX" $ THEN $! Case sensitive? $ echo "" $ echo "By default, perl (and pretty much everything else on VMS) uses" $ echo "case-insensitive linker symbols. Which is to say, when the" $ echo "underlying C code makes a call to a routine called Perl_foo in" $ echo "the source, the name in the object modules or shareable images" $ echo "is really PERL_FOO. There are some packages that use an" $ echo "embedded perl interpreter that instead require case-sensitive" $ echo "linker symbols." $ echo "" $ echo "If you have no idea what this means, and do not have" $ echo "any program requiring anything, choose the default." $ bool_dflt = be_case_sensitive $ if f$type(usecasesensitive) .nes. "" $ then $ if usecasesensitive .or. usecasesensitive .eqs. "define" then bool_dflt = "y" $ if f$extract(0,1,f$edit(usecasesensitive,"collapse,upcase")).eqs."N" .or. usecasesensitive .eqs. "undef" then bool_dflt = "n" $ endif $ rp = "Build with case-sensitive symbols? [''bool_dflt'] " $ GOSUB myread $ be_case_sensitive = ans $! IEEE math? $ echo "" $ echo "Perl normally uses IEEE format (T_FLOAT) floating point numbers on" $ echo "Alpha and Itanium, but if you need G_FLOAT for binary compatibility" $ echo "with an external library or existing data, you may wish to disable" $ echo "the IEEE math option." $ bool_dflt = use_ieee_math $ if f$type(useieee) .nes. "" $ then $ if useieee .or. useieee .eqs. "define" $ then $ bool_dflt="y" $ else $ bool_dflt="n" $ endif $ endif $ rp = "Use IEEE math? [''bool_dflt'] " $ GOSUB myread $ use_ieee_math = ans $ ELSE $ be_case_sensitive = "n" $ use_ieee_math = "n" $ ENDIF $ useieee = "undef" $ usecasesensitive = "undef" $ if (use_ieee_math) then useieee = "define" $ if (be_case_sensitive) then usecasesensitive = "define" $! Unlink all versions? $ echo "" $ echo "By default, Perl's unlink() provides VMS-like behavior and only" $ echo "deletes the latest version of a file. Enabling this option builds" $ echo "Perl so that unlink() deletes all versions of a file." $ bool_dflt = unlink_all_versions $ if f$type(unlink_all_versions) .nes. "" $ then $ if unlink_all_versions .or. unlink_all_versions .eqs. "define" $ then $ bool_dflt="y" $ else $ bool_dflt="n" $ endif $ endif $ rp = "Make unlink() delete all versions of a file? [''bool_dflt'] " $ GOSUB myread $ unlink_all_versions = ans $ IF unlink_all_versions $ THEN $ d_unlink_all_versions = "define" $ ELSE $ d_unlink_all_versions = "undef" $ ENDIF $! $! CC Flags $ echo "" $ echo "Your compiler may want other flags. For this question you should include" $ echo "/INCLUDE=(whatever) and /DEFINE=(whatever), flags and any other flags" $ echo "or qualifiers used by the compiler." $ echo "" $ echo "To use no flags, specify the word ""none""." $ dflt = user_c_flags $ rp = "Any additional cc flags? [''dflt'] " $ GOSUB myread $ IF ans .EQS. "none" THEN ans = "" $ user_c_flags = "''ans'" $! $! Ask whether they want to use secure logical translation when tainting $ echo "" $ echo "As Perl starts up, it checks several logical names, such as" $ echo "PERL5LIB and PERL_ENV_TABLES, which allow you to modify aspects" $ echo "of its behavior. For additional security, you may limit this" $ echo "process to executive- and kernel-mode translation when tainting" $ echo "is enabled. In this case, logical names normally skipped when" $ echo "tainting is enabled (e.g. PERL5OPTS) are translated as well." $ echo "If you do not choose to do this, the usual order of access modes" $ echo "is used for logical name translation." $ echo "" $ echo "This restriction does not apply to the %ENV hash or to implicit" $ echo "logical name translation during parsing of file specifications;" $ echo "these always use the normal sequence of access modes for logical" $ echo "name translation." $ bool_dflt = "y" $ if f$type(usesecurelog) .nes. "" $ then $ if f$extract(0,1,f$edit(usesecurelog,"collapse,upcase")).eqs."N" .or. usesecurelog .eqs. "undef" then bool_dflt = "n" $ endif $ rp = "Use secure logical name translation? [''bool_dflt'] " $ GOSUB myread $ d_secintgenv = ans $ usesecurelog = "undef" $ if (d_secintgenv) then usesecurelog = "define" $! $! Ask whether they want to default filetypes $ echo "" $ echo "When you pass the name of a program to Perl on the command line," $ echo "it generally doesn't supply any defaults unless the -S command" $ echo "line switch is specified. In keeping with the VMS tradition of" $ echo "default file types, however, you can configure Perl to try default" $ echo "file types of nothing, .pl, and .com, in that order (e.g. typing" $ echo """$ perl foo"" would cause Perl to look for foo., then foo.pl, and" $ echo "finally foo.com)." $ echo "" $ echo "This is currently broken in some configurations. Only enable it if" $ echo "you know what you are doing." $ bool_dflt = "n" $ if f$type(usedefaulttypes) .nes. "" $ then $ if usedefaulttypes .or. usedefaulttypes .eqs. "define" then bool_dflt="y" $ endif $ rp = "Always use default file types? [''bool_dflt'] " $ GOSUB myread $ d_alwdeftype = ans $ usedefaulttypes = "undef" $ if (d_alwdeftype) then usedefaulttypes = "define" $! $! determine whether to use malloc wrapping $ echo "" $ bool_dflt = "y" $ IF F$TYPE(usemallocwrap) .nes. "" $ then $ if .NOT. usemallocwrap .or. usemallocwrap .eqs. "undef" then bool_dflt = "n" $ endif $ rp = "Do you wish to wrap malloc calls to protect against potential overflows? [''bool_dflt'] " $ GOSUB myread $ IF ans $ THEN usemallocwrap = "define" $ ELSE usemallocwrap = "undef" $ ENDIF $! $! Ask if they want to use perl's memory allocator $ echo "" $ echo "Perl has a built-in memory allocator that is tuned for normal" $ echo "memory usage. It is oftentimes better than the standard system" $ echo "memory allocator. It also has the advantage of providing memory" $ echo "allocation statistics, if you choose to enable them." $ bool_dflt = "n" $ IF F$TYPE(usemymalloc) .nes. "" $ then $ if usemymalloc .or. usemymalloc .eqs. "define" then bool_dflt = "y" $ endif $ rp = "Do you wish to attempt to use the malloc that comes with ''package'? [''bool_dflt'] " $ GOSUB myread $ mymalloc = ans $ IF mymalloc $ THEN $ IF use_debugging_perl $ THEN $ echo "" $ echo "Perl can keep statistics on memory usage if you choose to use" $ echo "them. This is useful for debugging, but does have some" $ echo "performance overhead." $ bool_dflt = "n" $ rp = "Do you want the debugging memory allocator? [''bool_dflt'] " $ gosub myread $ use_debugmalloc = ans $ ENDIF $ ! Check which memory allocator we want $ echo "" $ echo "There are currently three different memory allocators: the" $ echo "default (which is a pretty good general-purpose memory manager)," $ echo "the TWO_POT allocator (which is optimized to save memory for" $ echo "larger allocations), and PACK_MALLOC (which is optimized to save" $ echo "memory for smaller allocations). They're all good, but if your" $ echo "usage tends towards larger chunks use TWO_POT, otherwise use" $ echo "PACK_MALLOC." $ dflt = "DEFAULT" $ rp = "Memory allocator (DEFAULT, TWO_POT, PACK_MALLOC) [''dflt'] " $ GOSUB myread $ if ans.eqs."TWO_POT" then use_two_pot_malloc = "Y" $ if ans.eqs."PACK_MALLOC" then use_pack_malloc = "Y" $ ENDIF $! $ known_extensions = "" $ xxx = "" $ OPEN/READ CONFIG 'manifestfound' $ext_loop: $ READ/END_OF_FILE=end_ext/ERROR=end_ext CONFIG line $ IF F$EXTRACT(0,4,line) .NES. "ext/" .AND. - F$EXTRACT(0,5,line) .NES. "dist/".AND. - F$EXTRACT(0,5,line) .NES. "cpan/" THEN goto ext_loop $ line = F$EDIT(line,"COMPRESS") $ line = F$ELEMENT(0," ",line) $ IF F$EXTRACT(0,4,line) .EQS. "ext/" $ THEN $ xxx = F$ELEMENT(1,"/",line) $ IF F$SEARCH("[-.ext]''xxx'.DIR;1") .EQS. "" THEN GOTO ext_loop $ ENDIF $ IF F$EXTRACT(0,5,line) .EQS. "dist/" $ THEN $ xxx = F$ELEMENT(1,"/",line) $ IF F$SEARCH("[-.dist]''xxx'.DIR;1") .EQS. "" THEN GOTO ext_loop $ ENDIF $ IF F$EXTRACT(0,5,line) .EQS. "cpan/" $ THEN $ xxx = F$ELEMENT(1,"/",line) $ IF F$SEARCH("[-.cpan]''xxx'.DIR;1") .EQS. "" THEN GOTO ext_loop $ ENDIF $ IF xxx .EQS. "DynaLoader" THEN goto ext_loop ! omit $! $! (extspec = xxx) =~ tr!-!/! $ extspec = "" $ idx = 0 $ extension_dir_name = xxx $ replace_dash_with_slash: $ before = F$ELEMENT(idx, "-", xxx) $ IF before .EQS. "-" THEN goto end_replace_dash_with_slash $ IF extspec .NES. "" $ THEN $ extspec = extspec + "/" $ ENDIF $ extspec = extspec + before $ idx = idx + 1 $ goto replace_dash_with_slash $ $ end_replace_dash_with_slash: $ $ xxx = known_extensions $ gosub may_already_have_extension $ IF $STATUS .EQ. 1 $ THEN $ xxx = nonxs_ext $ gosub may_already_have_extension $ ENDIF $ IF $STATUS .NE. 1 THEN goto ext_loop $ goto found_new_extension $! $ may_already_have_extension: $ idx = F$LOCATE(extspec, xxx) $ extlen = F$LENGTH(xxx) $ IF idx .EQ. extlen THEN return 1 $! But "Flirble" may just be part of "Acme-Flirble" $ IF idx .GT. 0 .AND. F$EXTRACT(idx - 1, 1, xxx) .NES. " " $ THEN $ xxx = F$EXTRACT(idx + F$LENGTH(extspec) + 1, extlen, xxx) $ GOTO may_already_have_extension $ ENDIF $! But "Foo" may just be part of "Foo-Bar" so check for equality. $ xxx = F$EXTRACT(idx, extlen - idx, xxx) $ IF F$ELEMENT(0, " ", xxx) .EQS. extspec $ THEN $ RETURN 3 $ ELSE $ xxx = F$EXTRACT(F$LENGTH(extspec) + 1, extlen, xxx) GOTO may_already_have_extension $ ENDIF $! $ found_new_extension: $ IF F$SEARCH("[-.ext.''extension_dir_name']*.xs") .EQS. "" .AND. F$SEARCH("[-.dist.''extension_dir_name']*.xs") .EQS. "" .AND. F$SEARCH("[-.cpan.''extension_dir_name']*.xs") .EQS. "" $ THEN $ nonxs_ext = nonxs_ext + " ''extspec'" $ ELSE $ known_extensions = known_extensions + " ''extspec'" $ ENDIF $ goto ext_loop $end_ext: $ close CONFIG $ DELETE/SYMBOL xxx $ DELETE/SYMBOL idx $ DELETE/SYMBOL extspec $ DELETE/SYMBOL extlen $ DELETE/SYMBOL extension_dir_name $ known_extensions = F$EDIT(known_extensions,"TRIM,COMPRESS") $ dflt = known_extensions $ IF ccname .NES. "DEC" .AND. ccname .NES. "CXX" $ THEN $ dflt = dflt - "POSIX" ! not with VAX C or GCC $ ENDIF $ dflt = dflt - "ByteLoader" ! needs to be ported $ dflt = dflt - "DB_File" ! needs to be ported $ dflt = dflt - "GDBM_File" ! needs porting/special library $ dflt = dflt - "IPC/SysV" ! needs to be ported $ dflt = dflt - "NDBM_File" ! needs porting/special library $ dflt = dflt - "ODBM_File" ! needs porting/special library $ dflt = dflt - "Sys/Syslog" ! needs porting/special library "GDBM_File macro LOG_DEBUG" $ IF .NOT. Has_socketshr .AND. .NOT. Has_Dec_C_Sockets $ THEN $ dflt = dflt - "Socket" ! optional on VMS $ ENDIF $ dflt = dflt - "Win32API/File" - "Win32" ! need Dave Cutler's other project $ nonxs_ext = nonxs_ext - "Win32CORE" $ dflt = F$EDIT(dflt,"TRIM,COMPRESS") $ nonxs_ext = F$EDIT(nonxs_ext,"TRIM,COMPRESS") $! $! Ask for their default list of extensions to build $ echo "" $ echo "It is time to specify which modules you want to build into" $ echo "perl. Most of these are standard and should be chosen, though" $ echo "you might, for example, want to build GDBM_File instead of" $ echo "SDBM_File if you have the GDBM library built on your machine." $ echo "" $ echo "Which modules do you want to build into perl?" $ rp = "[''dflt'] " $ GOSUB myread $ dynamic_ext = F$EDIT(ans,"TRIM,COMPRESS") $! $! %Config-I-VMS, determine build/make utility here (make gmake mmk mms) $ echo "" $ echo "Checking your ""make"" utilities..." $! If the 'build' that you use is not here add it and it's test $! switch to the _END_ of these strings (and increment max_build) $! (e.g. builders = builders + "/FOOMAKE" $! probers = probers + " -fooVersionSwitch" $! ) & please let me know about it. $ builders = "IMAKE/GNUMAKE/MGMAKE/GMAKE/MAKE/MMS/MMK" $ probers = "-f Makefile. -v!-f Makefile. -v!-f Makefile. -v!-f Makefile. -v!-f Makefile. -v!/IDENT!/IDENT" $ max_build = 7 $! $ orig_dflt = f$edit(builder,"UPCASE") $ if orig_dflt .eqs. "" then orig_dflt = "MMK" $ default_set = "" $ ok_builders = "" $ OPEN/WRITE/ERROR=Open_error CONFIG Makefile. $ WRITE CONFIG "dont_make_anything_yet:" $ WRITE CONFIG F$FAO("!_") $ CLOSE CONFIG $ n = 0 $ messages = F$ENVIRONMENT("MESSAGE") $Build_probe: $ build = F$ELEMENT(n,"/",builders) $ probe = F$ELEMENT(n,"!",probers) $ echo "Testing whether you have ''build' on your system..." $! $! Noted with GNU Make version 3.60 that the $status and $severity $! with the 'probe' Makefile appear to be: $STATUS == "%X1000000C" $! $SEVERITY == "4". $! $ SET NOON $ ON CONTROL_Y THEN GOTO Reenable_messages_build $ SET MESSAGE/NOFAC/NOSEV/NOIDENT/NOTEXT $ 'build' 'probe' $ IF ($SEVERITY .EQ. 1) ! not adequate? $ THEN $ echo "OK." $ IF (build .EQS. orig_dflt) $ THEN $ default_set = "TRUE" $ dflt = build $ ENDIF $ ok_builders = ok_builders + " " + build $ IF (.NOT. default_set) THEN dflt = build $ ELSE $ echo "Nope." $ ENDIF $Reenable_messages_build: $ SET MESSAGE 'messages' $ SET ON $ on control_y then goto clean_up $ n = n + 1 $ IF (n .LT. max_build) THEN GOTO Build_probe $! $ echo "" $ IF (ok_builders .NES. "") $ THEN $ echo "Here is the list of builders you can apparently use:" $ echo "(",ok_builders," )" $ rp = "Which """"make"""" utility do you wish to use? [''dflt'] " $ GOSUB myread $ ans = F$EDIT(ans,"TRIM, COMPRESS") $ ans = F$EXTRACT(0,F$LOCATE(" ",ans),ans) !throw out "-f Makefile." here $ IF (ans .EQS. "") $ THEN build = dflt $ ELSE build = ans $ ENDIF $ ELSE $ TYPE SYS$INPUT: $ DECK %Config-E-VMS, ERROR: Well this looks pretty serious. Perl5 cannot be compiled without a "make" utility of some sort and after checking my "builders" list I cannot find the symbol or command you use on your system to compile programs. $ EOD $ READ SYS$COMMAND/PROMPT="Which ""MMS"" do you use? " ans $ ans = F$EDIT(ans,"TRIM, COMPRESS") $ ans = F$EXTRACT(0,F$LOCATE(" ",ans),ans) !throw out "-f Makefile." here $ IF (ans .EQS. "") $ THEN build = dflt $ echo "I do not know where ""make"" is, and my life depends on it." $ echo "Go find a make program or fix your DCL$PATH setting!" $ echo "ABORTING..." $ SET DEFAULT 'vms_default_directory_name' !be kind rewind $ STOP $ EXIT 2 !$STATUS = "%X00000002" (error) $ ELSE $ build = ans $ ENDIF $ ENDIF $! $ DELETE/NOLOG/NOCONFIRM Makefile.; $ GOTO Beyond_open $Open_error: $ TYPE SYS$INPUT: $ DECK There seems to be trouble. I just tried to create a file in $ EOD $ echo4 'F$ENVIRONMENT("DEFAULT")' $ TYPE SYS$INPUT: $ DECK but was unsuccessful. I am stopping now. Please check that directories' PROTECTION bits. I will leave you in the directory where you started Configure.com $ EOD $ echo4 "ABORTING..." $ GOTO Clean_up $ STOP $ EXIT $! $Beyond_open: $! echo " Very well I will proceed with ""''build'""" $ make = F$EDIT(build,"UPCASE") $! $!: locate the preferred pager for this system $!pagers = "most|more|less|type/page" $ IF osvers .GES. "V6.1" $ THEN $ dflt = "type/page=save=10" $ ELSE $ dflt = "type/page" $ ENDIF $! assume that the presence of a most symbol indicates the presence $! of the pager. $ IF F$TYPE(most) .EQS. "STRING" THEN dflt = "most" $ IF F$TYPE(pager) .EQS. "STRING" THEN dflt = pager $ rp="What pager is used on your system? [''dflt'] " $ GOSUB myread $ pager = ans $! $! update makefile here $! echo4 "Updating makefile..." $! $ IF (make .EQS. "MMS").OR.(make .EQS. "MMK") $ THEN $ makefile = "" !wrt MANIFEST dir $ UUmakefile = "[-]DESCRIP.MMS" !wrt CWD dir $ DEFmakefile = "DESCRIP.MMS" !wrt DEF dir (?) $ Makefile_SH = "descrip_mms.template" $ ELSE $ makefile = " -f Makefile." !wrt MANIFEST dir $ UUmakefile = "[-]Makefile." !wrt CWD dir $ DEFmakefile = "Makefile." !wrt DEF dir (?) $ Makefile_SH = "Makefile.in" $ ENDIF $! $ IF macros .NES. "" $ THEN $ tmp = F$LENGTH(macros) $ macros = F$EXTRACT(0,(tmp-1),macros) !miss trailing comma $ macros = "/macro=(" + macros + ")" $ ENDIF $! Build up the extra C flags $! $ IF use_ieee_math $ THEN $ extra_flags = "''extra_flags'" + "/float=ieee/ieee=denorm" $ ELSE $ IF (archname.EQS."VMS_IA64") $ THEN $ extra_flags = "''extra_flags'" + "/float=g_float" $ ENDIF $ ENDIF $ IF be_case_sensitive $ THEN $ extra_flags = "''extra_flags'" + "/Names=As_Is" $ ENDIF $ extra_flags = "''extra_flags'" + "''user_c_flags'" $! $ min_pgflquota = "100000" $ pgflquota = F$STRING(F$GETJPI("","PGFLQUOTA")) $ IF pgflquota .LES. min_pgflquota $ THEN $ echo4 "Your PGFLQUOTA of ''pgflquota' appears too small to build ''package'." $ READ SYS$COMMAND/PROMPT="Continue? [n] " ans $ IF ans $ THEN $ echo4 "Continuing..." $ ELSE $ echo4 "ABORTING..." $ GOTO Clean_up $ ENDIF $ ENDIF $! $! PerlIO abstraction $! $ bool_dflt = "y" $ IF F$TYPE(useperlio) .NES. "" $ then $ if f$extract(0,1,f$edit(useperlio,"collapse,upcase")) .eqs. "N" .or. useperlio .eqs. "undef" then bool_dflt = "n" $ endif $ IF .NOT. silent $ THEN $ echo "Previous versions of ''package' used the standard IO mechanisms as" $ TYPE SYS$INPUT: $ DECK defined in . Versions 5.003_02 and later of perl allow alternate IO mechanisms via the PerlIO abstraction layer, but the stdio mechanism is still available if needed. The abstraction layer can use AT&T's sfio (if you already have sfio installed) or regular stdio. Using PerlIO with sfio may cause problems with some extension modules. $ EOD $ echo "If this does not make any sense to you, just accept the default '" + bool_dflt + "'." $ ENDIF $ rp = "Use the PerlIO abstraction layer? [''bool_dflt'] " $ GOSUB myread $ IF ans $ THEN $ useperlio = "define" $ ELSE $ echo "Ok, doing things the stdio way." $ useperlio = "undef" $ ENDIF $! $ echo "" $ echo4 "Checking the C run-time library." $! $! Former SUBCONFIGURE.COM $! $! - build a config.sh for VMS Perl. $! - use built config.sh to take config_h.SH -> config.h $! - also take vms/descrip_mms.template -> descrip.mms (VMS Makefile) $! vms/Makefile.in -> Makefile. (VMS GNU Makefile?) $! vms/Makefile.SH -> Makefile. (VMS GNU Makefile?) $! $! Note for folks from other platforms changing things in here: $! $! Fancy changes (based on compiler capabilities or VMS version or $! whatever) are tricky, so go ahead and punt on those. $! $! Simple changes, though (say, always setting something to 1, or undef, $! or something like that) are straightforward. Adding a new constant $! item for the ultimately created config.sh requires at least one $! (possibly more) line(s) to this file. $! $! Add a line in the format: $! $! $ WC "foo='undef'" $! $! somewhere between the line tagged '##BEGIN WRITE NEW CONSTANTS HERE##' $! and the one tagged '##END WRITE NEW CONSTANTS HERE##' (note the order $! is sorted ASCII and corresponds to the output of config.sh in the $! Bourne shell version of Configure). $! Be very careful with quoting, as it can be tricky. $! For example if instead of a constant string like 'undef' or 'define' $! you wanted to add something to VMS's config.sh that looks like: $! $! blank_string='' $! $! then add a line that looks like this before the $! '##END WRITE NEW CONSTANTS HERE##' tagged line: $! $! $ WC "blank_string='" + "'" $! $! (+ is the string concatenator and "''var'" has the effect $! of "${var}" in perl or sh, but "'const'" is not interpolated). $! $! Note that unitialized variables, such as a line like: $! $! $ WC "new_var='" + new_var + "'" $! $! should be avoided unless new_var has a value assigned prior $! to that line (think of perl's -w warnings). $! $! %DCL-W-UNDSYM, undefined symbol - check validity and spelling $! \NEW_VAR\ $! $! $ vms_ver = F$EXTRACT(1,3, osvers) $ IF F$LENGTH(Mcc) .EQ. 0 THEN Mcc := "cc" $ MCC = f$edit(mcc, "UPCASE") $ C_Compiler_Replace := "CC=CC=''Mcc'''ccflags'" $ IF ccname .EQS. "DEC" $ THEN $ Checkcc := "''Mcc'/prefix=all" $ ELSE $ IF ccname .EQS. "CXX" $ THEN $ Checkcc := cxx $ ELSE $ Checkcc := "''Mcc'" $ ENDIF $ ENDIF $ ccflags = ccflags + extra_flags $ IF be_case_sensitive $ THEN $ d_vms_be_case_sensitive = "define" $ ELSE $ d_vms_be_case_sensitive = "undef" $ ENDIF $! Some constant defaults. $ hwname = f$getsyi("HW_NAME") $ myname = myhostname $ IF myname .EQS. "" THEN myname = F$TRNLNM("SYS$NODE") $! $ ccdlflags="" $ cccdlflags="" $! $! FIXME -- This section does not really handle all the different permutations $! of 64-bitness, and it does not provide for the /POINTER_SIZE=64 compiler $! option that would be necessary to support the "explicit 64-bit interfaces" $! promised by -Dusemorebits. $! $ usemorebits = "undef" $ IF use64bitint .OR. use64bitint .EQS. "define" $ THEN $ use64bitint = "define" $ ivdformat="""Ld""" $ uvuformat="""Lu""" $ uvoformat="""Lo""" $ uvxformat="""Lx""" $ uvXUformat="""LX""" $ ELSE $ use64bitint = "undef" $ ivdformat="""ld""" $ uvuformat="""lu""" $ uvoformat="""lo""" $ uvxformat="""lx""" $ uvXUformat="""lX""" $ ENDIF $ IF uselongdouble .OR. uselongdouble .EQS. "define" $ THEN $ uselongdouble = "define" $ alignbytes="16" $ nveformat="""Le""" $ nvfformat="""Lf""" $ nvgformat="""Lg""" $ ELSE $ uselongdouble = "undef" $ nveformat="""e""" $ nvfformat="""f""" $ nvgformat="""g""" $ ENDIF $ IF use64bitall .OR. use64bitall .EQS. "define" $ THEN $ use64bitall = "define" $ ELSE $ use64bitall = "undef" $ ENDIF $ IF uselargefiles .OR. uselargefiles .EQS. "define" $ THEN $ uselargefiles = "define" $ ELSE $ uselargefiles = "undef" $ ENDIF $! $ usemymalloc = "undef" $ if mymalloc then usemymalloc = "define" $! $ perl_cc=Mcc $! $ IF (sharedperl .AND. archname .EQS. "VMS_AXP") $ THEN $ obj_ext=".abj" $ so="axe" $ dlext="axe" $ exe_ext=".axe" $ lib_ext=".alb" $ ELSE $ IF (sharedperl .AND. archname .EQS. "VMS_IA64") $ THEN $ obj_ext=".ibj" $ so="ixe" $ dlext="ixe" $ exe_ext=".ixe" $ lib_ext=".ilb" $ ELSE $ obj_ext=".obj" $ so="exe" $ dlext="exe" $ exe_ext=".exe" $ lib_ext=".olb" $ ENDIF $ ENDIF $ dlobj="dl_vms''obj_ext'" $! $ cppstdin="''perl_cc'/noobj/comments=as_is/preprocess=sys$output sys$input" $ cppminus=" " $ cpprun="''perl_cc'/noobj/comments=as_is/preprocess=sys$output sys$input" $ cpplast=" " $! $ timetype="time_t" $ signal_t="void" $ stdchar="char" $! $ IF mymalloc $ THEN d_mymalloc="define" $ ELSE d_mymalloc="undef" $ ENDIF $! $ usedevel="undef" $ usedl="define" $ startperl="""$ perl 'f$env(\""procedure\"")' \""'"+"'p1'\"" \""'"+"'p2'\"" \""'"+"'p3'\"" \""'"+"'p4'\"" \""'"+"'p5'\"" \""'"+"'p6'\"" \""'"+"'p7'\"" \""'"+"'p8'\""!\n" $ startperl=startperl + "$ exit++ + ++$status!=0 and $exit=$status=undef; while($#ARGV != -1 and $ARGV[$#ARGV] eq '"+"'){pop @ARGV;}""" $! $ IF ((use_threads) .AND. (vms_ver .LES. "6.2")) $ THEN $ libs="SYS$SHARE:CMA$LIB_SHR.EXE/SHARE SYS$SHARE:CMA$RTL.EXE/SHARE SYS$SHARE:CMA$OPEN_LIB_SHR.exe/SHARE SYS$SHARE:CMA$OPEN_RTL.exe/SHARE" $ ELSE $ libs=" " $ ENDIF $ IF ccname .EQS. "DEC" .OR. ccname .EQS. "CXX" $ THEN $ libc="(DECCRTL)" $ ELSE $ libc=" " $ ENDIF $! $! perllibs should be libs with all non-core libs (such as gdbm) removed. $! $ perllibs=libs $! $! $ IF archname .NES. "VMS_VAX" $ THEN $ d_PRId64 = "define" $ d_PRIu64 = "define" $ d_PRIo64 = "define" $ d_PRIx64 = "define" $ d_PRIXU64 = "define" $ sPRId64 = """Ld""" $ sPRIXU64 = """LX""" $ sPRIi64 = """Li""" $ sPRIo64 = """Lo""" $ sPRIu64 = """Lu""" $ sPRIx64 = """Lx""" $ d_quad = "define" $ quadtype = "long long" $ uquadtype = "unsigned long long" $ quadkind = "3" $! $ d_frexpl = "define" $ d_modfl = "define" $ d_modflproto = "define" $ ELSE $ d_PRId64 = "undef" $ d_PRIXU64 = "undef" $ d_PRIu64 = "undef" $ d_PRIo64 = "undef" $ d_PRIx64 = "undef" $ sPRId64 = "" $ sPRIXU64 = """lX""" $ sPRIi64 = "" $ sPRIo64 = "" $ sPRIu64 = "" $ sPRIx64 = "" $ d_quad = "undef" $ quadtype = "undef" $ uquadtype = "undef" $ quadkind = "undef" $! $ d_frexpl = "undef" $ d_modfl = "undef" $ d_modflproto = "undef" $ ENDIF $! $ IF useieee .OR. useieee .EQS. "define" $ THEN $ d_isnan = "define" $ d_isnanl = "define" $ ELSE $ d_isnan = "undef" $ d_isnanl = "undef" $ ENDIF $! $! Now some that we build up $! $ IF use_threads $ THEN $ IF use_5005_threads $ THEN $ arch = "''arch'-thread" $ archname = "''archname'-thread" $ d_old_pthread_create_joinable = "undef" $ old_pthread_create_joinable = " " $ use5005threads = "define" $ useithreads = "undef" $ ELSE $ arch = "''arch'-ithread" $ archname = "''archname'-ithread" $ d_old_pthread_create_joinable = "undef" $ old_pthread_create_joinable = " " $ use5005threads = "undef" $ useithreads = "define" $ ENDIF $ ELSE $ d_old_pthread_create_joinable = "undef" $ old_pthread_create_joinable = " " $ use5005threads = "undef" $ useithreads = "undef" $ ENDIF $! $! Some that we need to invoke the compiler for $! $! $! handy construction aliases/symbols $! $ OS := "open/write CONFIG []try.c" $ WS := "write CONFIG" $ CS := "close CONFIG" $ DS := "delete/nolog/noconfirm []try.*;*" $ Needs_Opt := N $ good_compile = %X10B90001 $ IF ccname .EQS. "GCC" $ THEN $ open/write OPTCHAN []try.opt $ write OPTCHAN "Gnu_CC:[000000]gcclib.olb/library" $ write OPTCHAN "Sys$Share:VAXCRTL/Share" $ Close OPTCHAN $ Needs_Opt := Y $ good_compile = %X10000001 $ ENDIF $ IF ccname .EQS. "CXX" $ THEN $ good_compile = %X15F60001 $ ENDIF $ good_link = %X10000001 $ tmp = "" ! null string default $! $ GOTO beyond_compile_ok $! $! Check for type sizes $! $type_size_check: $! $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "int main()" $ WS "{" $ WS "printf(""%d\n"", sizeof(''tmp'));" $ WS "exit(0);" $ WS "}" $ CS $ GOSUB compile $ RETURN $! $!: locate header file $findhdr: $! $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "#include <''tmp'>" $ WS "int main()" $ WS "{" $ WS "printf(""define\n"");" $ WS "exit(0);" $ WS "}" $ CS $ GOSUB link_ok $ RETURN $! $!: define an alternate in-header-list? function $inhdr: $! $ GOSUB findhdr $ IF compile_status .EQ. good_compile .AND. link_status .EQ. good_link $ THEN $ echo4 "<''tmp'> found." $ tmp = "define" $ ELSE $ echo4 "<''tmp'> NOT found." $ tmp = "undef" $ ENDIF $ RETURN $! $!: define an is-in-libc? function $inlibc: $ GOSUB link_ok $ IF compile_status .EQ. good_compile .AND. link_status .EQ. good_link $ THEN $ echo4 "''tmp'() found." $ tmp = "define" $ ELSE $ echo4 "''tmp'() NOT found." $ tmp = "undef" $ ENDIF $ RETURN $! $!: define a shorthand compile call $compile: $ GOSUB link_ok $just_mcr_it: $ IF compile_status .EQ. good_compile .AND. link_status .EQ. good_link $ THEN $ OPEN/WRITE CONFIG []try.out $ DEFINE/USER_MODE SYS$ERROR CONFIG $ DEFINE/USER_MODE SYS$OUTPUT CONFIG $ MCR []try.exe $ CLOSE CONFIG $ OPEN/READ CONFIG []try.out $ READ CONFIG tmp $ CLOSE CONFIG $ DELETE/NOLOG/NOCONFIRM []try.out; $ DELETE/NOLOG/NOCONFIRM []try.exe; $ ELSE $ tmp = "" ! null string default $ ENDIF $ RETURN $! $link_ok: $ GOSUB compile_ok $ DEFINE/USER_MODE SYS$ERROR _NLA0: $ DEFINE/USER_MODE SYS$OUTPUT _NLA0: $ SET NOON $ IF Needs_Opt $ THEN $ 'ld' try.obj,try.opt/opt $ link_status = $status $ ELSE $ 'ld' try.obj $ link_status = $status $ ENDIF $ SET ON $ IF F$SEARCH("try.obj") .NES. "" THEN DELETE/NOLOG/NOCONFIRM try.obj; $ RETURN $! $!: define a shorthand compile call for compilations that should be ok. $compile_ok: $ DEFINE/USER_MODE SYS$ERROR _NLA0: $ DEFINE/USER_MODE SYS$OUTPUT _NLA0: $ SET NOON $ 'Checkcc' try.c $ compile_status = $status $ SET ON $ DELETE/NOLOG/NOCONFIRM try.c; $ RETURN $! $beyond_compile_ok: $! $! Check for __STDC__ $! $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "int main()" $ WS "{" $ WS "#ifdef __STDC__" $ WS "printf(""42\n"");" $ WS "#else" $ WS "printf(""1\n"");" $ WS "#endif" $ WS "exit(0);" $ WS "}" $ CS $ GOSUB compile $ cpp_stuff=tmp $ IF F$INTEGER(tmp) .eq. 42 $ THEN $ echo4 "Your C compiler and pre-processor defines the symbol:" $ echo4 "__STDC__" $ ENDIF $! $! Check for double size $! $ echo4 "Checking to see how big your double precision numbers are..." $ tmp="double" $ GOSUB type_size_check $ doublesize = tmp $ echo "Your double is ''doublesize' bytes long." $! $! Check for long double size $! $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#pragma message disable ALL" ! VAX compilers may have distracting informationals $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "int main()" $ WS "{" $ WS "printf(""%d\n"", sizeof(long double));" $ WS "exit(0);" $ WS "}" $ CS $ echo4 "Checking to see if you have long double..." $ GOSUB link_ok $ IF link_status .NE. good_link $ THEN $ longdblsize="0" $ d_longdbl="undef" $ echo "You do not have long double." $ ELSE $ echo "You have long double." $ echo4 "Checking to see how big your long doubles are..." $ GOSUB just_mcr_it $ longdblsize = tmp $ d_longdbl = "define" $ echo "Your long doubles are ''longdblsize' bytes long." $ ENDIF $! $ IF d_longdbl .OR. d_longdbl .EQS. "define" $ THEN $ d_PRIEUldbl = "define" $ d_PRIFUldbl = "define" $ d_PRIGUldbl = "define" $ d_PRIeldbl = "define" $ d_PRIfldbl = "define" $ d_PRIgldbl = "define" $ sPRIEUldbl = """LE""" $ sPRIFUldbl = """LF""" $ sPRIGUldbl = """LG""" $ sPRIeldbl = """Le""" $ sPRIfldbl = """Lf""" $ sPRIgldbl = """Lg""" $ ELSE $ d_PRIEUldbl = "undef" $ d_PRIFUldbl = "undef" $ d_PRIGUldbl = "undef" $ d_PRIeldbl = "undef" $ d_PRIfldbl = "undef" $ d_PRIgldbl = "undef" $ sPRIEUldbl = "" $ sPRIFUldbl = "" $ sPRIGUldbl = "" $ sPRIeldbl = "" $ sPRIfldbl = "" $ sPRIgldbl = "" $ ENDIF $ d_SCNfldbl = d_PRIfldbl $ sSCNfldbl = sPRIfldbl ! expect consistency $! $!: check for long long $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "int main()" $ WS "{" $ WS "printf(""%d\n"", sizeof(long long));" $ WS "exit(0);" $ WS "}" $ CS $ echo4 "Checking to see if you have long long..." $ GOSUB link_ok $ IF link_status .NE. good_link $ THEN $ longlongsize="0" $ d_longlong="undef" $ echo "You do not have long long." $ ELSE $ echo "You have long long." $ echo4 "Checking to see how big your long longs are..." $ GOSUB just_mcr_it $ longlongsize = tmp $ d_longlong = "define" $ echo "Your long longs are ''longlongsize' bytes long." $ ENDIF $! $! Check the prototype for getgid $! $ echo "Looking for the type for group ids returned by getgid()." $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "#include " $ WS "int main()" $ WS "{" $ WS "gid_t foo;" $ WS "exit(0);" $ WS "}" $ CS $ GOSUB compile_ok $ IF compile_status .NE. good_compile $ THEN $! Okay, gid_t failed. Must be unsigned int $ gidtype = "unsigned int" $ echo4 "assuming ""''gidtype'""." $ ELSE $ gidtype = "gid_t" $ echo4 "gid_t found." $ ENDIF $! $! Check to see if we've got dev_t $! $ echo "Looking for the type for dev." $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "#include " $ WS "int main()" $ WS "{" $ WS "dev_t foo;" $ WS "exit(0);" $ WS "}" $ CS $ GOSUB compile_ok $ IF compile_status .NE. good_compile $ THEN $! Okay, dev_t failed. Must be unsigned int $ devtype = "unsigned int" $ echo4 "assuming ""''devtype'""." $ ELSE $ devtype = "dev_t" $ echo4 "dev_t found." $ ENDIF $! $! Check to see if we've got unistd.h (which we ought to, but you never know) $! $ i_netdb = "undef" $ tmp = "unistd.h" $ GOSUB inhdr $ i_unistd = tmp $! $! Check to see if we've got utime.h (which we should use if we have) $! $ i_netdb = "undef" $ tmp = "utime.h" $ GOSUB inhdr $ i_utime = tmp $! $! do we have getppid()? $! $ IF i_unistd .EQS. "define" $ THEN $ OS $ WS "#include " $ WS "#include " $ WS "int main() {" $ WS "printf(""%d\n"",getppid());" $ WS "return(0);" $ WS "}" $ CS $ tmp = "getppid" $ GOSUB inlibc $ d_getppid = tmp $ ELSE $ d_getppid = "undef" $ ENDIF $! $!: see if this is a libutil.h system $! $ tmp = "libutil.h" $ GOSUB inhdr $ i_libutil = tmp $! $! Check to see if we've got shadow.h (probably not, but...) $! $ tmp = "shadow.h" $ GOSUB inhdr $ i_shadow = tmp $! $! Check to see if we've got socks.h (probably not, but...) $! $ tmp = "socks.h" $ GOSUB inhdr $ i_socks = tmp $! $! Check the prototype for select $! $ IF Has_Dec_C_Sockets .OR. Has_Socketshr $ THEN $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "#include " $ IF i_unistd .EQS. "define" THEN WS "#include " $ IF Has_Socketshr $ THEN $ WS "#include " $ ELSE $ WS "#include " $ WS "#include " $ ENDIF $ WS "int main()" $ WS "{" $ WS "fd_set *foo;" $ WS "int bar;" $ WS "foo = NULL;" $ WS "bar = select(2, foo, foo, foo, NULL);" $ WS "exit(0);" $ WS "}" $ CS $ GOSUB compile_ok $ IF compile_status .NE. good_compile $ THEN $! Okay, select failed. Must be an int * $ selecttype = "int *" $ echo4 "select() NOT found." $ ELSE $ selecttype="fd_set *" $ echo4 "select() found." $ ENDIF $ ELSE $ ! No sockets, so stick in an int * : no select, so pick a harmless default $ selecttype = "int *" $ ENDIF $! $! Check to see if fd_set exists $! $ echo "Checking to see how well your C compiler handles fd_set and friends ..." $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "#include " $ IF Has_Socketshr $ THEN $ WS "#include " $ ENDIF $ IF Has_Dec_C_Sockets $ THEN $ WS "#include " $ WS "#include " $ ENDIF $ WS "int main()" $ WS "{" $ WS "fd_set *foo;" $ WS "int bar;" $ WS "exit(0);" $ WS "}" $ CS $ GOSUB compile_ok $ IF compile_status .ne. good_compile $ THEN $! Okay, fd_set failed. Must not exist $ d_fd_set = "undef" $ echo4 "Hmm, your compiler has some difficulty with fd_set." $ ELSE $ d_fd_set="define" $ echo4 "Well, your system knows about the normal fd_set typedef..." $ ENDIF $! $! Check for inttypes.h $! $ tmp = "inttypes.h" $ GOSUB inhdr $ i_inttypes = tmp $! $! Check to see if off64_t exists $! $ echo4 "Checking to see if you have off64_t..." $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "#include " $ WS "#''i_inttypes' IIH" $ WS "#ifdef IIH" $ WS "#include " $ WS "#endif" $ WS "int main()" $ WS "{" $ WS "off64_t bar;" $ WS "exit(0);" $ WS "}" $ CS $ GOSUB compile_ok $ IF compile_status .EQ. good_compile $ THEN $ d_off64_t="define" $ echo "You have off64_t." $ ELSE $ d_off64_t = "undef" $ echo "You do not have off64_t." $ ENDIF $! $! Check to see if fpos64_t exists $! $ echo4 "Checking to see if you have fpos64_t..." $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "#include " $ WS "#''i_inttypes' IIH" $ WS "#ifdef IIH" $ WS "#include " $ WS "#endif" $ WS "int main()" $ WS "{" $ WS "fpos64_t bar;" $ WS "exit(0);" $ WS "}" $ CS $ GOSUB compile_ok $ IF compile_status .EQ. good_compile $ THEN $ d_fpos64_t="define" $ echo "You have fpos64_t." $ ELSE $ d_fpos64_t = "undef" $ echo "You do not have fpos64_t." $ ENDIF $! $! Check to see if int64_t exists $! $ echo4 "Checking to see if you have int64_t..." $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "#include " $ WS "#''i_inttypes' IIH" $ WS "#ifdef IIH" $ WS "#include " $ WS "#endif" $ WS "int main()" $ WS "{" $ WS "int64_t bar;" $ WS "exit(0);" $ WS "}" $ CS $ GOSUB compile_ok $ IF compile_status .EQ. good_compile $ THEN $ d_int64_t="define" $ echo "You have int64_t." $ ELSE $ d_int64_t = "undef" $ echo "You do not have int64_t." $ ENDIF $! $! Check to see if fseeko exists $! $ OS $ WS "#include " $ WS "int main()" $ WS "{" $ WS "FILE *f=NULL;" $ WS "fseeko(f,(off_t)0,SEEK_SET);" $ WS "return(0);" $ WS "}" $ CS $ tmp = "fseeko" $ GOSUB inlibc $ d_fseeko = tmp $! $! Check to see if ftello exists $! $ OS $ WS "#include " $ WS "int main()" $ WS "{" $ WS "FILE *f=NULL; off_t o=0;" $ WS "o=ftello(f);" $ WS "return(0);" $ WS "}" $ CS $ tmp = "ftello" $ GOSUB inlibc $ d_ftello = tmp $! $!: see if this is a netdb.h system $ IF Has_Dec_C_Sockets $ THEN $ tmp = "netdb.h" $ GOSUB inhdr $ i_netdb = tmp $ ENDIF $! $! Check for h_errno $! $ echo4 "Checking to see if you have h_errno..." $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ IF i_unistd .EQS. "define" THEN WS "#include " $ IF i_netdb .EQS. "define" THEN WS "#include " $ WS "int main()" $ WS "{" $ WS "h_errno = 3;" $ WS "exit(0);" $ WS "}" $ CS $ GOSUB link_ok $ IF compile_status .EQ. good_compile .AND. link_status .EQ. good_link $ THEN $ d_herrno="define" $ echo "You have h_errno." $ ELSE $ d_herrno="undef" $ echo "You do not have h_errno." $ ENDIF $! $! Check to see if gethostname exists $! $ IF Has_Dec_C_Sockets .OR. Has_Socketshr $ THEN $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "#include " $ IF Has_Socketshr $ THEN $ WS "#include " $ ELSE $ WS "#include " $ WS "#include " $ ENDIF $ WS "int main()" $ WS "{" $ WS "char name[100];" $ WS "int bar, baz;" $ WS "bar = 100;" $ WS "baz = gethostname(name, bar);" $ WS "exit(0);" $ WS "}" $ CS $ GOSUB link_ok $ IF compile_status .EQ. good_compile .AND. link_status .EQ. good_link $ THEN $ d_gethname="define" $ echo4 "gethostname() found." $ ELSE $ d_gethname="undef" $ ENDIF $ ELSE $ ! No sockets, so no gethname $ d_gethname = "undef" $ ENDIF $! $! Check for sys/file.h $! $ tmp = "sys/file.h" $ GOSUB inhdr $ i_sysfile = tmp $! $! $! Check for sys/ioctl.h $! $ tmp = "sys/ioctl.h" $ GOSUB inhdr $ i_sysioctl = tmp $! $! Check for sys/utsname.h $! $ tmp = "sys/utsname.h" $ GOSUB inhdr $ i_sysutsname = tmp $! $! Check for syslog.h $! $ tmp = "syslog.h" $ GOSUB inhdr $ i_syslog = tmp $! $! Check for poll.h $! $ tmp = "poll.h" $ GOSUB inhdr $ i_poll = tmp $! $! Check for sys/uio.h $! $ tmp = "sys/uio.h" $ GOSUB inhdr $ i_sysuio = tmp $! $! Check for sys/mode.h $! $ tmp = "sys/mode.h" $ GOSUB inhdr $ i_sysmode = tmp $! $! Check for poll.h $! $ tmp = "sys/poll.h" $ gosub inhdr $ i_syspoll = tmp $! $! Check for sys/access.h $! $ tmp = "sys/access.h" $ GOSUB inhdr $ i_sysaccess = tmp $! $! Check for sys/security.h $! $ tmp = "sys/security.h" $ GOSUB inhdr $ i_syssecrt = tmp $! $! Check for fcntl.h $! $ tmp = "fcntl.h" $ GOSUB inhdr $ i_fcntl = tmp $! $! Check for fcntl $! $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "#include " $ WS "int main()" $ WS "{" $ WS "fcntl(1,2,3);" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "fcntl" $ GOSUB inlibc $ d_fcntl = tmp $! $! Check for fcntl locking capability $! $ echo4 "Checking if fcntl-based file locking works... " $ tmp = "undef" $ IF d_fcntl .EQS. "define" $ THEN $ OS $ WS "#include " $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "#include " $ WS "int main() {" $ WS "#if defined(F_SETLK) && defined(F_SETLKW)" $ WS " struct flock flock;" $ WS " int retval, fd;" $ WS " fd = open(""[-]perl.c"", O_RDONLY);" $ WS " flock.l_type = F_RDLCK;" $ WS " flock.l_whence = SEEK_SET;" $ WS " flock.l_start = flock.l_len = 0;" $ WS " retval = fcntl(fd, F_SETLK, &flock);" $ WS " close(fd);" $ WS " (retval < 0 ? printf(""undef\n"") : printf(""define\n""));" $ WS "#else" $ WS " printf(""undef\n"");" $ WS "#endif" $ WS "}" $ CS $ GOSUB link_ok $ IF compile_status .EQ. good_compile .AND. link_status .EQ. good_link $ THEN $ GOSUB just_mcr_it $ IF tmp .EQS. "define" $ THEN $ echo4 "Yes, it seems to work." $ ELSE $ echo4 "Nope, it didn't work." $ ENDIF $ ELSE $ echo4 "I'm unable to compile the test program, so I'll assume not." $ tmp = "undef" $ ENDIF $ ELSE $ echo4 "Nope, since you don't even have fcntl()." $ ENDIF $ d_fcntl_can_lock = tmp $! $! Check for memchr $! $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "int main()" $ WS "{" $ WS "char * place;" $ WS "place = memchr(""foo"", 47, 3);" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "memchr" $ GOSUB inlibc $ d_memchr = tmp $! $! Check for strtoull $! $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "int main()" $ WS "{" $ WS "unsigned __int64 result;" $ WS "result = strtoull(""123123"", NULL, 10);" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "strtoull" $ GOSUB inlibc $ d_strtoull = tmp $! $! Check for strtouq $! $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "int main()" $ WS "{" $ WS "unsigned __int64 result;" $ WS "result = strtouq(""123123"", NULL, 10);" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "strtouq" $ GOSUB inlibc $ d_strtouq = tmp $! $! Check for strtoll $! $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "int main()" $ WS "{" $ WS "__int64 result;" $ WS "result = strtoll(""123123"", NULL, 10);" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "strtoll" $ GOSUB inlibc $ d_strtoll = tmp $! $! Check for strtoq $! $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "int main()" $ WS "{" $ WS "__int64 result;" $ WS "result = strtoq(""123123"", NULL, 10);" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "strtoq" $ GOSUB inlibc $ d_strtoq = tmp $! $! Check for strtold $! $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "int main()" $ WS "{" $ WS "long double result;" $ WS "result = strtold(""123123"", NULL, 10);" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "strtold" $ GOSUB inlibc $ d_strtold = tmp $! $! Check for atoll $! $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "int main()" $ WS "{" $ WS " __int64 result;" $ WS "result = atoll(""123123"");" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "atoll" $ GOSUB inlibc $ d_atoll = tmp $! $! Check for atolf $! $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "int main()" $ WS "{" $ WS "long double" $ WS "result = atolf(""123123"");" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "atolf" $ GOSUB inlibc $ d_atolf = tmp $! $! Check for access $! $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "int main()" $ WS "{" $ WS "access(""foo"", F_OK);" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "acess" $ GOSUB inlibc $ d_access = tmp $! $! Check for bzero $! $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "#include " $ WS "int main()" $ WS "{" $ WS "char foo[10];" $ WS "bzero(foo, 10);" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "bzero" $ GOSUB inlibc $ d_bzero = tmp $! $! Check for bcopy $! $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "#include " $ WS "int main()" $ WS "{" $ WS "char foo[10], bar[10];" $ WS "bcopy(""foo"", bar, 3);" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "bcopy" $ GOSUB inlibc $ d_bcopy = tmp $! $! Check for mkstemp $! $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "int main()" $ WS "{" $ WS "mkstemp(""foo"");" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "mkstemp" $ GOSUB inlibc $ d_mkstemp = tmp $! $! Check for mkstemps $! $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "int main()" $ WS "{" $ WS "mkstemps(""foo"", 1);" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "mkstemps" $ GOSUB inlibc $ d_mkstemps = tmp $! $! Check for mkdtemp $! $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "int main()" $ WS "{" $ WS "mkdtemp(""foo"");" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "mkdtemp" $ GOSUB inlibc $ d_mkdtemp = tmp $! $! Check for poll $! $ if i_poll .eqs. "define" $ then $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "int main()" $ WS "{" $ WS "struct pollfd pfd;" $ WS "int count=poll(&pfd,1,0);" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "poll" $ GOSUB inlibc $ d_poll = tmp $ else $ d_poll = "undef" $ endif $! $! Check for setvbuf $! $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "int main()" $ WS "{" $ WS "FILE *foo;" $ WS "char Buffer[99];" $ WS "foo = fopen(""foo"", ""r"");" $ WS "setvbuf(foo, Buffer, 0, 0);" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "setvbuf" $ GOSUB inlibc $ d_setvbuf = tmp $! $! see if sfio.h is available $! see if sfio library is available $! Ok, but do we want to use it. $! IF F$TYPE(usesfio) .EQS. "" THEN usesfio = "undef" $! IF val .EQS. "define" $! THEN $! IF usesfio .EQS. "define" $! THEN dflt = "y" $! ELSE dflt = "n" $! ENDIF $! echo "''package' can use the sfio library, but it is experimental." $! IF useperlio .EQS. "undef" $! THEN $! echo "For sfio also the PerlIO abstraction layer is needed." $! echo "Earlier you said you would not want that." $! ENDIF $! rp="You seem to have sfio available, do you want to try using it? [''dflt'] " $! GOSUB myread $! IF ans .EQS. "" THEN ans = dflt $! IF ans $! THEN $! echo "Ok, turning on both sfio and PerlIO, then." $! useperlio="define" $! val="define" $! ELSE $! echo "Ok, avoiding sfio this time. I'll use stdio instead." $! val="undef" $! ENDIF $! ELSE $! IF usesfio .EQS. "define" $! THEN $! echo4 "Sorry, cannot find sfio on this machine." $! echo4 "Ignoring your setting of usesfio=''usesfio'." $! val="undef" $! ENDIF $! ENDIF $! $! Check for setenv $! $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "int main()" $ WS "{" $ WS "setenv(""FOO"", ""BAR"", 0);" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "setenv" $ GOSUB inlibc $ d_setenv = tmp $! $! Check for setproctitle $! $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "int main()" $ WS "{" $ WS "setproctitle(""%s"", ""FOO"");" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "setproctitle" $ GOSUB inlibc $ d_setproctitle = tmp $! $! Check for $! $ IF Has_Dec_C_Sockets .or. Has_Socketshr $ THEN $ tmp = "netinet/in.h" $ GOSUB inhdr $ i_niin = tmp $ ELSE $ i_niin="undef" $ ENDIF $! $! Check for $! $ IF Has_Dec_C_Sockets .or. Has_Socketshr $ THEN $ tmp = "netinet/tcp.h" $ GOSUB inhdr $ i_netinettcp = tmp $ ELSE $ i_netinettcp="undef" $ ENDIF $! $! Check for endhostent $! $ IF Has_Dec_C_Sockets .or. Has_Socketshr $ THEN $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ IF Has_Socketshr $ THEN WS "#include " $ ELSE IF i_netdb .EQS. "define" THEN WS "#include " $ ENDIF $ WS "int main()" $ WS "{" $ WS "endhostent();" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "endhostent" $ GOSUB inlibc $ d_endhent = tmp $ ELSE $ d_endhent="undef" $ ENDIF $! $! Check for endnetent $! $ IF Has_Dec_C_Sockets .or. Has_Socketshr $ THEN $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ IF Has_Socketshr $ THEN WS "#include " $ ELSE IF i_netdb .EQS. "define" THEN WS "#include " $ ENDIF $ WS "int main()" $ WS "{" $ WS "endnetent();" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "endnetent" $ GOSUB inlibc $ d_endnent = tmp $ ELSE $ d_endnent="undef" $ ENDIF $! $! Check for endprotoent $! $ IF Has_Dec_C_Sockets .OR. Has_Socketshr $ THEN $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ IF Has_Socketshr $ THEN WS "#include " $ ELSE IF i_netdb .EQS. "define" THEN WS "#include " $ ENDIF $ WS "int main()" $ WS "{" $ WS "endprotoent();" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "endprotoent" $ GOSUB inlibc $ d_endpent = tmp $ ELSE $ d_endpent="undef" $ ENDIF $! $! Check for endservent $! $ IF Has_Dec_C_Sockets .OR. Has_Socketshr $ THEN $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ IF Has_Socketshr $ THEN WS "#include " $ ELSE IF i_netdb .EQS. "define" THEN WS "#include " $ ENDIF $ WS "int main()" $ WS "{" $ WS "endservent();" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "endservent" $ GOSUB inlibc $ d_endsent = tmp $ ELSE $ d_endsent="undef" $ ENDIF $! $! Check for sethostent $! $ IF Has_Dec_C_Sockets .OR. Has_Socketshr $ THEN $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ IF Has_Socketshr $ THEN WS "#include " $ ELSE IF i_netdb .EQS. "define" THEN WS "#include " $ ENDIF $ WS "int main()" $ WS "{" $ WS "sethostent(1);" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "sethostent" $ GOSUB inlibc $ d_sethent = tmp $ ELSE $ d_sethent="undef" $ ENDIF $! $! Check for setnetent $! $ IF Has_Dec_C_Sockets .OR. Has_Socketshr $ THEN $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ IF Has_Socketshr $ THEN WS "#include " $ ELSE IF i_netdb .EQS. "define" THEN WS "#include " $ ENDIF $ WS "int main()" $ WS "{" $ WS "setnetent(1);" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "setnetent" $ GOSUB inlibc $ d_setnent = tmp $ ELSE $ d_setnent="undef" $ ENDIF $! $! Check for setprotoent $! $ IF Has_Dec_C_Sockets .OR. Has_Socketshr $ THEN $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ IF Has_Socketshr $ THEN WS "#include " $ ELSE IF i_netdb .EQS. "define" THEN WS "#include " $ ENDIF $ WS "int main()" $ WS "{" $ WS "setprotoent(1);" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "setprotoent" $ GOSUB inlibc $ d_setpent = tmp $ ELSE $ d_setpent="undef" $ ENDIF $! $! Check for setservent $! $ IF Has_Dec_C_Sockets .OR. Has_Socketshr $ THEN $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ IF Has_Socketshr $ THEN WS "#include " $ ELSE IF i_netdb .EQS. "define" THEN WS "#include " $ ENDIF $ WS "int main()" $ WS "{" $ WS "setservent(1);" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "setservent" $ GOSUB inlibc $ d_setsent = tmp $ ELSE $ d_setsent="undef" $ ENDIF $! $! Check for gethostent $! $ IF Has_Dec_C_Sockets .OR. Has_Socketshr $ THEN $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ IF Has_Socketshr $ THEN WS "#include " $ ELSE IF i_netdb .EQS. "define" THEN WS "#include " $ ENDIF $ WS "int main()" $ WS "{" $ WS "gethostent();" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "gethostent" $ GOSUB inlibc $ d_gethent = tmp $ ELSE $ d_gethent="undef" $ ENDIF $! $! Check for getnetent $! $ IF Has_Dec_C_Sockets .OR. Has_Socketshr $ THEN $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ IF Has_Socketshr $ THEN WS "#include " $ ELSE IF i_netdb .EQS. "define" THEN WS "#include " $ ENDIF $ WS "int main()" $ WS "{" $ WS "getnetent();" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "getnetent" $ GOSUB inlibc $ d_getnent = tmp $ ELSE $ d_getnent="undef" $ ENDIF $! $! Check for getprotoent $! $ IF Has_Dec_C_Sockets .OR. Has_Socketshr $ THEN $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ IF Has_Socketshr $ THEN WS "#include " $ ELSE IF i_netdb .EQS. "define" THEN WS "#include " $ ENDIF $ WS "int main()" $ WS "{" $ WS "getprotoent();" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "getprotoent" $ GOSUB inlibc $ d_getpent = tmp $ ELSE $ d_getpent="undef" $ ENDIF $! $! Check for getservent $! $ IF Has_Dec_C_Sockets .OR. Has_Socketshr $ THEN $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ IF Has_Socketshr $ THEN WS "#include " $ ELSE IF i_netdb .EQS. "define" THEN WS "#include " $ ENDIF $ WS "int main()" $ WS "{" $ WS "getservent();" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "getservent" $ GOSUB inlibc $ d_getsent = tmp $ ELSE $ d_getsent="undef" $ ENDIF $! $! Check for nanosleep $! $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "int main()" $ WS "{" $ WS "int asleep = nanosleep(NULL,NULL);" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "nanosleep" $ GOSUB inlibc $ d_nanosleep = tmp $! $! Check for socklen_t $! $ IF Has_Dec_C_Sockets .OR. Has_Socketshr $ THEN $ echo4 "Checking to see if you have socklen_t..." $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ IF Has_Socketshr $ THEN WS "#include " $ ELSE IF i_netdb .EQS. "define" THEN WS "#include " $ ENDIF $ WS "int main()" $ WS "{" $ WS "socklen_t x = 16;" $ WS "exit(0);" $ WS "}" $ CS $ GOSUB link_ok $ IF compile_status .EQ. good_compile .AND. link_status .EQ. good_link $ THEN $ d_socklen_t="define" $ echo "You have socklen_t." $ ELSE $ d_socklen_t="undef" $ echo "You do not have socklen_t." $ ENDIF $ ELSE $ d_socklen_t="undef" $ ENDIF $! $! Check for pthread_yield $! $ IF use_threads $ THEN $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "#include " $ WS "int main()" $ WS "{" $ WS "pthread_yield();" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "pthread_yield" $ GOSUB inlibc $ d_pthread_yield = tmp $ ELSE $ d_pthread_yield="undef" $ ENDIF $! $! Check for sched_yield $! $ IF use_threads $ THEN $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "#include " $ WS "int main()" $ WS "{" $ WS "sched_yield();" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "sched_yield" $ GOSUB inlibc $ d_sched_yield = tmp $ IF d_sched_yield .EQS. "define" $ THEN sched_yield = "sched_yield" $ ELSE sched_yield = " " $ ENDIF $ ELSE $ d_sched_yield="undef" $ sched_yield = " " $ ENDIF $! $! Check for pthread_attr_setscope and PTHREAD_SCOPE_SYSTEM. $! (The actual test is to be written.) $! $ d_pthread_attr_setscope="undef" $! $! Check for generic pointer size $! $ echo4 "Checking to see how big your pointers are..." $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "int main()" $ WS "{" $ WS "int foo;" $ WS "foo = sizeof(char *);" $ WS "printf(""%d\n"", foo);" $ WS "exit(0);" $ WS "}" $ CS $ tmp = "char *" $ GOSUB type_size_check $ ptrsize = tmp $ echo "Your pointers are ''ptrsize' bytes long." $! $! Check for size_t size $! $ tmp = "size_t" $ zzz = tmp $ echo4 "Checking the size of ''zzz'..." $ GOSUB type_size_check $ sizesize = tmp $ echo "Your ''zzz' size is ''sizesize' bytes." $! $! Check for _LARGEFILE capability. $! $ off_t_size = 4 $ OS $ WS "#define _LARGEFILE" $ WS "#include " $ WS "int main()" $ WS "{" $ WS "printf(""%d\n"", sizeof(off_t));" $ WS "return(0);" $ WS "}" $ CS $ GOSUB link_ok $ IF link_status .EQ. good_link $ THEN $ GOSUB just_mcr_it $ off_t_size = tmp $ ENDIF $ echo "Your off_t size is ''off_t_size' bytes when _LARGEFILE is defined." $ IF off_t_size .ne. 8 .AND. (uselargefiles .OR. uselargefiles .eqs. "define") $ THEN $ echo4 "You configured with -Duselargefiles but your CRTL does not support _LARGEFILE." $ echo4 "I'm disabling large file support." $ uselargefiles = "undef" $ ENDIF $! $! Tests for hard link, symbolic links, and 7.3 + CRTL features $! $ d_lchown = "undef" $ d_link = "undef" $ d_lstat = "undef" $ d_readlink = "undef" $ d_symlink = "undef" $ d_realpath = "undef" $! $! Hard link support has been present since 7.3-1 except for the $! easy to use DCL test to see if hardlinks are enabled on the build $! disk. That would require more work to test, and I am only testing $! this on 8.2, so that is why the 8.2 test. $! $ IF (vms_ver .GES. "8.2") .AND. (archname .NES. "VMS_VAX") $ THEN $ IF f$getdvi("SYS$DISK","HARDLINKS_SUPPORTED") $ THEN $ echo "I Found 64 bit OpenVMS 8.2 or later, and hard links enabled on build disk." $ echo "I will build with hard link support" $ d_link = "define" $ ELSE $ echo "I Found 64 bit OpenVMS 8.2 or later, and hard links disabled on build disk." $ echo "I will not build with hard link support." $ ENDIF $ ELSE $ echo4 "I can not detect if your CRTL and build disk support hard links." $ echo4 "I am disabling hard link support." $ ENDIF $! $ IF uselargefiles .OR. uselargefiles .eqs. "define" $ THEN $ IF (vms_ver .GES. "8.2") .AND. (archname .NES. "VMS_VAX") $ THEN $ echo4 "Largefile support enabled, so enabling standard stat support too." $ usestdstat = "y" $ echo4 - "Looking for the realpath() function to indicate symbolic link support..." $ OS $! WS "#include " $ WS "void exit(int foo);" $ WS "char *realpath(const char *file_name, char * resolved_name, ...);" $ WS "int main()" $ WS "{" $ WS "char result[255];" $ WS "realpath(""foo"",result);" $ WS "exit(0);" $ WS "}" $ CS $ GOSUB link_ok $ IF compile_status .EQ. good_compile .AND. link_status .EQ. good_link $ THEN $ echo - "Found realpath() which indicates symbolic link support is present." $ d_lchown = "define" $ d_lstat = "define" $ d_readlink = "define" $ d_symlink = "define" $! d_realpath = "define" ! Perl will not put it in the config.h file? $! Perl apparently does not use a built in realpath() on other platforms, $! but there is a severe performance penatly on OpenVMS to use the Perl $! script that implements a realpath(). The d_symlink symbol is used $! as a replacement for the d_realpath since they are related and both $! were activated by the CRTL at the same time. $! $ ELSE $ echo4 "Your system does not support symbolic links." $ echo4 "I am disabling symbolic link support." $ ENDIF $ ELSE $ echo4 "Your system does not support symbolic links." $ echo4 "I am disabling symbolic link support." $ ENDIF $ ELSE $ IF (vms_ver .GES. "8.2") .AND. (archname .NES. "VMS_VAX") $ THEN $ echo4 "-Duselargefiles is required for symbolic link support." $ echo4 "You did not specify that, so I am disabling symbolic link support." $ ENDIF $ ENDIF $! $! $! Check for grp.h -- should be 7.3 and later, but test to be sure $! $ tmp = "grp.h" $ GOSUB inhdr $ i_grp = tmp $! $! VMS V7.3-2 powered options $! We know that it is only available for V7.3-2 and later on 64 bit platforms. $! $ d_getgrgid_r = "undef" $ getgrgid_r_proto = "0" $ d_getgrnam_r = "undef" $ getgrnam_r_proto = "0" $ d_getpgid = "undef" $ d_getpgrp = "undef" $! N.B. We already have home-grown thread-safe versions of $! getpwnam and getpwuid -- no need to use CRTL versions $ d_getpwnam_r = "undef" $ getpwnam_r_proto = "0" $ d_getpwuid_r = "undef" $ getpwuid_r_proto = "0" $ d_setgrent = "undef" $ d_ttyname_r = "undef" $ ttyname_r_proto = "0" $ d_snprintf = "undef" $ d_vsnprintf = "undef" $ if (vms_ver .GES. "7.3-2") .AND. (archname .NES. "VMS_VAX") $ then $ echo "Found 64 bit OpenVMS ''vms_ver' -- will build with V7.3-2 routines" $ d_getgrgid_r = "define" $ getgrgid_r_proto = "1" $ d_getgrnam_r = "define" $ getgrnam_r_proto = "1" $ if d_symlink .or. d_symlink .EQS. "define" $ then $! FIXME: Need to find how to activate this. $! d_getpgid = "define" $! d_getpgrp = "define" $ endif $ d_setgrent = "define" $ d_ttyname_r = "define" $ ttyname_r_proto = "1" $ d_snprintf = "define" $ d_vsnprintf = "define" $ endif $! $! VMS V7.3-2 powered options $! We know that it is only available for V7.3-2 and later on 64 bit platforms. $! Only implementing right now on 8.2 because that is what I am testing $! These functions may require POSIX UIDs/GIDs to be active, so I am $! not activating the features at this time, just preparing this file $! to easily use them in the future. $! $ d_seteuid = "undef" $ d_setpgid = "undef" $ d_setpgrp = "undef" $ d_setregid = "undef" $ d_setreuid = "undef" $ d_setsid = "undef" $ ! Disable this section for now. $!$ if (vms_ver .GES. "8.2") .AND. (archname .NES. "VMS_VAX") $ if .NOT. 1 $ then $ echo "Found 64 bit OpenVMS ''vms_ver' -- will build with V7.3-2 UID setting routines" $ d_seteuid = "define" $ d_setpgid = "define" $ d_setpgrp = "define" $ d_setregid = "define" $ d_setreuid = "define" $ d_setsid = "define" $ endif $! $! VMS V8 powered options $! We know that it is only available for 8.2 and later on 64 bit platforms. $! $ d_fstatvfs = "undef" $! d_statvfs = "undef" $ i_sysstatvfs = "undef" $ if (vms_ver .GES. "8.2") .AND. (archname .NES. "VMS_VAX") $ then $ echo "Found 64 bit OpenVMS ''vms_ver' -- will build with 8.2 routines" $ d_fstatvfs = "define" $! d_statvfs = "define" $ i_sysstatvfs = "define" $ endif $! $! Check rand48 and its ilk $! $ echo4 "Looking for a random number function..." $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "int main()" $ WS "{" $ WS "srand48(12L);" $ WS "exit(0);" $ WS "}" $ CS $ GOSUB link_ok $ IF compile_status .EQ. good_compile .AND. link_status .EQ. good_link $ THEN $ drand01 = "drand48()" $ randbits = "48" $ randfunc = "drand48" $ randseedtype = "long int" $ seedfunc = "srand48" $ echo4 "Good, found drand48()." $ d_drand48proto = "define" $ ELSE $ d_drand48proto = "undef" $ drand01="random()" $ randbits = "31" $ randfunc = "random" $ randseedtype = "unsigned" $ seedfunc = "srandom" $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "int main()" $ WS "{" $ WS "srandom(12);" $ WS "exit(0);" $ WS "}" $ CS $ GOSUB link_ok $ IF compile_status .EQ. good_compile .AND. link_status .EQ. good_link $ THEN $ echo4 "OK, found random()." $ ELSE $ drand01="(((float)rand())*MY_INV_RAND_MAX)" $ randfunc = "rand" $ randseedtype = "unsigned" $ seedfunc = "srand" $ echo4 "Yick, looks like I have to use rand()." $ ENDIF $ ENDIF $! Done with compiler checks. Clean up. $ IF F$SEARCH("try.c") .NES."" THEN DELETE/NOLOG/NOCONFIRM try.c;* $ IF F$SEARCH("try.obj").NES."" THEN DELETE/NOLOG/NOCONFIRM try.obj;* $ IF F$SEARCH("try.exe").NES."" THEN DELETE/NOLOG/NOCONFIRM try.exe;* $ IF F$SEARCH("try.opt").NES."" THEN DELETE/NOLOG/NOCONFIRM try.opt;* $ IF F$SEARCH("try.out").NES."" THEN DELETE/NOLOG/NOCONFIRM try.out;* $ IF ccname .EQS. "CXX" $ THEN $ CALL Cxx_demangler_cleanup $ ENDIF $! $! Some that are compiler or VMS version sensitive $! $! Gnu C stuff $ IF ccname .EQS. "GCC" $ THEN $ d_attribut="define" $ vms_cc_type="gcc" $ ELSE $ vms_cc_type="cc" $ d_attribut="undef" $ ENDIF $! $! Dec C >= 5.2 and VMS ver >= 7.0 $ IF (ccname .EQS. "DEC") .AND. - (F$INTEGER(Dec_C_Version).GE.50200000) .AND. (vms_ver .GES. "7.0") $ THEN $ d_bcmp="define" $ d_getitimer="define" $ d_gettimeod="define" $ d_mmap="define" $ d_mprotect="define" $ d_munmap="define" $ d_msync="define" $ d_ualarm="define" $ d_uname="define" $! d_unsetenv="define" ! Fix me - Activating requires changing VMS code $ d_unsetenv="undef" ! Change will be needed to allow GNV integration $ d_clearenv="undef" $ d_usleep="define" $ d_setitimer="define" $ d_sigaction="define" $ d_sigprocmask="define" $ d_truncate="define" $ d_wait4="define" $ d_index="define" $ pidtype="pid_t" $ sig_name1="ZERO HUP INT QUIT ILL TRAP ABRT EMT FPE KILL BUS SEGV SYS PIPE" $ sig_name2=" ALRM TERM USR1 USR2 NUM18 NUM19 CHLD CONT STOP TSTP TTIN TTOU DEBUG" $ IF (vms_ver .GES. "7.3") $ THEN $ sig_name2 = sig_name2 + " NUM27 WINCH" $ ENDIF $!* signal.h defines SIGRTMIN as 33 and SIGRTMAX as 64, but there is no $!* sigqueue function or other apparent means to do realtime signalling, $!* so let's not try to include the realtime range for now. $!* sig_name3=" NUM29 NUM30 NUM31 NUM32 RTMIN NUM34 NUM35 NUM36 NUM37 NUM38 NUM39 NUM40 NUM41 NUM42 NUM43" $!* sig_name4=" NUM44 NUM45 NUM46 NUM47 NUM48 NUM49 NUM50 NUM51 NUM52 NUM53 NUM54 NUM55 NUM56 NUM57 NUM58" $!* sig_name5=" NUM59 NUM60 NUM61 NUMT62 NUM63 RTMAX" $ sig_name = sig_name1 + sig_name2 $ sig_num = "" $ sig_num_init = "" $ sig_name_init = "" $ sig_index = 0 $! $ PARSE_SIG_NAME_LOOP: $! $ tmp = F$ELEMENT(sig_index, " ", sig_name) $ IF F$LENGTH(F$EDIT(tmp,"TRIM")) .eq. 0 THEN GOTO END_SIG_NAME_LOOP $ sig_name_init = sig_name_init + """''tmp'""," $ sig_num = sig_num + "''sig_index' " $ sig_num_init = sig_num_init + "''sig_index'," $ sig_index = sig_index + 1 $ GOTO PARSE_SIG_NAME_LOOP $! $ END_SIG_NAME_LOOP: $! $ sig_name_init = sig_name_init + "0" $ sig_num_init = sig_num_init + "0" $ sig_size = "''sig_index'" $ sig_index = sig_index - 1 $ sig_count = "''sig_index'" $ uidtype="uid_t" $ d_pathconf="define" $ d_fpathconf="define" $ d_sysconf="define" $ d_sigsetjmp="define" $ ELSE $ pidtype="unsigned int" $ d_bcmp="undef" $ d_getitimer="undef" $ d_gettimeod="undef" $ d_mmap="undef" $ d_mprotect="undef" $ d_munmap="undef" $ d_msync="undef" $ d_ualarm="undef" $ d_uname="undef" $ d_unsetenv="undef" $ d_clearenv="undef" $ d_usleep="undef" $ d_setitimer="undef" $ d_sigaction="undef" $ d_sigprocmask="undef" $ d_truncate="undef" $ d_wait4="undef" $ d_index="undef" $ sig_name="ZERO HUP INT QUIT ILL TRAP IOT EMT FPE KILL BUS SEGV SYS PIPE ALRM TERM ABRT USR1 USR2" $ psnwc1="""ZERO"",""HUP"",""INT"",""QUIT"",""ILL"",""TRAP"",""IOT"",""EMT"",""FPE"",""KILL"",""BUS"",""SEGV"",""SYS""," $ psnwc2="""PIPE"",""ALRM"",""TERM"",""ABRT"",""USR1"",""USR2"",0" $ sig_name_init = psnwc1 + psnwc2 $ sig_num="0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 6 16 17" $ sig_num_init="0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,6,16,17,0" $ sig_size="19" $ sig_count="15" $ if (vms_ver .GES. "6.2") then sig_count="17" $ uidtype="unsigned int" $ d_pathconf="undef" $ d_fpathconf="undef" $ d_sysconf="undef" $ d_sigsetjmp="undef" $ ENDIF $!: see if tzname[] exists $ OS $ WS "#include " $ WS "#include " $ WS "int main() { extern short tzname[]; printf(""%hd"", tzname[0]); }" $ CS $ GOSUB compile_ok $ IF compile_status .EQ. good_compile $ THEN $ d_tzname = "undef" $ echo4 "tzname[] NOT found." $ ELSE $ d_tzname = "define" $ echo4 "tzname[] found." $ ENDIF $ IF F$SEARCH("try.obj") .NES. "" THEN DELETE/NOLOG/NOCONFIRM try.obj; $! $ IF d_gethname .EQS. "undef" .AND. d_uname .EQS. "undef" $ THEN $ d_phostname="define" $ ELSE $ d_phostname="undef" $ ENDIF $! $! Dec C alone $ IF ccname .EQS. "DEC" $ THEN $ d_mbstowcs="define" $ d_mbtowc="define" $ d_stdiobase="define" $ d_stdio_cnt_lval="define" $ d_stdio_ptr_lval="define" $ d_stdstdio="define" $ d_faststdio="define" $ d_wcstombs="define" $ d_mblen="define" $ d_mktime="define" $ d_strcoll="define" $ d_strxfrm="define" $ d_wctomb="define" $ i_locale="define" $ i_langinfo="define" $ d_locconv="define" $ IF vms_ver .GES. "6.2" $ THEN $ d_nl_langinfo="define" $ ELSE $ d_nl_langinfo="undef" $ ENDIF $ d_setlocale="define" $ vms_cc_type="decc" $ ELSE $ d_mbstowcs="undef" $ d_mbtowc="undef" $ d_stdiobase="undef" $ d_stdio_cnt_lval="undef" $ d_stdio_ptr_lval="undef" $ d_stdstdio="undef" $ d_faststdio="undef" $ d_wcstombs="undef" $ d_mblen="undef" $ d_mktime="undef" $ d_strcoll="undef" $ d_strxfrm="undef" $ d_wctomb="undef" $ i_locale="undef" $ i_langinfo="undef" $ d_locconv="undef" $ d_nl_langinfo="undef" $ d_setlocale="undef" $ ENDIF $ d_stdio_ptr_lval_sets_cnt="undef" $ d_stdio_ptr_lval_nochange_cnt="define" $ usefaststdio="undef" $! $! Sockets? $ if Has_Socketshr .OR. Has_Dec_C_Sockets $ THEN $ d_vms_do_sockets="define" $ d_htonl="define" $ d_socket="define" $ d_sockpair = "undef" $ if (vms_ver .GES. "8.2") .AND. (archname .NES. "VMS_VAX") $ then $ echo "Found 64 bit OpenVMS 8.2, will build with socketpair support" $ d_sockpair = "define" $ endif $ d_select="define" $ netdb_hlen_type="int" $ netdb_host_type="char *" $ netdb_name_type="char *" $ netdb_net_type="long" $ d_gethbyaddr="define" $ d_gethbyname="define" $ d_getnbyaddr="define" $ d_getnbyname="define" $ d_getpbynumber="define" $ d_getpbyname="define" $ d_getsbyport="define" $ d_getsbyname="define" $ d_gethostprotos="define" $ d_getnetprotos="define" $ d_getprotoprotos="define" $ d_getservprotos="define" $ IF ccname .EQS. "DEC" .OR. ccname .EQS. "CXX" $ THEN $ socksizetype="unsigned int" $ ELSE $ socksizetype="int *" $ ENDIF $ ELSE $ d_vms_do_sockets="undef" $ d_htonl="undef" $ d_socket="undef" $ d_socketpair = "undef" $ d_select="undef" $ netdb_hlen_type="int" $ netdb_host_type="char *" $ netdb_name_type="char *" $ netdb_net_type="long" $ d_gethbyaddr="undef" $ d_gethbyname="undef" $ d_getnbyaddr="undef" $ d_getnbyname="undef" $ d_getpbynumber="undef" $ d_getpbyname="undef" $ d_getsbyport="undef" $ d_getsbyname="undef" $ d_gethostprotos="undef" $ d_getnetprotos="undef" $ d_getprotoprotos="undef" $ d_getservprotos="undef" $ socksizetype="undef" $ ENDIF $! Threads $ IF use_threads $ THEN $ usethreads="define" $ d_pthreads_created_joinable="define" $ if (vms_ver .GES. "7.0") $ THEN $ d_oldpthreads="undef" $ ELSE $ d_oldpthreads="define" $ ENDIF $ ELSE $ d_oldpthreads="undef" $ usethreads="undef" $ d_pthreads_created_joinable="undef" $ ENDIF $! $! new (5.005_62++) typedefs for primitives $! $ echo "Choosing the C types to be used for Perl's internal types..." $ ivtype="long" $ uvtype="unsigned long" $ i8type="char" $ u8type="unsigned char" $ i16type="short" $ u16type="unsigned short" $ i32type="int" $ u32type="unsigned int" $ i64type="long long" $ u64type="unsigned long long" $ nvtype="double" $! $ IF use64bitint .OR. use64bitint .EQS. "define" $ THEN $ ivtype = "''i64type'" $ uvtype = "''u64type'" $ ELSE $ i64size="undef" $ u64size="undef" $ ENDIF $! $ IF uselongdouble .OR. uselongdouble .EQS. "define" $ THEN $ nvtype="long double" $ ENDIF $! $ tmp = "''ivtype'" $ GOSUB type_size_check $ ivsize = tmp $ IF use64bitint .OR. use64bitint .EQS. "define" THEN i64size = tmp $ IF ivtype .eqs. "long" $ THEN longsize = tmp $ ELSE $ tmp = "long" $ GOSUB type_size_check $ longsize = tmp $ ENDIF $! $ tmp = "''uvtype'" $ GOSUB type_size_check $ uvsize = tmp $ IF use64bitint .OR. use64bitint .EQS. "define" THEN u64size = tmp $! $ tmp = "''i8type'" $ GOSUB type_size_check $ i8size = tmp $! $ tmp = "''u8type'" $ GOSUB type_size_check $ u8size = tmp $! $ tmp = "''i16type'" $ GOSUB type_size_check $ i16size = tmp $ IF i16type .eqs. "short" $ THEN shortsize = tmp $ ELSE $ tmp = "short" $ gosub type_size_check $ shortsize = tmp $ ENDIF $! $ tmp = "''u16type'" $ GOSUB type_size_check $ u16size = tmp $! $ tmp = "''i32type'" $ GOSUB type_size_check $ i32size = tmp $ IF i32type .eqs. "int" $ THEN intsize = tmp $ ELSE $ tmp = "int" $ gosub type_size_check $ intsize = tmp $ ENDIF $! $ tmp = "''u32type'" $ gosub type_size_check $ u32size = tmp $! $ tmp = "''nvtype'" $ GOSUB type_size_check $ nvsize = tmp $! $ echo "(IV will be ""''ivtype'"", ''ivsize' bytes)" $ echo "(UV will be ""''uvtype'"", ''uvsize' bytes)" $ echo "(NV will be ""''nvtype'"", ''nvsize' bytes)" $! $ d_nv_preserves_uv = "undef" $ echo4 "Checking how many bits of your UVs your NVs can preserve..." $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "int main() {" $ WS " ''uvtype' u = 0;" $ WS " int n = 8 * ''uvsize';" $ WS " int i;" $ WS " for (i = 0; i < n; i++) {" $ WS " u = u << 1 | (''uvtype')1;" $ WS " if ((''uvtype')(''nvtype')u != u)" $ WS " break;" $ WS " }" $ WS " printf(""%d\n"", i);" $ WS " exit(0);" $ WS "}" $ CS $ GOSUB compile $ nv_preserves_uv_bits = tmp $ IF F$INTEGER(nv_preserves_uv_bits) .GE. (F$INTEGER(uvsize) * 8) $ THEN $ d_nv_preserves_uv = "define" $ echo "Your NVs can preserve all ''nv_preserves_uv_bits' bits of your UVs." $ ELSE $ d_nv_preserves_uv = "undef"" $ echo "Your NVs can preserve only ''nv_preserves_uv_bits' bits of your UVs." $ ENDIF $! $ nv_overflows_integers_at = "0" $ echo4 "Checking to find the largest integer value your NVs can hold..." $ OS $ WS "#include " $ WS "" $ WS "typedef ''nvtype' NV;" $ WS "" $ WS "int" $ WS "main() {" $ WS " NV value = 2;" $ WS " int count = 1;" $ WS "" $ WS " while(count < 256) {" $ WS " volatile NV up = value + 1.0;" $ WS " volatile NV negated = -value;" $ WS " volatile NV down = negated - 1.0;" $ WS " volatile NV got_up = up - value;" $ WS " int up_good = got_up == 1.0;" $ WS " int got_down = down - negated;" $ WS " int down_good = got_down == -1.0;" $ WS "" $ WS " if (down_good != up_good) {" $ WS " fprintf(stderr," $ WS " ""Inconsistency - up %d %f; down %d %f; for 2**%d (%.20f)\n""," $ WS " up_good, (double) got_up, down_good, (double) got_down," $ WS " count, (double) value);" $ WS " return 1;" $ WS " }" $ WS " if (!up_good) {" $ WS " while (1) {" $ WS " if (count > 8) {" $ WS " count -= 8;" $ WS " fputs(""256.0"", stdout);" $ WS " } else {" $ WS " count--;" $ WS " fputs(""2.0"", stdout);" $ WS " }" $ WS " if (!count) {" $ WS " puts("""");" $ WS " return 0;" $ WS " }" $ WS " fputs(""*"", stdout);" $ WS " }" $ WS " }" $ WS " value *= 2;" $ WS " ++count;" $ WS " }" $ WS " fprintf(stderr, ""Cannot overflow integer range, even at 2**%d (%.20f)\n""," $ WS " count, (double) value);" $ WS " return 1;" $ WS "}" $ CS $ GOSUB compile $ IF F$LENGTH(tmp) .GT. 0 $ THEN $ IF F$EXTRACT(0,1,tmp) .EQS. "2" $ THEN $ echo "The largest integer your NVs can preserve is equal to ''tmp'" $ nv_overflows_integers_at = tmp $ ELSE $ echo "Cannot determine the largest integer value your NVs can hold, unexpected output" $ echo "''tmp'" $ ENDIF $ ELSE $ echo "Cannot determine the largest integer value your NVs can hold" $ ENDIF $! $! Check for signbit (must already know nvtype) $! $ echo4 "Checking to see if you have signbit() available to work on ''nvtype'..." $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include " $ WS "#endif" $ WS "#include " $ WS "#include " $ WS "int main()" $ WS "{" $ WS " ''nvtype' x = 0.0;" $ WS " ''nvtype' y = -0.0;" $ WS " if ((signbit(x) == 0) && (signbit(y) != 0))" $ WS " printf(""1\n"");" $ WS " else" $ WS " printf(""0\n"");" $ WS "}" $ CS $ GOSUB compile $ IF tmp .EQS. "1" $ THEN $ d_signbit = "define" $ echo4 "Yes." $ ELSE $ d_signbit = "undef" $ echo4 "Nope." $ ENDIF $! $ echo4 "Checking if kill() uses SYS$FORCEX or can't be called from a signal handler..." $ kill_by_sigprc = "undef" $ OS $ WS "#include " $ WS "#include " $ WS "#include " $ WS "void handler1(int s) { printf(""%d"",s); kill(getpid(),2); }" $ WS "void handler2(int s) { printf(""%d"",s); }" $ WS "main(){" $ WS " printf(""0"");" $ WS " signal(1,handler1);" $ WS " signal(2,handler2);" $ WS " kill(getpid(),1);" $ WS " sleep(1);" $ WS " printf(""\n"");" $ WS "}" $ CS $ ON ERROR THEN CONTINUE $ GOSUB compile $ IF tmp .NES. "012" $ THEN $ echo4 "Yes, it has at least one of those limitations." $ echo4 "Checking whether we can use SYS$SIGPRC instead..." $ OS $ WS "#include " $ WS "#include " $ WS "unsigned long code = 0;" $ WS "int handler(unsigned long *args) {" $ WS " code = args[1];" $ WS " return 1;" $ WS "}" $ WS "main() { " $ WS " int iss, sys$sigprc();" $ WS " lib$establish(handler);" $ WS " iss = sys$sigprc(0,0,0x1234);" $ WS " iss = ((iss&1)==1 && code == 0x1234);" $ WS " printf(""%d\n"",iss);" $ WS "}" $ CS $ ON ERROR THEN CONTINUE $ GOSUB compile $ IF tmp .EQS. "1" $ THEN $ echo4 "Yep, we can." $ kill_by_sigprc = "define" $! $! Use the same list of signals the CRTL does for recent systems, but cook our own for very old systems. $! Note that the list controls what signals can be caught by name as well as what can be raised via kill(). $! $ if vms_ver .LTS. "6.2" $ then $! since SIGBUS and SIGSEGV indistinguishable, make them the same here. $ sig_name="ZERO HUP INT QUIT ILL TRAP IOT EMT FPE KILL BUS SEGV SYS PIPE ALRM TERM ABRT" $ psnwc1="""ZERO"",""HUP"",""INT"",""QUIT"",""ILL"",""TRAP"",""IOT"",""EMT"",""FPE"",""KILL"",""BUS"",""SEGV"",""SYS""," $ psnwc2="""PIPE"",""ALRM"",""TERM"",""ABRT"",0" $ sig_name_init = psnwc1 + psnwc2 $ sig_num="0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 6" $ sig_num_init="0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,6,0" $ sig_size="17" $ sig_count="15" $ endif $ ELSE $ echo4 "Nope, we can't." $ ENDIF $ ELSE $ echo4 "Nope, it doesn't." $ ENDIF $ DELETE/SYMBOL tmp $! $! Finally the composite ones. All config $! $ myuname="''osname' ''myname' ''osvers' ''F$EDIT(hwname, "TRIM")'" $! $ IF ccname .EQS. "DEC" $ THEN $ ccflags="/Include=[]/Standard=Relaxed_ANSI/Prefix=All/Obj=''obj_ext' ''ccflags'" $ ENDIF $ i_dirent = "undef" $ IF ccname .EQS. "CXX" $ THEN $ i_dirent = "define" $ ccflags="/Include=[]/Standard=ANSI/Prefix=All/Obj=''obj_ext' ''ccflags'" $ ENDIF $ IF use_vmsdebug_perl $ THEN $ optimize="/List/Debug/NoOpt" $ ldflags="/Debug/Trace/Map" $ dbgprefix = "DBG" $ ELSE $ optimize= "/NoList" $ ldflags="/NoTrace/NoMap" $ dbgprefix = "" $ ENDIF $! $! Okay, we've got everything configured. Now go write out a config.sh. $ basename_config_sh = F$PARSE(config_sh,,,"NAME",)+F$PARSE(config_sh,,,"TYPE",) $ echo4 "Creating ''basename_config_sh'..." $ open/write CONFIG 'config_sh' $ WC := write CONFIG $! $! ##BEGIN WRITE NEW CONSTANTS HERE## $! $ WC "#!/bin/sh" $ WC "#" $ WC "# This file was produced by Configure.COM on a ''osname' system." $ WC "#" $ WC "# Package name : ''package'" $ WC "# Source directory : ''src'" $ WC "# Configuration time: " + cf_time $ WC "# Configuration by : " + cf_by $ WC "# Target system : " + myuname $ WC "" $ WC "Makefile_SH='" + Makefile_SH + "'" $ WC "Mcc='" + Mcc + "'" $ WC "PERL_REVISION='" + revision + "'" $ WC "PERL_VERSION='" + patchlevel + "'" $ WC "PERL_SUBVERSION='" + subversion + "'" $ WC "PERL_API_REVISION='" + api_revision + "'" $ WC "PERL_API_VERSION='" + api_version + "'" $ WC "PERL_API_SUBVERSION='" + api_subversion + "'" $ WC "PERL_PATCHLEVEL='" + perl_patchlevel + "'" $ WC "perl_patchlevel='" + perl_patchlevel + "'" $ WC "PERL_CONFIG_SH='true'" $ WC "_a='" + lib_ext + "'" $ WC "_exe='" + exe_ext + "'" $ WC "_o='" + obj_ext + "'" $ WC "alignbytes='" + alignbytes + "'" $ WC "aphostname='write sys$output f$edit(f$getsyi(\""SCSNODE\""),\""TRIM,LOWERCASE\"")'" $ WC "ar='" + "'" $ WC "archlib='" + archlib + "'" $ WC "archlibexp='" + archlibexp + "'" $ WC "archname='" + archname + "'" $ WC "baserev='" + baserev + "'" $ WC "bin='" + bin + "'" $ WC "binexp='" + binexp + "'" $ WC "builddir='" + builddir + "'" $ WC "byteorder='1234'" $ WC "castflags='0'" $ WC "cc='" + perl_cc + "'" $ WC "cccdlflags='" + cccdlflags + "'" $ WC "ccdlflags='" + ccdlflags + "'" $ IF uselargefiles .OR. uselargefiles .EQS. "define" $ THEN $ IF usestdstat .OR. usestdstat .EQS. "define" $ THEN $ ccdefines = "_USE_STD_STAT=1" $ ELSE $ ccdefines = "_LARGEFILE=1" $ ENDIF $ ELSE $ ccdefines = "" $ ENDIF $ IF ccdefines .NES. "" $ THEN $ WC "ccflags='" + ccflags + "/Define=" + ccdefines + "'" $ ELSE $ WC "ccflags='" + ccflags + "'" $ ENDIF $ WC "ccflags_uselargefiles='" + "'" $ WC "ccname='" + ccname + "'" $ WC "ccversion='" + ccversion + "'" $ WC "cf_by='" + cf_by + "'" $ WC "cf_email='" + cf_email + "'" $ WC "cf_time='" + cf_time + "'" $ WC "charbits='8'" $ WC "config_args='" + config_args + "'" $ WC "config_sh='" + config_sh + "'" $ WC "cpp_stuff='" + cpp_stuff + "'" $ WC "cpplast='" + cpplast + "'" $ WC "cppminus='" + cppminus + "'" $ WC "cpprun='" + cpprun + "'" $ WC "cppstdin='" + cppstdin + "'" $ IF use64bitint .OR. use64bitint .EQS. "define" $ THEN $! gcvt() does not work for > 16 decimal places; fallback to sprintf $ WC "d_Gconvert='sprintf((b),""%.*" + (nvgformat-"""") + ",(n),(x))'" $ ELSE $ WC "d_Gconvert='my_gconvert(x,n,t,b)'" $ ENDIF $ WC "d_PRIEldbl='" + d_PRIEUldbl + "'" $ WC "d_PRIFldbl='" + d_PRIFUldbl + "'" $ WC "d_PRIGldbl='" + d_PRIGUldbl + "'" $ WC "d_PRIXU64='" + d_PRIXU64 + "'" $ WC "d_PRId64='" + d_PRId64 + "'" $ WC "d_PRIeldbl='" + d_PRIeldbl + "'" $ WC "d_PRIfldbl='" + d_PRIfldbl + "'" $ WC "d_PRIgldbl='" + d_PRIgldbl + "'" $ WC "d_PRIo64='" + d_PRIo64 + "'" $ WC "d_PRIu64='" + d_PRIu64 + "'" $ WC "d_PRIx64='" + d_PRIx64 + "'" $ WC "d_SCNfldbl='" + d_SCNfldbl + "'" $ WC "d__fwalk='undef'" $ WC "d_access='" + d_access + "'" $ WC "d_accessx='undef'" $ WC "d_aintl='undef'" $ WC "d_alarm='define'" $ WC "d_archlib='define'" $ WC "d_asctime64='undef'" $ WC "d_atolf='" + d_atolf + "'" $ WC "d_atoll='" + d_atoll + "'" $ WC "d_attribute_format='" + d_attribut + "'" $ WC "d_attribute_deprecated='undef'" $ WC "d_attribute_malloc='undef'" $ WC "d_attribute_nonnull='undef'" $ WC "d_attribute_noreturn='undef'" $ WC "d_attribute_pure='undef'" $ WC "d_attribute_unused='undef'" $ WC "d_attribute_warn_unused_result='undef'" $ WC "d_printf_format_null='undef'" $ WC "d_bcmp='" + d_bcmp + "'" $ WC "d_bcopy='" + d_bcopy + "'" $ WC "d_bincompat3='undef'" $! WC "d_bsdpgrp='undef'" $ WC "d_bsdgetpgrp='undef'" $ WC "d_bsdsetpgrp='undef'" $ WC "d_builtin_choose_expr='undef'" ! GCC only $ WC "d_builtin_expect='undef'" ! GCC only $ WC "d_bzero='" + d_bzero + "'" $ WC "d_casti32='define'" $ WC "d_castneg='define'" $ WC "d_charvspr='undef'" $ WC "d_chown='define'" $ WC "d_chroot='undef'" $ WC "d_chsize='undef'" $ WC "d_class='undef'" $ WC "d_cmsghdr_s='undef'" $ WC "d_const='define'" $ WC "d_copysignl='define'" $ WC "d_cplusplus='" + d_cplusplus + "'" $ WC "d_crypt='define'" $ WC "d_csh='undef'" $ WC "d_ctermid='define'" $ WC "d_ctime64='undef'" $ WC "d_cuserid='define'" $ WC "d_c99_variadic_macros='undef'" $ WC "d_dbl_dig='define'" $ WC "d_dbminitproto='undef'" $ WC "d_difftime='define'" $ WC "d_difftime64='undef'" $ WC "d_dir_dd_fd='undef'" $ WC "d_dirfd='undef'" $ WC "d_dirnamlen='define'" $ WC "d_dlerror='undef'" $ WC "d_dlsymun='undef'" $ WC "d_dosuid='undef'" $ WC "d_drand48proto='" + d_drand48proto + "'" $ WC "d_dup2='define'" $ WC "d_eaccess='undef'" $ WC "d_endgrent='define'" $ WC "d_endhent='" + d_endhent + "'" $ WC "d_endnent='" + d_endnent + "'" $ WC "d_endpent='" + d_endpent + "'" $ WC "d_endpwent='define'" $ WC "d_endsent='" + d_endsent + "'" $ WC "d_eofnblk='undef'" $ WC "d_eunice='undef'" $ WC "d_fchmod='undef'" $ WC "d_fchdir='undef'" $ WC "d_fchown='undef'" $ WC "d_fcntl='" + d_fcntl + "'" $ WC "d_fcntl_can_lock='" + d_fcntl_can_lock + "'" $ WC "d_fd_set='" + d_fd_set + "'" $ WC "d_fgetpos='define'" $ WC "d_finite='undef'" $ WC "d_finitel='undef'" $ WC "d_flexfnam='define'" $ WC "d_flock='undef'" $ WC "d_flockproto='undef'" $ WC "d_fork='undef'" $ WC "d_fp_class='undef'" $ WC "d_fpathconf='" + d_fpathconf + "'" $ WC "d_fpclass='undef'" $ WC "d_fpclassify='undef'" $ WC "d_fpclassl='undef'" $ WC "d_fpos64_t='" + d_fpos64_t + "'" $ WC "d_frexpl='" + d_frexpl + "'" $ WC "d_fs_data_s='undef'" $ WC "d_fseeko='" + d_fseeko + "'" $ WC "d_fsetpos='define'" $ WC "d_fstatfs='undef'" $ WC "d_fstatvfs='" + d_fstatvfs + "'" $ WC "d_fsync='undef'" $ WC "d_ftello='" + d_ftello + "'" $ WC "d_futimes='undef'" $ WC "d_gdbmndbm_h_uses_prototypes='undef'" $ WC "d_gdbm_ndbm_h_uses_prototypes='undef'" $ WC "d_getaddrinfo='undef'" $ WC "d_getcwd='define'" $ WC "d_getespwnam='undef'" $ WC "d_getfsstat='undef'" $ WC "d_getgrent='define'" $ WC "d_getgrps='undef'" $ WC "d_gethbyaddr='" + d_gethbyaddr + "'" $ WC "d_gethbyname='" + d_gethbyname + "'" $ WC "d_gethent='" + d_gethent + "'" $ WC "d_gethname='" + d_gethname + "'" $ WC "d_gethostprotos='" + d_gethostprotos + "'" $ WC "d_getitimer='" + d_getitimer + "'" $ WC "d_getlogin='define'" $ WC "d_getmnt='undef'" $ WC "d_getmntent='undef'" $ WC "d_getnameinfo='undef'" $ WC "d_getnbyaddr='" + d_getnbyaddr + "'" $ WC "d_getnbyname='" + d_getnbyname + "'" $ WC "d_getnent='" + d_getnent + "'" $ WC "d_getnetprotos='" + d_getnetprotos + "'" $ WC "d_getpagsz='undef'" $ WC "d_getpbyname='" + d_getpbyname + "'" $ WC "d_getpbynumber='" + d_getpbynumber + "'" $ WC "d_getpent='" + d_getpent + "'" $ WC "d_getpgid='" + d_getpgid + "'" $ WC "d_getpgrp2='undef'" $ WC "d_getpgrp='" + d_getpgrp + "'" $ WC "d_getppid='" + d_getppid + "'" $ WC "d_getprior='undef'" $ WC "d_getprotoprotos='" + d_getprotoprotos + "'" $ WC "d_getprpwnam='undef'" $ WC "d_getpwent='define'" $ WC "d_getsbyname='" + d_getsbyname + "'" $ WC "d_getsbyport='" + d_getsbyport + "'" $ WC "d_getsent='" + d_getsent + "'" $ WC "d_getservprotos='" + d_getservprotos + "'" $ WC "d_getspnam='undef'" $ WC "d_gettimeod='" + d_gettimeod + "'" $ WC "d_gmtime64='undef'" $ WC "d_gnulibc='undef'" $ WC "d_grpasswd='undef'" $ WC "d_hasmntopt='undef'" $ WC "d_htonl='" + d_htonl + "'" $ WC "d_ilogbl='undef'" $ WC "d_inc_version_list='undef'" $ WC "d_index='" + d_index + "'" $ WC "d_inetaton='undef'" $ WC "d_inetntop='undef'" $ WC "d_inetpton='undef'" $ WC "d_int64_t='" + d_int64_t + "'" $ WC "d_isascii='define'" $ WC "d_isfinite='undef'" $ WC "d_isinf='undef'" $ WC "d_isnan='" + d_isnan + "'" $ WC "d_isnanl='" + d_isnanl + "'" $ WC "d_killpg='undef'" $ WC "d_lchown='" + d_lchown + "'" $ WC "d_ldbl_dig='define'" $ WC "d_libm_lib_version='undef'" $ WC "d_link='" + d_link + "'" $ WC "d_llseek='undef'" $ WC "d_localtime64='undef'" $ WC "d_locconv='" + d_locconv + "'" $ WC "d_lockf='undef'" $ WC "d_longdbl='" + d_longdbl + "'" $ WC "d_longlong='" + d_longlong + "'" $ WC "d_lseekproto='define'" $ WC "d_lstat='" + d_lstat + "'" $ WC "d_madvise='undef'" $ WC "d_malloc_size='undef'" $ WC "d_malloc_good_size='undef'" $ WC "d_mblen='" + d_mblen + "'" $ WC "d_mbstowcs='" + d_mbstowcs + "'" $ WC "d_mbtowc='" + d_mbtowc + "'" $ WC "d_memchr='" + d_memchr + "'" $ WC "d_memcmp='define'" $ WC "d_memcpy='define'" $ WC "d_memmove='define'" $ WC "d_memset='define'" $ WC "d_mkdir='define'" $ WC "d_mkdtemp='" + d_mkdtemp + "'" $ WC "d_mkfifo='undef'" $ WC "d_mknod='undef'" $ WC "d_mkstemp='" + d_mkstemp + "'" $ WC "d_mkstemps='" + d_mkstemps + "'" $ WC "d_mktime='" + d_mktime + "'" $ WC "d_mktime64='undef'" $ WC "d_mmap='" + d_mmap + "'" $ WC "d_modfl='" + d_modfl + "'" $ WC "d_modflproto='" + d_modflproto + "'" $ WC "d_modfl_pow32_bug='undef'" $ WC "d_mprotect='" + d_mprotect + "'" $ WC "d_msg='undef'" $ WC "d_msg_ctrunc='undef'" $ WC "d_msg_dontroute='undef'" $ WC "d_msg_oob='undef'" $ WC "d_msg_peek='undef'" $ WC "d_msg_proxy='undef'" $ WC "d_msghdr_s='undef'" $ WC "d_msync='" + d_msync + "'" $ WC "d_munmap='" + d_munmap + "'" $ WC "d_mymalloc='" + d_mymalloc + "'" $ WC "d_nanosleep='" + d_nanosleep + "'" $ WC "d_ndbm_h_uses_prototypes='undef'" $ WC "d_nice='define'" $ WC "d_nl_langinfo='" + d_nl_langinfo + "'" $ WC "d_nv_preserves_uv='" + d_nv_preserves_uv + "'" $ WC "nv_overflows_integers_at='" + nv_overflows_integers_at + "'" $ WC "nv_preserves_uv_bits='" + nv_preserves_uv_bits + "'" $ WC "d_nv_zero_is_allbits_zero='define'" $ WC "d_off64_t='" + d_off64_t + "'" $ WC "d_old_pthread_create_joinable='" + d_old_pthread_create_joinable + "'" $ WC "d_oldarchlib='define'" $ WC "d_oldpthreads='" + d_oldpthreads + "'" $ WC "d_open3='define'" $ WC "d_pathconf='" + d_pathconf + "'" $ WC "d_pause='define'" $ WC "d_perl_otherlibdirs='undef'" $ WC "d_phostname='" + d_phostname + "'" $ WC "d_pipe='define'" $ WC "d_poll='" + d_poll + "'" $ WC "d_procselfexe='undef'" $ WC "d_pseudofork='undef'" $ WC "d_pthread_atfork='undef'" $ WC "d_pthread_attr_setscope='" + d_pthread_attr_setscope + "'" $ WC "d_pthread_yield='" + d_pthread_yield + "'" $ WC "d_pthreads_created_joinable='" + d_pthreads_created_joinable + "'" $ WC "d_pwage='undef'" $ WC "d_pwchange='undef'" $ WC "d_pwclass='undef'" $ WC "d_pwcomment='define'" $ WC "d_pwexpire='undef'" $ WC "d_pwgecos='define'" $ WC "d_pwpasswd='define'" $ WC "d_pwquota='undef'" $ WC "d_qgcvt='undef'" $ WC "d_quad='" + d_quad + "'" $ WC "d_readdir='define'" $ WC "d_readlink='" + d_readlink + "'" $ WC "d_readv='undef'" $ WC "d_realpath='" + d_realpath + "'" $ WC "d_recvmsg='undef'" $ WC "d_rename='define'" $ WC "d_rewinddir='define'" $ WC "d_rmdir='define'" $ WC "d_safebcpy='undef'" $ WC "d_safemcpy='define'" $ WC "d_sanemcmp='define'" $ WC "d_sbrkproto='define'" $ WC "d_scalbnl='undef'" $ WC "d_sched_yield='" + d_sched_yield + "'" $ WC "d_scm_rights='undef'" $ WC "d_seekdir='define'" $ WC "d_select='" + d_select + "'" $ WC "d_sem='undef'" $ WC "d_semctl_semid_ds='undef'" $ WC "d_semctl_semun='undef'" $ WC "d_sendmsg='undef'" $ WC "d_setegid='undef'" $ WC "d_setenv='" + d_setenv + "'" $ WC "d_seteuid='" + d_seteuid + "'" $ WC "d_setgrent='" + d_setgrent + "'" $ WC "d_setgrps='undef'" $ WC "d_sethent='" + d_sethent + "'" $ WC "d_setitimer='" + d_setitimer + "'" $ WC "d_setlinebuf='undef'" $ WC "d_setlocale='" + d_setlocale + "'" $ WC "d_setnent='" + d_setnent + "'" $ WC "d_setpent='" + d_setpent + "'" $ WC "d_setpgid='" + d_setpgid + "'" $ WC "d_setpgrp2='undef'" $ WC "d_setpgrp='" + d_setpgrp + "'" $ WC "d_setprior='undef'" $ WC "d_setproctitle='" + d_setproctitle + "'" $ WC "d_setpwent='define'" $ WC "d_setregid='" + d_setregid + "'" $ WC "d_setresgid='undef'" $ WC "d_setresuid='undef'" $ WC "d_setreuid='" + d_setreuid + "'" $ WC "d_setrgid='undef'" $ WC "d_setruid='undef'" $ WC "d_setsent='" + d_setsent + "'" $ WC "d_setsid='" + d_setsid + "'" $ WC "d_setvbuf='" + d_setvbuf + "'" $ WC "d_sfio='undef'" $ WC "d_shm='undef'" $ WC "d_shmatprototype='undef'" $ WC "d_sigaction='" + d_sigaction + "'" $ WC "d_signbit='" + d_signbit + "'" $ WC "d_sigprocmask='" + d_sigprocmask + "'" $ WC "d_sigsetjmp='" + d_sigsetjmp + "'" $ WC "d_sitearch='define'" $ WC "d_sockatmark='undef'" $ WC "d_sockatmarkproto='undef'" $ WC "d_socket='" + d_socket + "'" $ WC "d_socklen_t='" + d_socklen_t + "'" $ WC "d_sockpair='" + d_sockpair + "'" $ WC "d_socks5_init='undef'" $ WC "d_sprintf_returns_strlen='define'" $ WC "d_sqrtl='define'" $ WC "d_sresgproto='undef'" $ WC "d_sresgproto='undef'" $ WC "d_sresproto='undef'" $ WC "d_sresuproto='undef'" $ WC "d_statblks='undef'" $ WC "d_statfs_f_flags='undef'" $ WC "d_statfs_s='undef'" $ WC "d_statfsflags='undef'" $ WC "d_stdio_cnt_lval='" + d_stdio_cnt_lval + "'" $ WC "d_stdio_ptr_lval='" + d_stdio_ptr_lval + "'" $ WC "d_stdio_ptr_lval_nochange_cnt='" + d_stdio_ptr_lval_nochange_cnt + "'" $ WC "d_stdio_ptr_lval_sets_cnt='" + d_stdio_ptr_lval_sets_cnt + "'" $ WC "d_stdio_stream_array='undef'" $ WC "d_stdiobase='" + d_stdiobase + "'" $ WC "d_stdstdio='" + d_stdstdio + "'" $ WC "d_faststdio='" + d_faststdio + "'" $ WC "d_strchr='define'" $ WC "d_strcoll='" + d_strcoll + "'" $ WC "d_strctcpy='define'" $ WC "d_strerrm='strerror((e),vaxc$errno)'" $ WC "d_strerror='define'" $ WC "d_strftime='define'" $ WC "d_strlcat='undef'" $ WC "d_strlcpy='undef'" $ WC "d_strtod='define'" $ WC "d_strtol='define'" $ WC "d_strtold='" + d_strtold + "'" $ WC "d_strtoll='" + d_strtoll + "'" $ WC "d_strtoq='" + d_strtoq + "'" $ WC "d_strtoul='define'" $ WC "d_strtoull='" + d_strtoull + "'" $ WC "d_strtouq='" + d_strtouq + "'" $ WC "d_strxfrm='" + d_strxfrm + "'" $ WC "d_suidsafe='undef'" $ WC "d_symlink='" + d_symlink + "'" $ WC "d_syscall='undef'" $ WC "d_syscallproto='undef'" $ WC "d_sysconf='" + d_sysconf + "'" $ WC "d_syserrlst='undef'" $ WC "d_system='define'" $ WC "d_tcgetpgrp='undef'" $ WC "d_tcsetpgrp='undef'" $ WC "d_telldir='define'" $ WC "d_telldirproto='define'" $ WC "d_time='define'" $ WC "d_timegm='undef'" $ WC "d_times='define'" $ IF ("''F$EXTRACT(1,3, F$GETSYI(""VERSION""))'".GES."7.0") $ THEN $ WC "d_tm_tm_gmtoff='define'" $ WC "d_tm_tm_zone='define'" $ ELSE $ WC "d_tm_tm_gmtoff='undef'" $ WC "d_tm_tm_zone='undef'" $ ENDIF $ WC "d_truncate='" + d_truncate + "'" $ WC "d_tzname='" + d_tzname + "'" $ WC "d_u32align='define'" $ WC "d_ualarm='" + d_ualarm + "'" $ WC "d_umask='define'" $ WC "d_uname='" + d_uname + "'" $ WC "d_union_semun='undef'" $ WC "d_unlink_all_versions='" + d_unlink_all_versions + "'" ! VMS-specific $ WC "d_unordered='undef'" $ WC "d_unsetenv='" + d_unsetenv + "'" $ WC "d_clearenv='" + d_clearenv + "'" $ WC "d_usleep='" + d_usleep + "'" $ WC "d_usleepproto='" + d_usleep + "'" $ WC "d_ustat='undef'" $ WC "d_vendorarch='undef'" $ WC "d_vendorlib='undef'" $ WC "d_vfork='define'" $ WC "d_vms_case_sensitive_symbols='" + d_vms_be_case_sensitive + "'" ! VMS $ WC "d_vms_do_sockets='" + d_vms_do_sockets + "'" ! VMS $ WC "d_void_closedir='define'" $ WC "d_volatile='define'" $ WC "d_vprintf='define'" $ WC "d_vsnprintf='" + d_vsnprintf + "'" $ WC "d_wait4='" + d_wait4 + "'" $ WC "d_waitpid='define'" $ WC "d_wcstombs='" + d_wcstombs + "'" $ WC "d_wctomb='" + d_wctomb + "'" $ WC "d_writev='undef'" $ WC "db_hashtype=' '" $ WC "db_prefixtype=' '" $ WC "db_version_major='" + "'" $ WC "db_version_minor='" + "'" $ WC "db_version_patch='" + "'" $ WC "dbgprefix='" + dbgprefix + "'" $ WC "defvoidused='15'" $ WC "devtype='" + devtype + "'" $ WC "direntrytype='struct dirent'" $ WC "dlext='" + dlext + "'" $ WC "dlobj='" + dlobj + "'" $ WC "dlsrc='dl_vms.c'" $ WC "doublesize='" + doublesize + "'" $ WC "drand01='" + drand01 + "'" $ WC "dtrace='" + "'" $! $! The dynamic_ext symbol may be quite long $! $ tmp = "dynamic_ext='" + dynamic_ext + "'" $ WC/symbol tmp $ DELETE/SYMBOL tmp $ WC "eagain=' '" $ WC "ebcdic='undef'" $ WC "embedmymalloc='" + usemymalloc + "'" $ WC "eunicefix=':'" $ WC "exe_ext='" + exe_ext + "'" $! $! The extensions symbols may be quite long $! $ tmp = "extensions='" + nonxs_ext + " " + dynamic_ext + "'" $ WC/symbol tmp $ DELETE/SYMBOL tmp $ WC "fflushNULL='define'" $ WC "fflushall='undef'" $ WC "fpostype='fpos_t'" $ WC "freetype='void'" $ WC "full_ar='" + "'" $ WC "full_csh='" + " '" $ WC "full_sed='_NLA0:'" $ WC "gccversion='" + gccversion + "'" $ WC "gidformat='lu'" $ WC "gidsign='1'" $ WC "gidsize='4'" $ WC "gidtype='" + gidtype + "'" $ WC "groupstype='Gid_t'" $ WC "hint='none'" $ WC "hintfile='" + "'" $ WC "i16size='" + i16size + "'" $ WC "i16type='" + i16type + "'" $ WC "i32size='" + i32size + "'" $ WC "i32type='" + i32type + "'" $ WC "i64size='" + i64size + "'" $ WC "i64type='" + i64type + "'" $ WC "i8size='" + i8size + "'" $ WC "i8type='" + i8type + "'" $ WC "i_arpainet='undef'" $ WC "i_assert='define'" $ WC "i_crypt='undef'" $ WC "i_db='undef'" $ WC "i_dbm='undef'" $ WC "i_dirent='" + i_dirent + "'" $ WC "i_dlfcn='undef'" $ WC "i_fcntl='" + i_fcntl + "'" $ WC "i_float='define'" $ WC "i_fp='undef'" $ WC "i_fp_class='undef'" $ WC "i_gdbm='undef'" $ WC "i_gdbm_ndbm='undef'" $ WC "i_gdbmndbm='undef'" $ WC "i_grp='" + i_grp + "'" $ WC "i_ieeefp='undef'" $ WC "i_inttypes='" + i_inttypes + "'" $ WC "i_langinfo='" + i_langinfo + "'" $ WC "i_libutil='" + i_libutil + "'" $ WC "i_limits='define'" $ WC "i_locale='" + i_locale + "'" $ WC "i_machcthr='undef'" $ WC "i_machcthreads='undef'" $ WC "i_mallocmalloc='undef'" $ WC "i_math='define'" $ WC "i_memory='undef'" $ WC "i_mntent='undef'" $ WC "i_ndbm='undef'" $ WC "i_netdb='" + i_netdb + "'" $ WC "i_neterrno='define'" $ WC "i_netinettcp='" + i_netinettcp + "'" $ WC "i_niin='" + i_niin + "'" $ WC "i_poll='" + i_poll + "'" $ WC "i_prot='undef'" $ WC "i_pthread='define'" $ WC "i_pwd='undef'" $ WC "i_rpcsvcdbm='undef'" $ WC "i_sfio='undef'" $ WC "i_sgtty='undef'" $ WC "i_shadow='" + i_shadow + "'" $ WC "i_socks='" + i_socks + "'" $ WC "i_stdarg='define'" $ WC "i_stddef='define'" $ WC "i_stdlib='define'" $ WC "i_string='define'" $ WC "i_sunmath='undef'" $ WC "i_sysaccess='" + i_sysaccess + "'" $ WC "i_sysdir='undef'" $ WC "i_sysfile='" + i_sysfile + "'" $ WC "i_sysioctl='" + i_sysioctl + "'" $ WC "i_syslog='" + i_syslog + "'" $ WC "i_sysmman='undef'" $ WC "i_sysmode='" + i_sysmode + "'" $ WC "i_sysmount='undef'" $ WC "i_sysndir='undef'" $ WC "i_sysparam='undef'" $ WC "i_syspoll='" + i_syspoll + "'" $ WC "i_sysresrc='undef'" $ WC "i_syssecrt='" + i_syssecrt + "'" $ WC "i_sysselct='undef'" $ WC "i_syssockio='undef'" $ WC "i_sysstat='define'" $ WC "i_sysstatfs='undef'" $ WC "i_sysstatvfs='" + i_sysstatvfs + "'" $ WC "i_systime='undef'" $ WC "i_systimek='undef'" $ WC "i_systimes='undef'" $ WC "i_systypes='define'" $ WC "i_sysuio='" + i_sysuio + "'" $ WC "i_sysun='undef'" $ WC "i_sysutsname='" + i_sysutsname + "'" $ WC "i_sysvfs='undef'" $ WC "i_syswait='undef'" $ WC "i_termio='undef'" $ WC "i_termios='undef'" $ WC "i_time='define'" $ WC "i_unistd='" + i_unistd + "'" $ WC "i_ustat='undef'" $ WC "i_utime='" + i_utime + "'" $ WC "i_values='undef'" $ WC "i_varargs='undef'" $ WC "i_vfork='undef'" $ WC "inc_version_list='0'" $ WC "inc_version_list_init='0'" $ WC "installarchlib='" + installarchlib + "'" $ WC "installbin='" + installbin + "'" $ WC "installman1dir='" + installman1dir + "'" $ WC "installman3dir='" + installman3dir + "'" $ WC "installprefix='" + vms_prefix + "'" $ WC "installprefixexp='" + vms_prefix + ":'" $ WC "installprivlib='" + installprivlib + "'" $ WC "installscript='" + installscript + "'" $ WC "installsitearch='" + installsitearch + "'" $ WC "installsitebin='" + sitebin + "'" $ WC "installsitelib='" + installsitelib + "'" $ WC "installusrbinperl='undef'" $ WC "intsize='" + intsize + "'" $ WC "ivdformat='" + ivdformat + "'" $ WC "ivsize='" + ivsize + "'" $ WC "ivtype='" + ivtype + "'" $! $! The known_extensions symbol may be quite long $! $ tmp = "known_extensions='" + known_extensions + "'" $ WC/symbol tmp $ DELETE/SYMBOL tmp $ WC "ld='" + ld + "'" $ WC "lddlflags='/Share'" $ WC "ldflags='" + ldflags + "'" $ WC "ldflags_uselargefiles='" + "'" $ WC "lib_ext='" + lib_ext + "'" $ WC "libc='" + libc + "'" $ WC "libpth='/sys$share /sys$library'" $ WC "libs='" + libs + "'" $ WC "libswanted='" + "'" $ WC "libswanted_uselargefiles='" + "'" $ WC "longdblsize='" + longdblsize + "'" $ WC "longlongsize='" + longlongsize + "'" $ WC "longsize='" + longsize + "'" $ IF uselargefiles .OR. uselargefiles .EQS. "define" $ THEN $ WC "lseeksize='8'" $ WC "lseektype='off_t'" $ ELSE $ WC "lseeksize='4'" $ WC "lseektype='int'" $ ENDIF $ WC "mab='" + "'" $ WC "mad='undef'" $ WC "make='" + make + "'" $ WC "malloctype='void *'" $ WC "usemallocwrap='" + usemallocwrap + "'" $ WC "man1ext='rno'" $ WC "man3ext='rno'" $ WC "mmaptype='void *'" $ WC "modetype='unsigned int'" $ WC "multiarch='undef'" $ WC "mydomain='" + mydomain + "'" $ WC "myhostname='" + myhostname + "'" $ WC "myuname='" + myuname + "'" $ WC "need_va_copy='undef'" $ WC "netdb_hlen_type='" + netdb_hlen_type + "'" $ WC "netdb_host_type='" + netdb_host_type + "'" $ WC "netdb_name_type='" + netdb_name_type + "'" $ WC "netdb_net_type='" + netdb_net_type + "'" $ tmp = "nonxs_ext='" + nonxs_ext + "'" $ WC/symbol tmp $ DELETE/SYMBOL tmp $ WC "nveformat='" + nveformat + "'" $ WC "nvfformat='" + nvfformat + "'" $ WC "nvgformat='" + nvgformat + "'" $ WC "nvsize='" + nvsize + "'" $ WC "nvtype='" + nvtype + "'" $ WC "o_nonblock=' '" $ WC "obj_ext='" + obj_ext + "'" $ WC "old_pthread_create_joinable='" + old_pthread_create_joinable + "'" $ WC "oldarchlib='" + oldarchlib + "'" $ WC "oldarchlibexp='" + oldarchlibexp + "'" $ WC "optimize='" + optimize + "'" $ WC "osname='" + osname + "'" $ WC "osvers='" + osvers + "'" $ WC "otherlibdirs='" + "'" $ WC "package='" + package + "'" $ WC "pager='" + pager + "'" $ WC "patchlevel='" + patchlevel + "'" $ WC "path_sep='|'" $ WC "perl_root='" + perl_root + "'" ! VMS specific $trnlnm() $ WC "perladmin='" + perladmin + "'" $ WC "perllibs='" + perllibs + "'" $ WC "perlpath='" + "''vms_prefix':[000000]Perl''exe_ext'" + "'" $ WC "perl_symbol='" + perl_symbol + "'" ! VMS specific $ WC "perl_verb='" + perl_verb + "'" ! VMS specific $ WC "pgflquota='" + pgflquota + "'" $ WC "pidtype='" + pidtype + "'" $ WC "prefix='" + vms_prefix + "'" $ WC "prefixexp='" + vms_prefix + ":'" $ WC "privlib='" + privlib + "'" $ WC "privlibexp='" + privlibexp + "'" $ WC "procselfexe=' '" $ WC "prototype='define'" $ WC "ptrsize='" + ptrsize + "'" $ WC "quadkind='" + quadkind + "'" $ WC "quadtype='" + quadtype + "'" $ WC "randbits='" + randbits + "'" $ WC "randfunc='" + randfunc + "'" $ WC "randseedtype='" + randseedtype + "'" $ WC "ranlib='" + "'" $ WC "rd_nodata=' '" $ WC "revision='" + revision + "'" $ WC "sGMTIME_max='4294967295'" $ WC "sGMTIME_min='0'" $ WC "sLOCALTIME_max='4294967295'" $ WC "sLOCALTIME_min='0'" $ WC "sPRId64='" + sPRId64 + "'" $ WC "sPRIEldbl='" + sPRIEUldbl + "'" $ WC "sPRIFldbl='" + sPRIFUldbl + "'" $ WC "sPRIGldbl='" + sPRIGUldbl + "'" $ WC "sPRIX64='" + sPRIXU64 + "'" $ WC "sPRIeldbl='" + sPRIeldbl + "'" $ WC "sPRIfldbl='" + sPRIfldbl + "'" $ WC "sPRIgldbl='" + sPRIgldbl + "'" $! WC "sPRIi64='" + sPRIi64 + "'" $ WC "sPRIo64='" + sPRIo64 + "'" $ WC "sPRIu64='" + sPRIu64 + "'" $ WC "sPRIx64='" + sPRIx64 + "'" $ WC "sSCNfldbl='" + sSCNfldbl + "'" $ WC "sched_yield='" + sched_yield + "'" $ WC "scriptdir='" + scriptdir + "'" $ WC "scriptdirexp='" + scriptdir + "'" ! use scriptdir for now $ WC "seedfunc='" + seedfunc + "'" $ WC "selectminbits='32'" $ WC "selecttype='" + selecttype + "'" $ WC "sh='MCR'" $ WC "sharpbang='#!'" $ WC "shmattype='" + " '" $ WC "shortsize='" + shortsize + "'" $ IF (f$length(sig_name) .GE. 244) $ THEN $ tmp = "sig_name='" + sig_name + "'" $ WC/symbol tmp $ DELETE/SYMBOL tmp $ ELSE $ WC "sig_name='" + sig_name + "'" $ ENDIF $ IF (f$length(sig_name_init) .GE. 244) $ THEN $ tmp = "sig_name_init='" + sig_name_init + "'" $ WC/symbol tmp $ DELETE/SYMBOL tmp $ ELSE $ WC "sig_name_init='" + sig_name_init + "'" $ ENDIF $ WC "sig_num='" + sig_num + "'" $ WC "sig_num_init='" + sig_num_init + "'" $ WC "sig_count='" + sig_count + "'" $ WC "sig_size='" + sig_size + "'" $ WC "signal_t='" + signal_t + "'" $ WC "sitearch='" + sitearch + "'" $ WC "sitearchexp='" + sitearchexp + "'" $ WC "sitebin='" + sitebin + "'" $ WC "sitebinexp='" + sitebin + "'" $ WC "sitelib='" + sitelib + "'" $ WC "sitelib_stem='" + sitelib_stem + "'" $ WC "sitelibexp='" + sitelibexp + "'" $ WC "siteprefix='" + vms_prefix + "'" $ WC "siteprefixexp='" + vms_prefix + ":'" $ WC "sizesize='" + sizesize + "'" $ WC "sizetype='size_t'" $ WC "so='" + so + "'" $ WC "socksizetype='" + socksizetype + "'" $ WC "spitshell='write sys$output '" $ WC "src='" + src + "'" $ WC "ssizetype='int'" $ WC "startperl=" + startperl ! This one's special--no enclosing single quotes $ WC "static_ext='" + static_ext + "'" $ WC "stdchar='" + stdchar + "'" $ WC "stdio_base='((*fp)->_base)'" $ WC "stdio_bufsiz='((*fp)->_cnt + (*fp)->_ptr - (*fp)->_base)'" $ WC "stdio_cnt='((*fp)->_cnt)'" $ WC "stdio_ptr='((*fp)->_ptr)'" $ WC "stdio_stream_array=' " + "'" $ WC "subversion='" + subversion + "'" $ WC "targetarch='" + "'" $ WC "timetype='" + timetype + "'" $ WC "u16size='" + u16size + "'" $ WC "u16type='" + u16type + "'" $ WC "u32size='" + u32size + "'" $ WC "u32type='" + u32type + "'" $ WC "u64size='" + u64size + "'" $ WC "u64type='" + u64type + "'" $ WC "u8size='" + u8size + "'" $ WC "u8type='" + u8type + "'" $ WC "uidformat='lu'" $ WC "uidsign='1'" $ WC "uidsize='4'" $ WC "uidtype='" + uidtype + "'" $ WC "uquadtype='" + uquadtype + "'" $ WC "use5005threads='" + use5005threads + "'" $ WC "use64bitall='" + use64bitall + "'" $ WC "use64bitint='" + use64bitint + "'" $ WC "usecasesensitive='" + be_case_sensitive + "'" ! VMS-specific $ WC "usedebugging_perl='"+use_debugging_perl+"'" $ WC "usedefaulttypes='" + usedefaulttypes + "'" ! VMS-specific $ WC "usecrosscompile='undef'" $ WC "usedevel='" + usedevel + "'" $ WC "usedl='" + usedl + "'" $ WC "usedtrace='undef'" $ WC "usefaststdio='" + usefaststdio + "'" $ WC "useieee='" + useieee + "'" ! VMS-specific $ WC "useithreads='" + useithreads + "'" $ WC "usekernelthreads='" + usekernelthreads + "'" ! VMS-specific $ WC "uselargefiles='" + uselargefiles + "'" $ WC "uselongdouble='" + uselongdouble + "'" $ WC "usemorebits='" + usemorebits + "'" $ WC "usemultiplicity='" + usemultiplicity + "'" $ WC "usemymalloc='" + usemymalloc + "'" $ WC "useperlio='" + useperlio + "'" $ WC "useposix='false'" $ WC "usereentrant='undef'" $ WC "userelocatableinc='undef'" $ WC "usesecurelog='" + usesecurelog + "'" ! VMS-specific $ WC "useshrplib='true'" $ WC "usesitecustomize='" + usesitecustomize + "'" $ WC "usesocks='undef'" $ WC "usethreads='" + usethreads + "'" $ WC "usethreadupcalls='" + usethreadupcalls + "'" ! VMS-specific $ WC "usevendorprefix='" + "'" ! try to say no, though we'll be ignored as of MM 5.90_01 $ WC "usevfork='true'" $ WC "usevmsdebug='" + usevmsdebug + "'" ! VMS-specific $ WC "uvoformat='" + uvoformat + "'" $ WC "uvsize='" + uvsize + "'" $ WC "uvtype='" + uvtype + "'" $ WC "uvuformat='" + uvuformat + "'" $ WC "uvxformat='" + uvxformat + "'" $ WC "uvXUformat='" + uvXUformat + "'" $ WC "vendorarch='" + "'" $ WC "vaproto='define'" $ WC "vendorarchexp='" + "'" $ WC "vendorbin='" + "'" $ WC "vendorbinexp='" + "'" $ WC "vendorlib_stem='" + "'" $ WC "vendorlib='" + "'" $ WC "vendorlibexp='" + "'" $ WC "vendorprefix='" + "'" $ WC "vendorprefixexp='" + "'" $ WC "version='" + version + "'" $ WC "version_patchlevel_string='" + version_patchlevel_string + "'" $ WC "vms_cc_type='" + vms_cc_type + "'" ! VMS specific $ WC "vms_prefix='" + vms_prefix + "'" ! VMS specific $ WC "vms_ver='" + vms_ver + "'" ! VMS specific $ WC "voidflags='15'" $! $! ## The UNIXy POSIXy reentrantey thingys ## $! See "Appendix B, Version-Dependency Tables" in the C RTL $! manual for when assorted _r functions became available. $! $ IF use_threads .AND. vms_ver .GES. "7.2" $ THEN $ WC "asctime_r_proto='REENTRANT_PROTO_B_SB'" $ WC "d_asctime_r='define'" $ WC "ctime_r_proto='REENTRANT_PROTO_B_SB'" $ WC "d_ctime_r='define'" $ ELSE $ WC "asctime_r_proto='0'" $ WC "d_asctime_r='undef'" $ WC "ctime_r_proto='0'" $ WC "d_ctime_r='undef'" $ ENDIF $ WC "d_crypt_r='undef'" $ WC "d_ctermid_r='undef'" $ WC "d_drand48_r='undef'" $ WC "d_endgrent_r='undef'" $ WC "d_endhostent_r='undef'" $ WC "d_endnetent_r='undef'" $ WC "d_endprotoent_r='undef'" $ WC "d_endpwent_r='undef'" $ WC "d_endservent_r='undef'" $ WC "d_getgrent_r='undef'" $ WC "d_getgrgid_r='" + d_getgrgid_r + "'" $ WC "d_getgrnam_r='" + d_getgrnam_r + "'" $ WC "d_gethostbyaddr_r='undef'" $ WC "d_gethostbyname_r='undef'" $ WC "d_gethostent_r='undef'" $ WC "d_getlogin_r='undef'" $ WC "d_getnetbyaddr_r='undef'" $ WC "d_getnetbyname_r='undef'" $ WC "d_getnetent_r='undef'" $ WC "d_getprotobyname_r='undef'" $ WC "d_getprotobynumber_r='undef'" $ WC "d_getprotoent_r='undef'" $ WC "d_getpwent_r='undef'" $ WC "d_getpwnam_r='" + d_getpwnam_r + "'" $ WC "d_getpwuid_r='" + d_getpwuid_r + "'" $ WC "d_getservbyname_r='undef'" $ WC "d_getservbyport_r='undef'" $ WC "d_getservent_r='undef'" $ WC "d_getspnam_r='undef'" $ WC "d_gmtime_r='undef'" ! leave undef'd; we use my_gmtime $ WC "d_localtime_r='undef'" ! leave undef'd; we use my_localtime $ WC "d_localtime_r_needs_tzset='undef'" $ WC "d_random_r='undef'" $ WC "d_readdir_r='define'" ! always defined; we roll our own $ WC "d_readdir64_r='undef'" $ WC "d_setgrent_r='undef'" $ WC "d_sethostent_r='undef'" $ WC "d_setlocale_r='undef'" $ WC "d_setnetent_r='undef'" $ WC "d_setprotoent_r='undef'" $ WC "d_setpwent_r='undef'" $ WC "d_setservent_r='undef'" $ WC "d_snprintf='" + d_snprintf + "'" $ WC "d_srand48_r='undef'" $ WC "d_srandom_r='undef'" $ WC "d_strerror_r='undef'" $ WC "d_tmpnam_r='undef'" $ WC "d_ttyname_r='" + d_ttyname_r + "'" $ WC "ctermid_r_proto='0'" $ WC "crypt_r_proto='0'" $ WC "drand48_r_proto='0'" $ WC "endgrent_r_proto='0'" $ WC "endhostent_r_proto='0'" $ WC "endnetent_r_proto='0'" $ WC "endprotoent_r_proto='0'" $ WC "endpwent_r_proto='0'" $ WC "endservent_r_proto='0'" $ WC "getgrent_r_proto='0'" $ WC "getgrgid_r_proto='" + getgrgid_r_proto + "'" $ WC "getgrnam_r_proto='" + getgrnam_r_proto + "'" $ WC "gethostbyaddr_r_proto='0'" $ WC "gethostbyname_r_proto='0'" $ WC "gethostent_r_proto='0'" $ WC "getlogin_r_proto='0'" $ WC "getnetbyaddr_r_proto='0'" $ WC "getnetbyname_r_proto='0'" $ WC "getnetent_r_proto='0'" $ WC "getprotobyname_r_proto='0'" $ WC "getprotobynumber_r_proto='0'" $ WC "getprotoent_r_proto='0'" $ WC "getpwent_r_proto='0'" $ WC "getpwnam_r_proto='0'" $ WC "getpwuid_r_proto='0'" $ WC "getservbyname_r_proto='0'" $ WC "getservbyport_r_proto='0'" $ WC "getservent_r_proto='0'" $ WC "getspnam_r_proto='0'" $ WC "gmtime_r_proto='0'" $ WC "localtime_r_proto='0'" $ WC "random_r_proto='0'" $ WC "readdir_r_proto='REENTRANT_PROTO_I_TSR'" ! always defined; we roll our own $ WC "readdir64_r_proto='0'" $ WC "setgrent_r_proto='0'" $ WC "sethostent_r_proto='0'" $ WC "setlocale_r_proto='0'" $ WC "setnetent_r_proto='0'" $ WC "setprotoent_r_proto='0'" $ WC "setpwent_r_proto='0'" $ WC "setservent_r_proto='0'" $ WC "srand48_r_proto='0'" $ WC "srandom_r_proto='0'" $ WC "strerror_r_proto='0'" $ WC "tmpnam_r_proto='0'" $ WC "ttyname_r_proto='" + ttyname_r_proto + "'" $! $! ##END WRITE NEW CONSTANTS HERE## $! $ CLOSE CONFIG $! $! Okay, we've gotten here. Build munchconfig.exe $ COPY/NOLOG [-.vms]munchconfig.c [] $ COPY/NOLOG [-.vms]'Makefile_SH' [] $ 'Perl_CC' 'ccflags' munchconfig.c $ IF Needs_Opt $ THEN $ OPEN/WRITE CONFIG []munchconfig.opt $ IF ccname .EQS. "GCC" $ THEN $ WRITE CONFIG "Gnu_CC:[000000]gcclib.olb/library" $ ENDIF $ WRITE CONFIG "Sys$Share:VAXCRTL/Share" $ CLOSE CONFIG $ 'ld' munchconfig.obj,munchconfig.opt/opt $ DELETE/NOLOG/NOCONFIRM munchconfig.opt; $ ELSE $ 'ld' munchconfig.obj $ ENDIF $ IF F$SEARCH("munchconfig.obj") .NES. "" THEN DELETE/NOLOG/NOCONFIRM munchconfig.obj; $ IF F$SEARCH("munchconfig.c") .NES. "" THEN DELETE/NOLOG/NOCONFIRM munchconfig.c; $ IF ccname .EQS. "CXX" $ THEN $ CALL Cxx_demangler_cleanup $ ENDIF $! $ IF alldone .EQS. "" $ THEN $ cat4 SYS$INPUT: $ DECK If you'd like to make any changes to the config.sh file before I begin to configure things, answer yes to the following question. $ EOD $ bool_dflt="n" $ rp="Do you wish to edit ''basename_config_sh'? [''bool_dflt'] " $ GOSUB myread $ IF ans $ THEN $ echo4 "" $ echo4 "Be sure to type LOGOUT after you have edited the file," $ echo4 "then this procedure will resume." $ echo4 "" $ default = F$ENVIRONMENT("DEFAULT") $ DIRECTORY 'config_sh' $ SET DEFAULT [-] $ SPAWN/WAIT $ SET DEFAULT 'default' $ ENDIF $ ENDIF $! $ echo "" $ echo4 "Adding ''osname' specific preprocessor commands." $ ! $ ! we need an fdl file $ CREATE [-]CONFIG.FDL $ DECK RECORD FORMAT STREAM_LF $ EOD $ CREATE /FDL=[-]CONFIG.FDL [-]CONFIG.LOCAL $ ! First spit out the header info with the local defines (to get $ ! around the 255 character command line limit) $ OPEN/APPEND CONFIG [-]config.local $ IF use_debugging_perl THEN WC "#define DEBUGGING" $ IF use_two_pot_malloc THEN WC "#define TWO_POT_OPTIMIZE" $ IF mymalloc THEN WC "#define EMBEDMYMALLOC" $ IF use_pack_malloc THEN WC "#define PACK_MALLOC" $ IF use_debugmalloc THEN WC "#define DEBUGGING_MSTATS" $ IF ccname .EQS. "GCC" THEN WC "#define GNUC_ATTRIBUTE_CHECK" $ IF (Has_Dec_C_Sockets) $ THEN $ WC "#define VMS_DO_SOCKETS" $ WC "#define DECCRTL_SOCKETS" $ ELSE $ IF Has_Socketshr THEN WC "#define VMS_DO_SOCKETS" $ ENDIF $! This is VMS-specific for now $ WC "#''d_setenv' HAS_SETENV" $ IF d_secintgenv THEN WC "#define SECURE_INTERNAL_GETENV" $ IF d_alwdeftype THEN WC "#define ALWAYS_DEFTYPES" $ IF use64bitint .OR. use64bitint .EQS. "define" $ THEN $ WC "#define USE_64_BIT_INT" $ WC "#define USE_LONG_DOUBLE" $ ENDIF $ IF use64bitall .OR. use64bitall .EQS. "define" THEN - WC "#define USE_64_BIT_ALL" $ IF be_case_sensitive THEN WC "#define VMS_WE_ARE_CASE_SENSITIVE" $ IF use_ieee_math THEN WC "#define USE_IEEE" $ IF d_herrno .EQS. "undef" THEN WC "#define NEED_AN_H_ERRNO" $ WC "#define HAS_ENVGETENV" $ WC "#define PERL_EXTERNAL_GLOB" $ IF archname .EQS. "VMS_VAX" .AND. - ccname .EQS. "DEC" .AND. - ccversion .LE. 50390006 $ THEN $! Alas this does not help to build Fcntl $! WC "#define PERL_IGNORE_FPUSIG SIGFPE" $ ENDIF $ IF kill_by_sigprc .EQS. "define" then WC "#define KILL_BY_SIGPRC" $ IF unlink_all_versions .OR. unlink_all_versions .EQS. "define" THEN - WC "#define UNLINK_ALL_VERSIONS" $ CLOSE CONFIG $! $ echo4 "Doing variable substitutions on .SH files..." $ echo4 "Extracting config.h (with variable substitutions)" $! $! Now build the normal config.h $ DEFINE/USER_MODE sys$output [-]config.main $ mcr []munchconfig 'config_sh' [-]config_h.sh $ ! Concatenate them together $ copy [-]config.local,[-]config.main [-]config.h $! Clean up $ DELETE/NOLOG/NOCONFIRM [-]CONFIG.MAIN;* $ DELETE/NOLOG/NOCONFIRM [-]CONFIG.LOCAL;* $ DELETE/NOLOG/NOCONFIRM [-]CONFIG.FDL;* $! $ IF ccname .EQS. "DEC" $ THEN $ DECC_REPLACE = "DECC=decc=1" $ ELSE $ DECC_REPLACE = "DECC=" $ ENDIF $ IF ccname .EQS. "CXX" $ THEN $ DECCXX_REPLACE = "DECCXX=DECCXX=1" $ ELSE $ DECCXX_REPLACE = "DECCXX=" $ ENDIF $ IF ccname .EQS. "GCC" $ THEN $ GNUC_REPLACE = "GNUC=gnuc=1" $ ELSE $ GNUC_REPLACE = "GNUC=" $ ENDIF $ IF Has_Dec_C_Sockets $ THEN $ SOCKET_REPLACE = "SOCKET=DECC_SOCKETS=1" $ ELSE $ IF Has_Socketshr $ THEN $ SOCKET_REPLACE = "SOCKET=SOCKETSHR_SOCKETS=1" $ ELSE $ SOCKET_REPLACE = "SOCKET=" $ ENDIF $ ENDIF $ IF use_threads $ THEN $ IF (vms_ver .LES. "6.2") $ THEN $ THREAD_REPLACE = "THREAD=OLDTHREADED=1" $ ELSE $ THREAD_REPLACE = "THREAD=THREADED=1" $ ENDIF $ ELSE $ THREAD_REPLACE = "THREAD=" $ ENDIF $ IF mymalloc $ THEN $ MALLOC_REPLACE = "MALLOC=MALLOC=1" $ ELSE $ MALLOC_REPLACE = "MALLOC=" $ ENDIF $ IF uselargefiles .OR. uselargefiles .EQS. "define" $ THEN $ IF usestdstat .or. usestdstat .eqs. "define" $ THEN $ LARGEFILE_REPLACE = "LARGEFILE=LARGEFILE=_USE_STD_STAT=1" $ ELSE $ LARGEFILE_REPLACE = "LARGEFILE=LARGEFILE=_LARGEFILE=1" $ ENDIF $ ELSE $ LARGEFILE_REPLACE = "LARGEFILE=" $ ENDIF $! $! In order not to stress the tiny command buffer on pre-7.3-2 systems, $! we put the following substitutions in a file and pass the file to $! munchconfig. $! $ open/write CONFIG extra_subs.txt $ WC := write CONFIG $ WC "''DECC_REPLACE'" $ WC "''DECCXX_REPLACE'" $ WC "''ARCH_TYPE'" $ WC "''GNUC_REPLACE'" $ WC "''SOCKET_REPLACE'" $ WC "''THREAD_REPLACE'" $ WC "''C_Compiler_Replace'" $ WC "''MALLOC_REPLACE'" $ WC "''THREAD_UPCALLS'" $ WC "''THREAD_KERNEL'" $ WC "PV=''version'" $ WC "FLAGS=FLAGS=''extra_flags'" $ WC "''LARGEFILE_REPLACE'" $ close CONFIG $! $ echo4 "Extracting ''defmakefile' (with variable substitutions)" $ DEFINE/USER_MODE sys$output 'UUmakefile' $ mcr []munchconfig 'config_sh' 'Makefile_SH' -f extra_subs.txt $! Clean up after ourselves $ DELETE/NOLOG/NOCONFIRM []munchconfig.exe; $ DELETE/NOLOG/NOCONFIRM []extra_subs.txt; $! $! Note that the /key qualifier to search, as in: $! search README.* "=head"/key=(position=1)/window=0/output=extra.pods $! is not supported on VMS V5.5-2, hence not used in extra_pods.com. $! $ echo4 "Extracting extra_pods.com (without variable substitutions)" $ Create Sys$Disk:[-]extra_pods.com $ Deck/Dollar="$EOExtra_Pods$" $!++ extra_pods.com $! NOTE: This file is extracted as part of the VMS configuration process. $! Any changes made to it directly will be lost. If you need to make any $! changes, please edit the template in Configure.Com instead. $! Use FORCE if you've just podified a README.* file on VMS. $ if f$search("extra.pods") .eqs. "" .or. P1 .eqs. "FORCE" then - search README.* "=head"/window=0/output=extra.pods $ open/read/error=extra_close EXTRA extra.pods $extra_loop: $ read/error=extra_close/END_OF_FILE=extra_close EXTRA file $ file_type = f$edit(f$parse(file,,,"TYPE",),"LOWERCASE") - "." $ if file_type .nes. "VMS" .and. file_type .nes. "vms" $ then $ pod_file = "[.pod]perl''file_type'.pod" $ file = file - "''f$parse(file,,,"VERSION",)'" $ if p1 .eqs. "CLEAN" $ then if f$search(pod_file) .nes. "" then delete/log 'pod_file';* $ else $ do_copy := false $ if f$search(pod_file) .eqs. "" $ then do_copy := true $ else $ file_rdt = f$cvtime(f$file_attributes(file,"RDT")) $ pod_file_rdt = f$cvtime(f$file_attributes(pod_file,"RDT")) $ if file_rdt .GTS. pod_file_rdt then do_copy := true $ endif $ ! wacky method to preserve case on ODS-5 even when parse style is traditional $ if do_copy then mcr sys$disk:[]miniperl.exe -e "exit 0+$^E unless File::Copy::rmscopy(q{''file'}, q{''pod_file'});" $ endif $ endif $ goto extra_loop $extra_close: $ close EXTRA $ if p1 .eqs. "CLEAN" .and. f$search("extra.pods;-1") .nes. "" then - purge/nolog extra.pods $!-- extra_pods.com $EOExtra_Pods$ $! $! Warn of dangerous symbols or logical names $! $Bad_environment: SUBROUTINE $ Bad_env = "" $ IF p2 .eqs. "SYMBOL" $ THEN $ IF f$type('p1') .nes. "" THEN Bad_env := SYMBOL $ ELSE $ IF f$trnlnm(p1) .nes. "" THEN Bad_env := LOGICAL $ ENDIF $ IF Bad_env .eqs. "SYMBOL" .or. Bad_env .eqs. "LOGICAL" $ THEN $ IF f$search("config.msg") .nes. "" $ THEN $ OPEN/APPEND CONFIG config.msg $ ELSE $ OPEN/WRITE CONFIG config.msg $ ENDIF $ IF Bad_env .eqs. "SYMBOL" $ THEN $ WRITE CONFIG "" $ WRITE CONFIG "Symbol name ''p1' found in environment as " + &p1 $ WRITE CONFIG " delete before building ''package' via:" $ WRITE CONFIG " $ DELETE/SYMBOL/GLOBAL ''p1'" $ IF f$locate("""",&p1) .ge. f$length(&p1) $ THEN $ WRITE CONFIG " after building, testing, and installing ''package'" $ WRITE CONFIG " restore the symbol with:" $ WRITE CONFIG " $ ''p1' == """ + &p1 + """" $ ENDIF $ ENDIF $ IF Bad_env .eqs. "LOGICAL" $ THEN $ WRITE CONFIG "" $ WRITE CONFIG "Logical name ''p1' found in environment as " + f$trnlnm(p1) $ WRITE CONFIG " deassign before building ''package'" $ ENDIF $ CLOSE CONFIG $ Bad_env = "" $ ENDIF $ EXIT $ ENDSUBROUTINE ! Bad_environment $ echo "" $ echo4 "Checking for dangerous pre-existing global symbols and logical names." $ CALL Bad_environment "COMP" $ CALL Bad_environment "EXT" $ CALL Bad_environment "FOO" $ CALL Bad_environment "LIB" $ CALL Bad_environment "LIST" $ CALL Bad_environment "MIME" $ CALL Bad_environment "POSIX" $ CALL Bad_environment "SYS" $ CALL Bad_environment "T" $ CALL Bad_environment "THREAD" $ CALL Bad_environment "THREADS" $ CALL Bad_environment "TIME" $ CALL Bad_environment "TMP" $ CALL Bad_environment "UNICODE" $ CALL Bad_environment "UTIL" $ CALL Bad_environment "TEST" "SYMBOL" $ IF f$search("config.msg") .eqs. "" THEN echo "OK." $! $! %Config-I-VMS, write perl_setup.com here $! $ IF (.NOT.perl_symbol) $ THEN $ file_2_find = "[-]''packageup'.cld" $ echo "" $ echo4 "The perl.cld file is now being written..." $ OPEN/WRITE CONFIG 'file_2_find' $ ext = ".exe" $ IF (sharedperl .AND. F$EXTRACT(0,7,archname) .EQS. "VMS_AXP") THEN ext := .AXE $ IF (sharedperl .AND. F$EXTRACT(0,8,archname) .EQS. "VMS_IA64") THEN ext := .IXE $ IF (use_vmsdebug_perl) $ THEN $ WRITE CONFIG "define verb dbgperl" $ WRITE CONFIG F$FAO("!_!AS","image ''vms_prefix':[000000]dbgperl''ext'") $ WRITE CONFIG F$FAO("!_!AS","cliflags (foreign)") $ WRITE CONFIG "" $ WRITE CONFIG "define verb perl" $ WRITE CONFIG F$FAO("!_!AS","image ''vms_prefix':[000000]ndbgPerl''ext'") $ WRITE CONFIG F$FAO("!_!AS","cliflags (foreign)") $ ELSE $ WRITE CONFIG "define verb perl" $ WRITE CONFIG F$FAO("!_!AS","image ''vms_prefix':[000000]perl''ext'") $ WRITE CONFIG F$FAO("!_!AS","cliflags (foreign)") $ ENDIF $ CLOSE CONFIG $ ENDIF ! (.NOT.perl_symbol) $ echo "" $ echo4 "The perl_setup.com file is now being written..." $ file_2_find = "[-]perl_setup.com" $! $! Folks are likely to want to edit perl_setup.com. $! STMLF RFM plays nicer with ported editors than does VFC. $! $ CREATE [-]CONFIG.FDL $ DECK RECORD FORMAT STREAM_LF $ EOD $ CREATE /FDL=[-]CONFIG.FDL 'file_2_find' $ OPEN/APPEND CONFIG 'file_2_find' $ DELETE/NOLOG/NOCONFIRM [-]CONFIG.FDL; $ WRITE CONFIG "$!" $ WRITE CONFIG "$! Perl_Setup.com ''cf_time'" $ IF cf_email.NES.perladmin $ THEN $ WRITE CONFIG "$! perl configured by ''cf_email'" $ ELSE $ WRITE CONFIG "$! This perl configured & administered by ''perladmin'" $ ENDIF $ WRITE CONFIG "$!" $! HP hack to make distributing binaries easier $!---------------------------------------------- $ pcsi_producer = f$trnlnm("PCSI_PRODUCER") $ if pcsi_producer .eqs. "" $ then $ WRITE CONFIG "$ define/translation=concealed ''vms_prefix' ''prefix'" $ else $ WRITE CONFIG "$ myproc = f$environment(""PROCEDURE"")" $ WRITE CONFIG "$ myroot_dev = f$parse(myproc,,,""DEVICE"",""NO_CONCEAL"")" $ WRITE CONFIG "$ myroot_dir = f$parse(myproc,,,""DIRECTORY"",""NO_CONCEAL"")" $ WRITE CONFIG "$ myroot_dir = myroot_dir - ""][000000."" - ""><000000.""" $ WRITE CONFIG "$ myroot_dir = myroot_dir - ""][000000]"" - ""><000000>""" $ WRITE CONFIG "$ myroot_dir = myroot_dir - ""]["" - ""><""" $ WRITE CONFIG "$ myroot_dir = myroot_dir - "".]"" - "".>"" - ""["" - ""]"" - ""<"" - "">""" $ WRITE CONFIG "$ if f$trnlnm(""HP_BUILD_PERL_BIN_KIT"",""LNM$PROCESS_TABLE"") .EQS. """"" $ WRITE CONFIG "$ then" $ WRITE CONFIG "$ define/translation=concealed ''vms_prefix' 'myroot_dev'['myroot_dir'.]" $ WRITE CONFIG "$ endif" $ endif $ WRITE CONFIG "$ ext = "".exe""" $ IF sharedperl $ THEN $ WRITE CONFIG "$ if f$getsyi(""ARCH_TYPE"") .eq. 2 then ext = "".AXE""" $ WRITE CONFIG "$ if f$getsyi(""ARCH_TYPE"") .eq. 3 then ext = "".IXE""" $ ENDIF $ IF (perl_symbol) $ THEN $ perl_setup_perl = "'" + "'perl'" ! triple quoted foreign command symbol $ IF (use_vmsdebug_perl) $ THEN $ WRITE CONFIG "$ dbgperl :== $''vms_prefix':[000000]dbgperl'ext'" $ WRITE CONFIG "$ perl :== $''vms_prefix':[000000]ndbgperl'ext'" $ WRITE CONFIG "$ define dbgperlshr ''vms_prefix':[000000]dbgperlshr'ext'" $ ELSE $ WRITE CONFIG "$ perl :== $''vms_prefix':[000000]Perl'ext'" $ WRITE CONFIG "$ define perlshr ''vms_prefix':[000000]perlshr'ext'" $ ENDIF $ ELSE ! .NOT.perl_symbol $ perl_setup_perl = "perl" ! command verb $ IF (use_vmsdebug_perl) $ THEN $ WRITE CONFIG "$ define dbgperlshr ''vms_prefix':[000000]dbgperlshr'ext'" $ ELSE $ WRITE CONFIG "$ define perlshr ''vms_prefix':[000000]perlshr'ext'" $ ENDIF $ IF perl_verb .EQS. "PROCESS" $ THEN $ WRITE CONFIG "$ set command ''vms_prefix':[000000]''packageup'.CLD" $ ENDIF $ ENDIF ! perl_symbol $! $ IF (tzneedset) $ THEN $ WRITE CONFIG "$ define SYS$TIMEZONE_DIFFERENTIAL ''tzd'" $ ELSE !leave in but commented out (in case setting was from perl :-) $ WRITE CONFIG "$! define SYS$TIMEZONE_DIFFERENTIAL ''tzd'" $ ENDIF $ WRITE CONFIG "$!" $ WRITE CONFIG "$! Symbols for Perl-based utility programs:" $ WRITE CONFIG "$!" $ WRITE CONFIG "$ c2ph == """ + perl_setup_perl + " ''vms_prefix':[utils]c2ph.com""" $ WRITE CONFIG "$ config_data== """ + perl_setup_perl + " ''vms_prefix':[utils]config_data.com""" $ WRITE CONFIG "$ corelist == """ + perl_setup_perl + " ''vms_prefix':[utils]corelist.com""" $ WRITE CONFIG "$ cpan == """ + perl_setup_perl + " ''vms_prefix':[utils]cpan.com""" $ WRITE CONFIG "$ cpan2dist == """ + perl_setup_perl + " ''vms_prefix':[utils]cpan2dist.com""" $! FIXME: "-" is an operator and illegal in a symbol name -- cpanp-run-perl can't work $!$ WRITE CONFIG "$ cpanp-run-perl == """ + perl_setup_perl + " ''vms_prefix':[utils]cpanp-run-perl.com""" $ WRITE CONFIG "$ cpanp == """ + perl_setup_perl + " ''vms_prefix':[utils]cpanp.com""" $ IF F$LOCATE("Devel::DProf",dynamic_ext) .LT. F$LENGTH(dynamic_ext) $ THEN $ WRITE CONFIG "$ dprofpp == """ + perl_setup_perl + " ''vms_prefix':[utils]dprofpp.com""" $ ENDIF $ WRITE CONFIG "$ enc2xs == """ + perl_setup_perl + " ''vms_prefix':[utils]enc2xs.com""" $ WRITE CONFIG "$ find2perl == """ + perl_setup_perl + " ''vms_prefix':[utils]find2perl.com""" $ WRITE CONFIG "$ h2ph == """ + perl_setup_perl + " ''vms_prefix':[utils]h2ph.com""" $ WRITE CONFIG "$ h2xs == """ + perl_setup_perl + " ''vms_prefix':[utils]h2xs.com""" $ WRITE CONFIG "$ instmodsh == """ + perl_setup_perl + " ''vms_prefix':[utils]instmodsh.com""" $ WRITE CONFIG "$ libnetcfg == """ + perl_setup_perl + " ''vms_prefix':[utils]libnetcfg.com""" $ WRITE CONFIG "$ perlbug == """ + perl_setup_perl + " ''vms_prefix':[utils]perlbug.com""" $ WRITE CONFIG "$ perldoc == """ + perl_setup_perl + " ''vms_prefix':[utils]perldoc.com """"-t""""""" $ WRITE CONFIG "$ perlivp == """ + perl_setup_perl + " ''vms_prefix':[utils]perlivp.com""" $ WRITE CONFIG "$ piconv == """ + perl_setup_perl + " ''vms_prefix':[utils]piconv.com""" $ WRITE CONFIG "$ pl2pm == """ + perl_setup_perl + " ''vms_prefix':[utils]pl2pm.com""" $ WRITE CONFIG "$ pod2html == """ + perl_setup_perl + " ''vms_prefix':[utils]pod2html.com""" $ WRITE CONFIG "$ pod2latex == """ + perl_setup_perl + " ''vms_prefix':[utils]pod2latex.com""" $ WRITE CONFIG "$ pod2text == """ + perl_setup_perl + " ''vms_prefix':[utils]pod2text.com""" $ WRITE CONFIG "$!pod2man == """ + perl_setup_perl + " ''vms_prefix':[utils]pod2man.com""" $ WRITE CONFIG "$ pod2usage == """ + perl_setup_perl + " ''vms_prefix':[utils]pod2usage.com""" $ WRITE CONFIG "$ podchecker == """ + perl_setup_perl + " ''vms_prefix':[utils]podchecker.com""" $ WRITE CONFIG "$ podselect == """ + perl_setup_perl + " ''vms_prefix':[utils]podselect.com""" $ WRITE CONFIG "$ prove == """ + perl_setup_perl + " ''vms_prefix':[utils]prove.com""" $ WRITE CONFIG "$ psed == """ + perl_setup_perl + " ''vms_prefix':[utils]psed.com""" $ WRITE CONFIG "$ pstruct == """ + perl_setup_perl + " ''vms_prefix':[utils]pstruct.com""" $ WRITE CONFIG "$ s2p == """ + perl_setup_perl + " ''vms_prefix':[utils]s2p.com""" $ WRITE CONFIG "$ ptar == """ + perl_setup_perl + " ''vms_prefix':[utils]ptar.com""" $ WRITE CONFIG "$ ptardiff == """ + perl_setup_perl + " ''vms_prefix':[utils]ptardiff.com""" $ WRITE CONFIG "$ shasum == """ + perl_setup_perl + " ''vms_prefix':[utils]shasum.com""" $ WRITE CONFIG "$ splain == """ + perl_setup_perl + " ''vms_prefix':[utils]splain.com""" $ WRITE CONFIG "$ xsubpp == """ + perl_setup_perl + " ''vms_prefix':[utils]xsubpp.com""" $ CLOSE CONFIG $! $ echo "" $ echo "The file can be found at:" $ echo4 " ''F$SEARCH(file_2_find)'" $ echo "Add that file (or an @ call to it) to your [SY]LOGIN.COM" $ echo "when you are satisfied with a successful compilation," $ echo "testing, and installation of your perl." $ echo "" $ IF ((.NOT.perl_symbol) .AND. (perl_verb .EQS. "DCLTABLES")) $ THEN $ file_2_find = "[-]''packageup'_install.com" $ OPEN/WRITE CONFIG 'file_2_find' $ WRITE CONFIG "$ set command perl /table=sys$common:[syslib]dcltables.exe -" $ WRITE CONFIG " /output=sys$common:[syslib]dcltables.exe" $ WRITE CONFIG "$ install replace sys$common:[syslib]dcltables.exe" $ CLOSE CONFIG $ echo4 "" $ echo4 "In order to install the ''packageup' verb into DCLTABLES run:" $ echo4 " @ ''F$SEARCH(file_2_find)'" $ echo4 "after a successful build, test, and install. Do so with CMKRNL privilege." $ echo4 "" $ ENDIF $! $!figure out where we "are" by parsing 'vms_default_directory_name' $! $ set_def_command = "" $ dflt = F$ENVIRONMENT("DEFAULT") - ".UU]" $ tmp = vms_default_directory_name - dflt - "]" $ i = 0 $ IF tmp .EQS. "" THEN GOTO Beyond_set_def_loop $Set_def_loop: $ tmp1 = F$ELEMENT(i,".",tmp) $ IF tmp1 .EQS. "." THEN GOTO Beyond_set_def_loop $ IF i .EQ. 0 $ THEN set_def_command = "set default [-" $ ELSE set_def_command = set_def_command + "-" $ ENDIF $ i = i + 1 $ GOTO Set_def_loop $Beyond_set_def_loop: $ IF set_def_command.NES."" $ THEN $ set_def_command = set_def_command - "-" + "]" $ echo4 "" $ echo4 "In order to build ''package' you must now issue the commands:" $ echo4 "" $ echo4 " ''set_def_command'" $ ELSE $ echo4 "" $ echo4 "In order to build ''package' you must now issue the command:" $ echo4 "" $ ENDIF $ echo4 " ''make'''makefile'", macros $ echo4 "" $! $ IF ( F$SEARCH("config.msg").NES."" ) $ THEN $ echo4 "Hmm. I also noted the following information while running:" $ echo4 "" $ TYPE/OUTPUT=SYS$ERROR: config.msg $ SET PROTECTION=(SYSTEM:RWED,OWNER:RWED) config.msg $ DELETE/NOLOG/NOCONFIRM config.msg; $ ENDIF $! $Clean_up: $ SET NOON $ IF (silent) $ THEN $ CLOSE/NOLOG STDOUT $ DEASSIGN SYS$OUTPUT $ ENDIF $ CLOSE/NOLOG CONFIG $ IF F$GETJPI("","FILCNT").GT.vms_filcnt $ THEN WRITE SYS$ERROR "%Config-W-VMS, WARNING: There is a file still open" $ ENDIF $ dflt = F$ENVIRONMENT("DEFAULT") $ IF F$LOCATE("UU]",dflt).EQS.(F$LENGTH(dflt)-3) $ THEN $ IF ( F$SEARCH("[]*.*").NES."" ) THEN DELETE/NOLOG/NOCONFIRM []*.*;* $ SET DEFAULT [-] $ SET PROTECTION=(SYSTEM:RWED,OWNER:RWED) UU.DIR $ DELETE/NOLOG/NOCONFIRM UU.DIR; $ ENDIF $ SET DEFAULT 'vms_default_directory_name' !be kind rewind $ EXIT $!: End of Configure perl-5.12.0-RC0/installhtml0000444000175000017500000004455611325125741014422 0ustar jessejesse#!./perl -Ilib -w # This file should really be extracted from a .PL file use strict; use Config; # for config options in the makefile use File::Spec; use Getopt::Long; # for command-line parsing use Cwd; use Pod::Html 'anchorify'; =head1 NAME installhtml - converts a collection of POD pages to HTML format. =head1 SYNOPSIS installhtml [--help] [--podpath=:...:] [--podroot=] [--htmldir=] [--htmlroot=] [--norecurse] [--recurse] [--splithead=,...,] [--splititem=,...,] [--libpods=,...,] [--ignore=,...,] [--verbose] =head1 DESCRIPTION I converts a collection of POD pages to a corresponding collection of HTML pages. This is primarily used to convert the pod pages found in the perl distribution. =head1 OPTIONS =over 4 =item B<--help> help Displays the usage. =item B<--podroot> POD search path base directory The base directory to search for all .pod and .pm files to be converted. Default is current directory. =item B<--podpath> POD search path The list of directories to search for .pod and .pm files to be converted. Default is 'podroot/.'. =item B<--recurse> recurse on subdirectories Whether or not to convert all .pm and .pod files found in subdirectories too. Default is to not recurse. =item B<--htmldir> HTML destination directory The base directory which all HTML files will be written to. This should be a path relative to the filesystem, not the resulting URL. =item B<--htmlroot> URL base directory The base directory which all resulting HTML files will be visible at in a URL. The default is '/'. =item B<--splithead> POD files to split on =head directive Comma-separated list of pod files to split by the =head directive. The .pod suffix is optional. These files should have names specified relative to podroot. =item B<--splititem> POD files to split on =item directive Comma-separated list of all pod files to split by the =item directive. The .pod suffix is optional. I does not do the actual split, rather it invokes I to do the dirty work. As with --splithead, these files should have names specified relative to podroot. =item B<--splitpod> Directory containing the splitpod program The directory containing the splitpod program. The default is 'podroot/pod'. =item B<--libpods> library PODs for LEE links Comma-separated list of "library" pod files. This is the same list that will be passed to pod2html when any pod is converted. =item B<--ignore> files to be ignored Comma-separated of files that shouldn't be installed, given relative to podroot. =item B<--verbose> verbose output Self-explanatory. =back =head1 EXAMPLE The following command-line is an example of the one we use to convert perl documentation: ./installhtml --podpath=lib:ext:pod:vms \ --podroot=/usr/src/perl \ --htmldir=/perl/nmanual \ --htmlroot=/perl/nmanual \ --splithead=pod/perlipc \ --splititem=pod/perlfunc \ --libpods=perlfunc,perlguts,perlvar,perlrun,perlop \ --recurse \ --verbose =head1 AUTHOR Chris Hall Ehallc@cs.colorado.eduE =cut my $usage; $usage =<:...: --podroot= --htmldir= --htmlroot= --norecurse --recurse --splithead=,..., --splititem=,..., --libpods=,..., --ignore=,..., --verbose --help - this message --podpath - colon-separated list of directories containing .pod and .pm files to be converted (. by default). --podroot - filesystem base directory from which all relative paths in podpath stem (default is .). --htmldir - directory to store resulting html files in relative to the filesystem (\$podroot/html by default). --htmlroot - http-server base directory from which all relative paths in podpath stem (default is /). --libpods - comma-separated list of files to search for =item pod directives in as targets of C<> and implicit links (empty by default). --norecurse - don't recurse on those subdirectories listed in podpath. (default behavior). --recurse - recurse on those subdirectories listed in podpath --splithead - comma-separated list of .pod or .pm files to split. will split each file into several smaller files at every occurrence of a pod =head[1-6] directive. --splititem - comma-separated list of .pod or .pm files to split using splitpod. --splitpod - directory where the program splitpod can be found (\$podroot/pod by default). --ignore - comma-separated list of files that shouldn't be installed. --verbose - self-explanatory. END_OF_USAGE my (@libpods, @podpath, $podroot, $htmldir, $htmlroot, $recurse, @splithead, @splititem, $splitpod, $verbose, $pod2html, @ignore); @libpods = (); @podpath = ( "." ); # colon-separated list of directories containing .pod # and .pm files to be converted. $podroot = "."; # assume the pods we want are here $htmldir = ""; # nothing for now... $htmlroot = "/"; # default value $recurse = 0; # default behavior @splithead = (); # don't split any files by default @splititem = (); # don't split any files by default $splitpod = ""; # nothing for now. $verbose = 0; # whether or not to print debugging info $pod2html = "pod/pod2html"; usage("") unless @ARGV; # Overcome shell's p1,..,p8 limitation. # See vms/descrip_mms.template -> descrip.mms for invokation. if ( $^O eq 'VMS' ) { @ARGV = split(/\s+/,$ARGV[0]); } use vars qw( %Options ); # parse the command-line my $result = GetOptions( \%Options, qw( help podpath=s podroot=s htmldir=s htmlroot=s libpods=s ignore=s recurse! splithead=s splititem=s splitpod=s verbose )); usage("invalid parameters") unless $result; parse_command_line(); # set these variables to appropriate values if the user didn't specify # values for them. $htmldir = "$htmlroot/html" unless $htmldir; $splitpod = "$podroot/pod" unless $splitpod; # make sure that the destination directory exists (mkdir($htmldir, 0755) || die "$0: cannot make directory $htmldir: $!\n") if ! -d $htmldir; # the following array will eventually contain files that are to be # ignored in the conversion process. these are files that have been # process by splititem or splithead and should not be converted as a # result. my @splitdirs; # split pods. It's important to do this before convert ANY pods because # it may affect some of the links @splitdirs = (); # files in these directories won't get an index split_on_head($podroot, $htmldir, \@splitdirs, \@ignore, @splithead); split_on_item($podroot, \@splitdirs, \@ignore, @splititem); # convert the pod pages found in @poddirs #warn "converting files\n" if $verbose; #warn "\@ignore\t= @ignore\n" if $verbose; foreach my $dir (@podpath) { installdir($dir, $recurse, $podroot, \@splitdirs, \@ignore); } # now go through and create master indices for each pod we split foreach my $dir (@splititem) { print "creating index $htmldir/$dir.html\n" if $verbose; create_index("$htmldir/$dir.html", "$htmldir/$dir"); } foreach my $dir (@splithead) { (my $pod = $dir) =~ s,^.*/,,; $dir .= ".pod" unless $dir =~ /(\.pod|\.pm)$/; # let pod2html create the file runpod2html($dir, 1); # now go through and truncate after the index $dir =~ /^(.*?)(\.pod|\.pm)?$/sm; my $file = "$htmldir/$1"; print "creating index $file.html\n" if $verbose; # read in everything until what would have been the first =head # directive, patching the index as we go. open(H, "<$file.html") || die "$0: error opening $file.html for input: $!\n"; $/ = ""; my @data = (); while () { last if /name="name"/i; $_ =~ s{href="#(.*)">}{ my $url = "$pod/$1.html" ; $url = Pod::Html::relativize_url( $url, "$file.html" ) if ( ! defined $Options{htmlroot} || $Options{htmlroot} eq '' ); "href=\"$url\">" ; }egi; push @data, $_; } close(H); # now rewrite the file open(H, ">$file.html") || die "$0: error opening $file.html for output: $!\n"; print H "@data", "\n"; close(H); } ############################################################################## sub usage { warn "$0: @_\n" if @_; die $usage; } sub parse_command_line { usage() if defined $Options{help}; $Options{help} = ""; # make -w shut up # list of directories @podpath = split(":", $Options{podpath}) if defined $Options{podpath}; # lists of files @splithead = split(",", $Options{splithead}) if defined $Options{splithead}; @splititem = split(",", $Options{splititem}) if defined $Options{splititem}; @libpods = split(",", $Options{libpods}) if defined $Options{libpods}; $htmldir = $Options{htmldir} if defined $Options{htmldir}; $htmlroot = $Options{htmlroot} if defined $Options{htmlroot}; $podroot = $Options{podroot} if defined $Options{podroot}; $splitpod = $Options{splitpod} if defined $Options{splitpod}; $recurse = $Options{recurse} if defined $Options{recurse}; $verbose = $Options{verbose} if defined $Options{verbose}; @ignore = map "$podroot/$_", split(",", $Options{ignore}) if defined $Options{ignore}; } sub create_index { my($html, $dir) = @_; (my $pod = $dir) =~ s,^.*/,,; my(@files, @filedata, @index, $file); my($lcp1,$lcp2); # get the list of .html files in this directory opendir(DIR, $dir) || die "$0: error opening directory $dir for reading: $!\n"; @files = sort(grep(/\.html?$/, readdir(DIR))); closedir(DIR); open(HTML, ">$html") || die "$0: error opening $html for output: $!\n"; # for each .html file in the directory, extract the index # embedded in the file and throw it into the big index. print HTML "
\n"; foreach $file (@files) { $/ = ""; open(IN, "<$dir/$file") || die "$0: error opening $dir/$file for input: $!\n"; @filedata = ; close(IN); # pull out the NAME section my $name; ($name) = grep(/name="name"/i, @filedata); ($lcp1,$lcp2) = ($name =~ m,/H1>\s(\S+)\s[\s-]*(.*?)\s*$,smi); if (defined $lcp1 and $lcp1 =~ m,^

$,i) { # Uninteresting. Try again. ($lcp1,$lcp2) = ($name =~ m,/H1>\s

\s*(\S+)\s[\s-]*(.*?)\s*$,smi); } my $url= "$pod/$file" ; if ( ! defined $Options{htmlroot} || $Options{htmlroot} eq '' ) { $url = Pod::Html::relativize_url( "$pod/$file", $html ) ; } if (defined $lcp1) { print HTML qq(

); print HTML "$lcp1
$lcp2
\n"; } next; @index = grep(/.*/s, @filedata); for (@index) { s/(\s*\s*)/$lcp2/s; s,#,$dir/$file#,g; print HTML "$_\n

\n"; } } print HTML "

\n"; close(HTML); } sub split_on_head { my($podroot, $htmldir, $splitdirs, $ignore, @splithead) = @_; my($pod, $dirname, $filename); # split the files specified in @splithead on =head[1-6] pod directives print "splitting files by head.\n" if $verbose && $#splithead >= 0; foreach $pod (@splithead) { # figure out the directory name and filename $pod =~ s,^([^/]*)$,/$1,; $pod =~ m,(.*)/(.*?)(\.pod)?$,; $dirname = $1; $filename = "$2.pod"; # since we are splitting this file it shouldn't be converted. push(@$ignore, "$podroot/$dirname/$filename"); # split the pod splitpod("$podroot/$dirname/$filename", "$podroot/$dirname", $htmldir, $splitdirs); } } sub split_on_item { my($podroot, $splitdirs, $ignore, @splititem) = @_; my($pwd, $dirname, $filename); print "splitting files by item.\n" if $verbose && $#splititem >= 0; $pwd = getcwd(); my $splitter = File::Spec->rel2abs("$splitpod/splitpod", $pwd); my $perl = File::Spec->rel2abs($^X, $pwd); foreach my $pod (@splititem) { # figure out the directory to split into $pod =~ s,^([^/]*)$,/$1,; $pod =~ m,(.*)/(.*?)(\.pod)?$,; $dirname = "$1/$2"; $filename = "$2.pod"; # since we are splitting this file it shouldn't be converted. push(@$ignore, "$podroot/$dirname.pod"); # split the pod push(@$splitdirs, "$podroot/$dirname"); if (! -d "$podroot/$dirname") { mkdir("$podroot/$dirname", 0755) || die "$0: error creating directory $podroot/$dirname: $!\n"; } chdir("$podroot/$dirname") || die "$0: error changing to directory $podroot/$dirname: $!\n"; die "$splitter not found. Use '-splitpod dir' option.\n" unless -f $splitter; system($perl, $splitter, "../$filename") && warn "$0: error running '$splitter ../$filename'" ." from $podroot/$dirname"; } chdir($pwd); } # # splitpod - splits a .pod file into several smaller .pod files # where a new file is started each time a =head[1-6] pod directive # is encountered in the input file. # sub splitpod { my($pod, $poddir, $htmldir, $splitdirs) = @_; my(@poddata, @filedata, @heads); my($file, $i, $j, $prevsec, $section, $nextsec); print "splitting $pod\n" if $verbose; # read the file in paragraphs $/ = ""; open(SPLITIN, "<$pod") || die "$0: error opening $pod for input: $!\n"; @filedata = ; close(SPLITIN) || die "$0: error closing $pod: $!\n"; # restore the file internally by =head[1-6] sections @poddata = (); for ($i = 0, $j = -1; $i <= $#filedata; $i++) { $j++ if ($filedata[$i] =~ /^\s*=head[1-6]/); if ($j >= 0) { $poddata[$j] = "" unless defined $poddata[$j]; $poddata[$j] .= "\n$filedata[$i]" if $j >= 0; } } # create list of =head[1-6] sections so that we can rewrite # L<> links as necessary. my %heads = (); foreach $i (0..$#poddata) { $heads{anchorify($1)} = 1 if $poddata[$i] =~ /=head[1-6]\s+(.*)/; } # create a directory of a similar name and store all the # files in there $pod =~ s,.*/(.*),$1,; # get the last part of the name my $dir = $pod; $dir =~ s/\.pod//g; push(@$splitdirs, "$poddir/$dir"); mkdir("$poddir/$dir", 0755) || die "$0: could not create directory $poddir/$dir: $!\n" unless -d "$poddir/$dir"; $poddata[0] =~ /^\s*=head[1-6]\s+(.*)/; $section = ""; $nextsec = $1; # for each section of the file create a separate pod file for ($i = 0; $i <= $#poddata; $i++) { # determine the "prev" and "next" links $prevsec = $section; $section = $nextsec; if ($i < $#poddata) { $poddata[$i+1] =~ /^\s*=head[1-6]\s+(.*)/; $nextsec = $1; } else { $nextsec = ""; } # determine an appropriate filename (this must correspond with # what pod2html will try and guess) # $poddata[$i] =~ /^\s*=head[1-6]\s+(.*)/; $file = "$dir/" . anchorify($section) . ".pod"; # create the new .pod file print "\tcreating $poddir/$file\n" if $verbose; open(SPLITOUT, ">$poddir/$file") || die "$0: error opening $poddir/$file for output: $!\n"; $poddata[$i] =~ s,L<([^<>]*)>, defined $heads{anchorify($1)} ? "L<$dir/$1>" : "L<$1>" ,ge; print SPLITOUT $poddata[$i]."\n\n"; print SPLITOUT "=over 4\n\n"; print SPLITOUT "=item *\n\nBack to L<$dir/\"$prevsec\">\n\n" if $prevsec; print SPLITOUT "=item *\n\nForward to L<$dir/\"$nextsec\">\n\n" if $nextsec; print SPLITOUT "=item *\n\nUp to L<$dir>\n\n"; print SPLITOUT "=back\n\n"; close(SPLITOUT) || die "$0: error closing $poddir/$file: $!\n"; } } # # installdir - takes care of converting the .pod and .pm files in the # current directory to .html files and then installing those. # sub installdir { my($dir, $recurse, $podroot, $splitdirs, $ignore) = @_; my(@dirlist, @podlist, @pmlist, $doindex); @dirlist = (); # directories to recurse on @podlist = (); # .pod files to install @pmlist = (); # .pm files to install # should files in this directory get an index? $doindex = (grep($_ eq "$podroot/$dir", @$splitdirs) ? 0 : 1); opendir(DIR, "$podroot/$dir") || die "$0: error opening directory $podroot/$dir: $!\n"; # find the directories to recurse on @dirlist = map { if ($^O eq 'VMS') {/^(.*)\.dir$/i; "$dir/$1";} else {"$dir/$_";}} grep(-d "$podroot/$dir/$_" && !/^\.{1,2}/, readdir(DIR)) if $recurse; rewinddir(DIR); # find all the .pod files within the directory @podlist = map { /^(.*)\.pod$/; "$dir/$1" } grep(! -d "$podroot/$dir/$_" && /\.pod$/, readdir(DIR)); rewinddir(DIR); # find all the .pm files within the directory @pmlist = map { /^(.*)\.pm$/; "$dir/$1" } grep(! -d "$podroot/$dir/$_" && /\.pm$/, readdir(DIR)); closedir(DIR); # recurse on all subdirectories we kept track of foreach $dir (@dirlist) { installdir($dir, $recurse, $podroot, $splitdirs, $ignore); } # install all the pods we found foreach my $pod (@podlist) { # check if we should ignore it. next if $pod =~ m(/t/); # comes from a test file next if grep($_ eq "$pod.pod", @$ignore); # check if a .pm files exists too if (grep($_ eq $pod, @pmlist)) { print "$0: Warning both '$podroot/$pod.pod' and " . "'$podroot/$pod.pm' exist, using pod\n"; push(@ignore, "$pod.pm"); } runpod2html("$pod.pod", $doindex); } # install all the .pm files we found foreach my $pm (@pmlist) { # check if we should ignore it. next if $pm =~ m(/t/); # comes from a test file next if grep($_ eq "$pm.pm", @ignore); runpod2html("$pm.pm", $doindex); } } # # runpod2html - invokes pod2html to convert a .pod or .pm file to a .html # file. # sub runpod2html { my($pod, $doindex) = @_; my($html, $i, $dir, @dirs); $html = $pod; $html =~ s/\.(pod|pm)$/.html/g; # make sure the destination directories exist @dirs = split("/", $html); $dir = "$htmldir/"; for ($i = 0; $i < $#dirs; $i++) { if (! -d "$dir$dirs[$i]") { mkdir("$dir$dirs[$i]", 0755) || die "$0: error creating directory $dir$dirs[$i]: $!\n"; } $dir .= "$dirs[$i]/"; } # invoke pod2html print "$podroot/$pod => $htmldir/$html\n" if $verbose; Pod::Html::pod2html( "--htmldir=$htmldir", "--htmlroot=$htmlroot", "--podpath=".join(":", @podpath), "--podroot=$podroot", "--netscape", "--header", ($doindex ? "--index" : "--noindex"), "--" . ($recurse ? "" : "no") . "recurse", ($#libpods >= 0) ? "--libpods=" . join(":", @libpods) : "", "--infile=$podroot/$pod", "--outfile=$htmldir/$html"); die "$0: error running $pod2html: $!\n" if $?; } perl-5.12.0-RC0/perldtrace.d0000444000175000017500000000033411325125742014421 0ustar jessejesse/* * Written by Alan Burlinson -- taken from his blog post * at . */ provider perl { probe sub__entry(char *, char *, int); probe sub__return(char *, char *, int); }; perl-5.12.0-RC0/installman0000555000175000017500000001503011325125741014215 0ustar jessejesse#!./perl -w BEGIN { @INC = qw(lib); # This needs to be at BEGIN time, before any use of Config require './install_lib.pl'; } use strict; use Getopt::Long; use File::Find; use File::Copy; use File::Path qw(mkpath); use ExtUtils::Packlist; use Pod::Man; use vars qw($Is_VMS $Is_W32 $Is_OS2 $Is_Cygwin $Is_Darwin $Is_NetWare %opts $packlist); $ENV{SHELL} = 'sh' if $^O eq 'os2'; my $patchlevel = substr($],3,2); die "Patchlevel of perl ($patchlevel)", "and patchlevel of config.sh ($Config{'PERL_VERSION'}) don't match\n" if $patchlevel != $Config{'PERL_VERSION'}; my $usage = "Usage: installman --man1dir=/usr/wherever --man1ext=1 --man3dir=/usr/wherever --man3ext=3 --batchlimit=40 --notify --verbose --silent --help Defaults are: man1dir = $Config{'installman1dir'}; man1ext = $Config{'man1ext'}; man3dir = $Config{'installman3dir'}; man3ext = $Config{'man3ext'}; --notify (or -n) just lists commands that would be executed. --verbose (or -V) report all progress. --silent (or -S) be silent. Only report errors.\n"; GetOptions( \%opts, qw( man1dir=s man1ext=s man3dir=s man3ext=s batchlimit=i destdir:s notify n help silent S verbose V)) || die $usage; die $usage if $opts{help}; $opts{destdir} //= ''; foreach my $pre (qw(man1 man3)) { $opts{"${pre}dir"} //= $opts{destdir} . $Config{"install${pre}dir"}; $opts{"${pre}ext"} //= $Config{"${pre}ext"}; } $opts{silent} ||= $opts{S}; $opts{notify} ||= $opts{n}; $opts{verbose} ||= $opts{V} || $opts{notify}; #Sanity checks -x "./perl$Config{exe_ext}" or warn "./perl$Config{exe_ext} not found! Have you run make?\n"; -d "$opts{destdir}$Config{'installprivlib'}" || warn "Perl library directory $Config{'installprivlib'} not found. Have you run make install?. (Installing anyway.)\n"; -x "t/perl$Config{exe_ext}" || warn "WARNING: You've never run 'make test'!!!", " (Installing anyway.)\n"; $packlist = ExtUtils::Packlist->new("$opts{destdir}$Config{installarchlib}/.packlist"); # Install the main pod pages. pod2man('pod', $opts{man1dir}, $opts{man1ext}); # Install the pods for library modules. pod2man('lib', $opts{man3dir}, $opts{man3ext}); # Install the pods embedded in the installed scripts my $has_man1dir = $opts{man1dir} ne '' && -d $opts{man1dir}; open UTILS, "utils.lst" or die "Can't open 'utils.lst': $!"; while () { next if /^#/; chomp; $_ = $1 if /#.*pod\s*=\s*(\S+)/; my ($where, $what) = m|^(\S*)/(\S+)|; pod2man($where, $opts{man1dir}, $opts{man1ext}, $what); if ($has_man1dir) { if (my ($where2, $what2) = m|#.*link\s*=\s*(\S+)/(\S+)|) { my $old = "$opts{man1dir}/$what.$opts{man1ext}"; my $new = "$opts{man1dir}/$what2.$opts{man1ext}"; unlink($new); link($old, $new); my $xold = $old; $xold =~ s/^\Q$opts{'destdir'}\E// if $opts{'destdir'}; my $xnew = $new; $xnew =~ s/^\Q$opts{'destdir'}\E// if $opts{'destdir'}; $packlist->{$xnew} = { from => $xold, type => 'link' }; } } } sub pod2man { # @script is scripts names if we are installing manpages embedded # in scripts, () otherwise my($poddir, $mandir, $manext, @script) = @_; if ($mandir eq ' ' or $mandir eq '') { if (@script) { warn "Skipping installation of $poddir/$_ man page.\n" foreach @script; } else { warn "Skipping installation of $poddir man pages.\n"; } return; } print "installing from $poddir\n" if $opts{verbose}; mkpath($mandir, $opts{verbose}, 0777) unless $opts{notify}; # In File::Path # Make a list of all the .pm and .pod files in the directory. We avoid # chdir because we are running with @INC = '../lib', and modules may wish # to dynamically require Carp::Heavy or other diagnostics warnings. # Hash the names of files we find, keys are names relative to perl build # dir ('.'), values are names relative to $poddir. my %modpods; if (@script) { %modpods = (map {+"$poddir/$_", $_} @script); } else { File::Find::find({no_chdir=>1, wanted => sub { # $_ is $File::Find::name when using no_chdir if (-f $_ and /\.p(?:m|od)$/) { my $fullname = $_; s!^\Q$poddir\E/!!; $modpods{$fullname} = $_; } }}, $poddir); } my @to_process; foreach my $mod (sort keys %modpods) { my $manpage = $modpods{$mod}; my $tmp; # Skip .pm files that have corresponding .pod files, and Functions.pm. next if (($tmp = $mod) =~ s/\.pm$/.pod/ && -f $tmp); next if $mod =~ m:/t/:; # no pods from test directories next if ($manpage eq 'Pod/Functions.pm'); #### Used only by pod itself # Skip files without pod docs my $has_pod; if (open T, $mod) { local $_; while () { ++$has_pod and last if /^=(?:head\d+|item|pod)\b/; } close T; } unless ($has_pod) { warn "no documentation in $mod\n"; next; } # Convert name from File/Basename.pm to File::Basename.3 format, # if necessary. $manpage =~ s#\.p(m|od)$##; if ($^O eq 'os2' || $^O eq 'amigaos' || $^O eq 'uwin' || $^O eq 'cygwin') { $manpage =~ s#/#.#g; } else { $manpage =~ s#/#::#g; } $tmp = "${mandir}/${manpage}.tmp"; $manpage = "${mandir}/${manpage}.${manext}"; push @to_process, [$mod, $tmp, $manpage]; } foreach my $page (@to_process) { my($pod, $tmp, $manpage) = @$page; my $parser = Pod::Man->new( section => $manext, official=> 1, center => 'Perl Programmers Reference Guide' ); my $xmanpage = $manpage; $xmanpage =~ s/^\Q$opts{'destdir'}\E// if $opts{'destdir'}; print " $xmanpage\n"; if (!$opts{notify} && $parser->parse_from_file($pod, $tmp)) { if (-s $tmp) { if (rename($tmp, $manpage)) { $packlist->{$xmanpage} = { type => 'file' }; next; } } unlink($tmp); } } } $packlist->write() unless $opts{notify}; print " Installation complete\n" if $opts{verbose}; exit 0; sub rename { my($from,$to) = @_; if (-f $to and not unlink($to)) { my($i); for ($i = 1; $i < 50; $i++) { last if CORE::rename($to, "$to.$i"); } warn("Cannot rename to `$to.$i': $!"), return 0 if $i >= 50; # Give up! } link($from,$to) || return 0; unlink($from); } perl-5.12.0-RC0/reentr.c0000644000175000017500000003763611325125742013613 0ustar jessejesse/* -*- buffer-read-only: t -*- * * reentr.c * * Copyright (C) 2002, 2003, 2005, 2006, 2007 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * * !!!!!!! DO NOT EDIT THIS FILE !!!!!!! * This file is built by reentr.pl from data in reentr.pl. * * "Saruman," I said, standing away from him, "only one hand at a time can * wield the One, and you know that well, so do not trouble to say we!" * * This file contains a collection of automatically created wrappers * (created by running reentr.pl) for reentrant (thread-safe) versions of * various library calls, such as getpwent_r. The wrapping is done so * that other files like pp_sys.c calling those library functions need not * care about the differences between various platforms' idiosyncrasies * regarding these reentrant interfaces. */ #include "EXTERN.h" #define PERL_IN_REENTR_C #include "perl.h" #include "reentr.h" void Perl_reentrant_size(pTHX) { #ifdef USE_REENTRANT_API #define REENTRANTSMALLSIZE 256 /* Make something up. */ #define REENTRANTUSUALSIZE 4096 /* Make something up. */ #ifdef HAS_ASCTIME_R PL_reentrant_buffer->_asctime_size = REENTRANTSMALLSIZE; #endif /* HAS_ASCTIME_R */ #ifdef HAS_CRYPT_R #endif /* HAS_CRYPT_R */ #ifdef HAS_CTIME_R PL_reentrant_buffer->_ctime_size = REENTRANTSMALLSIZE; #endif /* HAS_CTIME_R */ #ifdef HAS_DRAND48_R #endif /* HAS_DRAND48_R */ #ifdef HAS_GETGRNAM_R # if defined(HAS_SYSCONF) && defined(_SC_GETGR_R_SIZE_MAX) && !defined(__GLIBC__) PL_reentrant_buffer->_grent_size = sysconf(_SC_GETGR_R_SIZE_MAX); if (PL_reentrant_buffer->_grent_size == (size_t) -1) PL_reentrant_buffer->_grent_size = REENTRANTUSUALSIZE; # else # if defined(__osf__) && defined(__alpha) && defined(SIABUFSIZ) PL_reentrant_buffer->_grent_size = SIABUFSIZ; # else # ifdef __sgi PL_reentrant_buffer->_grent_size = BUFSIZ; # else PL_reentrant_buffer->_grent_size = REENTRANTUSUALSIZE; # endif # endif # endif #endif /* HAS_GETGRNAM_R */ #ifdef HAS_GETHOSTBYNAME_R #if !(GETHOSTBYNAME_R_PROTO == REENTRANT_PROTO_I_CSD) PL_reentrant_buffer->_hostent_size = REENTRANTUSUALSIZE; #endif #endif /* HAS_GETHOSTBYNAME_R */ #ifdef HAS_GETLOGIN_R PL_reentrant_buffer->_getlogin_size = REENTRANTSMALLSIZE; #endif /* HAS_GETLOGIN_R */ #ifdef HAS_GETNETBYNAME_R #if !(GETNETBYNAME_R_PROTO == REENTRANT_PROTO_I_CSD) PL_reentrant_buffer->_netent_size = REENTRANTUSUALSIZE; #endif #endif /* HAS_GETNETBYNAME_R */ #ifdef HAS_GETPROTOBYNAME_R #if !(GETPROTOBYNAME_R_PROTO == REENTRANT_PROTO_I_CSD) PL_reentrant_buffer->_protoent_size = REENTRANTUSUALSIZE; #endif #endif /* HAS_GETPROTOBYNAME_R */ #ifdef HAS_GETPWNAM_R # if defined(HAS_SYSCONF) && defined(_SC_GETPW_R_SIZE_MAX) && !defined(__GLIBC__) PL_reentrant_buffer->_pwent_size = sysconf(_SC_GETPW_R_SIZE_MAX); if (PL_reentrant_buffer->_pwent_size == (size_t) -1) PL_reentrant_buffer->_pwent_size = REENTRANTUSUALSIZE; # else # if defined(__osf__) && defined(__alpha) && defined(SIABUFSIZ) PL_reentrant_buffer->_pwent_size = SIABUFSIZ; # else # ifdef __sgi PL_reentrant_buffer->_pwent_size = BUFSIZ; # else PL_reentrant_buffer->_pwent_size = REENTRANTUSUALSIZE; # endif # endif # endif #endif /* HAS_GETPWNAM_R */ #ifdef HAS_GETSERVBYNAME_R #if !(GETSERVBYNAME_R_PROTO == REENTRANT_PROTO_I_CCSD) PL_reentrant_buffer->_servent_size = REENTRANTUSUALSIZE; #endif #endif /* HAS_GETSERVBYNAME_R */ #ifdef HAS_GETSPNAM_R # if defined(HAS_SYSCONF) && defined(_SC_GETPW_R_SIZE_MAX) && !defined(__GLIBC__) PL_reentrant_buffer->_spent_size = sysconf(_SC_GETPW_R_SIZE_MAX); if (PL_reentrant_buffer->_spent_size == (size_t) -1) PL_reentrant_buffer->_spent_size = REENTRANTUSUALSIZE; # else # if defined(__osf__) && defined(__alpha) && defined(SIABUFSIZ) PL_reentrant_buffer->_spent_size = SIABUFSIZ; # else # ifdef __sgi PL_reentrant_buffer->_spent_size = BUFSIZ; # else PL_reentrant_buffer->_spent_size = REENTRANTUSUALSIZE; # endif # endif # endif #endif /* HAS_GETSPNAM_R */ #ifdef HAS_RANDOM_R #endif /* HAS_RANDOM_R */ #ifdef HAS_READDIR_R /* This is the size Solaris recommends. * (though we go static, should use pathconf() instead) */ PL_reentrant_buffer->_readdir_size = sizeof(struct dirent) + MAXPATHLEN + 1; #endif /* HAS_READDIR_R */ #ifdef HAS_READDIR64_R /* This is the size Solaris recommends. * (though we go static, should use pathconf() instead) */ PL_reentrant_buffer->_readdir64_size = sizeof(struct dirent64) + MAXPATHLEN + 1; #endif /* HAS_READDIR64_R */ #ifdef HAS_SETLOCALE_R PL_reentrant_buffer->_setlocale_size = REENTRANTSMALLSIZE; #endif /* HAS_SETLOCALE_R */ #ifdef HAS_SRANDOM_R #endif /* HAS_SRANDOM_R */ #ifdef HAS_STRERROR_R PL_reentrant_buffer->_strerror_size = REENTRANTSMALLSIZE; #endif /* HAS_STRERROR_R */ #ifdef HAS_TTYNAME_R PL_reentrant_buffer->_ttyname_size = REENTRANTSMALLSIZE; #endif /* HAS_TTYNAME_R */ #endif /* USE_REENTRANT_API */ } void Perl_reentrant_init(pTHX) { #ifdef USE_REENTRANT_API Newx(PL_reentrant_buffer, 1, REENTR); Perl_reentrant_size(aTHX); #ifdef HAS_ASCTIME_R Newx(PL_reentrant_buffer->_asctime_buffer, PL_reentrant_buffer->_asctime_size, char); #endif /* HAS_ASCTIME_R */ #ifdef HAS_CRYPT_R #if CRYPT_R_PROTO != REENTRANT_PROTO_B_CCD PL_reentrant_buffer->_crypt_struct_buffer = 0; #endif #endif /* HAS_CRYPT_R */ #ifdef HAS_CTIME_R Newx(PL_reentrant_buffer->_ctime_buffer, PL_reentrant_buffer->_ctime_size, char); #endif /* HAS_CTIME_R */ #ifdef HAS_DRAND48_R #endif /* HAS_DRAND48_R */ #ifdef HAS_GETGRNAM_R # ifdef USE_GRENT_FPTR PL_reentrant_buffer->_grent_fptr = NULL; # endif Newx(PL_reentrant_buffer->_grent_buffer, PL_reentrant_buffer->_grent_size, char); #endif /* HAS_GETGRNAM_R */ #ifdef HAS_GETHOSTBYNAME_R #if !(GETHOSTBYNAME_R_PROTO == REENTRANT_PROTO_I_CSD) Newx(PL_reentrant_buffer->_hostent_buffer, PL_reentrant_buffer->_hostent_size, char); #endif #endif /* HAS_GETHOSTBYNAME_R */ #ifdef HAS_GETLOGIN_R Newx(PL_reentrant_buffer->_getlogin_buffer, PL_reentrant_buffer->_getlogin_size, char); #endif /* HAS_GETLOGIN_R */ #ifdef HAS_GETNETBYNAME_R #if !(GETNETBYNAME_R_PROTO == REENTRANT_PROTO_I_CSD) Newx(PL_reentrant_buffer->_netent_buffer, PL_reentrant_buffer->_netent_size, char); #endif #endif /* HAS_GETNETBYNAME_R */ #ifdef HAS_GETPROTOBYNAME_R #if !(GETPROTOBYNAME_R_PROTO == REENTRANT_PROTO_I_CSD) Newx(PL_reentrant_buffer->_protoent_buffer, PL_reentrant_buffer->_protoent_size, char); #endif #endif /* HAS_GETPROTOBYNAME_R */ #ifdef HAS_GETPWNAM_R # ifdef USE_PWENT_FPTR PL_reentrant_buffer->_pwent_fptr = NULL; # endif Newx(PL_reentrant_buffer->_pwent_buffer, PL_reentrant_buffer->_pwent_size, char); #endif /* HAS_GETPWNAM_R */ #ifdef HAS_GETSERVBYNAME_R #if !(GETSERVBYNAME_R_PROTO == REENTRANT_PROTO_I_CCSD) Newx(PL_reentrant_buffer->_servent_buffer, PL_reentrant_buffer->_servent_size, char); #endif #endif /* HAS_GETSERVBYNAME_R */ #ifdef HAS_GETSPNAM_R # ifdef USE_SPENT_FPTR PL_reentrant_buffer->_spent_fptr = NULL; # endif Newx(PL_reentrant_buffer->_spent_buffer, PL_reentrant_buffer->_spent_size, char); #endif /* HAS_GETSPNAM_R */ #ifdef HAS_RANDOM_R #endif /* HAS_RANDOM_R */ #ifdef HAS_READDIR_R PL_reentrant_buffer->_readdir_struct = (struct dirent*)safemalloc(PL_reentrant_buffer->_readdir_size); #endif /* HAS_READDIR_R */ #ifdef HAS_READDIR64_R PL_reentrant_buffer->_readdir64_struct = (struct dirent64*)safemalloc(PL_reentrant_buffer->_readdir64_size); #endif /* HAS_READDIR64_R */ #ifdef HAS_SETLOCALE_R Newx(PL_reentrant_buffer->_setlocale_buffer, PL_reentrant_buffer->_setlocale_size, char); #endif /* HAS_SETLOCALE_R */ #ifdef HAS_SRANDOM_R #endif /* HAS_SRANDOM_R */ #ifdef HAS_STRERROR_R Newx(PL_reentrant_buffer->_strerror_buffer, PL_reentrant_buffer->_strerror_size, char); #endif /* HAS_STRERROR_R */ #ifdef HAS_TTYNAME_R Newx(PL_reentrant_buffer->_ttyname_buffer, PL_reentrant_buffer->_ttyname_size, char); #endif /* HAS_TTYNAME_R */ #endif /* USE_REENTRANT_API */ } void Perl_reentrant_free(pTHX) { #ifdef USE_REENTRANT_API #ifdef HAS_ASCTIME_R Safefree(PL_reentrant_buffer->_asctime_buffer); #endif /* HAS_ASCTIME_R */ #ifdef HAS_CRYPT_R #if CRYPT_R_PROTO != REENTRANT_PROTO_B_CCD Safefree(PL_reentrant_buffer->_crypt_struct_buffer); #endif #endif /* HAS_CRYPT_R */ #ifdef HAS_CTIME_R Safefree(PL_reentrant_buffer->_ctime_buffer); #endif /* HAS_CTIME_R */ #ifdef HAS_DRAND48_R #endif /* HAS_DRAND48_R */ #ifdef HAS_GETGRNAM_R Safefree(PL_reentrant_buffer->_grent_buffer); #endif /* HAS_GETGRNAM_R */ #ifdef HAS_GETHOSTBYNAME_R #if !(GETHOSTBYNAME_R_PROTO == REENTRANT_PROTO_I_CSD) Safefree(PL_reentrant_buffer->_hostent_buffer); #endif #endif /* HAS_GETHOSTBYNAME_R */ #ifdef HAS_GETLOGIN_R Safefree(PL_reentrant_buffer->_getlogin_buffer); #endif /* HAS_GETLOGIN_R */ #ifdef HAS_GETNETBYNAME_R #if !(GETNETBYNAME_R_PROTO == REENTRANT_PROTO_I_CSD) Safefree(PL_reentrant_buffer->_netent_buffer); #endif #endif /* HAS_GETNETBYNAME_R */ #ifdef HAS_GETPROTOBYNAME_R #if !(GETPROTOBYNAME_R_PROTO == REENTRANT_PROTO_I_CSD) Safefree(PL_reentrant_buffer->_protoent_buffer); #endif #endif /* HAS_GETPROTOBYNAME_R */ #ifdef HAS_GETPWNAM_R Safefree(PL_reentrant_buffer->_pwent_buffer); #endif /* HAS_GETPWNAM_R */ #ifdef HAS_GETSERVBYNAME_R #if !(GETSERVBYNAME_R_PROTO == REENTRANT_PROTO_I_CCSD) Safefree(PL_reentrant_buffer->_servent_buffer); #endif #endif /* HAS_GETSERVBYNAME_R */ #ifdef HAS_GETSPNAM_R Safefree(PL_reentrant_buffer->_spent_buffer); #endif /* HAS_GETSPNAM_R */ #ifdef HAS_RANDOM_R #endif /* HAS_RANDOM_R */ #ifdef HAS_READDIR_R Safefree(PL_reentrant_buffer->_readdir_struct); #endif /* HAS_READDIR_R */ #ifdef HAS_READDIR64_R Safefree(PL_reentrant_buffer->_readdir64_struct); #endif /* HAS_READDIR64_R */ #ifdef HAS_SETLOCALE_R Safefree(PL_reentrant_buffer->_setlocale_buffer); #endif /* HAS_SETLOCALE_R */ #ifdef HAS_SRANDOM_R #endif /* HAS_SRANDOM_R */ #ifdef HAS_STRERROR_R Safefree(PL_reentrant_buffer->_strerror_buffer); #endif /* HAS_STRERROR_R */ #ifdef HAS_TTYNAME_R Safefree(PL_reentrant_buffer->_ttyname_buffer); #endif /* HAS_TTYNAME_R */ Safefree(PL_reentrant_buffer); #endif /* USE_REENTRANT_API */ } void* Perl_reentrant_retry(const char *f, ...) { dTHX; void *retptr = NULL; va_list ap; #ifdef USE_REENTRANT_API /* Easier to special case this here than in embed.pl. (Look at what it generates for proto.h) */ PERL_ARGS_ASSERT_REENTRANT_RETRY; #endif va_start(ap, f); { #ifdef USE_REENTRANT_API # if defined(USE_HOSTENT_BUFFER) || defined(USE_GRENT_BUFFER) || defined(USE_NETENT_BUFFER) || defined(USE_PWENT_BUFFER) || defined(USE_PROTOENT_BUFFER) || defined(USE_SERVENT_BUFFER) void *p0; # endif # if defined(USE_SERVENT_BUFFER) void *p1; # endif # if defined(USE_HOSTENT_BUFFER) size_t asize; # endif # if defined(USE_HOSTENT_BUFFER) || defined(USE_NETENT_BUFFER) || defined(USE_PROTOENT_BUFFER) || defined(USE_SERVENT_BUFFER) int anint; # endif switch (PL_op->op_type) { #ifdef USE_HOSTENT_BUFFER case OP_GHBYADDR: case OP_GHBYNAME: case OP_GHOSTENT: { #ifdef PERL_REENTRANT_MAXSIZE if (PL_reentrant_buffer->_hostent_size <= PERL_REENTRANT_MAXSIZE / 2) #endif { PL_reentrant_buffer->_hostent_size *= 2; Renew(PL_reentrant_buffer->_hostent_buffer, PL_reentrant_buffer->_hostent_size, char); switch (PL_op->op_type) { case OP_GHBYADDR: p0 = va_arg(ap, void *); asize = va_arg(ap, size_t); anint = va_arg(ap, int); retptr = gethostbyaddr(p0, asize, anint); break; case OP_GHBYNAME: p0 = va_arg(ap, void *); retptr = gethostbyname((char *)p0); break; case OP_GHOSTENT: retptr = gethostent(); break; default: SETERRNO(ERANGE, LIB_INVARG); break; } } } break; #endif #ifdef USE_GRENT_BUFFER case OP_GGRNAM: case OP_GGRGID: case OP_GGRENT: { #ifdef PERL_REENTRANT_MAXSIZE if (PL_reentrant_buffer->_grent_size <= PERL_REENTRANT_MAXSIZE / 2) #endif { Gid_t gid; PL_reentrant_buffer->_grent_size *= 2; Renew(PL_reentrant_buffer->_grent_buffer, PL_reentrant_buffer->_grent_size, char); switch (PL_op->op_type) { case OP_GGRNAM: p0 = va_arg(ap, void *); retptr = getgrnam((char *)p0); break; case OP_GGRGID: #if Gid_t_size < INTSIZE gid = (Gid_t)va_arg(ap, int); #else gid = va_arg(ap, Gid_t); #endif retptr = getgrgid(gid); break; case OP_GGRENT: retptr = getgrent(); break; default: SETERRNO(ERANGE, LIB_INVARG); break; } } } break; #endif #ifdef USE_NETENT_BUFFER case OP_GNBYADDR: case OP_GNBYNAME: case OP_GNETENT: { #ifdef PERL_REENTRANT_MAXSIZE if (PL_reentrant_buffer->_netent_size <= PERL_REENTRANT_MAXSIZE / 2) #endif { Netdb_net_t net; PL_reentrant_buffer->_netent_size *= 2; Renew(PL_reentrant_buffer->_netent_buffer, PL_reentrant_buffer->_netent_size, char); switch (PL_op->op_type) { case OP_GNBYADDR: net = va_arg(ap, Netdb_net_t); anint = va_arg(ap, int); retptr = getnetbyaddr(net, anint); break; case OP_GNBYNAME: p0 = va_arg(ap, void *); retptr = getnetbyname((char *)p0); break; case OP_GNETENT: retptr = getnetent(); break; default: SETERRNO(ERANGE, LIB_INVARG); break; } } } break; #endif #ifdef USE_PWENT_BUFFER case OP_GPWNAM: case OP_GPWUID: case OP_GPWENT: { #ifdef PERL_REENTRANT_MAXSIZE if (PL_reentrant_buffer->_pwent_size <= PERL_REENTRANT_MAXSIZE / 2) #endif { Uid_t uid; PL_reentrant_buffer->_pwent_size *= 2; Renew(PL_reentrant_buffer->_pwent_buffer, PL_reentrant_buffer->_pwent_size, char); switch (PL_op->op_type) { case OP_GPWNAM: p0 = va_arg(ap, void *); retptr = getpwnam((char *)p0); break; case OP_GPWUID: #if Uid_t_size < INTSIZE uid = (Uid_t)va_arg(ap, int); #else uid = va_arg(ap, Uid_t); #endif retptr = getpwuid(uid); break; case OP_GPWENT: retptr = getpwent(); break; default: SETERRNO(ERANGE, LIB_INVARG); break; } } } break; #endif #ifdef USE_PROTOENT_BUFFER case OP_GPBYNAME: case OP_GPBYNUMBER: case OP_GPROTOENT: { #ifdef PERL_REENTRANT_MAXSIZE if (PL_reentrant_buffer->_protoent_size <= PERL_REENTRANT_MAXSIZE / 2) #endif { PL_reentrant_buffer->_protoent_size *= 2; Renew(PL_reentrant_buffer->_protoent_buffer, PL_reentrant_buffer->_protoent_size, char); switch (PL_op->op_type) { case OP_GPBYNAME: p0 = va_arg(ap, void *); retptr = getprotobyname((char *)p0); break; case OP_GPBYNUMBER: anint = va_arg(ap, int); retptr = getprotobynumber(anint); break; case OP_GPROTOENT: retptr = getprotoent(); break; default: SETERRNO(ERANGE, LIB_INVARG); break; } } } break; #endif #ifdef USE_SERVENT_BUFFER case OP_GSBYNAME: case OP_GSBYPORT: case OP_GSERVENT: { #ifdef PERL_REENTRANT_MAXSIZE if (PL_reentrant_buffer->_servent_size <= PERL_REENTRANT_MAXSIZE / 2) #endif { PL_reentrant_buffer->_servent_size *= 2; Renew(PL_reentrant_buffer->_servent_buffer, PL_reentrant_buffer->_servent_size, char); switch (PL_op->op_type) { case OP_GSBYNAME: p0 = va_arg(ap, void *); p1 = va_arg(ap, void *); retptr = getservbyname((char *)p0, (char *)p1); break; case OP_GSBYPORT: anint = va_arg(ap, int); p0 = va_arg(ap, void *); retptr = getservbyport(anint, (char *)p0); break; case OP_GSERVENT: retptr = getservent(); break; default: SETERRNO(ERANGE, LIB_INVARG); break; } } } break; #endif default: /* Not known how to retry, so just fail. */ break; } #else PERL_UNUSED_ARG(f); #endif } va_end(ap); return retptr; } /* ex: set ro: */ perl-5.12.0-RC0/h2pl/0000755000175000017500000000000011351321566012777 5ustar jessejesseperl-5.12.0-RC0/h2pl/tcbreak20000444000175000017500000000026411143650476014423 0ustar jessejesse#!/usr/bin/perl require 'cbreak2.pl'; &cbreak; $| = 1; print "gimme a char: "; $c = getc; print "$c\n"; printf "you gave me `%s', which is 0x%02x\n", $c, ord($c); &cooked; perl-5.12.0-RC0/h2pl/mksizes0000444000175000017500000000131411143650476014410 0ustar jessejesse#!/usr/local/bin/perl ($iam = $0) =~ s%.*/%%; $tmp = "$iam.$$"; open (CODE,">$tmp.c") || die "$iam: cannot create $tmp.c: $!\n"; $mask = q/printf ("$sizeof{'%s'} = %d;\n"/; # write C program select(CODE); print < #include #include #include #include #include #include main() { EO_C_PROGRAM while ( <> ) { chop; printf "\t%s, \n\t\t\"%s\", sizeof(%s));\n", $mask, $_,$_; } print "\n}\n"; close CODE; # compile C program select(STDOUT); system "cc $tmp.c -o $tmp"; die "couldn't compile $tmp.c" if $?; system "./$tmp"; die "couldn't run $tmp" if $?; unlink "$tmp.c", $tmp; perl-5.12.0-RC0/h2pl/README0000444000175000017500000000526511143650476013671 0ustar jessejesse[This file of Tom Christiansen's has been edited to change makelib to h2ph and .h to .ph where appropriate--law.] This directory contains files to help you convert the *.ph files generated my h2ph out of the perl source directory into *.pl files with all the indirection of the subroutine calls removed. The .ph version will be more safely portable, because if something isn't defined on the new system, like &TIOCGETP, then you'll get a fatal run-time error on the system lacking that function. Using the .pl version means that the subsequent scripts will give you a 0 $TIOCGETP and God only knows what may then happen. Still, I like the .pl stuff because they're faster to load. FIrst, you need to run h2ph on things like sys/ioctl.h to get stuff into the perl library directory, often /usr/local/lib/perl. For example, # h2ph sys/ioctl.h takes /usr/include/sys/ioctl.h as input and writes (without i/o redirection) the file /usr/local/lib/perl/sys/ioctl.ph, which looks like this eval 'sub TIOCM_RTS {0004;}'; eval 'sub TIOCM_ST {0010;}'; eval 'sub TIOCM_SR {0020;}'; eval 'sub TIOCM_CTS {0040;}'; eval 'sub TIOCM_CAR {0100;}'; and much worse, rather than what Larry's ioctl.pl from the perl source dir has, which is: $TIOCM_RTS = 0004; $TIOCM_ST = 0010; $TIOCM_SR = 0020; $TIOCM_CTS = 0040; $TIOCM_CAR = 0100; [Workaround for fixed bug in makedir/h2ph deleted--law.] The more complicated ioctl subs look like this: eval 'sub TIOCGSIZE {&TIOCGWINSZ;}'; eval 'sub TIOCGWINSZ {&_IOR("t", 104, \'struct winsize\');}'; eval 'sub TIOCSETD {&_IOW("t", 1, \'int\');}'; eval 'sub TIOCGETP {&_IOR("t", 8,\'struct sgttyb\');}'; The _IO[RW] routines use a %sizeof array, which (presumably) is keyed on the type name with the value being the size in bytes. To build %sizeof, try running this in this directory: % ./getioctlsizes Which will tell you which things the %sizeof array needs to hold. You can try to build a sizeof.ph file with: % ./getioctlsizes | ./mksizes > sizeof.ph Note that mksizes hardcodes the #include files for all the types, so it will probably require customization. Once you have sizeof.ph, install it in the perl library directory. Run my tcbreak script to see whether you can do ioctls in perl now. You'll get some kind of fatal run-time error if you can't. That script should be included in this directory. If this works well, now you can try to convert the *.ph files into *.pl files. Try this: foreach file ( sysexits.ph sys/{errno.ph,ioctl.ph} ) ./mkvars $file > t/$file:r.pl end The last one will be the hardest. If it works, should be able to run tcbreak2 and have it work the same as tcbreak. Good luck. perl-5.12.0-RC0/h2pl/getioctlsizes0000444000175000017500000000041011143650476015607 0ustar jessejesse#!/usr/bin/perl open (IOCTLS,'/usr/include/sys/ioctl.h') || die "ioctl open failed"; while () { if (/^\s*#\s*define\s+\w+\s+_IO(R|W|WR)\('?\w+'?,\s*\w+,\s*([^)]+)/) { $need{$2}++; } } foreach $key ( sort keys %need ) { print $key,"\n"; } perl-5.12.0-RC0/h2pl/tcbreak0000444000175000017500000000026311143650476014340 0ustar jessejesse#!/usr/bin/perl require 'cbreak.pl'; &cbreak; $| = 1; print "gimme a char: "; $c = getc; print "$c\n"; printf "you gave me `%s', which is 0x%02x\n", $c, ord($c); &cooked; perl-5.12.0-RC0/h2pl/cbreak.pl0000444000175000017500000000107611143650476014571 0ustar jessejesse$sgttyb_t = 'C4 S'; sub cbreak { &set_cbreak(1); } sub cooked { &set_cbreak(0); } sub set_cbreak { local($on) = @_; require 'sizeof.ph'; require 'sys/ioctl.ph'; ioctl(STDIN,&TIOCGETP,$sgttyb) || die "Can't ioctl TIOCGETP: $!"; @ary = unpack($sgttyb_t,$sgttyb); if ($on) { $ary[4] |= &CBREAK; $ary[4] &= ~&ECHO; } else { $ary[4] &= ~&CBREAK; $ary[4] |= &ECHO; } $sgttyb = pack($sgttyb_t,@ary); ioctl(STDIN,&TIOCSETP,$sgttyb) || die "Can't ioctl TIOCSETP: $!"; } 1; perl-5.12.0-RC0/h2pl/cbreak2.pl0000444000175000017500000000104511143650476014647 0ustar jessejesse$sgttyb_t = 'C4 S'; sub cbreak { &set_cbreak(1); } sub cooked { &set_cbreak(0); } sub set_cbreak { local($on) = @_; require 'sys/ioctl.pl'; ioctl(STDIN,$TIOCGETP,$sgttyb) || die "Can't ioctl TIOCGETP: $!"; @ary = unpack($sgttyb_t,$sgttyb); if ($on) { $ary[4] |= $CBREAK; $ary[4] &= ~$ECHO; } else { $ary[4] &= ~$CBREAK; $ary[4] |= $ECHO; } $sgttyb = pack($sgttyb_t,@ary); ioctl(STDIN,$TIOCSETP,$sgttyb) || die "Can't ioctl TIOCSETP: $!"; } 1; perl-5.12.0-RC0/h2pl/eg/0000755000175000017500000000000011351321566013372 5ustar jessejesseperl-5.12.0-RC0/h2pl/eg/sysexits.pl0000444000175000017500000000046711143650476015633 0ustar jessejesse$EX_OK = 0x0; $EX__BASE = 0x40; $EX_USAGE = 0x40; $EX_DATAERR = 0x41; $EX_NOINPUT = 0x42; $EX_NOUSER = 0x43; $EX_NOHOST = 0x44; $EX_UNAVAILABLE = 0x45; $EX_SOFTWARE = 0x46; $EX_OSERR = 0x47; $EX_OSFILE = 0x48; $EX_CANTCREAT = 0x49; $EX_IOERR = 0x4A; $EX_TEMPFAIL = 0x4B; $EX_PROTOCOL = 0x4C; $EX_NOPERM = 0x4D; perl-5.12.0-RC0/h2pl/eg/sizeof.ph0000444000175000017500000000062411143650476015226 0ustar jessejesse$sizeof{'char'} = 1; $sizeof{'int'} = 4; $sizeof{'long'} = 4; $sizeof{'struct arpreq'} = 36; $sizeof{'struct ifconf'} = 8; $sizeof{'struct ifreq'} = 32; $sizeof{'struct ltchars'} = 6; $sizeof{'struct pcntl'} = 116; $sizeof{'struct rtentry'} = 52; $sizeof{'struct sgttyb'} = 6; $sizeof{'struct tchars'} = 6; $sizeof{'struct ttychars'} = 14; $sizeof{'struct winsize'} = 8; $sizeof{'struct termios'} = 132; perl-5.12.0-RC0/h2pl/eg/sys/0000755000175000017500000000000011351321566014210 5ustar jessejesseperl-5.12.0-RC0/h2pl/eg/sys/errno.pl0000444000175000017500000000327411143650476015702 0ustar jessejesse$EPERM = 0x1; $ENOENT = 0x2; $ESRCH = 0x3; $EINTR = 0x4; $EIO = 0x5; $ENXIO = 0x6; $E2BIG = 0x7; $ENOEXEC = 0x8; $EBADF = 0x9; $ECHILD = 0xA; $EAGAIN = 0xB; $ENOMEM = 0xC; $EACCES = 0xD; $EFAULT = 0xE; $ENOTBLK = 0xF; $EBUSY = 0x10; $EEXIST = 0x11; $EXDEV = 0x12; $ENODEV = 0x13; $ENOTDIR = 0x14; $EISDIR = 0x15; $EINVAL = 0x16; $ENFILE = 0x17; $EMFILE = 0x18; $ENOTTY = 0x19; $ETXTBSY = 0x1A; $EFBIG = 0x1B; $ENOSPC = 0x1C; $ESPIPE = 0x1D; $EROFS = 0x1E; $EMLINK = 0x1F; $EPIPE = 0x20; $EDOM = 0x21; $ERANGE = 0x22; $EWOULDBLOCK = 0x23; $EINPROGRESS = 0x24; $EALREADY = 0x25; $ENOTSOCK = 0x26; $EDESTADDRREQ = 0x27; $EMSGSIZE = 0x28; $EPROTOTYPE = 0x29; $ENOPROTOOPT = 0x2A; $EPROTONOSUPPORT = 0x2B; $ESOCKTNOSUPPORT = 0x2C; $EOPNOTSUPP = 0x2D; $EPFNOSUPPORT = 0x2E; $EAFNOSUPPORT = 0x2F; $EADDRINUSE = 0x30; $EADDRNOTAVAIL = 0x31; $ENETDOWN = 0x32; $ENETUNREACH = 0x33; $ENETRESET = 0x34; $ECONNABORTED = 0x35; $ECONNRESET = 0x36; $ENOBUFS = 0x37; $EISCONN = 0x38; $ENOTCONN = 0x39; $ESHUTDOWN = 0x3A; $ETOOMANYREFS = 0x3B; $ETIMEDOUT = 0x3C; $ECONNREFUSED = 0x3D; $ELOOP = 0x3E; $ENAMETOOLONG = 0x3F; $EHOSTDOWN = 0x40; $EHOSTUNREACH = 0x41; $ENOTEMPTY = 0x42; $EPROCLIM = 0x43; $EUSERS = 0x44; $EDQUOT = 0x45; $ESTALE = 0x46; $EREMOTE = 0x47; $EDEADLK = 0x48; $ENOLCK = 0x49; $MTH_UNDEF_SQRT = 0x12C; $MTH_OVF_EXP = 0x12D; $MTH_UNDEF_LOG = 0x12E; $MTH_NEG_BASE = 0x12F; $MTH_ZERO_BASE = 0x130; $MTH_OVF_POW = 0x131; $MTH_LRG_SIN = 0x132; $MTH_LRG_COS = 0x133; $MTH_LRG_TAN = 0x134; $MTH_LRG_COT = 0x135; $MTH_OVF_TAN = 0x136; $MTH_OVF_COT = 0x137; $MTH_UNDEF_ASIN = 0x138; $MTH_UNDEF_ACOS = 0x139; $MTH_UNDEF_ATAN2 = 0x13A; $MTH_OVF_SINH = 0x13B; $MTH_OVF_COSH = 0x13C; $MTH_UNDEF_ZLOG = 0x13D; $MTH_UNDEF_ZDIV = 0x13E; perl-5.12.0-RC0/h2pl/eg/sys/ioctl.pl0000444000175000017500000000774311143650476015674 0ustar jessejesse$_IOCTL_ = 0x1; $TIOCGSIZE = 0x40087468; $TIOCSSIZE = 0x80087467; $IOCPARM_MASK = 0x7F; $IOC_VOID = 0x20000000; $IOC_OUT = 0x40000000; $IOC_IN = 0x80000000; $IOC_INOUT = 0xC0000000; $TIOCGETD = 0x40047400; $TIOCSETD = 0x80047401; $TIOCHPCL = 0x20007402; $TIOCMODG = 0x40047403; $TIOCMODS = 0x80047404; $TIOCM_LE = 0x1; $TIOCM_DTR = 0x2; $TIOCM_RTS = 0x4; $TIOCM_ST = 0x8; $TIOCM_SR = 0x10; $TIOCM_CTS = 0x20; $TIOCM_CAR = 0x40; $TIOCM_CD = 0x40; $TIOCM_RNG = 0x80; $TIOCM_RI = 0x80; $TIOCM_DSR = 0x100; $TIOCGETP = 0x40067408; $TIOCSETP = 0x80067409; $TIOCSETN = 0x8006740A; $TIOCEXCL = 0x2000740D; $TIOCNXCL = 0x2000740E; $TIOCFLUSH = 0x80047410; $TIOCSETC = 0x80067411; $TIOCGETC = 0x40067412; $TIOCSET = 0x80047413; $TIOCBIS = 0x80047414; $TIOCBIC = 0x80047415; $TIOCGET = 0x40047416; $TANDEM = 0x1; $CBREAK = 0x2; $LCASE = 0x4; $ECHO = 0x8; $CRMOD = 0x10; $RAW = 0x20; $ODDP = 0x40; $EVENP = 0x80; $ANYP = 0xC0; $NLDELAY = 0x300; $NL0 = 0x0; $NL1 = 0x100; $NL2 = 0x200; $NL3 = 0x300; $TBDELAY = 0xC00; $TAB0 = 0x0; $TAB1 = 0x400; $TAB2 = 0x800; $XTABS = 0xC00; $CRDELAY = 0x3000; $CR0 = 0x0; $CR1 = 0x1000; $CR2 = 0x2000; $CR3 = 0x3000; $VTDELAY = 0x4000; $FF0 = 0x0; $FF1 = 0x4000; $BSDELAY = 0x8000; $BS0 = 0x0; $BS1 = 0x8000; $ALLDELAY = 0xFF00; $CRTBS = 0x10000; $PRTERA = 0x20000; $CRTERA = 0x40000; $TILDE = 0x80000; $MDMBUF = 0x100000; $LITOUT = 0x200000; $TOSTOP = 0x400000; $FLUSHO = 0x800000; $NOHANG = 0x1000000; $L001000 = 0x2000000; $CRTKIL = 0x4000000; $L004000 = 0x8000000; $CTLECH = 0x10000000; $PENDIN = 0x20000000; $DECCTQ = 0x40000000; $NOFLSH = 0x80000000; $TIOCCSET = 0x800E7417; $TIOCCGET = 0x400E7418; $TIOCLBIS = 0x8004747F; $TIOCLBIC = 0x8004747E; $TIOCLSET = 0x8004747D; $TIOCLGET = 0x4004747C; $LCRTBS = 0x1; $LPRTERA = 0x2; $LCRTERA = 0x4; $LTILDE = 0x8; $LMDMBUF = 0x10; $LLITOUT = 0x20; $LTOSTOP = 0x40; $LFLUSHO = 0x80; $LNOHANG = 0x100; $LCRTKIL = 0x400; $LCTLECH = 0x1000; $LPENDIN = 0x2000; $LDECCTQ = 0x4000; $LNOFLSH = 0x8000; $TIOCSBRK = 0x2000747B; $TIOCCBRK = 0x2000747A; $TIOCSDTR = 0x20007479; $TIOCCDTR = 0x20007478; $TIOCGPGRP = 0x40047477; $TIOCSPGRP = 0x80047476; $TIOCSLTC = 0x80067475; $TIOCGLTC = 0x40067474; $TIOCOUTQ = 0x40047473; $TIOCSTI = 0x80017472; $TIOCNOTTY = 0x20007471; $TIOCPKT = 0x80047470; $TIOCPKT_DATA = 0x0; $TIOCPKT_FLUSHREAD = 0x1; $TIOCPKT_FLUSHWRITE = 0x2; $TIOCPKT_STOP = 0x4; $TIOCPKT_START = 0x8; $TIOCPKT_NOSTOP = 0x10; $TIOCPKT_DOSTOP = 0x20; $TIOCSTOP = 0x2000746F; $TIOCSTART = 0x2000746E; $TIOCREMOTE = 0x20007469; $TIOCGWINSZ = 0x40087468; $TIOCSWINSZ = 0x80087467; $TIOCRESET = 0x20007466; $OTTYDISC = 0x0; $NETLDISC = 0x1; $NTTYDISC = 0x2; $FIOCLEX = 0x20006601; $FIONCLEX = 0x20006602; $FIONREAD = 0x4004667F; $FIONBIO = 0x8004667E; $FIOASYNC = 0x8004667D; $FIOSETOWN = 0x8004667C; $FIOGETOWN = 0x4004667B; $STPUTTABLE = 0x8004667A; $STGETTABLE = 0x80046679; $SIOCSHIWAT = 0x80047300; $SIOCGHIWAT = 0x40047301; $SIOCSLOWAT = 0x80047302; $SIOCGLOWAT = 0x40047303; $SIOCATMARK = 0x40047307; $SIOCSPGRP = 0x80047308; $SIOCGPGRP = 0x40047309; $SIOCADDRT = 0x8034720A; $SIOCDELRT = 0x8034720B; $SIOCSIFADDR = 0x8020690C; $SIOCGIFADDR = 0xC020690D; $SIOCSIFDSTADDR = 0x8020690E; $SIOCGIFDSTADDR = 0xC020690F; $SIOCSIFFLAGS = 0x80206910; $SIOCGIFFLAGS = 0xC0206911; $SIOCGIFBRDADDR = 0xC0206912; $SIOCSIFBRDADDR = 0x80206913; $SIOCGIFCONF = 0xC0086914; $SIOCGIFNETMASK = 0xC0206915; $SIOCSIFNETMASK = 0x80206916; $SIOCGIFMETRIC = 0xC0206917; $SIOCSIFMETRIC = 0x80206918; $SIOCSARP = 0x8024691E; $SIOCGARP = 0xC024691F; $SIOCDARP = 0x80246920; $PIXCONTINUE = 0x80747000; $PIXSTEP = 0x80747001; $PIXTERMINATE = 0x20007002; $PIGETFLAGS = 0x40747003; $PIXINHERIT = 0x80747004; $PIXDETACH = 0x20007005; $PIXGETSUBCODE = 0xC0747006; $PIXRDREGS = 0xC0747007; $PIXWRREGS = 0xC0747008; $PIXRDVREGS = 0xC0747009; $PIXWRVREGS = 0xC074700A; $PIXRDVSTATE = 0xC074700B; $PIXWRVSTATE = 0xC074700C; $PIXRDCREGS = 0xC074700D; $PIXWRCREGS = 0xC074700E; $PIRDSDRS = 0xC074700F; $PIXGETSIGACTION = 0xC0747010; $PIGETU = 0xC0747011; $PISETRWTID = 0xC0747012; $PIXGETTHCOUNT = 0xC0747013; $PIXRUN = 0x20007014; perl-5.12.0-RC0/h2pl/mkvars0000444000175000017500000000126111143650476014227 0ustar jessejesse#!/usr/bin/perl require 'sizeof.ph'; $LIB = '/usr/local/lib/perl'; foreach $include (@ARGV) { printf STDERR "including %s\n", $include; do $include; warn "sourcing $include: $@\n" if ($@); if (!open (INCLUDE,"$LIB/$include")) { warn "can't open $LIB/$include: $!\n"; next; } while () { chop; if (/^\s*eval\s+'sub\s+(\w+)\s.*[^{]$/ || /^\s*sub\s+(\w+)\s.*[^{]$/) { $var = $1; $val = eval "&$var;"; if ($@) { warn "$@: $_"; print < #endif #ifdef I_LANGINFO # include #endif #include "reentr.h" #if defined(USE_LOCALE_NUMERIC) || defined(USE_LOCALE_COLLATE) /* * Standardize the locale name from a string returned by 'setlocale'. * * The standard return value of setlocale() is either * (1) "xx_YY" if the first argument of setlocale() is not LC_ALL * (2) "xa_YY xb_YY ..." if the first argument of setlocale() is LC_ALL * (the space-separated values represent the various sublocales, * in some unspecificed order) * * In some platforms it has a form like "LC_SOMETHING=Lang_Country.866\n", * which is harmful for further use of the string in setlocale(). * */ STATIC char * S_stdize_locale(pTHX_ char *locs) { const char * const s = strchr(locs, '='); bool okay = TRUE; 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; } } } if (!okay) Perl_croak(aTHX_ "Can't fix broken locale name \"%s\"", locs); return locs; } #endif void Perl_set_numeric_radix(pTHX) { #ifdef USE_LOCALE_NUMERIC dVAR; # ifdef HAS_LOCALECONV const struct lconv* const lc = localeconv(); if (lc && lc->decimal_point) { if (lc->decimal_point[0] == '.' && lc->decimal_point[1] == 0) { SvREFCNT_dec(PL_numeric_radix_sv); PL_numeric_radix_sv = NULL; } else { if (PL_numeric_radix_sv) sv_setpv(PL_numeric_radix_sv, lc->decimal_point); else PL_numeric_radix_sv = newSVpv(lc->decimal_point, 0); } } else PL_numeric_radix_sv = NULL; # endif /* HAS_LOCALECONV */ #endif /* USE_LOCALE_NUMERIC */ } /* * Set up for a new numeric locale. */ void Perl_new_numeric(pTHX_ const char *newnum) { #ifdef USE_LOCALE_NUMERIC dVAR; if (! newnum) { Safefree(PL_numeric_name); PL_numeric_name = NULL; PL_numeric_standard = TRUE; PL_numeric_local = TRUE; return; } if (! PL_numeric_name || strNE(PL_numeric_name, newnum)) { Safefree(PL_numeric_name); PL_numeric_name = stdize_locale(savepv(newnum)); PL_numeric_standard = ((*newnum == 'C' && newnum[1] == '\0') || strEQ(newnum, "POSIX")); PL_numeric_local = TRUE; set_numeric_radix(); } #endif /* USE_LOCALE_NUMERIC */ } void Perl_set_numeric_standard(pTHX) { #ifdef USE_LOCALE_NUMERIC dVAR; if (! PL_numeric_standard) { setlocale(LC_NUMERIC, "C"); PL_numeric_standard = TRUE; PL_numeric_local = FALSE; set_numeric_radix(); } #endif /* USE_LOCALE_NUMERIC */ } void Perl_set_numeric_local(pTHX) { #ifdef USE_LOCALE_NUMERIC dVAR; if (! PL_numeric_local) { setlocale(LC_NUMERIC, PL_numeric_name); PL_numeric_standard = FALSE; PL_numeric_local = TRUE; set_numeric_radix(); } #endif /* USE_LOCALE_NUMERIC */ } /* * Set up for a new ctype locale. */ void Perl_new_ctype(pTHX_ const char *newctype) { #ifdef USE_LOCALE_CTYPE dVAR; int i; PERL_ARGS_ASSERT_NEW_CTYPE; for (i = 0; i < 256; i++) { if (isUPPER_LC(i)) PL_fold_locale[i] = toLOWER_LC(i); else if (isLOWER_LC(i)) PL_fold_locale[i] = toUPPER_LC(i); else PL_fold_locale[i] = i; } #endif /* USE_LOCALE_CTYPE */ PERL_ARGS_ASSERT_NEW_CTYPE; PERL_UNUSED_ARG(newctype); PERL_UNUSED_CONTEXT; } /* * Set up for a new collation locale. */ void Perl_new_collate(pTHX_ const char *newcoll) { #ifdef USE_LOCALE_COLLATE dVAR; if (! newcoll) { if (PL_collation_name) { ++PL_collation_ix; Safefree(PL_collation_name); PL_collation_name = NULL; } PL_collation_standard = TRUE; PL_collxfrm_base = 0; PL_collxfrm_mult = 2; return; } 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 = ((*newcoll == 'C' && newcoll[1] == '\0') || strEQ(newcoll, "POSIX")); { /* 2: at most so many chars ('a', 'b'). */ /* 50: surely no system expands a char more. */ #define XFRMBUFSIZE (2 * 50) char xbuf[XFRMBUFSIZE]; const Size_t fa = strxfrm(xbuf, "a", XFRMBUFSIZE); const Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE); const SSize_t mult = fb - fa; if (mult < 1) Perl_croak(aTHX_ "strxfrm() gets absurd"); PL_collxfrm_base = (fa > (Size_t)mult) ? (fa - mult) : 0; PL_collxfrm_mult = mult; } } #endif /* USE_LOCALE_COLLATE */ } /* * Initialize locale awareness. */ int Perl_init_i18nl10n(pTHX_ int printwarn) { int ok = 1; /* returns * 1 = set ok or not applicable, * 0 = fallback to C locale, * -1 = fallback to C locale failed */ #if defined(USE_LOCALE) dVAR; #ifdef USE_LOCALE_CTYPE char *curctype = NULL; #endif /* USE_LOCALE_CTYPE */ #ifdef USE_LOCALE_COLLATE char *curcoll = NULL; #endif /* USE_LOCALE_COLLATE */ #ifdef USE_LOCALE_NUMERIC char *curnum = NULL; #endif /* USE_LOCALE_NUMERIC */ #ifdef __GLIBC__ char * const language = PerlEnv_getenv("LANGUAGE"); #endif char * const lc_all = PerlEnv_getenv("LC_ALL"); char * const lang = PerlEnv_getenv("LANG"); bool setlocale_failure = FALSE; #ifdef LOCALE_ENVIRON_REQUIRED /* * Ultrix setlocale(..., "") fails if there are no environment * variables from which to get a locale name. */ bool done = FALSE; #ifdef LC_ALL if (lang) { if (setlocale(LC_ALL, "")) done = TRUE; else setlocale_failure = TRUE; } if (!setlocale_failure) { #ifdef USE_LOCALE_CTYPE Safefree(curctype); if (! (curctype = setlocale(LC_CTYPE, (!done && (lang || PerlEnv_getenv("LC_CTYPE"))) ? "" : NULL))) setlocale_failure = TRUE; else curctype = savepv(curctype); #endif /* USE_LOCALE_CTYPE */ #ifdef USE_LOCALE_COLLATE Safefree(curcoll); if (! (curcoll = setlocale(LC_COLLATE, (!done && (lang || PerlEnv_getenv("LC_COLLATE"))) ? "" : NULL))) setlocale_failure = TRUE; else curcoll = savepv(curcoll); #endif /* USE_LOCALE_COLLATE */ #ifdef USE_LOCALE_NUMERIC Safefree(curnum); if (! (curnum = setlocale(LC_NUMERIC, (!done && (lang || PerlEnv_getenv("LC_NUMERIC"))) ? "" : NULL))) setlocale_failure = TRUE; else curnum = savepv(curnum); #endif /* USE_LOCALE_NUMERIC */ } #endif /* LC_ALL */ #endif /* !LOCALE_ENVIRON_REQUIRED */ #ifdef LC_ALL if (! setlocale(LC_ALL, "")) setlocale_failure = TRUE; #endif /* LC_ALL */ if (!setlocale_failure) { #ifdef USE_LOCALE_CTYPE Safefree(curctype); if (! (curctype = setlocale(LC_CTYPE, ""))) setlocale_failure = TRUE; else curctype = savepv(curctype); #endif /* USE_LOCALE_CTYPE */ #ifdef USE_LOCALE_COLLATE Safefree(curcoll); if (! (curcoll = setlocale(LC_COLLATE, ""))) setlocale_failure = TRUE; else curcoll = savepv(curcoll); #endif /* USE_LOCALE_COLLATE */ #ifdef USE_LOCALE_NUMERIC Safefree(curnum); if (! (curnum = setlocale(LC_NUMERIC, ""))) setlocale_failure = TRUE; else curnum = savepv(curnum); #endif /* USE_LOCALE_NUMERIC */ } if (setlocale_failure) { char *p; const bool locwarn = (printwarn > 1 || (printwarn && (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p)))); if (locwarn) { #ifdef LC_ALL PerlIO_printf(Perl_error_log, "perl: warning: Setting locale failed.\n"); #else /* !LC_ALL */ PerlIO_printf(Perl_error_log, "perl: warning: Setting locale failed for the categories:\n\t"); #ifdef USE_LOCALE_CTYPE if (! curctype) PerlIO_printf(Perl_error_log, "LC_CTYPE "); #endif /* USE_LOCALE_CTYPE */ #ifdef USE_LOCALE_COLLATE if (! curcoll) PerlIO_printf(Perl_error_log, "LC_COLLATE "); #endif /* USE_LOCALE_COLLATE */ #ifdef USE_LOCALE_NUMERIC if (! curnum) PerlIO_printf(Perl_error_log, "LC_NUMERIC "); #endif /* USE_LOCALE_NUMERIC */ PerlIO_printf(Perl_error_log, "\n"); #endif /* LC_ALL */ PerlIO_printf(Perl_error_log, "perl: warning: Please check that your locale settings:\n"); #ifdef __GLIBC__ PerlIO_printf(Perl_error_log, "\tLANGUAGE = %c%s%c,\n", language ? '"' : '(', language ? language : "unset", language ? '"' : ')'); #endif PerlIO_printf(Perl_error_log, "\tLC_ALL = %c%s%c,\n", lc_all ? '"' : '(', lc_all ? lc_all : "unset", lc_all ? '"' : ')'); #if defined(USE_ENVIRON_ARRAY) { char **e; for (e = environ; *e; e++) { if (strnEQ(*e, "LC_", 3) && strnNE(*e, "LC_ALL=", 7) && (p = strchr(*e, '='))) PerlIO_printf(Perl_error_log, "\t%.*s = \"%s\",\n", (int)(p - *e), *e, p + 1); } } #else PerlIO_printf(Perl_error_log, "\t(possibly more locale environment variables)\n"); #endif PerlIO_printf(Perl_error_log, "\tLANG = %c%s%c\n", lang ? '"' : '(', lang ? lang : "unset", lang ? '"' : ')'); PerlIO_printf(Perl_error_log, " are supported and installed on your system.\n"); } #ifdef LC_ALL if (setlocale(LC_ALL, "C")) { if (locwarn) PerlIO_printf(Perl_error_log, "perl: warning: Falling back to the standard locale (\"C\").\n"); ok = 0; } else { if (locwarn) PerlIO_printf(Perl_error_log, "perl: warning: Failed to fall back to the standard locale (\"C\").\n"); ok = -1; } #else /* ! LC_ALL */ if (0 #ifdef USE_LOCALE_CTYPE || !(curctype || setlocale(LC_CTYPE, "C")) #endif /* USE_LOCALE_CTYPE */ #ifdef USE_LOCALE_COLLATE || !(curcoll || setlocale(LC_COLLATE, "C")) #endif /* USE_LOCALE_COLLATE */ #ifdef USE_LOCALE_NUMERIC || !(curnum || setlocale(LC_NUMERIC, "C")) #endif /* USE_LOCALE_NUMERIC */ ) { if (locwarn) PerlIO_printf(Perl_error_log, "perl: warning: Cannot fall back to the standard locale (\"C\").\n"); ok = -1; } #endif /* ! LC_ALL */ #ifdef USE_LOCALE_CTYPE Safefree(curctype); curctype = savepv(setlocale(LC_CTYPE, NULL)); #endif /* USE_LOCALE_CTYPE */ #ifdef USE_LOCALE_COLLATE Safefree(curcoll); curcoll = savepv(setlocale(LC_COLLATE, NULL)); #endif /* USE_LOCALE_COLLATE */ #ifdef USE_LOCALE_NUMERIC Safefree(curnum); curnum = savepv(setlocale(LC_NUMERIC, NULL)); #endif /* USE_LOCALE_NUMERIC */ } else { #ifdef USE_LOCALE_CTYPE new_ctype(curctype); #endif /* USE_LOCALE_CTYPE */ #ifdef USE_LOCALE_COLLATE new_collate(curcoll); #endif /* USE_LOCALE_COLLATE */ #ifdef USE_LOCALE_NUMERIC new_numeric(curnum); #endif /* USE_LOCALE_NUMERIC */ } #endif /* USE_LOCALE */ #ifdef USE_PERLIO { /* Set PL_utf8locale to TRUE if using PerlIO _and_ any of the following are true: - nl_langinfo(CODESET) contains /^utf-?8/i - $ENV{LC_ALL} contains /^utf-?8/i - $ENV{LC_CTYPE} contains /^utf-?8/i - $ENV{LANG} contains /^utf-?8/i The LC_ALL, LC_CTYPE, LANG obey the usual override hierarchy of locale environment variables. (LANGUAGE affects only LC_MESSAGES only under glibc.) (If present, it overrides LC_MESSAGES for GNU gettext, and it also can have more than one locale, separated by spaces, in case you need to know.) If PL_utf8locale and PL_unicode (set by -C or by $ENV{PERL_UNICODE}) are true, perl.c:S_parse_body() will turn on the PerlIO :utf8 layer on STDIN, STDOUT, STDERR, _and_ the default open discipline. */ bool utf8locale = FALSE; char *codeset = NULL; #if defined(HAS_NL_LANGINFO) && defined(CODESET) codeset = nl_langinfo(CODESET); #endif if (codeset) utf8locale = (ibcmp(codeset, STR_WITH_LEN("UTF-8")) == 0 || ibcmp(codeset, STR_WITH_LEN("UTF8") ) == 0); #if defined(USE_LOCALE) else { /* nl_langinfo(CODESET) is supposed to correctly * interpret the locale environment variables, * but just in case it fails, let's do this manually. */ if (lang) utf8locale = (ibcmp(lang, STR_WITH_LEN("UTF-8")) == 0 || ibcmp(lang, STR_WITH_LEN("UTF8") ) == 0); #ifdef USE_LOCALE_CTYPE if (curctype) utf8locale = (ibcmp(curctype, STR_WITH_LEN("UTF-8")) == 0 || ibcmp(curctype, STR_WITH_LEN("UTF8") ) == 0); #endif if (lc_all) utf8locale = (ibcmp(lc_all, STR_WITH_LEN("UTF-8")) == 0 || ibcmp(lc_all, STR_WITH_LEN("UTF8") ) == 0); } #endif /* USE_LOCALE */ if (utf8locale) PL_utf8locale = TRUE; } /* Set PL_unicode to $ENV{PERL_UNICODE} if using PerlIO. 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; } #endif #ifdef USE_LOCALE_CTYPE Safefree(curctype); #endif /* USE_LOCALE_CTYPE */ #ifdef USE_LOCALE_COLLATE Safefree(curcoll); #endif /* USE_LOCALE_COLLATE */ #ifdef USE_LOCALE_NUMERIC Safefree(curnum); #endif /* USE_LOCALE_NUMERIC */ return ok; } #ifdef USE_LOCALE_COLLATE /* * mem_collxfrm() is a bit like strxfrm() but with two important * differences. First, it handles embedded NULs. Second, it allocates * a bit more memory than needed for the transformed data itself. * The real transformed data begins at offset sizeof(collationix). * Please see sv_collxfrm() to see how this is used. */ char * Perl_mem_collxfrm(pTHX_ const char *s, STRLEN len, STRLEN *xlen) { dVAR; char *xbuf; STRLEN xAlloc, xin, xout; /* xalloc is a reserved word in VC */ PERL_ARGS_ASSERT_MEM_COLLXFRM; /* the first sizeof(collationix) bytes are used by sv_collxfrm(). */ /* the +1 is for the terminating NUL. */ xAlloc = sizeof(PL_collation_ix) + PL_collxfrm_base + (PL_collxfrm_mult * len) + 1; Newx(xbuf, xAlloc, char); if (! xbuf) goto bad; *(U32*)xbuf = PL_collation_ix; xout = sizeof(PL_collation_ix); for (xin = 0; xin < len; ) { Size_t xused; for (;;) { xused = strxfrm(xbuf + xout, s + xin, xAlloc - xout); if (xused >= PERL_INT_MAX) goto bad; if ((STRLEN)xused < xAlloc - xout) break; xAlloc = (2 * xAlloc) + 1; Renew(xbuf, xAlloc, char); if (! xbuf) goto bad; } xin += strlen(s + xin) + 1; xout += xused; /* Embedded NULs are understood but silently skipped * because they make no sense in locale collation. */ } xbuf[xout] = '\0'; *xlen = xout - sizeof(PL_collation_ix); return xbuf; bad: Safefree(xbuf); *xlen = 0; return NULL; } #endif /* USE_LOCALE_COLLATE */ /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */ perl-5.12.0-RC0/mydtrace.h0000444000175000017500000000166011325125742014113 0ustar jessejesse/* mydtrace.h * * Copyright (C) 2008, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * * Provides macros that wrap the various DTrace probes we use. We add * an extra level of wrapping to encapsulate the _ENABLED tests. */ #if defined(USE_DTRACE) && defined(PERL_CORE) # include "perldtrace.h" # define ENTRY_PROBE(func, file, line) \ if (PERL_SUB_ENTRY_ENABLED()) { \ PERL_SUB_ENTRY(func, file, line); \ } # define RETURN_PROBE(func, file, line) \ if (PERL_SUB_RETURN_ENABLED()) { \ PERL_SUB_RETURN(func, file, line); \ } #else /* NOPs */ # define ENTRY_PROBE(func, file, line) # define RETURN_PROBE(func, file, line) #endif /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */ perl-5.12.0-RC0/embed.h0000644000175000017500000052421411346267327013377 0ustar jessejesse/* -*- buffer-read-only: t -*- * * embed.h * * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * * !!!!!!! DO NOT EDIT THIS FILE !!!!!!! * This file is built by embed.pl from data in embed.fnc, embed.pl, * pp.sym, intrpvar.h, and perlvars.h. * Any changes made here will be lost! * * Edit those files and run 'make regen_headers' to effect changes. */ /* (Doing namespace management portably in C is really gross.) */ /* By defining PERL_NO_SHORT_NAMES (not done by default) the short forms * (like warn instead of Perl_warn) for the API are not defined. * Not defining the short forms is a good thing for cleaner embedding. */ #ifndef PERL_NO_SHORT_NAMES /* Hide global symbols */ #if !defined(PERL_IMPLICIT_CONTEXT) #if defined(PERL_IMPLICIT_SYS) #endif #define doing_taint Perl_doing_taint #if defined(USE_ITHREADS) # if defined(PERL_IMPLICIT_SYS) # endif #endif #if defined(MYMALLOC) #ifdef PERL_CORE #define malloced_size Perl_malloced_size #define malloc_good_size Perl_malloc_good_size #endif #endif #define get_context Perl_get_context #define set_context Perl_set_context #if defined(PERL_CORE) || defined(PERL_EXT) #define regcurly Perl_regcurly #endif #define amagic_call Perl_amagic_call #define Gv_AMupdate Perl_Gv_AMupdate #define gv_handler Perl_gv_handler #ifdef PERL_CORE #define append_elem Perl_append_elem #define append_list Perl_append_list #define apply Perl_apply #endif #define apply_attrs_string Perl_apply_attrs_string #define av_clear Perl_av_clear #define av_delete Perl_av_delete #define av_exists Perl_av_exists #define av_extend Perl_av_extend #define av_fetch Perl_av_fetch #define av_fill Perl_av_fill #define av_len Perl_av_len #define av_make Perl_av_make #define av_pop Perl_av_pop #define av_push Perl_av_push #if defined(PERL_CORE) || defined(PERL_EXT) #define av_reify Perl_av_reify #endif #define av_shift Perl_av_shift #define av_store Perl_av_store #define av_undef Perl_av_undef #define av_unshift Perl_av_unshift #if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define get_aux_mg S_get_aux_mg #endif #endif #ifdef PERL_CORE #define bind_match Perl_bind_match #define block_end Perl_block_end #endif #define block_gimme Perl_block_gimme #ifdef PERL_CORE #define block_start Perl_block_start #define boot_core_UNIVERSAL Perl_boot_core_UNIVERSAL #define boot_core_PerlIO Perl_boot_core_PerlIO #endif #define call_list Perl_call_list #ifdef PERL_CORE #define cando Perl_cando #endif #define cast_ulong Perl_cast_ulong #define cast_i32 Perl_cast_i32 #define cast_iv Perl_cast_iv #define cast_uv Perl_cast_uv #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP) #define my_chsize Perl_my_chsize #endif #ifdef PERL_CORE #define convert Perl_convert #define create_eval_scope Perl_create_eval_scope #endif #define croak Perl_croak #define vcroak Perl_vcroak #define croak_xs_usage Perl_croak_xs_usage #if defined(PERL_IMPLICIT_CONTEXT) #define croak_nocontext Perl_croak_nocontext #define die_nocontext Perl_die_nocontext #define deb_nocontext Perl_deb_nocontext #define form_nocontext Perl_form_nocontext #define load_module_nocontext Perl_load_module_nocontext #define mess_nocontext Perl_mess_nocontext #define warn_nocontext Perl_warn_nocontext #define warner_nocontext Perl_warner_nocontext #define newSVpvf_nocontext Perl_newSVpvf_nocontext #define sv_catpvf_nocontext Perl_sv_catpvf_nocontext #define sv_setpvf_nocontext Perl_sv_setpvf_nocontext #define sv_catpvf_mg_nocontext Perl_sv_catpvf_mg_nocontext #define sv_setpvf_mg_nocontext Perl_sv_setpvf_mg_nocontext #define fprintf_nocontext Perl_fprintf_nocontext #define printf_nocontext Perl_printf_nocontext #endif #ifdef PERL_CORE #define cv_ckproto_len Perl_cv_ckproto_len #define cv_clone Perl_cv_clone #endif #define gv_const_sv Perl_gv_const_sv #define cv_const_sv Perl_cv_const_sv #ifdef PERL_CORE #define op_const_sv Perl_op_const_sv #endif #define cv_undef Perl_cv_undef #define cx_dump Perl_cx_dump #define filter_add Perl_filter_add #define filter_del Perl_filter_del #define filter_read Perl_filter_read #define get_op_descs Perl_get_op_descs #define get_op_names Perl_get_op_names #ifdef PERL_CORE #define get_no_modify Perl_get_no_modify #define get_opargs Perl_get_opargs #endif #define get_ppaddr Perl_get_ppaddr #define cxinc Perl_cxinc #define deb Perl_deb #define vdeb Perl_vdeb #define debprofdump Perl_debprofdump #define debop Perl_debop #define debstack Perl_debstack #define debstackptrs Perl_debstackptrs #define delimcpy Perl_delimcpy #ifdef PERL_CORE #define delete_eval_scope Perl_delete_eval_scope #endif #define die Perl_die #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define vdie S_vdie #endif #endif #ifdef PERL_CORE #define die_where Perl_die_where #endif #define dounwind Perl_dounwind #ifdef PERL_CORE #define do_aexec5 Perl_do_aexec5 #endif #define do_binmode Perl_do_binmode #ifdef PERL_CORE #define do_chop Perl_do_chop #endif #define do_close Perl_do_close #ifdef PERL_CORE #define do_eof Perl_do_eof #endif #ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION #else #ifdef PERL_CORE #define do_exec Perl_do_exec #endif #endif #if defined(WIN32) || defined(__SYMBIAN32__) || defined(VMS) #define do_aspawn Perl_do_aspawn #define do_spawn Perl_do_spawn #define do_spawn_nowait Perl_do_spawn_nowait #endif #if !defined(WIN32) #ifdef PERL_CORE #define do_exec3 Perl_do_exec3 #endif #endif #ifdef PERL_CORE #define do_execfree Perl_do_execfree #endif #if defined(PERL_IN_DOIO_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define exec_failed S_exec_failed #endif #endif #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) #ifdef PERL_CORE #define do_ipcctl Perl_do_ipcctl #define do_ipcget Perl_do_ipcget #define do_msgrcv Perl_do_msgrcv #define do_msgsnd Perl_do_msgsnd #define do_semop Perl_do_semop #define do_shmio Perl_do_shmio #endif #endif #define do_join Perl_do_join #ifdef PERL_CORE #define do_kv Perl_do_kv #endif #define do_open9 Perl_do_open9 #define do_openn Perl_do_openn #ifdef PERL_CORE #define do_print Perl_do_print #define do_readline Perl_do_readline #define do_chomp Perl_do_chomp #define do_seek Perl_do_seek #endif #define do_sprintf Perl_do_sprintf #ifdef PERL_CORE #define do_sysseek Perl_do_sysseek #define do_tell Perl_do_tell #define do_trans Perl_do_trans #define do_vecget Perl_do_vecget #define do_vecset Perl_do_vecset #define do_vop Perl_do_vop #define dofile Perl_dofile #endif #define dowantarray Perl_dowantarray #define dump_all Perl_dump_all #ifdef PERL_CORE #define dump_all_perl Perl_dump_all_perl #endif #define dump_eval Perl_dump_eval #if defined(DUMP_FDS) #define dump_fds Perl_dump_fds #endif #define dump_form Perl_dump_form #define gv_dump Perl_gv_dump #define op_dump Perl_op_dump #define pmop_dump Perl_pmop_dump #define dump_packsubs Perl_dump_packsubs #ifdef PERL_CORE #define dump_packsubs_perl Perl_dump_packsubs_perl #endif #define dump_sub Perl_dump_sub #ifdef PERL_CORE #define dump_sub_perl Perl_dump_sub_perl #endif #define fbm_compile Perl_fbm_compile #define fbm_instr Perl_fbm_instr #ifdef PERL_CORE #define find_script Perl_find_script #endif #if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define force_list S_force_list #define fold_constants S_fold_constants #endif #endif #define form Perl_form #define vform Perl_vform #define free_tmps Perl_free_tmps #if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define gen_constant_list S_gen_constant_list #endif #endif #if !defined(HAS_GETENV_LEN) #ifdef PERL_CORE #define getenv_len Perl_getenv_len #endif #endif #define gp_free Perl_gp_free #define gp_ref Perl_gp_ref #define gv_add_by_type Perl_gv_add_by_type #define gv_autoload4 Perl_gv_autoload4 #define gv_check Perl_gv_check #define gv_efullname Perl_gv_efullname #define gv_efullname4 Perl_gv_efullname4 #define gv_fetchfile Perl_gv_fetchfile #define gv_fetchfile_flags Perl_gv_fetchfile_flags #define gv_fetchmeth Perl_gv_fetchmeth #define gv_fetchmeth_autoload Perl_gv_fetchmeth_autoload #define gv_fetchmethod_autoload Perl_gv_fetchmethod_autoload #define gv_fetchmethod_flags Perl_gv_fetchmethod_flags #define gv_fetchpv Perl_gv_fetchpv #define gv_fullname Perl_gv_fullname #define gv_fullname4 Perl_gv_fullname4 #define gv_init Perl_gv_init #define gv_name_set Perl_gv_name_set #ifdef PERL_CORE #define gv_try_downgrade Perl_gv_try_downgrade #endif #define gv_stashpv Perl_gv_stashpv #define gv_stashpvn Perl_gv_stashpvn #define gv_stashsv Perl_gv_stashsv #define hv_clear Perl_hv_clear #define hv_delayfree_ent Perl_hv_delayfree_ent #define hv_common Perl_hv_common #define hv_common_key_len Perl_hv_common_key_len #define hv_free_ent Perl_hv_free_ent #define hv_iterinit Perl_hv_iterinit #define hv_iterkey Perl_hv_iterkey #define hv_iterkeysv Perl_hv_iterkeysv #define hv_iternextsv Perl_hv_iternextsv #define hv_iternext_flags Perl_hv_iternext_flags #define hv_iterval Perl_hv_iterval #define hv_ksplit Perl_hv_ksplit #if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define refcounted_he_new_common S_refcounted_he_new_common #endif #endif #define hv_undef Perl_hv_undef #define ibcmp Perl_ibcmp #define ibcmp_locale Perl_ibcmp_locale #define ibcmp_utf8 Perl_ibcmp_utf8 #if defined(PERL_IN_DOIO_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define ingroup S_ingroup #endif #endif #ifdef PERL_CORE #define init_argv_symbols Perl_init_argv_symbols #define init_debugger Perl_init_debugger #endif #define init_stacks Perl_init_stacks #define init_tm Perl_init_tm #ifdef PERL_CORE #define intro_my Perl_intro_my #endif #define instr Perl_instr #ifdef PERL_CORE #define io_close Perl_io_close #define invert Perl_invert #endif #define is_lvalue_sub Perl_is_lvalue_sub #define to_uni_upper_lc Perl_to_uni_upper_lc #define to_uni_title_lc Perl_to_uni_title_lc #define to_uni_lower_lc Perl_to_uni_lower_lc #define is_uni_alnum Perl_is_uni_alnum #define is_uni_idfirst Perl_is_uni_idfirst #define is_uni_alpha Perl_is_uni_alpha #define is_uni_ascii Perl_is_uni_ascii #define is_uni_space Perl_is_uni_space #define is_uni_cntrl Perl_is_uni_cntrl #define is_uni_graph Perl_is_uni_graph #define is_uni_digit Perl_is_uni_digit #define is_uni_upper Perl_is_uni_upper #define is_uni_lower Perl_is_uni_lower #define is_uni_print Perl_is_uni_print #define is_uni_punct Perl_is_uni_punct #define is_uni_xdigit Perl_is_uni_xdigit #define to_uni_upper Perl_to_uni_upper #define to_uni_title Perl_to_uni_title #define to_uni_lower Perl_to_uni_lower #define to_uni_fold Perl_to_uni_fold #define is_uni_alnum_lc Perl_is_uni_alnum_lc #define is_uni_idfirst_lc Perl_is_uni_idfirst_lc #define is_uni_alpha_lc Perl_is_uni_alpha_lc #define is_uni_ascii_lc Perl_is_uni_ascii_lc #define is_uni_space_lc Perl_is_uni_space_lc #define is_uni_cntrl_lc Perl_is_uni_cntrl_lc #define is_uni_graph_lc Perl_is_uni_graph_lc #define is_uni_digit_lc Perl_is_uni_digit_lc #define is_uni_upper_lc Perl_is_uni_upper_lc #define is_uni_lower_lc Perl_is_uni_lower_lc #define is_uni_print_lc Perl_is_uni_print_lc #define is_uni_punct_lc Perl_is_uni_punct_lc #define is_uni_xdigit_lc Perl_is_uni_xdigit_lc #define is_ascii_string Perl_is_ascii_string #define is_utf8_char Perl_is_utf8_char #define is_utf8_string Perl_is_utf8_string #define is_utf8_string_loclen Perl_is_utf8_string_loclen #define is_utf8_alnum Perl_is_utf8_alnum #define is_utf8_idfirst Perl_is_utf8_idfirst #define is_utf8_idcont Perl_is_utf8_idcont #define is_utf8_alpha Perl_is_utf8_alpha #define is_utf8_ascii Perl_is_utf8_ascii #define is_utf8_space Perl_is_utf8_space #define is_utf8_perl_space Perl_is_utf8_perl_space #define is_utf8_perl_word Perl_is_utf8_perl_word #define is_utf8_cntrl Perl_is_utf8_cntrl #define is_utf8_digit Perl_is_utf8_digit #define is_utf8_posix_digit Perl_is_utf8_posix_digit #define is_utf8_graph Perl_is_utf8_graph #define is_utf8_upper Perl_is_utf8_upper #define is_utf8_lower Perl_is_utf8_lower #define is_utf8_print Perl_is_utf8_print #define is_utf8_punct Perl_is_utf8_punct #define is_utf8_xdigit Perl_is_utf8_xdigit #define is_utf8_mark Perl_is_utf8_mark #if defined(PERL_CORE) || defined(PERL_EXT) #define is_utf8_X_begin Perl_is_utf8_X_begin #define is_utf8_X_extend Perl_is_utf8_X_extend #define is_utf8_X_prepend Perl_is_utf8_X_prepend #define is_utf8_X_non_hangul Perl_is_utf8_X_non_hangul #define is_utf8_X_L Perl_is_utf8_X_L #define is_utf8_X_LV Perl_is_utf8_X_LV #define is_utf8_X_LVT Perl_is_utf8_X_LVT #define is_utf8_X_LV_LVT_V Perl_is_utf8_X_LV_LVT_V #define is_utf8_X_T Perl_is_utf8_X_T #define is_utf8_X_V Perl_is_utf8_X_V #endif #ifdef PERL_CORE #define jmaybe Perl_jmaybe #define keyword Perl_keyword #endif #if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define opt_scalarhv S_opt_scalarhv #define is_inplace_av S_is_inplace_av #endif #endif #define leave_scope Perl_leave_scope #if defined(PERL_CORE) || defined(PERL_EXT) #define lex_end Perl_lex_end #endif #ifdef PERL_CORE #define lex_start Perl_lex_start #endif #define lex_bufutf8 Perl_lex_bufutf8 #define lex_grow_linestr Perl_lex_grow_linestr #define lex_stuff_pvn Perl_lex_stuff_pvn #define lex_stuff_sv Perl_lex_stuff_sv #define lex_unstuff Perl_lex_unstuff #define lex_read_to Perl_lex_read_to #define lex_discard_to Perl_lex_discard_to #define lex_next_chunk Perl_lex_next_chunk #define lex_peek_unichar Perl_lex_peek_unichar #define lex_read_unichar Perl_lex_read_unichar #define lex_read_space Perl_lex_read_space #define op_null Perl_op_null #if defined(PERL_CORE) || defined(PERL_EXT) #define op_clear Perl_op_clear #endif #define op_refcnt_lock Perl_op_refcnt_lock #define op_refcnt_unlock Perl_op_refcnt_unlock #if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define linklist S_linklist #define listkids S_listkids #endif #endif #ifdef PERL_CORE #define list Perl_list #endif #define load_module Perl_load_module #define vload_module Perl_vload_module #ifdef PERL_CORE #define localize Perl_localize #endif #define looks_like_number Perl_looks_like_number #define grok_bin Perl_grok_bin #define grok_hex Perl_grok_hex #define grok_number Perl_grok_number #define grok_numeric_radix Perl_grok_numeric_radix #define grok_oct Perl_grok_oct #ifdef PERL_CORE #define magic_clearenv Perl_magic_clearenv #define magic_clear_all_env Perl_magic_clear_all_env #define magic_clearhint Perl_magic_clearhint #define magic_clearhints Perl_magic_clearhints #define magic_clearisa Perl_magic_clearisa #define magic_clearpack Perl_magic_clearpack #define magic_clearsig Perl_magic_clearsig #define magic_existspack Perl_magic_existspack #define magic_freeovrld Perl_magic_freeovrld #define magic_get Perl_magic_get #define magic_getarylen Perl_magic_getarylen #define magic_getdefelem Perl_magic_getdefelem #define magic_getnkeys Perl_magic_getnkeys #define magic_getpack Perl_magic_getpack #define magic_getpos Perl_magic_getpos #define magic_getsig Perl_magic_getsig #define magic_getsubstr Perl_magic_getsubstr #define magic_gettaint Perl_magic_gettaint #define magic_getuvar Perl_magic_getuvar #define magic_getvec Perl_magic_getvec #define magic_len Perl_magic_len #define magic_nextpack Perl_magic_nextpack #define magic_regdata_cnt Perl_magic_regdata_cnt #define magic_regdatum_get Perl_magic_regdatum_get #define magic_regdatum_set Perl_magic_regdatum_set #define magic_set Perl_magic_set #define magic_setamagic Perl_magic_setamagic #define magic_setarylen Perl_magic_setarylen #define magic_freearylen_p Perl_magic_freearylen_p #define magic_setdbline Perl_magic_setdbline #define magic_setdefelem Perl_magic_setdefelem #define magic_setenv Perl_magic_setenv #define magic_sethint Perl_magic_sethint #define magic_setisa Perl_magic_setisa #define magic_setmglob Perl_magic_setmglob #define magic_setnkeys Perl_magic_setnkeys #define magic_setpack Perl_magic_setpack #define magic_setpos Perl_magic_setpos #define magic_setregexp Perl_magic_setregexp #define magic_setsig Perl_magic_setsig #define magic_setsubstr Perl_magic_setsubstr #define magic_settaint Perl_magic_settaint #define magic_setuvar Perl_magic_setuvar #define magic_setvec Perl_magic_setvec #define magic_setutf8 Perl_magic_setutf8 #define magic_set_all_env Perl_magic_set_all_env #define magic_sizepack Perl_magic_sizepack #define magic_wipepack Perl_magic_wipepack #endif #define markstack_grow Perl_markstack_grow #if defined(USE_LOCALE_COLLATE) #ifdef PERL_CORE #define magic_setcollxfrm Perl_magic_setcollxfrm #define mem_collxfrm Perl_mem_collxfrm #endif #endif #define mess Perl_mess #define vmess Perl_vmess #if defined(PERL_CORE) || defined(PERL_EXT) #define qerror Perl_qerror #endif #define sortsv Perl_sortsv #define sortsv_flags Perl_sortsv_flags #define mg_clear Perl_mg_clear #define mg_copy Perl_mg_copy #ifdef PERL_CORE #define mg_localize Perl_mg_localize #endif #define mg_find Perl_mg_find #define mg_free Perl_mg_free #define mg_get Perl_mg_get #define mg_length Perl_mg_length #define mg_magical Perl_mg_magical #define mg_set Perl_mg_set #define mg_size Perl_mg_size #define mini_mktime Perl_mini_mktime #if defined(PERL_CORE) || defined(PERL_EXT) #define mod Perl_mod #endif #ifdef PERL_CORE #define mode_from_discipline Perl_mode_from_discipline #endif #define moreswitches Perl_moreswitches #define my_atof Perl_my_atof #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY)) #define my_bcopy Perl_my_bcopy #endif #if !defined(HAS_BZERO) && !defined(HAS_MEMSET) #define my_bzero Perl_my_bzero #endif #define my_exit Perl_my_exit #define my_failure_exit Perl_my_failure_exit #define my_fflush_all Perl_my_fflush_all #define my_fork Perl_my_fork #define atfork_lock Perl_atfork_lock #define atfork_unlock Perl_atfork_unlock #define my_lstat Perl_my_lstat #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP) #define my_memcmp Perl_my_memcmp #endif #if !defined(HAS_MEMSET) #define my_memset Perl_my_memset #endif #define my_pclose Perl_my_pclose #define my_popen Perl_my_popen #define my_popen_list Perl_my_popen_list #define my_setenv Perl_my_setenv #define my_stat Perl_my_stat #define my_strftime Perl_my_strftime #if defined(MYSWAP) #define my_swap Perl_my_swap #define my_htonl Perl_my_htonl #define my_ntohl Perl_my_ntohl #endif #ifdef PERL_CORE #define my_unexec Perl_my_unexec #endif #define newANONLIST Perl_newANONLIST #define newANONHASH Perl_newANONHASH #define newANONSUB Perl_newANONSUB #define newASSIGNOP Perl_newASSIGNOP #define newCONDOP Perl_newCONDOP #define newCONSTSUB Perl_newCONSTSUB #ifdef PERL_MAD #define newFORM Perl_newFORM #else #define newFORM Perl_newFORM #endif #define newFOROP Perl_newFOROP #define newGIVENOP Perl_newGIVENOP #define newLOGOP Perl_newLOGOP #define newLOOPEX Perl_newLOOPEX #define newLOOPOP Perl_newLOOPOP #define newNULLLIST Perl_newNULLLIST #define newOP Perl_newOP #define newPROG Perl_newPROG #define newRANGE Perl_newRANGE #define newSLICEOP Perl_newSLICEOP #define newSTATEOP Perl_newSTATEOP #define newSUB Perl_newSUB #define newXS_flags Perl_newXS_flags #define newXS Perl_newXS #define newAVREF Perl_newAVREF #define newBINOP Perl_newBINOP #define newCVREF Perl_newCVREF #define newGVOP Perl_newGVOP #define newGVgen Perl_newGVgen #define newGVREF Perl_newGVREF #define newHVREF Perl_newHVREF #define newHVhv Perl_newHVhv #define newLISTOP Perl_newLISTOP #ifdef USE_ITHREADS #define newPADOP Perl_newPADOP #endif #define newPMOP Perl_newPMOP #define newPVOP Perl_newPVOP #define newRV Perl_newRV #define newRV_noinc Perl_newRV_noinc #define newSV Perl_newSV #define newSVREF Perl_newSVREF #define newSVOP Perl_newSVOP #define newSViv Perl_newSViv #define newSVuv Perl_newSVuv #define newSVnv Perl_newSVnv #define newSVpv Perl_newSVpv #define newSVpvn Perl_newSVpvn #define newSVpvn_flags Perl_newSVpvn_flags #define newSVhek Perl_newSVhek #define newSVpvn_share Perl_newSVpvn_share #define newSVpvf Perl_newSVpvf #define vnewSVpvf Perl_vnewSVpvf #define newSVrv Perl_newSVrv #define newSVsv Perl_newSVsv #define newSV_type Perl_newSV_type #define newUNOP Perl_newUNOP #define newWHENOP Perl_newWHENOP #define newWHILEOP Perl_newWHILEOP #define new_stackinfo Perl_new_stackinfo #define scan_vstring Perl_scan_vstring #define scan_version Perl_scan_version #define prescan_version Perl_prescan_version #define new_version Perl_new_version #define upg_version Perl_upg_version #define vverify Perl_vverify #define vnumify Perl_vnumify #define vnormal Perl_vnormal #define vstringify Perl_vstringify #define vcmp Perl_vcmp #ifdef PERL_CORE #define nextargv Perl_nextargv #endif #define ninstr Perl_ninstr #define op_free Perl_op_free #ifdef PERL_MAD #ifdef PERL_CORE #define package Perl_package #endif #else #ifdef PERL_CORE #define package Perl_package #endif #endif #ifdef PERL_CORE #define package_version Perl_package_version #define pad_alloc Perl_pad_alloc #define allocmy Perl_allocmy #endif #define pad_findmy Perl_pad_findmy #define find_rundefsvoffset Perl_find_rundefsvoffset #ifdef PERL_CORE #define oopsAV Perl_oopsAV #define oopsHV Perl_oopsHV #define pad_leavemy Perl_pad_leavemy #endif #ifdef DEBUGGING #define pad_sv Perl_pad_sv #endif #ifdef PERL_CORE #define pad_free Perl_pad_free #endif #if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define pad_reset S_pad_reset #endif #endif #ifdef PERL_CORE #define pad_swipe Perl_pad_swipe #define peep Perl_peep #endif #if defined(USE_REENTRANT_API) #define reentrant_size Perl_reentrant_size #define reentrant_init Perl_reentrant_init #define reentrant_free Perl_reentrant_free #define reentrant_retry Perl_reentrant_retry #endif #define call_atexit Perl_call_atexit #define call_argv Perl_call_argv #define call_method Perl_call_method #define call_pv Perl_call_pv #define call_sv Perl_call_sv #define despatch_signals Perl_despatch_signals #define doref Perl_doref #define eval_pv Perl_eval_pv #define eval_sv Perl_eval_sv #define get_sv Perl_get_sv #define get_av Perl_get_av #define get_hv Perl_get_hv #define get_cv Perl_get_cv #define get_cvn_flags Perl_get_cvn_flags #define init_i18nl10n Perl_init_i18nl10n #define init_i18nl14n Perl_init_i18nl14n #define new_collate Perl_new_collate #define new_ctype Perl_new_ctype #define new_numeric Perl_new_numeric #define set_numeric_local Perl_set_numeric_local #define set_numeric_radix Perl_set_numeric_radix #define set_numeric_standard Perl_set_numeric_standard #define require_pv Perl_require_pv #define pack_cat Perl_pack_cat #define packlist Perl_packlist #if defined(PERL_USES_PL_PIDSTATUS) && defined(PERL_IN_UTIL_C) #ifdef PERL_CORE #define pidgone S_pidgone #endif #endif #ifdef PERL_CORE #define pmruntime Perl_pmruntime #endif #if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define pmtrans S_pmtrans #endif #endif #define pop_scope Perl_pop_scope #ifdef PERL_CORE #define prepend_elem Perl_prepend_elem #endif #define push_scope Perl_push_scope #if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define refkids S_refkids #endif #endif #define regdump Perl_regdump #define regdump Perl_regdump #define regclass_swash Perl_regclass_swash #define pregexec Perl_pregexec #define pregfree Perl_pregfree #define pregfree2 Perl_pregfree2 #if defined(PERL_CORE) || defined(PERL_EXT) #define reg_temp_copy Perl_reg_temp_copy #endif #define regfree_internal Perl_regfree_internal #if defined(USE_ITHREADS) #define regdupe_internal Perl_regdupe_internal #endif #define pregcomp Perl_pregcomp #define re_compile Perl_re_compile #define re_intuit_start Perl_re_intuit_start #define re_intuit_string Perl_re_intuit_string #define regexec_flags Perl_regexec_flags #define regnext Perl_regnext #if defined(PERL_CORE) || defined(PERL_EXT) #define reg_named_buff Perl_reg_named_buff #define reg_named_buff_iter Perl_reg_named_buff_iter #endif #define reg_named_buff_fetch Perl_reg_named_buff_fetch #define reg_named_buff_exists Perl_reg_named_buff_exists #define reg_named_buff_firstkey Perl_reg_named_buff_firstkey #define reg_named_buff_nextkey Perl_reg_named_buff_nextkey #define reg_named_buff_scalar Perl_reg_named_buff_scalar #define reg_named_buff_all Perl_reg_named_buff_all #if defined(PERL_CORE) || defined(PERL_EXT) #define reg_numbered_buff_fetch Perl_reg_numbered_buff_fetch #define reg_numbered_buff_store Perl_reg_numbered_buff_store #define reg_numbered_buff_length Perl_reg_numbered_buff_length #endif #if defined(PERL_CORE) || defined(PERL_EXT) #define reg_qr_package Perl_reg_qr_package #endif #if defined(PERL_CORE) || defined(PERL_EXT) #define regprop Perl_regprop #endif #define repeatcpy Perl_repeatcpy #define rninstr Perl_rninstr #define rsignal Perl_rsignal #ifdef PERL_CORE #define rsignal_restore Perl_rsignal_restore #define rsignal_save Perl_rsignal_save #endif #define rsignal_state Perl_rsignal_state #if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define rxres_free S_rxres_free #define rxres_restore S_rxres_restore #endif #endif #ifdef PERL_CORE #define rxres_save Perl_rxres_save #endif #if !defined(HAS_RENAME) #ifdef PERL_CORE #define same_dirent Perl_same_dirent #endif #endif #define savepv Perl_savepv #define savepvn Perl_savepvn #define savesharedpv Perl_savesharedpv #define savesharedpvn Perl_savesharedpvn #define savesvpv Perl_savesvpv #define savestack_grow Perl_savestack_grow #define savestack_grow_cnt Perl_savestack_grow_cnt #define save_aelem_flags Perl_save_aelem_flags #define save_alloc Perl_save_alloc #define save_aptr Perl_save_aptr #define save_ary Perl_save_ary #define save_bool Perl_save_bool #define save_clearsv Perl_save_clearsv #define save_delete Perl_save_delete #define save_hdelete Perl_save_hdelete #define save_adelete Perl_save_adelete #define save_destructor Perl_save_destructor #define save_destructor_x Perl_save_destructor_x #define save_generic_svref Perl_save_generic_svref #define save_generic_pvref Perl_save_generic_pvref #define save_shared_pvref Perl_save_shared_pvref #define save_gp Perl_save_gp #define save_hash Perl_save_hash #ifdef PERL_CORE #define save_hints Perl_save_hints #endif #define save_helem_flags Perl_save_helem_flags #define save_hptr Perl_save_hptr #define save_I16 Perl_save_I16 #define save_I32 Perl_save_I32 #define save_I8 Perl_save_I8 #define save_int Perl_save_int #define save_item Perl_save_item #define save_iv Perl_save_iv #define save_list Perl_save_list #define save_long Perl_save_long #define save_nogv Perl_save_nogv #define save_scalar Perl_save_scalar #define save_pptr Perl_save_pptr #define save_vptr Perl_save_vptr #define save_re_context Perl_save_re_context #define save_padsv_and_mortalize Perl_save_padsv_and_mortalize #define save_sptr Perl_save_sptr #define save_svref Perl_save_svref #define save_pushptr Perl_save_pushptr #ifdef PERL_CORE #define save_pushi32ptr Perl_save_pushi32ptr #define save_pushptrptr Perl_save_pushptrptr #endif #if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define save_pushptri32ptr S_save_pushptri32ptr #endif #endif #ifdef PERL_CORE #define sawparens Perl_sawparens #define scalar Perl_scalar #endif #if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define scalarkids S_scalarkids #define scalarseq S_scalarseq #endif #endif #ifdef PERL_CORE #define scalarvoid Perl_scalarvoid #endif #define scan_bin Perl_scan_bin #define scan_hex Perl_scan_hex #define scan_num Perl_scan_num #define scan_oct Perl_scan_oct #ifdef PERL_CORE #define scope Perl_scope #endif #define screaminstr Perl_screaminstr #define setdefout Perl_setdefout #define share_hek Perl_share_hek #if defined(HAS_SIGACTION) && defined(SA_SIGINFO) #ifdef PERL_CORE #define sighandler Perl_sighandler #endif #define csighandler Perl_csighandler #else #ifdef PERL_CORE #define sighandler Perl_sighandler #endif #define csighandler Perl_csighandler #endif #define stack_grow Perl_stack_grow #define start_subparse Perl_start_subparse #ifdef PERL_CORE #define sub_crush_depth Perl_sub_crush_depth #endif #define sv_2bool Perl_sv_2bool #define sv_2cv Perl_sv_2cv #define sv_2io Perl_sv_2io #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define glob_2number S_glob_2number #endif #endif #define sv_2iv_flags Perl_sv_2iv_flags #define sv_2mortal Perl_sv_2mortal #define sv_2nv Perl_sv_2nv #ifdef PERL_CORE #define sv_2num Perl_sv_2num #endif #define sv_2pv_flags Perl_sv_2pv_flags #define sv_2pvutf8 Perl_sv_2pvutf8 #define sv_2pvbyte Perl_sv_2pvbyte #define sv_pvn_nomg Perl_sv_pvn_nomg #define sv_2uv_flags Perl_sv_2uv_flags #define sv_iv Perl_sv_iv #define sv_uv Perl_sv_uv #define sv_nv Perl_sv_nv #define sv_pvn Perl_sv_pvn #define sv_pvutf8n Perl_sv_pvutf8n #define sv_pvbyten Perl_sv_pvbyten #define sv_true Perl_sv_true #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define sv_add_arena S_sv_add_arena #endif #endif #define sv_backoff Perl_sv_backoff #define sv_bless Perl_sv_bless #define sv_catpvf Perl_sv_catpvf #define sv_vcatpvf Perl_sv_vcatpvf #define sv_catpv Perl_sv_catpv #define sv_chop Perl_sv_chop #ifdef PERL_CORE #define sv_clean_all Perl_sv_clean_all #define sv_clean_objs Perl_sv_clean_objs #endif #define sv_clear Perl_sv_clear #define sv_cmp Perl_sv_cmp #define sv_cmp_locale Perl_sv_cmp_locale #if defined(USE_LOCALE_COLLATE) #define sv_collxfrm Perl_sv_collxfrm #endif #define sv_compile_2op Perl_sv_compile_2op #define getcwd_sv Perl_getcwd_sv #define sv_dec Perl_sv_dec #define sv_dump Perl_sv_dump #define sv_derived_from Perl_sv_derived_from #define sv_does Perl_sv_does #define sv_eq Perl_sv_eq #define sv_free Perl_sv_free #ifdef PERL_CORE #define sv_free_arenas Perl_sv_free_arenas #endif #define sv_gets Perl_sv_gets #define sv_grow Perl_sv_grow #define sv_inc Perl_sv_inc #define sv_insert_flags Perl_sv_insert_flags #define sv_isa Perl_sv_isa #define sv_isobject Perl_sv_isobject #define sv_len Perl_sv_len #define sv_len_utf8 Perl_sv_len_utf8 #define sv_magic Perl_sv_magic #define sv_magicext Perl_sv_magicext #define sv_mortalcopy Perl_sv_mortalcopy #define sv_newmortal Perl_sv_newmortal #define sv_newref Perl_sv_newref #define sv_peek Perl_sv_peek #define sv_pos_u2b Perl_sv_pos_u2b #define sv_pos_u2b_flags Perl_sv_pos_u2b_flags #define sv_pos_b2u Perl_sv_pos_b2u #define sv_pvutf8n_force Perl_sv_pvutf8n_force #define sv_pvbyten_force Perl_sv_pvbyten_force #define sv_recode_to_utf8 Perl_sv_recode_to_utf8 #define sv_cat_decode Perl_sv_cat_decode #define sv_reftype Perl_sv_reftype #define sv_replace Perl_sv_replace #define sv_report_used Perl_sv_report_used #define sv_reset Perl_sv_reset #define sv_setpvf Perl_sv_setpvf #define sv_vsetpvf Perl_sv_vsetpvf #define sv_setiv Perl_sv_setiv #define sv_setpviv Perl_sv_setpviv #define sv_setuv Perl_sv_setuv #define sv_setnv Perl_sv_setnv #define sv_setref_iv Perl_sv_setref_iv #define sv_setref_uv Perl_sv_setref_uv #define sv_setref_nv Perl_sv_setref_nv #define sv_setref_pv Perl_sv_setref_pv #define sv_setref_pvn Perl_sv_setref_pvn #define sv_setpv Perl_sv_setpv #define sv_setpvn Perl_sv_setpvn #define sv_tainted Perl_sv_tainted #define sv_unmagic Perl_sv_unmagic #define sv_unref_flags Perl_sv_unref_flags #define sv_untaint Perl_sv_untaint #define sv_upgrade Perl_sv_upgrade #define sv_usepvn_flags Perl_sv_usepvn_flags #define sv_vcatpvfn Perl_sv_vcatpvfn #define sv_vsetpvfn Perl_sv_vsetpvfn #define str_to_version Perl_str_to_version #define swash_init Perl_swash_init #define swash_fetch Perl_swash_fetch #define taint_env Perl_taint_env #define taint_proper Perl_taint_proper #define to_utf8_case Perl_to_utf8_case #define to_utf8_lower Perl_to_utf8_lower #define to_utf8_upper Perl_to_utf8_upper #define to_utf8_title Perl_to_utf8_title #define to_utf8_fold Perl_to_utf8_fold #if defined(UNLINK_ALL_VERSIONS) #define unlnk Perl_unlnk #endif #define unpack_str Perl_unpack_str #define unpackstring Perl_unpackstring #define unsharepvn Perl_unsharepvn #ifdef PERL_CORE #define unshare_hek Perl_unshare_hek #endif #ifdef PERL_MAD #ifdef PERL_CORE #define utilize Perl_utilize #endif #else #ifdef PERL_CORE #define utilize Perl_utilize #endif #endif #define utf16_to_utf8 Perl_utf16_to_utf8 #define utf16_to_utf8_reversed Perl_utf16_to_utf8_reversed #define utf8_length Perl_utf8_length #define utf8_distance Perl_utf8_distance #define utf8_hop Perl_utf8_hop #define utf8_to_bytes Perl_utf8_to_bytes #define bytes_from_utf8 Perl_bytes_from_utf8 #define bytes_to_utf8 Perl_bytes_to_utf8 #define utf8_to_uvchr Perl_utf8_to_uvchr #define utf8_to_uvuni Perl_utf8_to_uvuni #ifdef EBCDIC #define utf8n_to_uvchr Perl_utf8n_to_uvchr #else #endif #define utf8n_to_uvuni Perl_utf8n_to_uvuni #ifdef EBCDIC #define uvchr_to_utf8 Perl_uvchr_to_utf8 #else #endif #define uvchr_to_utf8_flags Perl_uvchr_to_utf8_flags #define uvuni_to_utf8_flags Perl_uvuni_to_utf8_flags #define pv_uni_display Perl_pv_uni_display #define sv_uni_display Perl_sv_uni_display #if defined(PERL_CORE) || defined(PERL_EXT) #define vivify_defelem Perl_vivify_defelem #endif #ifdef PERL_CORE #define vivify_ref Perl_vivify_ref #define wait4pid Perl_wait4pid #define parse_unicode_opts Perl_parse_unicode_opts #endif #define seed Perl_seed #ifdef PERL_CORE #define get_hash_seed Perl_get_hash_seed #define report_evil_fh Perl_report_evil_fh #endif #if defined(PERL_CORE) || defined(PERL_EXT) #define report_uninit Perl_report_uninit #endif #define warn Perl_warn #define vwarn Perl_vwarn #define warner Perl_warner #define ck_warner Perl_ck_warner #define ck_warner_d Perl_ck_warner_d #define vwarner Perl_vwarner #ifdef PERL_CORE #define watch Perl_watch #endif #define whichsig Perl_whichsig #ifdef PERL_CORE #define write_to_stderr Perl_write_to_stderr #define yyerror Perl_yyerror #endif #if defined(PERL_CORE) || defined(PERL_EXT) #define yylex Perl_yylex #endif #ifdef PERL_CORE #define yyparse Perl_yyparse #define parser_free Perl_parser_free #endif #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define yywarn S_yywarn #endif #endif #if defined(MYMALLOC) #define dump_mstats Perl_dump_mstats #define get_mstats Perl_get_mstats #endif #define safesysmalloc Perl_safesysmalloc #define safesyscalloc Perl_safesyscalloc #define safesysrealloc Perl_safesysrealloc #define safesysfree Perl_safesysfree #if defined(PERL_GLOBAL_STRUCT) #define GetVars Perl_GetVars #define init_global_struct Perl_init_global_struct #define free_global_struct Perl_free_global_struct #endif #define runops_standard Perl_runops_standard #define runops_debug Perl_runops_debug #define sv_catpvf_mg Perl_sv_catpvf_mg #define sv_vcatpvf_mg Perl_sv_vcatpvf_mg #define sv_catpv_mg Perl_sv_catpv_mg #define sv_setpvf_mg Perl_sv_setpvf_mg #define sv_vsetpvf_mg Perl_sv_vsetpvf_mg #define sv_setiv_mg Perl_sv_setiv_mg #define sv_setpviv_mg Perl_sv_setpviv_mg #define sv_setuv_mg Perl_sv_setuv_mg #define sv_setnv_mg Perl_sv_setnv_mg #define sv_setpv_mg Perl_sv_setpv_mg #define sv_setpvn_mg Perl_sv_setpvn_mg #define sv_setsv_mg Perl_sv_setsv_mg #define get_vtbl Perl_get_vtbl #define pv_display Perl_pv_display #define pv_escape Perl_pv_escape #define pv_pretty Perl_pv_pretty #define dump_indent Perl_dump_indent #define dump_vindent Perl_dump_vindent #define do_gv_dump Perl_do_gv_dump #define do_gvgv_dump Perl_do_gvgv_dump #define do_hv_dump Perl_do_hv_dump #define do_magic_dump Perl_do_magic_dump #define do_op_dump Perl_do_op_dump #define do_pmop_dump Perl_do_pmop_dump #define do_sv_dump Perl_do_sv_dump #define magic_dump Perl_magic_dump #define reginitcolors Perl_reginitcolors #define sv_utf8_downgrade Perl_sv_utf8_downgrade #define sv_utf8_encode Perl_sv_utf8_encode #define sv_utf8_decode Perl_sv_utf8_decode #define sv_force_normal_flags Perl_sv_force_normal_flags #define tmps_grow Perl_tmps_grow #define sv_rvweaken Perl_sv_rvweaken #ifdef PERL_CORE #define magic_killbackrefs Perl_magic_killbackrefs #endif #define newANONATTRSUB Perl_newANONATTRSUB #define newATTRSUB Perl_newATTRSUB #ifdef PERL_MAD #define newMYSUB Perl_newMYSUB #else #define newMYSUB Perl_newMYSUB #endif #ifdef PERL_CORE #define my_attrs Perl_my_attrs #endif #if defined(USE_ITHREADS) #define cx_dup Perl_cx_dup #define si_dup Perl_si_dup #define ss_dup Perl_ss_dup #define any_dup Perl_any_dup #define he_dup Perl_he_dup #define hek_dup Perl_hek_dup #define re_dup_guts Perl_re_dup_guts #define fp_dup Perl_fp_dup #define dirp_dup Perl_dirp_dup #define gp_dup Perl_gp_dup #define mg_dup Perl_mg_dup #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define sv_dup_inc_multiple S_sv_dup_inc_multiple #endif #endif #define sv_dup Perl_sv_dup #define rvpv_dup Perl_rvpv_dup #define parser_dup Perl_parser_dup #endif #define ptr_table_new Perl_ptr_table_new #define ptr_table_fetch Perl_ptr_table_fetch #define ptr_table_store Perl_ptr_table_store #define ptr_table_split Perl_ptr_table_split #define ptr_table_clear Perl_ptr_table_clear #define ptr_table_free Perl_ptr_table_free #if defined(USE_ITHREADS) # if defined(HAVE_INTERP_INTERN) #define sys_intern_dup Perl_sys_intern_dup # endif #endif #if defined(HAVE_INTERP_INTERN) #define sys_intern_clear Perl_sys_intern_clear #define sys_intern_init Perl_sys_intern_init #endif #define custom_op_name Perl_custom_op_name #define custom_op_desc Perl_custom_op_desc #define sv_nosharing Perl_sv_nosharing #define sv_destroyable Perl_sv_destroyable #ifdef NO_MATHOMS #else #define sv_nounlocking Perl_sv_nounlocking #endif #define nothreadhook Perl_nothreadhook #if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define do_trans_simple S_do_trans_simple #define do_trans_count S_do_trans_count #define do_trans_complex S_do_trans_complex #define do_trans_simple_utf8 S_do_trans_simple_utf8 #define do_trans_count_utf8 S_do_trans_count_utf8 #define do_trans_complex_utf8 S_do_trans_complex_utf8 #endif #endif #if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define gv_init_sv S_gv_init_sv #define gv_get_super_pkg S_gv_get_super_pkg #define require_tie_mod S_require_tie_mod #endif #endif #if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define hsplit S_hsplit #define hfreeentries S_hfreeentries #define anonymise_cv S_anonymise_cv #define new_he S_new_he #define save_hek_flags S_save_hek_flags #define hv_magic_check S_hv_magic_check #define unshare_hek_or_pvn S_unshare_hek_or_pvn #define share_hek_flags S_share_hek_flags #define hv_notallowed S_hv_notallowed #define hv_auxinit S_hv_auxinit #define hv_delete_common S_hv_delete_common #define clear_placeholders S_clear_placeholders #define refcounted_he_value S_refcounted_he_value #endif #endif #if defined(PERL_IN_MG_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define save_magic S_save_magic #define magic_methpack S_magic_methpack #define magic_methcall S_magic_methcall #define restore_magic S_restore_magic #define unwind_handler_stack S_unwind_handler_stack #endif #endif #if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define ck_anoncode Perl_ck_anoncode #define ck_bitop Perl_ck_bitop #define ck_concat Perl_ck_concat #define ck_defined Perl_ck_defined #define ck_delete Perl_ck_delete #define ck_die Perl_ck_die #define ck_eof Perl_ck_eof #define ck_eval Perl_ck_eval #define ck_exec Perl_ck_exec #define ck_exists Perl_ck_exists #define ck_exit Perl_ck_exit #define ck_ftst Perl_ck_ftst #define ck_fun Perl_ck_fun #define ck_glob Perl_ck_glob #define ck_grep Perl_ck_grep #define ck_index Perl_ck_index #define ck_join Perl_ck_join #define ck_lfun Perl_ck_lfun #define ck_listiob Perl_ck_listiob #define ck_match Perl_ck_match #define ck_method Perl_ck_method #define ck_null Perl_ck_null #define ck_open Perl_ck_open #define ck_readline Perl_ck_readline #define ck_repeat Perl_ck_repeat #define ck_require Perl_ck_require #define ck_return Perl_ck_return #define ck_rfun Perl_ck_rfun #define ck_rvconst Perl_ck_rvconst #define ck_sassign Perl_ck_sassign #define ck_select Perl_ck_select #define ck_shift Perl_ck_shift #define ck_sort Perl_ck_sort #define ck_spair Perl_ck_spair #define ck_split Perl_ck_split #define ck_subr Perl_ck_subr #define ck_substr Perl_ck_substr #define ck_svconst Perl_ck_svconst #define ck_trunc Perl_ck_trunc #define ck_unpack Perl_ck_unpack #define ck_each Perl_ck_each #define is_handle_constructor S_is_handle_constructor #define is_list_assignment S_is_list_assignment #endif # ifdef USE_ITHREADS # else # endif #ifdef PERL_CORE #define find_and_forget_pmops S_find_and_forget_pmops #define cop_free S_cop_free #define modkids S_modkids #define scalarboolean S_scalarboolean #define newDEFSVOP S_newDEFSVOP #define search_const S_search_const #define new_logop S_new_logop #define simplify_sort S_simplify_sort #define gv_ename S_gv_ename #define scalar_mod_type S_scalar_mod_type #define my_kid S_my_kid #define dup_attrlist S_dup_attrlist #define apply_attrs S_apply_attrs #define apply_attrs_my S_apply_attrs_my #define bad_type S_bad_type #define no_bareword_allowed S_no_bareword_allowed #define no_fh_allowed S_no_fh_allowed #define too_few_arguments S_too_few_arguments #define too_many_arguments S_too_many_arguments #define looks_like_bool S_looks_like_bool #define newGIVWHENOP S_newGIVWHENOP #define ref_array_or_hash S_ref_array_or_hash #define process_special_blocks S_process_special_blocks #endif #endif #if defined(PL_OP_SLAB_ALLOC) #define Slab_Alloc Perl_Slab_Alloc #define Slab_Free Perl_Slab_Free # if defined(PERL_DEBUG_READONLY_OPS) # if defined(PERL_IN_OP_C) #ifdef PERL_CORE #define Slab_to_rw S_Slab_to_rw #endif # endif # endif #endif #if defined(PERL_IN_PERL_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define find_beginning S_find_beginning #define forbid_setid S_forbid_setid #define incpush S_incpush #define incpush_use_sep S_incpush_use_sep #define init_interp S_init_interp #define init_ids S_init_ids #define init_main_stash S_init_main_stash #define init_perllib S_init_perllib #define init_postdump_symbols S_init_postdump_symbols #define init_predump_symbols S_init_predump_symbols #define my_exit_jump S_my_exit_jump #define nuke_stacks S_nuke_stacks #define open_script S_open_script #define usage S_usage #endif #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW #endif #ifdef PERL_CORE #define parse_body S_parse_body #define run_body S_run_body #define incpush_if_exists S_incpush_if_exists #endif #endif #if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define do_delete_local S_do_delete_local #define refto S_refto #endif #endif #if defined(PERL_IN_PP_C) || defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT) #endif #if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define unpack_rec S_unpack_rec #define pack_rec S_pack_rec #define mul128 S_mul128 #define measure_struct S_measure_struct #define next_symbol S_next_symbol #define is_an_int S_is_an_int #define div128 S_div128 #define group_end S_group_end #define get_num S_get_num #define need_utf8 S_need_utf8 #define first_symbol S_first_symbol #define sv_exp_grow S_sv_exp_grow #define bytes_to_uni S_bytes_to_uni #endif #endif #if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define docatch S_docatch #define dofindlabel S_dofindlabel #define doparseform S_doparseform #define num_overflow S_num_overflow #define dopoptoeval S_dopoptoeval #define dopoptogiven S_dopoptogiven #define dopoptolabel S_dopoptolabel #define dopoptoloop S_dopoptoloop #define dopoptosub_at S_dopoptosub_at #define dopoptowhen S_dopoptowhen #define save_lines S_save_lines #define doeval S_doeval #define check_type_and_open S_check_type_and_open #endif #ifndef PERL_DISABLE_PMC #ifdef PERL_CORE #define doopen_pm S_doopen_pm #endif #endif #ifdef PERL_CORE #define path_is_absolute S_path_is_absolute #define run_user_filter S_run_user_filter #define make_matcher S_make_matcher #define matcher_matches_sv S_matcher_matches_sv #define destroy_matcher S_destroy_matcher #define do_smartmatch S_do_smartmatch #endif #endif #if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define do_oddball S_do_oddball #define method_common S_method_common #endif #endif #if defined(PERL_IN_PP_SORT_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define sv_ncmp S_sv_ncmp #define sv_i_ncmp S_sv_i_ncmp #define amagic_ncmp S_amagic_ncmp #define amagic_i_ncmp S_amagic_i_ncmp #define amagic_cmp S_amagic_cmp #define amagic_cmp_locale S_amagic_cmp_locale #define sortcv S_sortcv #define sortcv_xsub S_sortcv_xsub #define sortcv_stacked S_sortcv_stacked #define qsortsvu S_qsortsvu #endif #endif #if defined(PERL_IN_PP_SYS_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define doform S_doform #endif # if !defined(HAS_MKDIR) || !defined(HAS_RMDIR) #ifdef PERL_CORE #define dooneliner S_dooneliner #endif # endif #ifdef PERL_CORE #define space_join_names_mortal S_space_join_names_mortal #endif #endif #if defined(PERL_IN_REGCOMP_C) || defined(PERL_DECL_PROT) #if defined(PERL_CORE) || defined(PERL_EXT) #define reg S_reg #define reganode S_reganode #define regatom S_regatom #define regbranch S_regbranch #define reguni S_reguni #define regclass S_regclass #define reg_node S_reg_node #define reg_recode S_reg_recode #define regpiece S_regpiece #define reg_namedseq S_reg_namedseq #define reginsert S_reginsert #define regtail S_regtail #define reg_scan_name S_reg_scan_name #define join_exact S_join_exact #define regwhite S_regwhite #define nextchar S_nextchar #define reg_skipcomment S_reg_skipcomment #define scan_commit S_scan_commit #define cl_anything S_cl_anything #define cl_is_anything S_cl_is_anything #define cl_init S_cl_init #define cl_init_zero S_cl_init_zero #define cl_and S_cl_and #define cl_or S_cl_or #define study_chunk S_study_chunk #define add_data S_add_data #endif #ifdef PERL_CORE #define re_croak2 S_re_croak2 #endif #if defined(PERL_CORE) || defined(PERL_EXT) #define regpposixcc S_regpposixcc #define checkposixcc S_checkposixcc #define make_trie S_make_trie #define make_trie_failtable S_make_trie_failtable #endif # ifdef DEBUGGING #if defined(PERL_CORE) || defined(PERL_EXT) #define regdump_extflags S_regdump_extflags #define dumpuntil S_dumpuntil #define put_byte S_put_byte #define dump_trie S_dump_trie #define dump_trie_interim_list S_dump_trie_interim_list #define dump_trie_interim_table S_dump_trie_interim_table #define regtail_study S_regtail_study #endif # endif #endif #if defined(PERL_IN_REGEXEC_C) || defined(PERL_DECL_PROT) #if defined(PERL_CORE) || defined(PERL_EXT) #define regmatch S_regmatch #define regrepeat S_regrepeat #define regtry S_regtry #define reginclass S_reginclass #define regcppush S_regcppush #define regcppop S_regcppop #define reghop3 S_reghop3 #endif #ifdef XXX_dmq #if defined(PERL_CORE) || defined(PERL_EXT) #define reghop4 S_reghop4 #endif #endif #if defined(PERL_CORE) || defined(PERL_EXT) #define reghopmaybe3 S_reghopmaybe3 #define find_byclass S_find_byclass #define to_utf8_substr S_to_utf8_substr #define to_byte_substr S_to_byte_substr #define reg_check_named_buff_matched S_reg_check_named_buff_matched #endif # ifdef DEBUGGING #if defined(PERL_CORE) || defined(PERL_EXT) #define dump_exec_pos S_dump_exec_pos #define debug_start_match S_debug_start_match #endif # endif #endif #if defined(PERL_IN_DUMP_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define deb_curcv S_deb_curcv #define debprof S_debprof #define sequence S_sequence #define sequence_tail S_sequence_tail #define sequence_num S_sequence_num #define pm_description S_pm_description #endif #endif #if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define save_scalar_at S_save_scalar_at #endif #endif #if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT) #endif #if defined(PERL_IN_HV_C) || defined(PERL_IN_MG_C) || defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) #endif #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define uiv_2buf S_uiv_2buf #define sv_unglob S_sv_unglob #define not_a_number S_not_a_number #define visit S_visit #define sv_del_backref S_sv_del_backref #define varname S_varname #endif # ifdef DEBUGGING #ifdef PERL_CORE #define del_sv S_del_sv #endif # endif # if !defined(NV_PRESERVES_UV) # ifdef DEBUGGING #ifdef PERL_CORE #define sv_2iuv_non_preserve S_sv_2iuv_non_preserve #endif # else #ifdef PERL_CORE #define sv_2iuv_non_preserve S_sv_2iuv_non_preserve #endif # endif # endif #ifdef PERL_CORE #define expect_number S_expect_number #endif #ifdef PERL_CORE #define sv_pos_u2b_forwards S_sv_pos_u2b_forwards #define sv_pos_u2b_midway S_sv_pos_u2b_midway #define sv_pos_u2b_cached S_sv_pos_u2b_cached #define utf8_mg_pos_cache_update S_utf8_mg_pos_cache_update #define sv_pos_b2u_midway S_sv_pos_b2u_midway #define F0convert S_F0convert #endif # if defined(PERL_OLD_COPY_ON_WRITE) #ifdef PERL_CORE #define sv_release_COW S_sv_release_COW #endif # endif #ifdef PERL_CORE #define more_sv S_more_sv #define more_bodies S_more_bodies #define sv_2iuv_common S_sv_2iuv_common #define glob_assign_glob S_glob_assign_glob #define glob_assign_ref S_glob_assign_ref #define ptr_table_find S_ptr_table_find #endif #endif #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define check_uni S_check_uni #define force_next S_force_next #define force_version S_force_version #define force_strict_version S_force_strict_version #define force_word S_force_word #define tokeq S_tokeq #define readpipe_override S_readpipe_override #define scan_const S_scan_const #define scan_formline S_scan_formline #define scan_heredoc S_scan_heredoc #define scan_ident S_scan_ident #define scan_inputsymbol S_scan_inputsymbol #define scan_pat S_scan_pat #define scan_str S_scan_str #define scan_subst S_scan_subst #define scan_trans S_scan_trans #define scan_word S_scan_word #define update_debugger_info S_update_debugger_info #define skipspace S_skipspace #define swallow_bom S_swallow_bom #endif #ifndef PERL_NO_UTF16_FILTER #ifdef PERL_CORE #define utf16_textfilter S_utf16_textfilter #define add_utf16_textfilter S_add_utf16_textfilter #endif #endif #ifdef PERL_CORE #define checkcomma S_checkcomma #define feature_is_enabled S_feature_is_enabled #define force_ident S_force_ident #define incline S_incline #define intuit_method S_intuit_method #define intuit_more S_intuit_more #define lop S_lop #define missingterm S_missingterm #define no_op S_no_op #define sublex_done S_sublex_done #define sublex_push S_sublex_push #define sublex_start S_sublex_start #define filter_gets S_filter_gets #define find_in_my_stash S_find_in_my_stash #define tokenize_use S_tokenize_use #endif #ifdef PERL_CORE #define deprecate_commaless_var_list S_deprecate_commaless_var_list #define ao S_ao #endif # if defined(PERL_CR_FILTER) #ifdef PERL_CORE #define cr_textfilter S_cr_textfilter #define strip_return S_strip_return #endif # endif # if defined(DEBUGGING) #ifdef PERL_CORE #define tokereport S_tokereport #define printbuf S_printbuf #endif # endif #endif #if defined(PERL_IN_UNIVERSAL_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define isa_lookup S_isa_lookup #endif #endif #if defined(PERL_IN_LOCALE_C) || defined(PERL_DECL_PROT) #if defined(USE_LOCALE_NUMERIC) || defined(USE_LOCALE_COLLATE) #ifdef PERL_CORE #define stdize_locale S_stdize_locale #endif #endif #endif #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define closest_cop S_closest_cop #define mess_alloc S_mess_alloc #define vdie_croak_common S_vdie_croak_common #define vdie_common S_vdie_common #define write_no_mem S_write_no_mem #endif #if defined(PERL_MEM_LOG) && !defined(PERL_MEM_LOG_NOIMPL) #ifdef PERL_CORE #define mem_log_common S_mem_log_common #endif #endif #endif #if defined(PERL_IN_NUMERIC_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define mulexp10 S_mulexp10 #endif #endif #if defined(PERL_IN_UTF8_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define is_utf8_char_slow S_is_utf8_char_slow #define is_utf8_common S_is_utf8_common #define swash_get S_swash_get #endif #endif #define sv_setsv_flags Perl_sv_setsv_flags #define sv_catpvn_flags Perl_sv_catpvn_flags #define sv_catsv_flags Perl_sv_catsv_flags #define sv_utf8_upgrade_flags_grow Perl_sv_utf8_upgrade_flags_grow #define sv_pvn_force_flags Perl_sv_pvn_force_flags #define sv_copypv Perl_sv_copypv #define my_atof2 Perl_my_atof2 #define my_socketpair Perl_my_socketpair #define my_dirfd Perl_my_dirfd #ifdef PERL_OLD_COPY_ON_WRITE #if defined(PERL_CORE) || defined(PERL_EXT) #define sv_setsv_cow Perl_sv_setsv_cow #endif #endif #if defined(USE_PERLIO) && !defined(USE_SFIO) #define PerlIO_close Perl_PerlIO_close #define PerlIO_fill Perl_PerlIO_fill #define PerlIO_fileno Perl_PerlIO_fileno #define PerlIO_eof Perl_PerlIO_eof #define PerlIO_error Perl_PerlIO_error #define PerlIO_flush Perl_PerlIO_flush #define PerlIO_clearerr Perl_PerlIO_clearerr #define PerlIO_set_cnt Perl_PerlIO_set_cnt #define PerlIO_set_ptrcnt Perl_PerlIO_set_ptrcnt #define PerlIO_setlinebuf Perl_PerlIO_setlinebuf #define PerlIO_read Perl_PerlIO_read #define PerlIO_write Perl_PerlIO_write #define PerlIO_unread Perl_PerlIO_unread #define PerlIO_tell Perl_PerlIO_tell #define PerlIO_seek Perl_PerlIO_seek #define PerlIO_get_base Perl_PerlIO_get_base #define PerlIO_get_ptr Perl_PerlIO_get_ptr #define PerlIO_get_bufsiz Perl_PerlIO_get_bufsiz #define PerlIO_get_cnt Perl_PerlIO_get_cnt #define PerlIO_stdin Perl_PerlIO_stdin #define PerlIO_stdout Perl_PerlIO_stdout #define PerlIO_stderr Perl_PerlIO_stderr #endif /* PERLIO_LAYERS */ #ifdef PERL_CORE #define deb_stack_all Perl_deb_stack_all #endif #if defined(PERL_IN_DEB_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define deb_stack_n S_deb_stack_n #endif #endif #ifdef PERL_CORE #define pad_new Perl_pad_new #define pad_undef Perl_pad_undef #define pad_add_name Perl_pad_add_name #define pad_add_anon Perl_pad_add_anon #endif #if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define pad_check_dup S_pad_check_dup #endif #endif #ifdef DEBUGGING #ifdef PERL_CORE #define pad_setsv Perl_pad_setsv #endif #endif #ifdef PERL_CORE #define pad_block_start Perl_pad_block_start #define pad_tidy Perl_pad_tidy #define do_dump_pad Perl_do_dump_pad #define pad_fixup_inner_anons Perl_pad_fixup_inner_anons #endif #ifdef PERL_CORE #define pad_push Perl_pad_push #define pad_compname_type Perl_pad_compname_type #endif #if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define pad_findlex S_pad_findlex #define pad_add_name_sv S_pad_add_name_sv #endif # if defined(DEBUGGING) #ifdef PERL_CORE #define cv_dump S_cv_dump #endif # endif #endif #define find_runcv Perl_find_runcv #ifdef PERL_CORE #define free_tied_hv_pool Perl_free_tied_hv_pool #endif #if defined(DEBUGGING) #ifdef PERL_CORE #define get_debug_opts Perl_get_debug_opts #endif #endif #define save_set_svflags Perl_save_set_svflags #ifdef DEBUGGING #endif #define hv_scalar Perl_hv_scalar #define hv_name_set Perl_hv_name_set #if defined(PERL_IN_DUMP_C) || defined(PERL_IN_HV_C) || defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) #endif #define hv_clear_placeholders Perl_hv_clear_placeholders #ifdef PERL_CORE #define magic_scalarpack Perl_magic_scalarpack #endif #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define find_hash_subscript S_find_hash_subscript #define find_array_subscript S_find_array_subscript #define find_uninit_var S_find_uninit_var #endif #endif #ifdef PERL_NEED_MY_HTOLE16 #ifdef PERL_CORE #define my_htole16 Perl_my_htole16 #endif #endif #ifdef PERL_NEED_MY_LETOH16 #ifdef PERL_CORE #define my_letoh16 Perl_my_letoh16 #endif #endif #ifdef PERL_NEED_MY_HTOBE16 #ifdef PERL_CORE #define my_htobe16 Perl_my_htobe16 #endif #endif #ifdef PERL_NEED_MY_BETOH16 #ifdef PERL_CORE #define my_betoh16 Perl_my_betoh16 #endif #endif #ifdef PERL_NEED_MY_HTOLE32 #ifdef PERL_CORE #define my_htole32 Perl_my_htole32 #endif #endif #ifdef PERL_NEED_MY_LETOH32 #ifdef PERL_CORE #define my_letoh32 Perl_my_letoh32 #endif #endif #ifdef PERL_NEED_MY_HTOBE32 #ifdef PERL_CORE #define my_htobe32 Perl_my_htobe32 #endif #endif #ifdef PERL_NEED_MY_BETOH32 #ifdef PERL_CORE #define my_betoh32 Perl_my_betoh32 #endif #endif #ifdef PERL_NEED_MY_HTOLE64 #ifdef PERL_CORE #define my_htole64 Perl_my_htole64 #endif #endif #ifdef PERL_NEED_MY_LETOH64 #ifdef PERL_CORE #define my_letoh64 Perl_my_letoh64 #endif #endif #ifdef PERL_NEED_MY_HTOBE64 #ifdef PERL_CORE #define my_htobe64 Perl_my_htobe64 #endif #endif #ifdef PERL_NEED_MY_BETOH64 #ifdef PERL_CORE #define my_betoh64 Perl_my_betoh64 #endif #endif #ifdef PERL_NEED_MY_HTOLES #ifdef PERL_CORE #define my_htoles Perl_my_htoles #endif #endif #ifdef PERL_NEED_MY_LETOHS #ifdef PERL_CORE #define my_letohs Perl_my_letohs #endif #endif #ifdef PERL_NEED_MY_HTOBES #ifdef PERL_CORE #define my_htobes Perl_my_htobes #endif #endif #ifdef PERL_NEED_MY_BETOHS #ifdef PERL_CORE #define my_betohs Perl_my_betohs #endif #endif #ifdef PERL_NEED_MY_HTOLEI #ifdef PERL_CORE #define my_htolei Perl_my_htolei #endif #endif #ifdef PERL_NEED_MY_LETOHI #ifdef PERL_CORE #define my_letohi Perl_my_letohi #endif #endif #ifdef PERL_NEED_MY_HTOBEI #ifdef PERL_CORE #define my_htobei Perl_my_htobei #endif #endif #ifdef PERL_NEED_MY_BETOHI #ifdef PERL_CORE #define my_betohi Perl_my_betohi #endif #endif #ifdef PERL_NEED_MY_HTOLEL #ifdef PERL_CORE #define my_htolel Perl_my_htolel #endif #endif #ifdef PERL_NEED_MY_LETOHL #ifdef PERL_CORE #define my_letohl Perl_my_letohl #endif #endif #ifdef PERL_NEED_MY_HTOBEL #ifdef PERL_CORE #define my_htobel Perl_my_htobel #endif #endif #ifdef PERL_NEED_MY_BETOHL #ifdef PERL_CORE #define my_betohl Perl_my_betohl #endif #endif #ifdef PERL_CORE #define my_swabn Perl_my_swabn #endif #define gv_fetchpvn_flags Perl_gv_fetchpvn_flags #define gv_fetchsv Perl_gv_fetchsv #ifdef PERL_CORE #define is_gv_magical_sv Perl_is_gv_magical_sv #endif #define stashpv_hvname_match Perl_stashpv_hvname_match #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP #ifdef PERL_CORE #define dump_sv_child Perl_dump_sv_child #endif #endif #ifdef PERL_DONT_CREATE_GVSV #endif #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define ckwarn_common S_ckwarn_common #endif #endif #ifdef PERL_CORE #define offer_nice_chunk Perl_offer_nice_chunk #endif #ifndef SPRINTF_RETURNS_STRLEN #endif #ifdef PERL_CORE #define my_clearenv Perl_my_clearenv #endif #ifdef PERL_IMPLICIT_CONTEXT #ifdef PERL_GLOBAL_STRUCT_PRIVATE #else #endif #endif #ifndef HAS_STRLCAT #endif #ifndef HAS_STRLCPY #endif #ifdef PERL_MAD #ifdef PERL_CORE #define pad_peg Perl_pad_peg #endif #if defined(PERL_IN_DUMP_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define xmldump_attr S_xmldump_attr #endif #endif #ifdef PERL_CORE #define xmldump_indent Perl_xmldump_indent #define xmldump_vindent Perl_xmldump_vindent #define xmldump_all Perl_xmldump_all #define xmldump_all_perl Perl_xmldump_all_perl #define xmldump_packsubs Perl_xmldump_packsubs #define xmldump_packsubs_perl Perl_xmldump_packsubs_perl #define xmldump_sub Perl_xmldump_sub #define xmldump_sub_perl Perl_xmldump_sub_perl #define xmldump_form Perl_xmldump_form #define xmldump_eval Perl_xmldump_eval #define sv_catxmlsv Perl_sv_catxmlsv #define sv_catxmlpvn Perl_sv_catxmlpvn #define sv_xmlpeek Perl_sv_xmlpeek #define do_pmop_xmldump Perl_do_pmop_xmldump #define pmop_xmldump Perl_pmop_xmldump #define do_op_xmldump Perl_do_op_xmldump #define op_xmldump Perl_op_xmldump #endif #ifdef PERL_CORE #define newTOKEN Perl_newTOKEN #define token_free Perl_token_free #define token_getmad Perl_token_getmad #define op_getmad_weak Perl_op_getmad_weak #define op_getmad Perl_op_getmad #define prepend_madprops Perl_prepend_madprops #define append_madprops Perl_append_madprops #define addmad Perl_addmad #define newMADsv Perl_newMADsv #define newMADPROP Perl_newMADPROP #define mad_free Perl_mad_free #endif # if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define skipspace0 S_skipspace0 #define skipspace1 S_skipspace1 #define skipspace2 S_skipspace2 #define start_force S_start_force #define curmad S_curmad #endif # endif #ifdef PERL_CORE #define madlex Perl_madlex #define madparse Perl_madparse #endif #endif #if !defined(HAS_SIGNBIT) #endif #if defined(USE_ITHREADS) #ifdef PERL_CORE #define mro_meta_dup Perl_mro_meta_dup #endif #endif #define mro_get_linear_isa Perl_mro_get_linear_isa #if defined(PERL_IN_MRO_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define mro_get_linear_isa_dfs S_mro_get_linear_isa_dfs #endif #endif #ifdef PERL_CORE #define mro_isa_changed_in Perl_mro_isa_changed_in #endif #define mro_method_changed_in Perl_mro_method_changed_in #ifdef PERL_CORE #define boot_core_mro Perl_boot_core_mro #endif #define ck_anoncode Perl_ck_anoncode #define ck_bitop Perl_ck_bitop #define ck_chdir Perl_ck_chdir #define ck_concat Perl_ck_concat #define ck_defined Perl_ck_defined #define ck_delete Perl_ck_delete #define ck_die Perl_ck_die #define ck_each Perl_ck_each #define ck_eof Perl_ck_eof #define ck_eval Perl_ck_eval #define ck_exec Perl_ck_exec #define ck_exists Perl_ck_exists #define ck_exit Perl_ck_exit #define ck_ftst Perl_ck_ftst #define ck_fun Perl_ck_fun #define ck_glob Perl_ck_glob #define ck_grep Perl_ck_grep #define ck_index Perl_ck_index #define ck_join Perl_ck_join #define ck_lfun Perl_ck_lfun #define ck_listiob Perl_ck_listiob #define ck_match Perl_ck_match #define ck_method Perl_ck_method #define ck_null Perl_ck_null #define ck_open Perl_ck_open #define ck_readline Perl_ck_readline #define ck_repeat Perl_ck_repeat #define ck_require Perl_ck_require #define ck_return Perl_ck_return #define ck_rfun Perl_ck_rfun #define ck_rvconst Perl_ck_rvconst #define ck_sassign Perl_ck_sassign #define ck_select Perl_ck_select #define ck_shift Perl_ck_shift #define ck_smartmatch Perl_ck_smartmatch #define ck_sort Perl_ck_sort #define ck_spair Perl_ck_spair #define ck_split Perl_ck_split #define ck_subr Perl_ck_subr #define ck_substr Perl_ck_substr #define ck_svconst Perl_ck_svconst #define ck_trunc Perl_ck_trunc #define ck_unpack Perl_ck_unpack #define pp_aassign Perl_pp_aassign #define pp_abs Perl_pp_abs #define pp_accept Perl_pp_accept #define pp_add Perl_pp_add #define pp_aeach Perl_pp_aeach #define pp_aelem Perl_pp_aelem #define pp_aelemfast Perl_pp_aelemfast #define pp_akeys Perl_pp_akeys #define pp_alarm Perl_pp_alarm #define pp_and Perl_pp_and #define pp_andassign Perl_pp_andassign #define pp_anoncode Perl_pp_anoncode #define pp_anonhash Perl_pp_anonhash #define pp_anonlist Perl_pp_anonlist #define pp_aslice Perl_pp_aslice #define pp_atan2 Perl_pp_atan2 #define pp_av2arylen Perl_pp_av2arylen #define pp_avalues Perl_pp_avalues #define pp_backtick Perl_pp_backtick #define pp_bind Perl_pp_bind #define pp_binmode Perl_pp_binmode #define pp_bit_and Perl_pp_bit_and #define pp_bit_or Perl_pp_bit_or #define pp_bit_xor Perl_pp_bit_xor #define pp_bless Perl_pp_bless #define pp_boolkeys Perl_pp_boolkeys #define pp_break Perl_pp_break #define pp_caller Perl_pp_caller #define pp_chdir Perl_pp_chdir #define pp_chmod Perl_pp_chmod #define pp_chomp Perl_pp_chomp #define pp_chop Perl_pp_chop #define pp_chown Perl_pp_chown #define pp_chr Perl_pp_chr #define pp_chroot Perl_pp_chroot #define pp_close Perl_pp_close #define pp_closedir Perl_pp_closedir #define pp_complement Perl_pp_complement #define pp_concat Perl_pp_concat #define pp_cond_expr Perl_pp_cond_expr #define pp_connect Perl_pp_connect #define pp_const Perl_pp_const #define pp_continue Perl_pp_continue #define pp_cos Perl_pp_cos #define pp_crypt Perl_pp_crypt #define pp_dbmclose Perl_pp_dbmclose #define pp_dbmopen Perl_pp_dbmopen #define pp_dbstate Perl_pp_dbstate #define pp_defined Perl_pp_defined #define pp_delete Perl_pp_delete #define pp_die Perl_pp_die #define pp_divide Perl_pp_divide #define pp_dofile Perl_pp_dofile #define pp_dor Perl_pp_dor #define pp_dorassign Perl_pp_dorassign #define pp_dump Perl_pp_dump #define pp_each Perl_pp_each #define pp_egrent Perl_pp_egrent #define pp_ehostent Perl_pp_ehostent #define pp_enetent Perl_pp_enetent #define pp_enter Perl_pp_enter #define pp_entereval Perl_pp_entereval #define pp_entergiven Perl_pp_entergiven #define pp_enteriter Perl_pp_enteriter #define pp_enterloop Perl_pp_enterloop #define pp_entersub Perl_pp_entersub #define pp_entertry Perl_pp_entertry #define pp_enterwhen Perl_pp_enterwhen #define pp_enterwrite Perl_pp_enterwrite #define pp_eof Perl_pp_eof #define pp_eprotoent Perl_pp_eprotoent #define pp_epwent Perl_pp_epwent #define pp_eq Perl_pp_eq #define pp_eservent Perl_pp_eservent #define pp_exec Perl_pp_exec #define pp_exists Perl_pp_exists #define pp_exit Perl_pp_exit #define pp_exp Perl_pp_exp #define pp_fcntl Perl_pp_fcntl #define pp_fileno Perl_pp_fileno #define pp_flip Perl_pp_flip #define pp_flock Perl_pp_flock #define pp_flop Perl_pp_flop #define pp_fork Perl_pp_fork #define pp_formline Perl_pp_formline #define pp_ftatime Perl_pp_ftatime #define pp_ftbinary Perl_pp_ftbinary #define pp_ftblk Perl_pp_ftblk #define pp_ftchr Perl_pp_ftchr #define pp_ftctime Perl_pp_ftctime #define pp_ftdir Perl_pp_ftdir #define pp_fteexec Perl_pp_fteexec #define pp_fteowned Perl_pp_fteowned #define pp_fteread Perl_pp_fteread #define pp_ftewrite Perl_pp_ftewrite #define pp_ftfile Perl_pp_ftfile #define pp_ftis Perl_pp_ftis #define pp_ftlink Perl_pp_ftlink #define pp_ftmtime Perl_pp_ftmtime #define pp_ftpipe Perl_pp_ftpipe #define pp_ftrexec Perl_pp_ftrexec #define pp_ftrowned Perl_pp_ftrowned #define pp_ftrread Perl_pp_ftrread #define pp_ftrwrite Perl_pp_ftrwrite #define pp_ftsgid Perl_pp_ftsgid #define pp_ftsize Perl_pp_ftsize #define pp_ftsock Perl_pp_ftsock #define pp_ftsuid Perl_pp_ftsuid #define pp_ftsvtx Perl_pp_ftsvtx #define pp_fttext Perl_pp_fttext #define pp_fttty Perl_pp_fttty #define pp_ftzero Perl_pp_ftzero #define pp_ge Perl_pp_ge #define pp_gelem Perl_pp_gelem #define pp_getc Perl_pp_getc #define pp_getlogin Perl_pp_getlogin #define pp_getpeername Perl_pp_getpeername #define pp_getpgrp Perl_pp_getpgrp #define pp_getppid Perl_pp_getppid #define pp_getpriority Perl_pp_getpriority #define pp_getsockname Perl_pp_getsockname #define pp_ggrent Perl_pp_ggrent #define pp_ggrgid Perl_pp_ggrgid #define pp_ggrnam Perl_pp_ggrnam #define pp_ghbyaddr Perl_pp_ghbyaddr #define pp_ghbyname Perl_pp_ghbyname #define pp_ghostent Perl_pp_ghostent #define pp_glob Perl_pp_glob #define pp_gmtime Perl_pp_gmtime #define pp_gnbyaddr Perl_pp_gnbyaddr #define pp_gnbyname Perl_pp_gnbyname #define pp_gnetent Perl_pp_gnetent #define pp_goto Perl_pp_goto #define pp_gpbyname Perl_pp_gpbyname #define pp_gpbynumber Perl_pp_gpbynumber #define pp_gprotoent Perl_pp_gprotoent #define pp_gpwent Perl_pp_gpwent #define pp_gpwnam Perl_pp_gpwnam #define pp_gpwuid Perl_pp_gpwuid #define pp_grepstart Perl_pp_grepstart #define pp_grepwhile Perl_pp_grepwhile #define pp_gsbyname Perl_pp_gsbyname #define pp_gsbyport Perl_pp_gsbyport #define pp_gservent Perl_pp_gservent #define pp_gsockopt Perl_pp_gsockopt #define pp_gt Perl_pp_gt #define pp_gv Perl_pp_gv #define pp_gvsv Perl_pp_gvsv #define pp_helem Perl_pp_helem #define pp_hex Perl_pp_hex #define pp_hintseval Perl_pp_hintseval #define pp_hslice Perl_pp_hslice #define pp_i_add Perl_pp_i_add #define pp_i_divide Perl_pp_i_divide #define pp_i_eq Perl_pp_i_eq #define pp_i_ge Perl_pp_i_ge #define pp_i_gt Perl_pp_i_gt #define pp_i_le Perl_pp_i_le #define pp_i_lt Perl_pp_i_lt #define pp_i_modulo Perl_pp_i_modulo #define pp_i_multiply Perl_pp_i_multiply #define pp_i_ncmp Perl_pp_i_ncmp #define pp_i_ne Perl_pp_i_ne #define pp_i_negate Perl_pp_i_negate #define pp_i_subtract Perl_pp_i_subtract #define pp_index Perl_pp_index #define pp_int Perl_pp_int #define pp_ioctl Perl_pp_ioctl #define pp_iter Perl_pp_iter #define pp_join Perl_pp_join #define pp_keys Perl_pp_keys #define pp_kill Perl_pp_kill #define pp_last Perl_pp_last #define pp_lc Perl_pp_lc #define pp_lcfirst Perl_pp_lcfirst #define pp_le Perl_pp_le #define pp_leave Perl_pp_leave #define pp_leaveeval Perl_pp_leaveeval #define pp_leavegiven Perl_pp_leavegiven #define pp_leaveloop Perl_pp_leaveloop #define pp_leavesub Perl_pp_leavesub #define pp_leavesublv Perl_pp_leavesublv #define pp_leavetry Perl_pp_leavetry #define pp_leavewhen Perl_pp_leavewhen #define pp_leavewrite Perl_pp_leavewrite #define pp_left_shift Perl_pp_left_shift #define pp_length Perl_pp_length #define pp_lineseq Perl_pp_lineseq #define pp_link Perl_pp_link #define pp_list Perl_pp_list #define pp_listen Perl_pp_listen #define pp_localtime Perl_pp_localtime #define pp_lock Perl_pp_lock #define pp_log Perl_pp_log #define pp_lslice Perl_pp_lslice #define pp_lstat Perl_pp_lstat #define pp_lt Perl_pp_lt #define pp_mapstart Perl_pp_mapstart #define pp_mapwhile Perl_pp_mapwhile #define pp_match Perl_pp_match #define pp_method Perl_pp_method #define pp_method_named Perl_pp_method_named #define pp_mkdir Perl_pp_mkdir #define pp_modulo Perl_pp_modulo #define pp_msgctl Perl_pp_msgctl #define pp_msgget Perl_pp_msgget #define pp_msgrcv Perl_pp_msgrcv #define pp_msgsnd Perl_pp_msgsnd #define pp_multiply Perl_pp_multiply #define pp_ncmp Perl_pp_ncmp #define pp_ne Perl_pp_ne #define pp_negate Perl_pp_negate #define pp_next Perl_pp_next #define pp_nextstate Perl_pp_nextstate #define pp_not Perl_pp_not #define pp_null Perl_pp_null #define pp_oct Perl_pp_oct #define pp_once Perl_pp_once #define pp_open Perl_pp_open #define pp_open_dir Perl_pp_open_dir #define pp_or Perl_pp_or #define pp_orassign Perl_pp_orassign #define pp_ord Perl_pp_ord #define pp_pack Perl_pp_pack #define pp_padany Perl_pp_padany #define pp_padav Perl_pp_padav #define pp_padhv Perl_pp_padhv #define pp_padsv Perl_pp_padsv #define pp_pipe_op Perl_pp_pipe_op #define pp_pop Perl_pp_pop #define pp_pos Perl_pp_pos #define pp_postdec Perl_pp_postdec #define pp_postinc Perl_pp_postinc #define pp_pow Perl_pp_pow #define pp_predec Perl_pp_predec #define pp_preinc Perl_pp_preinc #define pp_print Perl_pp_print #define pp_prototype Perl_pp_prototype #define pp_prtf Perl_pp_prtf #define pp_push Perl_pp_push #define pp_pushmark Perl_pp_pushmark #define pp_pushre Perl_pp_pushre #define pp_qr Perl_pp_qr #define pp_quotemeta Perl_pp_quotemeta #define pp_rand Perl_pp_rand #define pp_range Perl_pp_range #define pp_rcatline Perl_pp_rcatline #define pp_read Perl_pp_read #define pp_readdir Perl_pp_readdir #define pp_readline Perl_pp_readline #define pp_readlink Perl_pp_readlink #define pp_recv Perl_pp_recv #define pp_redo Perl_pp_redo #define pp_ref Perl_pp_ref #define pp_refgen Perl_pp_refgen #define pp_regcmaybe Perl_pp_regcmaybe #define pp_regcomp Perl_pp_regcomp #define pp_regcreset Perl_pp_regcreset #define pp_rename Perl_pp_rename #define pp_repeat Perl_pp_repeat #define pp_require Perl_pp_require #define pp_reset Perl_pp_reset #define pp_return Perl_pp_return #define pp_reverse Perl_pp_reverse #define pp_rewinddir Perl_pp_rewinddir #define pp_right_shift Perl_pp_right_shift #define pp_rindex Perl_pp_rindex #define pp_rmdir Perl_pp_rmdir #define pp_rv2av Perl_pp_rv2av #define pp_rv2cv Perl_pp_rv2cv #define pp_rv2gv Perl_pp_rv2gv #define pp_rv2hv Perl_pp_rv2hv #define pp_rv2sv Perl_pp_rv2sv #define pp_sassign Perl_pp_sassign #define pp_say Perl_pp_say #define pp_scalar Perl_pp_scalar #define pp_schomp Perl_pp_schomp #define pp_schop Perl_pp_schop #define pp_scmp Perl_pp_scmp #define pp_scope Perl_pp_scope #define pp_seek Perl_pp_seek #define pp_seekdir Perl_pp_seekdir #define pp_select Perl_pp_select #define pp_semctl Perl_pp_semctl #define pp_semget Perl_pp_semget #define pp_semop Perl_pp_semop #define pp_send Perl_pp_send #define pp_seq Perl_pp_seq #define pp_setpgrp Perl_pp_setpgrp #define pp_setpriority Perl_pp_setpriority #define pp_sge Perl_pp_sge #define pp_sgrent Perl_pp_sgrent #define pp_sgt Perl_pp_sgt #define pp_shift Perl_pp_shift #define pp_shmctl Perl_pp_shmctl #define pp_shmget Perl_pp_shmget #define pp_shmread Perl_pp_shmread #define pp_shmwrite Perl_pp_shmwrite #define pp_shostent Perl_pp_shostent #define pp_shutdown Perl_pp_shutdown #define pp_sin Perl_pp_sin #define pp_sle Perl_pp_sle #define pp_sleep Perl_pp_sleep #define pp_slt Perl_pp_slt #define pp_smartmatch Perl_pp_smartmatch #define pp_sne Perl_pp_sne #define pp_snetent Perl_pp_snetent #define pp_socket Perl_pp_socket #define pp_sockpair Perl_pp_sockpair #define pp_sort Perl_pp_sort #define pp_splice Perl_pp_splice #define pp_split Perl_pp_split #define pp_sprintf Perl_pp_sprintf #define pp_sprotoent Perl_pp_sprotoent #define pp_spwent Perl_pp_spwent #define pp_sqrt Perl_pp_sqrt #define pp_srand Perl_pp_srand #define pp_srefgen Perl_pp_srefgen #define pp_sselect Perl_pp_sselect #define pp_sservent Perl_pp_sservent #define pp_ssockopt Perl_pp_ssockopt #define pp_stat Perl_pp_stat #define pp_stringify Perl_pp_stringify #define pp_stub Perl_pp_stub #define pp_study Perl_pp_study #define pp_subst Perl_pp_subst #define pp_substcont Perl_pp_substcont #define pp_substr Perl_pp_substr #define pp_subtract Perl_pp_subtract #define pp_symlink Perl_pp_symlink #define pp_syscall Perl_pp_syscall #define pp_sysopen Perl_pp_sysopen #define pp_sysread Perl_pp_sysread #define pp_sysseek Perl_pp_sysseek #define pp_system Perl_pp_system #define pp_syswrite Perl_pp_syswrite #define pp_tell Perl_pp_tell #define pp_telldir Perl_pp_telldir #define pp_tie Perl_pp_tie #define pp_tied Perl_pp_tied #define pp_time Perl_pp_time #define pp_tms Perl_pp_tms #define pp_trans Perl_pp_trans #define pp_truncate Perl_pp_truncate #define pp_uc Perl_pp_uc #define pp_ucfirst Perl_pp_ucfirst #define pp_umask Perl_pp_umask #define pp_undef Perl_pp_undef #define pp_unlink Perl_pp_unlink #define pp_unpack Perl_pp_unpack #define pp_unshift Perl_pp_unshift #define pp_unstack Perl_pp_unstack #define pp_untie Perl_pp_untie #define pp_utime Perl_pp_utime #define pp_values Perl_pp_values #define pp_vec Perl_pp_vec #define pp_wait Perl_pp_wait #define pp_waitpid Perl_pp_waitpid #define pp_wantarray Perl_pp_wantarray #define pp_warn Perl_pp_warn #define pp_xor Perl_pp_xor #else /* PERL_IMPLICIT_CONTEXT */ #if defined(PERL_IMPLICIT_SYS) #endif #define doing_taint Perl_doing_taint #if defined(USE_ITHREADS) # if defined(PERL_IMPLICIT_SYS) # endif #endif #if defined(MYMALLOC) #ifdef PERL_CORE #define malloced_size Perl_malloced_size #define malloc_good_size Perl_malloc_good_size #endif #endif #define get_context Perl_get_context #define set_context Perl_set_context #if defined(PERL_CORE) || defined(PERL_EXT) #define regcurly Perl_regcurly #endif #define amagic_call(a,b,c,d) Perl_amagic_call(aTHX_ a,b,c,d) #define Gv_AMupdate(a,b) Perl_Gv_AMupdate(aTHX_ a,b) #define gv_handler(a,b) Perl_gv_handler(aTHX_ a,b) #ifdef PERL_CORE #define append_elem(a,b,c) Perl_append_elem(aTHX_ a,b,c) #define append_list(a,b,c) Perl_append_list(aTHX_ a,b,c) #define apply(a,b,c) Perl_apply(aTHX_ a,b,c) #endif #define apply_attrs_string(a,b,c,d) Perl_apply_attrs_string(aTHX_ a,b,c,d) #define av_clear(a) Perl_av_clear(aTHX_ a) #define av_delete(a,b,c) Perl_av_delete(aTHX_ a,b,c) #define av_exists(a,b) Perl_av_exists(aTHX_ a,b) #define av_extend(a,b) Perl_av_extend(aTHX_ a,b) #define av_fetch(a,b,c) Perl_av_fetch(aTHX_ a,b,c) #define av_fill(a,b) Perl_av_fill(aTHX_ a,b) #define av_len(a) Perl_av_len(aTHX_ a) #define av_make(a,b) Perl_av_make(aTHX_ a,b) #define av_pop(a) Perl_av_pop(aTHX_ a) #define av_push(a,b) Perl_av_push(aTHX_ a,b) #if defined(PERL_CORE) || defined(PERL_EXT) #define av_reify(a) Perl_av_reify(aTHX_ a) #endif #define av_shift(a) Perl_av_shift(aTHX_ a) #define av_store(a,b,c) Perl_av_store(aTHX_ a,b,c) #define av_undef(a) Perl_av_undef(aTHX_ a) #define av_unshift(a,b) Perl_av_unshift(aTHX_ a,b) #if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define get_aux_mg(a) S_get_aux_mg(aTHX_ a) #endif #endif #ifdef PERL_CORE #define bind_match(a,b,c) Perl_bind_match(aTHX_ a,b,c) #define block_end(a,b) Perl_block_end(aTHX_ a,b) #endif #define block_gimme() Perl_block_gimme(aTHX) #ifdef PERL_CORE #define block_start(a) Perl_block_start(aTHX_ a) #define boot_core_UNIVERSAL() Perl_boot_core_UNIVERSAL(aTHX) #define boot_core_PerlIO() Perl_boot_core_PerlIO(aTHX) #endif #define call_list(a,b) Perl_call_list(aTHX_ a,b) #ifdef PERL_CORE #define cando(a,b,c) Perl_cando(aTHX_ a,b,c) #endif #define cast_ulong(a) Perl_cast_ulong(aTHX_ a) #define cast_i32(a) Perl_cast_i32(aTHX_ a) #define cast_iv(a) Perl_cast_iv(aTHX_ a) #define cast_uv(a) Perl_cast_uv(aTHX_ a) #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP) #define my_chsize(a,b) Perl_my_chsize(aTHX_ a,b) #endif #ifdef PERL_CORE #define convert(a,b,c) Perl_convert(aTHX_ a,b,c) #define create_eval_scope(a) Perl_create_eval_scope(aTHX_ a) #endif #define vcroak(a,b) Perl_vcroak(aTHX_ a,b) #define croak_xs_usage(a,b) Perl_croak_xs_usage(aTHX_ a,b) #if defined(PERL_IMPLICIT_CONTEXT) #endif #ifdef PERL_CORE #define cv_ckproto_len(a,b,c,d) Perl_cv_ckproto_len(aTHX_ a,b,c,d) #define cv_clone(a) Perl_cv_clone(aTHX_ a) #endif #define gv_const_sv(a) Perl_gv_const_sv(aTHX_ a) #define cv_const_sv(a) Perl_cv_const_sv(aTHX_ a) #ifdef PERL_CORE #define op_const_sv(a,b) Perl_op_const_sv(aTHX_ a,b) #endif #define cv_undef(a) Perl_cv_undef(aTHX_ a) #define cx_dump(a) Perl_cx_dump(aTHX_ a) #define filter_add(a,b) Perl_filter_add(aTHX_ a,b) #define filter_del(a) Perl_filter_del(aTHX_ a) #define filter_read(a,b,c) Perl_filter_read(aTHX_ a,b,c) #define get_op_descs() Perl_get_op_descs(aTHX) #define get_op_names() Perl_get_op_names(aTHX) #ifdef PERL_CORE #define get_no_modify() Perl_get_no_modify(aTHX) #define get_opargs() Perl_get_opargs(aTHX) #endif #define get_ppaddr() Perl_get_ppaddr(aTHX) #define cxinc() Perl_cxinc(aTHX) #define vdeb(a,b) Perl_vdeb(aTHX_ a,b) #define debprofdump() Perl_debprofdump(aTHX) #define debop(a) Perl_debop(aTHX_ a) #define debstack() Perl_debstack(aTHX) #define debstackptrs() Perl_debstackptrs(aTHX) #define delimcpy Perl_delimcpy #ifdef PERL_CORE #define delete_eval_scope() Perl_delete_eval_scope(aTHX) #endif #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define vdie(a,b) S_vdie(aTHX_ a,b) #endif #endif #ifdef PERL_CORE #define die_where(a) Perl_die_where(aTHX_ a) #endif #define dounwind(a) Perl_dounwind(aTHX_ a) #ifdef PERL_CORE #define do_aexec5(a,b,c,d,e) Perl_do_aexec5(aTHX_ a,b,c,d,e) #endif #define do_binmode(a,b,c) Perl_do_binmode(aTHX_ a,b,c) #ifdef PERL_CORE #define do_chop(a,b) Perl_do_chop(aTHX_ a,b) #endif #define do_close(a,b) Perl_do_close(aTHX_ a,b) #ifdef PERL_CORE #define do_eof(a) Perl_do_eof(aTHX_ a) #endif #ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION #ifdef PERL_CORE #endif #else #ifdef PERL_CORE #define do_exec(a) Perl_do_exec(aTHX_ a) #endif #endif #if defined(WIN32) || defined(__SYMBIAN32__) || defined(VMS) #define do_aspawn(a,b,c) Perl_do_aspawn(aTHX_ a,b,c) #define do_spawn(a) Perl_do_spawn(aTHX_ a) #define do_spawn_nowait(a) Perl_do_spawn_nowait(aTHX_ a) #endif #if !defined(WIN32) #ifdef PERL_CORE #define do_exec3(a,b,c) Perl_do_exec3(aTHX_ a,b,c) #endif #endif #ifdef PERL_CORE #define do_execfree() Perl_do_execfree(aTHX) #endif #if defined(PERL_IN_DOIO_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define exec_failed(a,b,c) S_exec_failed(aTHX_ a,b,c) #endif #endif #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) #ifdef PERL_CORE #define do_ipcctl(a,b,c) Perl_do_ipcctl(aTHX_ a,b,c) #define do_ipcget(a,b,c) Perl_do_ipcget(aTHX_ a,b,c) #define do_msgrcv(a,b) Perl_do_msgrcv(aTHX_ a,b) #define do_msgsnd(a,b) Perl_do_msgsnd(aTHX_ a,b) #define do_semop(a,b) Perl_do_semop(aTHX_ a,b) #define do_shmio(a,b,c) Perl_do_shmio(aTHX_ a,b,c) #endif #endif #define do_join(a,b,c,d) Perl_do_join(aTHX_ a,b,c,d) #ifdef PERL_CORE #define do_kv() Perl_do_kv(aTHX) #endif #define do_open9(a,b,c,d,e,f,g,h,i) Perl_do_open9(aTHX_ a,b,c,d,e,f,g,h,i) #define do_openn(a,b,c,d,e,f,g,h,i) Perl_do_openn(aTHX_ a,b,c,d,e,f,g,h,i) #ifdef PERL_CORE #define do_print(a,b) Perl_do_print(aTHX_ a,b) #define do_readline() Perl_do_readline(aTHX) #define do_chomp(a) Perl_do_chomp(aTHX_ a) #define do_seek(a,b,c) Perl_do_seek(aTHX_ a,b,c) #endif #define do_sprintf(a,b,c) Perl_do_sprintf(aTHX_ a,b,c) #ifdef PERL_CORE #define do_sysseek(a,b,c) Perl_do_sysseek(aTHX_ a,b,c) #define do_tell(a) Perl_do_tell(aTHX_ a) #define do_trans(a) Perl_do_trans(aTHX_ a) #define do_vecget(a,b,c) Perl_do_vecget(aTHX_ a,b,c) #define do_vecset(a) Perl_do_vecset(aTHX_ a) #define do_vop(a,b,c,d) Perl_do_vop(aTHX_ a,b,c,d) #define dofile(a,b) Perl_dofile(aTHX_ a,b) #endif #define dowantarray() Perl_dowantarray(aTHX) #define dump_all() Perl_dump_all(aTHX) #ifdef PERL_CORE #define dump_all_perl(a) Perl_dump_all_perl(aTHX_ a) #endif #define dump_eval() Perl_dump_eval(aTHX) #if defined(DUMP_FDS) #define dump_fds(a) Perl_dump_fds(aTHX_ a) #endif #define dump_form(a) Perl_dump_form(aTHX_ a) #define gv_dump(a) Perl_gv_dump(aTHX_ a) #define op_dump(a) Perl_op_dump(aTHX_ a) #define pmop_dump(a) Perl_pmop_dump(aTHX_ a) #define dump_packsubs(a) Perl_dump_packsubs(aTHX_ a) #ifdef PERL_CORE #define dump_packsubs_perl(a,b) Perl_dump_packsubs_perl(aTHX_ a,b) #endif #define dump_sub(a) Perl_dump_sub(aTHX_ a) #ifdef PERL_CORE #define dump_sub_perl(a,b) Perl_dump_sub_perl(aTHX_ a,b) #endif #define fbm_compile(a,b) Perl_fbm_compile(aTHX_ a,b) #define fbm_instr(a,b,c,d) Perl_fbm_instr(aTHX_ a,b,c,d) #ifdef PERL_CORE #define find_script(a,b,c,d) Perl_find_script(aTHX_ a,b,c,d) #endif #if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define force_list(a) S_force_list(aTHX_ a) #define fold_constants(a) S_fold_constants(aTHX_ a) #endif #endif #define vform(a,b) Perl_vform(aTHX_ a,b) #define free_tmps() Perl_free_tmps(aTHX) #if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define gen_constant_list(a) S_gen_constant_list(aTHX_ a) #endif #endif #if !defined(HAS_GETENV_LEN) #ifdef PERL_CORE #define getenv_len(a,b) Perl_getenv_len(aTHX_ a,b) #endif #endif #ifdef PERL_CORE #endif #define gp_free(a) Perl_gp_free(aTHX_ a) #define gp_ref(a) Perl_gp_ref(aTHX_ a) #define gv_add_by_type(a,b) Perl_gv_add_by_type(aTHX_ a,b) #define gv_autoload4(a,b,c,d) Perl_gv_autoload4(aTHX_ a,b,c,d) #define gv_check(a) Perl_gv_check(aTHX_ a) #define gv_efullname(a,b) Perl_gv_efullname(aTHX_ a,b) #define gv_efullname4(a,b,c,d) Perl_gv_efullname4(aTHX_ a,b,c,d) #define gv_fetchfile(a) Perl_gv_fetchfile(aTHX_ a) #define gv_fetchfile_flags(a,b,c) Perl_gv_fetchfile_flags(aTHX_ a,b,c) #define gv_fetchmeth(a,b,c,d) Perl_gv_fetchmeth(aTHX_ a,b,c,d) #define gv_fetchmeth_autoload(a,b,c,d) Perl_gv_fetchmeth_autoload(aTHX_ a,b,c,d) #define gv_fetchmethod_autoload(a,b,c) Perl_gv_fetchmethod_autoload(aTHX_ a,b,c) #define gv_fetchmethod_flags(a,b,c) Perl_gv_fetchmethod_flags(aTHX_ a,b,c) #define gv_fetchpv(a,b,c) Perl_gv_fetchpv(aTHX_ a,b,c) #define gv_fullname(a,b) Perl_gv_fullname(aTHX_ a,b) #define gv_fullname4(a,b,c,d) Perl_gv_fullname4(aTHX_ a,b,c,d) #ifdef PERL_CORE #endif #define gv_init(a,b,c,d,e) Perl_gv_init(aTHX_ a,b,c,d,e) #define gv_name_set(a,b,c,d) Perl_gv_name_set(aTHX_ a,b,c,d) #ifdef PERL_CORE #define gv_try_downgrade(a) Perl_gv_try_downgrade(aTHX_ a) #endif #define gv_stashpv(a,b) Perl_gv_stashpv(aTHX_ a,b) #define gv_stashpvn(a,b,c) Perl_gv_stashpvn(aTHX_ a,b,c) #define gv_stashsv(a,b) Perl_gv_stashsv(aTHX_ a,b) #define hv_clear(a) Perl_hv_clear(aTHX_ a) #ifdef PERL_CORE #endif #define hv_delayfree_ent(a,b) Perl_hv_delayfree_ent(aTHX_ a,b) #define hv_common(a,b,c,d,e,f,g,h) Perl_hv_common(aTHX_ a,b,c,d,e,f,g,h) #define hv_common_key_len(a,b,c,d,e,f) Perl_hv_common_key_len(aTHX_ a,b,c,d,e,f) #define hv_free_ent(a,b) Perl_hv_free_ent(aTHX_ a,b) #define hv_iterinit(a) Perl_hv_iterinit(aTHX_ a) #define hv_iterkey(a,b) Perl_hv_iterkey(aTHX_ a,b) #define hv_iterkeysv(a) Perl_hv_iterkeysv(aTHX_ a) #define hv_iternextsv(a,b,c) Perl_hv_iternextsv(aTHX_ a,b,c) #define hv_iternext_flags(a,b) Perl_hv_iternext_flags(aTHX_ a,b) #define hv_iterval(a,b) Perl_hv_iterval(aTHX_ a,b) #define hv_ksplit(a,b) Perl_hv_ksplit(aTHX_ a,b) #if defined(PERL_CORE) || defined(PERL_EXT) #endif #ifdef PERL_CORE #endif #if defined(PERL_CORE) || defined(PERL_EXT) #endif #if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define refcounted_he_new_common(a,b,c,d,e,f,g) S_refcounted_he_new_common(aTHX_ a,b,c,d,e,f,g) #endif #endif #define hv_undef(a) Perl_hv_undef(aTHX_ a) #define ibcmp Perl_ibcmp #define ibcmp_locale Perl_ibcmp_locale #define ibcmp_utf8(a,b,c,d,e,f,g,h) Perl_ibcmp_utf8(aTHX_ a,b,c,d,e,f,g,h) #if defined(PERL_IN_DOIO_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define ingroup(a,b) S_ingroup(aTHX_ a,b) #endif #endif #ifdef PERL_CORE #define init_argv_symbols(a,b) Perl_init_argv_symbols(aTHX_ a,b) #define init_debugger() Perl_init_debugger(aTHX) #endif #define init_stacks() Perl_init_stacks(aTHX) #define init_tm(a) Perl_init_tm(aTHX_ a) #ifdef PERL_CORE #define intro_my() Perl_intro_my(aTHX) #endif #define instr Perl_instr #ifdef PERL_CORE #define io_close(a,b) Perl_io_close(aTHX_ a,b) #define invert(a) Perl_invert(aTHX_ a) #endif #define is_lvalue_sub() Perl_is_lvalue_sub(aTHX) #define to_uni_upper_lc(a) Perl_to_uni_upper_lc(aTHX_ a) #define to_uni_title_lc(a) Perl_to_uni_title_lc(aTHX_ a) #define to_uni_lower_lc(a) Perl_to_uni_lower_lc(aTHX_ a) #define is_uni_alnum(a) Perl_is_uni_alnum(aTHX_ a) #define is_uni_idfirst(a) Perl_is_uni_idfirst(aTHX_ a) #define is_uni_alpha(a) Perl_is_uni_alpha(aTHX_ a) #define is_uni_ascii(a) Perl_is_uni_ascii(aTHX_ a) #define is_uni_space(a) Perl_is_uni_space(aTHX_ a) #define is_uni_cntrl(a) Perl_is_uni_cntrl(aTHX_ a) #define is_uni_graph(a) Perl_is_uni_graph(aTHX_ a) #define is_uni_digit(a) Perl_is_uni_digit(aTHX_ a) #define is_uni_upper(a) Perl_is_uni_upper(aTHX_ a) #define is_uni_lower(a) Perl_is_uni_lower(aTHX_ a) #define is_uni_print(a) Perl_is_uni_print(aTHX_ a) #define is_uni_punct(a) Perl_is_uni_punct(aTHX_ a) #define is_uni_xdigit(a) Perl_is_uni_xdigit(aTHX_ a) #define to_uni_upper(a,b,c) Perl_to_uni_upper(aTHX_ a,b,c) #define to_uni_title(a,b,c) Perl_to_uni_title(aTHX_ a,b,c) #define to_uni_lower(a,b,c) Perl_to_uni_lower(aTHX_ a,b,c) #define to_uni_fold(a,b,c) Perl_to_uni_fold(aTHX_ a,b,c) #define is_uni_alnum_lc(a) Perl_is_uni_alnum_lc(aTHX_ a) #define is_uni_idfirst_lc(a) Perl_is_uni_idfirst_lc(aTHX_ a) #define is_uni_alpha_lc(a) Perl_is_uni_alpha_lc(aTHX_ a) #define is_uni_ascii_lc(a) Perl_is_uni_ascii_lc(aTHX_ a) #define is_uni_space_lc(a) Perl_is_uni_space_lc(aTHX_ a) #define is_uni_cntrl_lc(a) Perl_is_uni_cntrl_lc(aTHX_ a) #define is_uni_graph_lc(a) Perl_is_uni_graph_lc(aTHX_ a) #define is_uni_digit_lc(a) Perl_is_uni_digit_lc(aTHX_ a) #define is_uni_upper_lc(a) Perl_is_uni_upper_lc(aTHX_ a) #define is_uni_lower_lc(a) Perl_is_uni_lower_lc(aTHX_ a) #define is_uni_print_lc(a) Perl_is_uni_print_lc(aTHX_ a) #define is_uni_punct_lc(a) Perl_is_uni_punct_lc(aTHX_ a) #define is_uni_xdigit_lc(a) Perl_is_uni_xdigit_lc(aTHX_ a) #define is_ascii_string Perl_is_ascii_string #define is_utf8_char Perl_is_utf8_char #define is_utf8_string Perl_is_utf8_string #define is_utf8_string_loclen Perl_is_utf8_string_loclen #define is_utf8_alnum(a) Perl_is_utf8_alnum(aTHX_ a) #define is_utf8_idfirst(a) Perl_is_utf8_idfirst(aTHX_ a) #define is_utf8_idcont(a) Perl_is_utf8_idcont(aTHX_ a) #define is_utf8_alpha(a) Perl_is_utf8_alpha(aTHX_ a) #define is_utf8_ascii(a) Perl_is_utf8_ascii(aTHX_ a) #define is_utf8_space(a) Perl_is_utf8_space(aTHX_ a) #define is_utf8_perl_space(a) Perl_is_utf8_perl_space(aTHX_ a) #define is_utf8_perl_word(a) Perl_is_utf8_perl_word(aTHX_ a) #define is_utf8_cntrl(a) Perl_is_utf8_cntrl(aTHX_ a) #define is_utf8_digit(a) Perl_is_utf8_digit(aTHX_ a) #define is_utf8_posix_digit(a) Perl_is_utf8_posix_digit(aTHX_ a) #define is_utf8_graph(a) Perl_is_utf8_graph(aTHX_ a) #define is_utf8_upper(a) Perl_is_utf8_upper(aTHX_ a) #define is_utf8_lower(a) Perl_is_utf8_lower(aTHX_ a) #define is_utf8_print(a) Perl_is_utf8_print(aTHX_ a) #define is_utf8_punct(a) Perl_is_utf8_punct(aTHX_ a) #define is_utf8_xdigit(a) Perl_is_utf8_xdigit(aTHX_ a) #define is_utf8_mark(a) Perl_is_utf8_mark(aTHX_ a) #if defined(PERL_CORE) || defined(PERL_EXT) #define is_utf8_X_begin(a) Perl_is_utf8_X_begin(aTHX_ a) #define is_utf8_X_extend(a) Perl_is_utf8_X_extend(aTHX_ a) #define is_utf8_X_prepend(a) Perl_is_utf8_X_prepend(aTHX_ a) #define is_utf8_X_non_hangul(a) Perl_is_utf8_X_non_hangul(aTHX_ a) #define is_utf8_X_L(a) Perl_is_utf8_X_L(aTHX_ a) #define is_utf8_X_LV(a) Perl_is_utf8_X_LV(aTHX_ a) #define is_utf8_X_LVT(a) Perl_is_utf8_X_LVT(aTHX_ a) #define is_utf8_X_LV_LVT_V(a) Perl_is_utf8_X_LV_LVT_V(aTHX_ a) #define is_utf8_X_T(a) Perl_is_utf8_X_T(aTHX_ a) #define is_utf8_X_V(a) Perl_is_utf8_X_V(aTHX_ a) #endif #ifdef PERL_CORE #define jmaybe(a) Perl_jmaybe(aTHX_ a) #define keyword(a,b,c) Perl_keyword(aTHX_ a,b,c) #endif #if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define opt_scalarhv(a) S_opt_scalarhv(aTHX_ a) #define is_inplace_av(a,b) S_is_inplace_av(aTHX_ a,b) #endif #endif #define leave_scope(a) Perl_leave_scope(aTHX_ a) #if defined(PERL_CORE) || defined(PERL_EXT) #define lex_end() Perl_lex_end(aTHX) #endif #ifdef PERL_CORE #define lex_start(a,b,c) Perl_lex_start(aTHX_ a,b,c) #endif #define lex_bufutf8() Perl_lex_bufutf8(aTHX) #define lex_grow_linestr(a) Perl_lex_grow_linestr(aTHX_ a) #define lex_stuff_pvn(a,b,c) Perl_lex_stuff_pvn(aTHX_ a,b,c) #define lex_stuff_sv(a,b) Perl_lex_stuff_sv(aTHX_ a,b) #define lex_unstuff(a) Perl_lex_unstuff(aTHX_ a) #define lex_read_to(a) Perl_lex_read_to(aTHX_ a) #define lex_discard_to(a) Perl_lex_discard_to(aTHX_ a) #define lex_next_chunk(a) Perl_lex_next_chunk(aTHX_ a) #define lex_peek_unichar(a) Perl_lex_peek_unichar(aTHX_ a) #define lex_read_unichar(a) Perl_lex_read_unichar(aTHX_ a) #define lex_read_space(a) Perl_lex_read_space(aTHX_ a) #define op_null(a) Perl_op_null(aTHX_ a) #if defined(PERL_CORE) || defined(PERL_EXT) #define op_clear(a) Perl_op_clear(aTHX_ a) #endif #define op_refcnt_lock() Perl_op_refcnt_lock(aTHX) #define op_refcnt_unlock() Perl_op_refcnt_unlock(aTHX) #if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define linklist(a) S_linklist(aTHX_ a) #define listkids(a) S_listkids(aTHX_ a) #endif #endif #ifdef PERL_CORE #define list(a) Perl_list(aTHX_ a) #endif #define vload_module(a,b,c,d) Perl_vload_module(aTHX_ a,b,c,d) #ifdef PERL_CORE #define localize(a,b) Perl_localize(aTHX_ a,b) #endif #define looks_like_number(a) Perl_looks_like_number(aTHX_ a) #define grok_bin(a,b,c,d) Perl_grok_bin(aTHX_ a,b,c,d) #define grok_hex(a,b,c,d) Perl_grok_hex(aTHX_ a,b,c,d) #define grok_number(a,b,c) Perl_grok_number(aTHX_ a,b,c) #define grok_numeric_radix(a,b) Perl_grok_numeric_radix(aTHX_ a,b) #define grok_oct(a,b,c,d) Perl_grok_oct(aTHX_ a,b,c,d) #ifdef PERL_CORE #define magic_clearenv(a,b) Perl_magic_clearenv(aTHX_ a,b) #define magic_clear_all_env(a,b) Perl_magic_clear_all_env(aTHX_ a,b) #define magic_clearhint(a,b) Perl_magic_clearhint(aTHX_ a,b) #define magic_clearhints(a,b) Perl_magic_clearhints(aTHX_ a,b) #define magic_clearisa(a,b) Perl_magic_clearisa(aTHX_ a,b) #define magic_clearpack(a,b) Perl_magic_clearpack(aTHX_ a,b) #define magic_clearsig(a,b) Perl_magic_clearsig(aTHX_ a,b) #define magic_existspack(a,b) Perl_magic_existspack(aTHX_ a,b) #define magic_freeovrld(a,b) Perl_magic_freeovrld(aTHX_ a,b) #define magic_get(a,b) Perl_magic_get(aTHX_ a,b) #define magic_getarylen(a,b) Perl_magic_getarylen(aTHX_ a,b) #define magic_getdefelem(a,b) Perl_magic_getdefelem(aTHX_ a,b) #define magic_getnkeys(a,b) Perl_magic_getnkeys(aTHX_ a,b) #define magic_getpack(a,b) Perl_magic_getpack(aTHX_ a,b) #define magic_getpos(a,b) Perl_magic_getpos(aTHX_ a,b) #define magic_getsig(a,b) Perl_magic_getsig(aTHX_ a,b) #define magic_getsubstr(a,b) Perl_magic_getsubstr(aTHX_ a,b) #define magic_gettaint(a,b) Perl_magic_gettaint(aTHX_ a,b) #define magic_getuvar(a,b) Perl_magic_getuvar(aTHX_ a,b) #define magic_getvec(a,b) Perl_magic_getvec(aTHX_ a,b) #define magic_len(a,b) Perl_magic_len(aTHX_ a,b) #define magic_nextpack(a,b,c) Perl_magic_nextpack(aTHX_ a,b,c) #define magic_regdata_cnt(a,b) Perl_magic_regdata_cnt(aTHX_ a,b) #define magic_regdatum_get(a,b) Perl_magic_regdatum_get(aTHX_ a,b) #define magic_regdatum_set(a,b) Perl_magic_regdatum_set(aTHX_ a,b) #define magic_set(a,b) Perl_magic_set(aTHX_ a,b) #define magic_setamagic(a,b) Perl_magic_setamagic(aTHX_ a,b) #define magic_setarylen(a,b) Perl_magic_setarylen(aTHX_ a,b) #define magic_freearylen_p(a,b) Perl_magic_freearylen_p(aTHX_ a,b) #define magic_setdbline(a,b) Perl_magic_setdbline(aTHX_ a,b) #define magic_setdefelem(a,b) Perl_magic_setdefelem(aTHX_ a,b) #define magic_setenv(a,b) Perl_magic_setenv(aTHX_ a,b) #define magic_sethint(a,b) Perl_magic_sethint(aTHX_ a,b) #define magic_setisa(a,b) Perl_magic_setisa(aTHX_ a,b) #define magic_setmglob(a,b) Perl_magic_setmglob(aTHX_ a,b) #define magic_setnkeys(a,b) Perl_magic_setnkeys(aTHX_ a,b) #define magic_setpack(a,b) Perl_magic_setpack(aTHX_ a,b) #define magic_setpos(a,b) Perl_magic_setpos(aTHX_ a,b) #define magic_setregexp(a,b) Perl_magic_setregexp(aTHX_ a,b) #define magic_setsig(a,b) Perl_magic_setsig(aTHX_ a,b) #define magic_setsubstr(a,b) Perl_magic_setsubstr(aTHX_ a,b) #define magic_settaint(a,b) Perl_magic_settaint(aTHX_ a,b) #define magic_setuvar(a,b) Perl_magic_setuvar(aTHX_ a,b) #define magic_setvec(a,b) Perl_magic_setvec(aTHX_ a,b) #define magic_setutf8(a,b) Perl_magic_setutf8(aTHX_ a,b) #define magic_set_all_env(a,b) Perl_magic_set_all_env(aTHX_ a,b) #define magic_sizepack(a,b) Perl_magic_sizepack(aTHX_ a,b) #define magic_wipepack(a,b) Perl_magic_wipepack(aTHX_ a,b) #endif #define markstack_grow() Perl_markstack_grow(aTHX) #if defined(USE_LOCALE_COLLATE) #ifdef PERL_CORE #define magic_setcollxfrm(a,b) Perl_magic_setcollxfrm(aTHX_ a,b) #define mem_collxfrm(a,b,c) Perl_mem_collxfrm(aTHX_ a,b,c) #endif #endif #define vmess(a,b) Perl_vmess(aTHX_ a,b) #if defined(PERL_CORE) || defined(PERL_EXT) #define qerror(a) Perl_qerror(aTHX_ a) #endif #define sortsv(a,b,c) Perl_sortsv(aTHX_ a,b,c) #define sortsv_flags(a,b,c,d) Perl_sortsv_flags(aTHX_ a,b,c,d) #define mg_clear(a) Perl_mg_clear(aTHX_ a) #define mg_copy(a,b,c,d) Perl_mg_copy(aTHX_ a,b,c,d) #ifdef PERL_CORE #define mg_localize(a,b,c) Perl_mg_localize(aTHX_ a,b,c) #endif #define mg_find(a,b) Perl_mg_find(aTHX_ a,b) #define mg_free(a) Perl_mg_free(aTHX_ a) #define mg_get(a) Perl_mg_get(aTHX_ a) #define mg_length(a) Perl_mg_length(aTHX_ a) #define mg_magical(a) Perl_mg_magical(aTHX_ a) #define mg_set(a) Perl_mg_set(aTHX_ a) #define mg_size(a) Perl_mg_size(aTHX_ a) #define mini_mktime(a) Perl_mini_mktime(aTHX_ a) #if defined(PERL_CORE) || defined(PERL_EXT) #define mod(a,b) Perl_mod(aTHX_ a,b) #endif #ifdef PERL_CORE #define mode_from_discipline(a,b) Perl_mode_from_discipline(aTHX_ a,b) #endif #define moreswitches(a) Perl_moreswitches(aTHX_ a) #define my_atof(a) Perl_my_atof(aTHX_ a) #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY)) #define my_bcopy Perl_my_bcopy #endif #if !defined(HAS_BZERO) && !defined(HAS_MEMSET) #define my_bzero Perl_my_bzero #endif #define my_exit(a) Perl_my_exit(aTHX_ a) #define my_failure_exit() Perl_my_failure_exit(aTHX) #define my_fflush_all() Perl_my_fflush_all(aTHX) #define my_fork Perl_my_fork #define atfork_lock Perl_atfork_lock #define atfork_unlock Perl_atfork_unlock #define my_lstat() Perl_my_lstat(aTHX) #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP) #define my_memcmp Perl_my_memcmp #endif #if !defined(HAS_MEMSET) #define my_memset Perl_my_memset #endif #define my_pclose(a) Perl_my_pclose(aTHX_ a) #define my_popen(a,b) Perl_my_popen(aTHX_ a,b) #define my_popen_list(a,b,c) Perl_my_popen_list(aTHX_ a,b,c) #define my_setenv(a,b) Perl_my_setenv(aTHX_ a,b) #define my_stat() Perl_my_stat(aTHX) #define my_strftime(a,b,c,d,e,f,g,h,i,j) Perl_my_strftime(aTHX_ a,b,c,d,e,f,g,h,i,j) #if defined(MYSWAP) #define my_swap(a) Perl_my_swap(aTHX_ a) #define my_htonl(a) Perl_my_htonl(aTHX_ a) #define my_ntohl(a) Perl_my_ntohl(aTHX_ a) #endif #ifdef PERL_CORE #define my_unexec() Perl_my_unexec(aTHX) #endif #define newANONLIST(a) Perl_newANONLIST(aTHX_ a) #define newANONHASH(a) Perl_newANONHASH(aTHX_ a) #define newANONSUB(a,b,c) Perl_newANONSUB(aTHX_ a,b,c) #define newASSIGNOP(a,b,c,d) Perl_newASSIGNOP(aTHX_ a,b,c,d) #define newCONDOP(a,b,c,d) Perl_newCONDOP(aTHX_ a,b,c,d) #define newCONSTSUB(a,b,c) Perl_newCONSTSUB(aTHX_ a,b,c) #ifdef PERL_MAD #define newFORM(a,b,c) Perl_newFORM(aTHX_ a,b,c) #else #define newFORM(a,b,c) Perl_newFORM(aTHX_ a,b,c) #endif #define newFOROP(a,b,c,d,e,f,g) Perl_newFOROP(aTHX_ a,b,c,d,e,f,g) #define newGIVENOP(a,b,c) Perl_newGIVENOP(aTHX_ a,b,c) #define newLOGOP(a,b,c,d) Perl_newLOGOP(aTHX_ a,b,c,d) #define newLOOPEX(a,b) Perl_newLOOPEX(aTHX_ a,b) #define newLOOPOP(a,b,c,d) Perl_newLOOPOP(aTHX_ a,b,c,d) #define newNULLLIST() Perl_newNULLLIST(aTHX) #define newOP(a,b) Perl_newOP(aTHX_ a,b) #define newPROG(a) Perl_newPROG(aTHX_ a) #define newRANGE(a,b,c) Perl_newRANGE(aTHX_ a,b,c) #define newSLICEOP(a,b,c) Perl_newSLICEOP(aTHX_ a,b,c) #define newSTATEOP(a,b,c) Perl_newSTATEOP(aTHX_ a,b,c) #define newSUB(a,b,c,d) Perl_newSUB(aTHX_ a,b,c,d) #define newXS_flags(a,b,c,d,e) Perl_newXS_flags(aTHX_ a,b,c,d,e) #define newXS(a,b,c) Perl_newXS(aTHX_ a,b,c) #define newAVREF(a) Perl_newAVREF(aTHX_ a) #define newBINOP(a,b,c,d) Perl_newBINOP(aTHX_ a,b,c,d) #define newCVREF(a,b) Perl_newCVREF(aTHX_ a,b) #define newGVOP(a,b,c) Perl_newGVOP(aTHX_ a,b,c) #define newGVgen(a) Perl_newGVgen(aTHX_ a) #define newGVREF(a,b) Perl_newGVREF(aTHX_ a,b) #define newHVREF(a) Perl_newHVREF(aTHX_ a) #define newHVhv(a) Perl_newHVhv(aTHX_ a) #define newLISTOP(a,b,c,d) Perl_newLISTOP(aTHX_ a,b,c,d) #ifdef USE_ITHREADS #define newPADOP(a,b,c) Perl_newPADOP(aTHX_ a,b,c) #endif #define newPMOP(a,b) Perl_newPMOP(aTHX_ a,b) #define newPVOP(a,b,c) Perl_newPVOP(aTHX_ a,b,c) #define newRV(a) Perl_newRV(aTHX_ a) #define newRV_noinc(a) Perl_newRV_noinc(aTHX_ a) #define newSV(a) Perl_newSV(aTHX_ a) #define newSVREF(a) Perl_newSVREF(aTHX_ a) #define newSVOP(a,b,c) Perl_newSVOP(aTHX_ a,b,c) #define newSViv(a) Perl_newSViv(aTHX_ a) #define newSVuv(a) Perl_newSVuv(aTHX_ a) #define newSVnv(a) Perl_newSVnv(aTHX_ a) #define newSVpv(a,b) Perl_newSVpv(aTHX_ a,b) #define newSVpvn(a,b) Perl_newSVpvn(aTHX_ a,b) #define newSVpvn_flags(a,b,c) Perl_newSVpvn_flags(aTHX_ a,b,c) #define newSVhek(a) Perl_newSVhek(aTHX_ a) #define newSVpvn_share(a,b,c) Perl_newSVpvn_share(aTHX_ a,b,c) #define vnewSVpvf(a,b) Perl_vnewSVpvf(aTHX_ a,b) #define newSVrv(a,b) Perl_newSVrv(aTHX_ a,b) #define newSVsv(a) Perl_newSVsv(aTHX_ a) #define newSV_type(a) Perl_newSV_type(aTHX_ a) #define newUNOP(a,b,c) Perl_newUNOP(aTHX_ a,b,c) #define newWHENOP(a,b) Perl_newWHENOP(aTHX_ a,b) #define newWHILEOP(a,b,c,d,e,f,g,h) Perl_newWHILEOP(aTHX_ a,b,c,d,e,f,g,h) #define new_stackinfo(a,b) Perl_new_stackinfo(aTHX_ a,b) #define scan_vstring(a,b,c) Perl_scan_vstring(aTHX_ a,b,c) #define scan_version(a,b,c) Perl_scan_version(aTHX_ a,b,c) #define prescan_version(a,b,c,d,e,f,g) Perl_prescan_version(aTHX_ a,b,c,d,e,f,g) #define new_version(a) Perl_new_version(aTHX_ a) #define upg_version(a,b) Perl_upg_version(aTHX_ a,b) #define vverify(a) Perl_vverify(aTHX_ a) #define vnumify(a) Perl_vnumify(aTHX_ a) #define vnormal(a) Perl_vnormal(aTHX_ a) #define vstringify(a) Perl_vstringify(aTHX_ a) #define vcmp(a,b) Perl_vcmp(aTHX_ a,b) #ifdef PERL_CORE #define nextargv(a) Perl_nextargv(aTHX_ a) #endif #define ninstr Perl_ninstr #define op_free(a) Perl_op_free(aTHX_ a) #ifdef PERL_MAD #ifdef PERL_CORE #define package(a) Perl_package(aTHX_ a) #endif #else #ifdef PERL_CORE #define package(a) Perl_package(aTHX_ a) #endif #endif #ifdef PERL_CORE #define package_version(a) Perl_package_version(aTHX_ a) #define pad_alloc(a,b) Perl_pad_alloc(aTHX_ a,b) #define allocmy(a,b,c) Perl_allocmy(aTHX_ a,b,c) #endif #define pad_findmy(a,b,c) Perl_pad_findmy(aTHX_ a,b,c) #define find_rundefsvoffset() Perl_find_rundefsvoffset(aTHX) #ifdef PERL_CORE #define oopsAV(a) Perl_oopsAV(aTHX_ a) #define oopsHV(a) Perl_oopsHV(aTHX_ a) #define pad_leavemy() Perl_pad_leavemy(aTHX) #endif #ifdef DEBUGGING #define pad_sv(a) Perl_pad_sv(aTHX_ a) #endif #ifdef PERL_CORE #define pad_free(a) Perl_pad_free(aTHX_ a) #endif #if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define pad_reset() S_pad_reset(aTHX) #endif #endif #ifdef PERL_CORE #define pad_swipe(a,b) Perl_pad_swipe(aTHX_ a,b) #define peep(a) Perl_peep(aTHX_ a) #endif #if defined(USE_REENTRANT_API) #define reentrant_size() Perl_reentrant_size(aTHX) #define reentrant_init() Perl_reentrant_init(aTHX) #define reentrant_free() Perl_reentrant_free(aTHX) #endif #define call_atexit(a,b) Perl_call_atexit(aTHX_ a,b) #define call_argv(a,b,c) Perl_call_argv(aTHX_ a,b,c) #define call_method(a,b) Perl_call_method(aTHX_ a,b) #define call_pv(a,b) Perl_call_pv(aTHX_ a,b) #define call_sv(a,b) Perl_call_sv(aTHX_ a,b) #define despatch_signals() Perl_despatch_signals(aTHX) #define doref(a,b,c) Perl_doref(aTHX_ a,b,c) #define eval_pv(a,b) Perl_eval_pv(aTHX_ a,b) #define eval_sv(a,b) Perl_eval_sv(aTHX_ a,b) #define get_sv(a,b) Perl_get_sv(aTHX_ a,b) #define get_av(a,b) Perl_get_av(aTHX_ a,b) #define get_hv(a,b) Perl_get_hv(aTHX_ a,b) #define get_cv(a,b) Perl_get_cv(aTHX_ a,b) #define get_cvn_flags(a,b,c) Perl_get_cvn_flags(aTHX_ a,b,c) #define init_i18nl10n(a) Perl_init_i18nl10n(aTHX_ a) #define init_i18nl14n(a) Perl_init_i18nl14n(aTHX_ a) #define new_collate(a) Perl_new_collate(aTHX_ a) #define new_ctype(a) Perl_new_ctype(aTHX_ a) #define new_numeric(a) Perl_new_numeric(aTHX_ a) #define set_numeric_local() Perl_set_numeric_local(aTHX) #define set_numeric_radix() Perl_set_numeric_radix(aTHX) #define set_numeric_standard() Perl_set_numeric_standard(aTHX) #define require_pv(a) Perl_require_pv(aTHX_ a) #define pack_cat(a,b,c,d,e,f,g) Perl_pack_cat(aTHX_ a,b,c,d,e,f,g) #define packlist(a,b,c,d,e) Perl_packlist(aTHX_ a,b,c,d,e) #if defined(PERL_USES_PL_PIDSTATUS) && defined(PERL_IN_UTIL_C) #ifdef PERL_CORE #define pidgone(a,b) S_pidgone(aTHX_ a,b) #endif #endif #ifdef PERL_CORE #define pmruntime(a,b,c) Perl_pmruntime(aTHX_ a,b,c) #endif #if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define pmtrans(a,b,c) S_pmtrans(aTHX_ a,b,c) #endif #endif #define pop_scope() Perl_pop_scope(aTHX) #ifdef PERL_CORE #define prepend_elem(a,b,c) Perl_prepend_elem(aTHX_ a,b,c) #endif #define push_scope() Perl_push_scope(aTHX) #if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define refkids(a,b) S_refkids(aTHX_ a,b) #endif #endif #define regdump(a) Perl_regdump(aTHX_ a) #define regdump(a) Perl_regdump(aTHX_ a) #define regclass_swash(a,b,c,d,e) Perl_regclass_swash(aTHX_ a,b,c,d,e) #define pregexec(a,b,c,d,e,f,g) Perl_pregexec(aTHX_ a,b,c,d,e,f,g) #define pregfree(a) Perl_pregfree(aTHX_ a) #define pregfree2(a) Perl_pregfree2(aTHX_ a) #if defined(PERL_CORE) || defined(PERL_EXT) #define reg_temp_copy(a,b) Perl_reg_temp_copy(aTHX_ a,b) #endif #define regfree_internal(a) Perl_regfree_internal(aTHX_ a) #if defined(USE_ITHREADS) #define regdupe_internal(a,b) Perl_regdupe_internal(aTHX_ a,b) #endif #define pregcomp(a,b) Perl_pregcomp(aTHX_ a,b) #define re_compile(a,b) Perl_re_compile(aTHX_ a,b) #define re_intuit_start(a,b,c,d,e,f) Perl_re_intuit_start(aTHX_ a,b,c,d,e,f) #define re_intuit_string(a) Perl_re_intuit_string(aTHX_ a) #define regexec_flags(a,b,c,d,e,f,g,h) Perl_regexec_flags(aTHX_ a,b,c,d,e,f,g,h) #define regnext(a) Perl_regnext(aTHX_ a) #if defined(PERL_CORE) || defined(PERL_EXT) #define reg_named_buff(a,b,c,d) Perl_reg_named_buff(aTHX_ a,b,c,d) #define reg_named_buff_iter(a,b,c) Perl_reg_named_buff_iter(aTHX_ a,b,c) #endif #define reg_named_buff_fetch(a,b,c) Perl_reg_named_buff_fetch(aTHX_ a,b,c) #define reg_named_buff_exists(a,b,c) Perl_reg_named_buff_exists(aTHX_ a,b,c) #define reg_named_buff_firstkey(a,b) Perl_reg_named_buff_firstkey(aTHX_ a,b) #define reg_named_buff_nextkey(a,b) Perl_reg_named_buff_nextkey(aTHX_ a,b) #define reg_named_buff_scalar(a,b) Perl_reg_named_buff_scalar(aTHX_ a,b) #define reg_named_buff_all(a,b) Perl_reg_named_buff_all(aTHX_ a,b) #if defined(PERL_CORE) || defined(PERL_EXT) #define reg_numbered_buff_fetch(a,b,c) Perl_reg_numbered_buff_fetch(aTHX_ a,b,c) #define reg_numbered_buff_store(a,b,c) Perl_reg_numbered_buff_store(aTHX_ a,b,c) #define reg_numbered_buff_length(a,b,c) Perl_reg_numbered_buff_length(aTHX_ a,b,c) #endif #if defined(PERL_CORE) || defined(PERL_EXT) #define reg_qr_package(a) Perl_reg_qr_package(aTHX_ a) #endif #if defined(PERL_CORE) || defined(PERL_EXT) #define regprop(a,b,c) Perl_regprop(aTHX_ a,b,c) #endif #define repeatcpy Perl_repeatcpy #define rninstr Perl_rninstr #define rsignal(a,b) Perl_rsignal(aTHX_ a,b) #ifdef PERL_CORE #define rsignal_restore(a,b) Perl_rsignal_restore(aTHX_ a,b) #define rsignal_save(a,b,c) Perl_rsignal_save(aTHX_ a,b,c) #endif #define rsignal_state(a) Perl_rsignal_state(aTHX_ a) #if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define rxres_free(a) S_rxres_free(aTHX_ a) #define rxres_restore(a,b) S_rxres_restore(aTHX_ a,b) #endif #endif #ifdef PERL_CORE #define rxres_save(a,b) Perl_rxres_save(aTHX_ a,b) #endif #if !defined(HAS_RENAME) #ifdef PERL_CORE #define same_dirent(a,b) Perl_same_dirent(aTHX_ a,b) #endif #endif #define savepv(a) Perl_savepv(aTHX_ a) #define savepvn(a,b) Perl_savepvn(aTHX_ a,b) #define savesharedpv(a) Perl_savesharedpv(aTHX_ a) #define savesharedpvn(a,b) Perl_savesharedpvn(aTHX_ a,b) #define savesvpv(a) Perl_savesvpv(aTHX_ a) #define savestack_grow() Perl_savestack_grow(aTHX) #define savestack_grow_cnt(a) Perl_savestack_grow_cnt(aTHX_ a) #define save_aelem_flags(a,b,c,d) Perl_save_aelem_flags(aTHX_ a,b,c,d) #define save_alloc(a,b) Perl_save_alloc(aTHX_ a,b) #define save_aptr(a) Perl_save_aptr(aTHX_ a) #define save_ary(a) Perl_save_ary(aTHX_ a) #define save_bool(a) Perl_save_bool(aTHX_ a) #define save_clearsv(a) Perl_save_clearsv(aTHX_ a) #define save_delete(a,b,c) Perl_save_delete(aTHX_ a,b,c) #define save_hdelete(a,b) Perl_save_hdelete(aTHX_ a,b) #define save_adelete(a,b) Perl_save_adelete(aTHX_ a,b) #define save_destructor(a,b) Perl_save_destructor(aTHX_ a,b) #define save_destructor_x(a,b) Perl_save_destructor_x(aTHX_ a,b) #ifdef PERL_CORE #endif #define save_generic_svref(a) Perl_save_generic_svref(aTHX_ a) #define save_generic_pvref(a) Perl_save_generic_pvref(aTHX_ a) #define save_shared_pvref(a) Perl_save_shared_pvref(aTHX_ a) #define save_gp(a,b) Perl_save_gp(aTHX_ a,b) #define save_hash(a) Perl_save_hash(aTHX_ a) #ifdef PERL_CORE #define save_hints() Perl_save_hints(aTHX) #endif #define save_helem_flags(a,b,c,d) Perl_save_helem_flags(aTHX_ a,b,c,d) #define save_hptr(a) Perl_save_hptr(aTHX_ a) #define save_I16(a) Perl_save_I16(aTHX_ a) #define save_I32(a) Perl_save_I32(aTHX_ a) #define save_I8(a) Perl_save_I8(aTHX_ a) #define save_int(a) Perl_save_int(aTHX_ a) #define save_item(a) Perl_save_item(aTHX_ a) #define save_iv(a) Perl_save_iv(aTHX_ a) #define save_list(a,b) Perl_save_list(aTHX_ a,b) #define save_long(a) Perl_save_long(aTHX_ a) #define save_nogv(a) Perl_save_nogv(aTHX_ a) #ifdef PERL_CORE #endif #define save_scalar(a) Perl_save_scalar(aTHX_ a) #define save_pptr(a) Perl_save_pptr(aTHX_ a) #define save_vptr(a) Perl_save_vptr(aTHX_ a) #define save_re_context() Perl_save_re_context(aTHX) #define save_padsv_and_mortalize(a) Perl_save_padsv_and_mortalize(aTHX_ a) #define save_sptr(a) Perl_save_sptr(aTHX_ a) #define save_svref(a) Perl_save_svref(aTHX_ a) #define save_pushptr(a,b) Perl_save_pushptr(aTHX_ a,b) #ifdef PERL_CORE #define save_pushi32ptr(a,b,c) Perl_save_pushi32ptr(aTHX_ a,b,c) #define save_pushptrptr(a,b,c) Perl_save_pushptrptr(aTHX_ a,b,c) #endif #if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define save_pushptri32ptr(a,b,c,d) S_save_pushptri32ptr(aTHX_ a,b,c,d) #endif #endif #ifdef PERL_CORE #define sawparens(a) Perl_sawparens(aTHX_ a) #define scalar(a) Perl_scalar(aTHX_ a) #endif #if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define scalarkids(a) S_scalarkids(aTHX_ a) #define scalarseq(a) S_scalarseq(aTHX_ a) #endif #endif #ifdef PERL_CORE #define scalarvoid(a) Perl_scalarvoid(aTHX_ a) #endif #define scan_bin(a,b,c) Perl_scan_bin(aTHX_ a,b,c) #define scan_hex(a,b,c) Perl_scan_hex(aTHX_ a,b,c) #define scan_num(a,b) Perl_scan_num(aTHX_ a,b) #define scan_oct(a,b,c) Perl_scan_oct(aTHX_ a,b,c) #ifdef PERL_CORE #define scope(a) Perl_scope(aTHX_ a) #endif #define screaminstr(a,b,c,d,e,f) Perl_screaminstr(aTHX_ a,b,c,d,e,f) #define setdefout(a) Perl_setdefout(aTHX_ a) #define share_hek(a,b,c) Perl_share_hek(aTHX_ a,b,c) #if defined(HAS_SIGACTION) && defined(SA_SIGINFO) #ifdef PERL_CORE #define sighandler Perl_sighandler #endif #define csighandler Perl_csighandler #else #ifdef PERL_CORE #define sighandler Perl_sighandler #endif #define csighandler Perl_csighandler #endif #define stack_grow(a,b,c) Perl_stack_grow(aTHX_ a,b,c) #define start_subparse(a,b) Perl_start_subparse(aTHX_ a,b) #ifdef PERL_CORE #define sub_crush_depth(a) Perl_sub_crush_depth(aTHX_ a) #endif #define sv_2bool(a) Perl_sv_2bool(aTHX_ a) #define sv_2cv(a,b,c,d) Perl_sv_2cv(aTHX_ a,b,c,d) #define sv_2io(a) Perl_sv_2io(aTHX_ a) #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define glob_2number(a) S_glob_2number(aTHX_ a) #endif #endif #define sv_2iv_flags(a,b) Perl_sv_2iv_flags(aTHX_ a,b) #define sv_2mortal(a) Perl_sv_2mortal(aTHX_ a) #define sv_2nv(a) Perl_sv_2nv(aTHX_ a) #ifdef PERL_CORE #define sv_2num(a) Perl_sv_2num(aTHX_ a) #endif #define sv_2pv_flags(a,b,c) Perl_sv_2pv_flags(aTHX_ a,b,c) #define sv_2pvutf8(a,b) Perl_sv_2pvutf8(aTHX_ a,b) #define sv_2pvbyte(a,b) Perl_sv_2pvbyte(aTHX_ a,b) #define sv_pvn_nomg(a,b) Perl_sv_pvn_nomg(aTHX_ a,b) #define sv_2uv_flags(a,b) Perl_sv_2uv_flags(aTHX_ a,b) #define sv_iv(a) Perl_sv_iv(aTHX_ a) #define sv_uv(a) Perl_sv_uv(aTHX_ a) #define sv_nv(a) Perl_sv_nv(aTHX_ a) #define sv_pvn(a,b) Perl_sv_pvn(aTHX_ a,b) #define sv_pvutf8n(a,b) Perl_sv_pvutf8n(aTHX_ a,b) #define sv_pvbyten(a,b) Perl_sv_pvbyten(aTHX_ a,b) #define sv_true(a) Perl_sv_true(aTHX_ a) #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define sv_add_arena(a,b,c) S_sv_add_arena(aTHX_ a,b,c) #endif #endif #define sv_backoff(a) Perl_sv_backoff(aTHX_ a) #define sv_bless(a,b) Perl_sv_bless(aTHX_ a,b) #define sv_vcatpvf(a,b,c) Perl_sv_vcatpvf(aTHX_ a,b,c) #define sv_catpv(a,b) Perl_sv_catpv(aTHX_ a,b) #define sv_chop(a,b) Perl_sv_chop(aTHX_ a,b) #ifdef PERL_CORE #define sv_clean_all() Perl_sv_clean_all(aTHX) #define sv_clean_objs() Perl_sv_clean_objs(aTHX) #endif #define sv_clear(a) Perl_sv_clear(aTHX_ a) #define sv_cmp(a,b) Perl_sv_cmp(aTHX_ a,b) #define sv_cmp_locale(a,b) Perl_sv_cmp_locale(aTHX_ a,b) #if defined(USE_LOCALE_COLLATE) #define sv_collxfrm(a,b) Perl_sv_collxfrm(aTHX_ a,b) #endif #define sv_compile_2op(a,b,c,d) Perl_sv_compile_2op(aTHX_ a,b,c,d) #define getcwd_sv(a) Perl_getcwd_sv(aTHX_ a) #define sv_dec(a) Perl_sv_dec(aTHX_ a) #define sv_dump(a) Perl_sv_dump(aTHX_ a) #define sv_derived_from(a,b) Perl_sv_derived_from(aTHX_ a,b) #define sv_does(a,b) Perl_sv_does(aTHX_ a,b) #define sv_eq(a,b) Perl_sv_eq(aTHX_ a,b) #define sv_free(a) Perl_sv_free(aTHX_ a) #ifdef PERL_CORE #define sv_free_arenas() Perl_sv_free_arenas(aTHX) #endif #define sv_gets(a,b,c) Perl_sv_gets(aTHX_ a,b,c) #define sv_grow(a,b) Perl_sv_grow(aTHX_ a,b) #define sv_inc(a) Perl_sv_inc(aTHX_ a) #define sv_insert_flags(a,b,c,d,e,f) Perl_sv_insert_flags(aTHX_ a,b,c,d,e,f) #define sv_isa(a,b) Perl_sv_isa(aTHX_ a,b) #define sv_isobject(a) Perl_sv_isobject(aTHX_ a) #define sv_len(a) Perl_sv_len(aTHX_ a) #define sv_len_utf8(a) Perl_sv_len_utf8(aTHX_ a) #define sv_magic(a,b,c,d,e) Perl_sv_magic(aTHX_ a,b,c,d,e) #define sv_magicext(a,b,c,d,e,f) Perl_sv_magicext(aTHX_ a,b,c,d,e,f) #define sv_mortalcopy(a) Perl_sv_mortalcopy(aTHX_ a) #define sv_newmortal() Perl_sv_newmortal(aTHX) #define sv_newref(a) Perl_sv_newref(aTHX_ a) #define sv_peek(a) Perl_sv_peek(aTHX_ a) #define sv_pos_u2b(a,b,c) Perl_sv_pos_u2b(aTHX_ a,b,c) #define sv_pos_u2b_flags(a,b,c,d) Perl_sv_pos_u2b_flags(aTHX_ a,b,c,d) #define sv_pos_b2u(a,b) Perl_sv_pos_b2u(aTHX_ a,b) #define sv_pvutf8n_force(a,b) Perl_sv_pvutf8n_force(aTHX_ a,b) #define sv_pvbyten_force(a,b) Perl_sv_pvbyten_force(aTHX_ a,b) #define sv_recode_to_utf8(a,b) Perl_sv_recode_to_utf8(aTHX_ a,b) #define sv_cat_decode(a,b,c,d,e,f) Perl_sv_cat_decode(aTHX_ a,b,c,d,e,f) #define sv_reftype(a,b) Perl_sv_reftype(aTHX_ a,b) #define sv_replace(a,b) Perl_sv_replace(aTHX_ a,b) #define sv_report_used() Perl_sv_report_used(aTHX) #define sv_reset(a,b) Perl_sv_reset(aTHX_ a,b) #define sv_vsetpvf(a,b,c) Perl_sv_vsetpvf(aTHX_ a,b,c) #define sv_setiv(a,b) Perl_sv_setiv(aTHX_ a,b) #define sv_setpviv(a,b) Perl_sv_setpviv(aTHX_ a,b) #define sv_setuv(a,b) Perl_sv_setuv(aTHX_ a,b) #define sv_setnv(a,b) Perl_sv_setnv(aTHX_ a,b) #define sv_setref_iv(a,b,c) Perl_sv_setref_iv(aTHX_ a,b,c) #define sv_setref_uv(a,b,c) Perl_sv_setref_uv(aTHX_ a,b,c) #define sv_setref_nv(a,b,c) Perl_sv_setref_nv(aTHX_ a,b,c) #define sv_setref_pv(a,b,c) Perl_sv_setref_pv(aTHX_ a,b,c) #define sv_setref_pvn(a,b,c,d) Perl_sv_setref_pvn(aTHX_ a,b,c,d) #define sv_setpv(a,b) Perl_sv_setpv(aTHX_ a,b) #define sv_setpvn(a,b,c) Perl_sv_setpvn(aTHX_ a,b,c) #define sv_tainted(a) Perl_sv_tainted(aTHX_ a) #define sv_unmagic(a,b) Perl_sv_unmagic(aTHX_ a,b) #define sv_unref_flags(a,b) Perl_sv_unref_flags(aTHX_ a,b) #define sv_untaint(a) Perl_sv_untaint(aTHX_ a) #define sv_upgrade(a,b) Perl_sv_upgrade(aTHX_ a,b) #define sv_usepvn_flags(a,b,c,d) Perl_sv_usepvn_flags(aTHX_ a,b,c,d) #define sv_vcatpvfn(a,b,c,d,e,f,g) Perl_sv_vcatpvfn(aTHX_ a,b,c,d,e,f,g) #define sv_vsetpvfn(a,b,c,d,e,f,g) Perl_sv_vsetpvfn(aTHX_ a,b,c,d,e,f,g) #define str_to_version(a) Perl_str_to_version(aTHX_ a) #define swash_init(a,b,c,d,e) Perl_swash_init(aTHX_ a,b,c,d,e) #define swash_fetch(a,b,c) Perl_swash_fetch(aTHX_ a,b,c) #define taint_env() Perl_taint_env(aTHX) #define taint_proper(a,b) Perl_taint_proper(aTHX_ a,b) #define to_utf8_case(a,b,c,d,e,f) Perl_to_utf8_case(aTHX_ a,b,c,d,e,f) #define to_utf8_lower(a,b,c) Perl_to_utf8_lower(aTHX_ a,b,c) #define to_utf8_upper(a,b,c) Perl_to_utf8_upper(aTHX_ a,b,c) #define to_utf8_title(a,b,c) Perl_to_utf8_title(aTHX_ a,b,c) #define to_utf8_fold(a,b,c) Perl_to_utf8_fold(aTHX_ a,b,c) #if defined(UNLINK_ALL_VERSIONS) #define unlnk(a) Perl_unlnk(aTHX_ a) #endif #define unpack_str(a,b,c,d,e,f,g,h) Perl_unpack_str(aTHX_ a,b,c,d,e,f,g,h) #define unpackstring(a,b,c,d,e) Perl_unpackstring(aTHX_ a,b,c,d,e) #define unsharepvn(a,b,c) Perl_unsharepvn(aTHX_ a,b,c) #ifdef PERL_CORE #define unshare_hek(a) Perl_unshare_hek(aTHX_ a) #endif #ifdef PERL_MAD #ifdef PERL_CORE #define utilize(a,b,c,d,e) Perl_utilize(aTHX_ a,b,c,d,e) #endif #else #ifdef PERL_CORE #define utilize(a,b,c,d,e) Perl_utilize(aTHX_ a,b,c,d,e) #endif #endif #define utf16_to_utf8(a,b,c,d) Perl_utf16_to_utf8(aTHX_ a,b,c,d) #define utf16_to_utf8_reversed(a,b,c,d) Perl_utf16_to_utf8_reversed(aTHX_ a,b,c,d) #define utf8_length(a,b) Perl_utf8_length(aTHX_ a,b) #define utf8_distance(a,b) Perl_utf8_distance(aTHX_ a,b) #define utf8_hop(a,b) Perl_utf8_hop(aTHX_ a,b) #define utf8_to_bytes(a,b) Perl_utf8_to_bytes(aTHX_ a,b) #define bytes_from_utf8(a,b,c) Perl_bytes_from_utf8(aTHX_ a,b,c) #define bytes_to_utf8(a,b) Perl_bytes_to_utf8(aTHX_ a,b) #define utf8_to_uvchr(a,b) Perl_utf8_to_uvchr(aTHX_ a,b) #define utf8_to_uvuni(a,b) Perl_utf8_to_uvuni(aTHX_ a,b) #ifdef EBCDIC #define utf8n_to_uvchr(a,b,c,d) Perl_utf8n_to_uvchr(aTHX_ a,b,c,d) #else #endif #define utf8n_to_uvuni(a,b,c,d) Perl_utf8n_to_uvuni(aTHX_ a,b,c,d) #ifdef EBCDIC #define uvchr_to_utf8(a,b) Perl_uvchr_to_utf8(aTHX_ a,b) #else #endif #define uvchr_to_utf8_flags(a,b,c) Perl_uvchr_to_utf8_flags(aTHX_ a,b,c) #define uvuni_to_utf8_flags(a,b,c) Perl_uvuni_to_utf8_flags(aTHX_ a,b,c) #define pv_uni_display(a,b,c,d,e) Perl_pv_uni_display(aTHX_ a,b,c,d,e) #define sv_uni_display(a,b,c,d) Perl_sv_uni_display(aTHX_ a,b,c,d) #if defined(PERL_CORE) || defined(PERL_EXT) #define vivify_defelem(a) Perl_vivify_defelem(aTHX_ a) #endif #ifdef PERL_CORE #define vivify_ref(a,b) Perl_vivify_ref(aTHX_ a,b) #define wait4pid(a,b,c) Perl_wait4pid(aTHX_ a,b,c) #define parse_unicode_opts(a) Perl_parse_unicode_opts(aTHX_ a) #endif #define seed() Perl_seed(aTHX) #ifdef PERL_CORE #define get_hash_seed() Perl_get_hash_seed(aTHX) #define report_evil_fh(a,b,c) Perl_report_evil_fh(aTHX_ a,b,c) #endif #if defined(PERL_CORE) || defined(PERL_EXT) #define report_uninit(a) Perl_report_uninit(aTHX_ a) #endif #define vwarn(a,b) Perl_vwarn(aTHX_ a,b) #define vwarner(a,b,c) Perl_vwarner(aTHX_ a,b,c) #ifdef PERL_CORE #define watch(a) Perl_watch(aTHX_ a) #endif #define whichsig(a) Perl_whichsig(aTHX_ a) #ifdef PERL_CORE #define write_to_stderr(a) Perl_write_to_stderr(aTHX_ a) #define yyerror(a) Perl_yyerror(aTHX_ a) #endif #if defined(PERL_CORE) || defined(PERL_EXT) #define yylex() Perl_yylex(aTHX) #endif #ifdef PERL_CORE #define yyparse() Perl_yyparse(aTHX) #define parser_free(a) Perl_parser_free(aTHX_ a) #endif #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define yywarn(a) S_yywarn(aTHX_ a) #endif #endif #if defined(MYMALLOC) #define dump_mstats(a) Perl_dump_mstats(aTHX_ a) #define get_mstats(a,b,c) Perl_get_mstats(aTHX_ a,b,c) #endif #define safesysmalloc Perl_safesysmalloc #define safesyscalloc Perl_safesyscalloc #define safesysrealloc Perl_safesysrealloc #define safesysfree Perl_safesysfree #if defined(PERL_GLOBAL_STRUCT) #define GetVars() Perl_GetVars(aTHX) #define init_global_struct() Perl_init_global_struct(aTHX) #define free_global_struct(a) Perl_free_global_struct(aTHX_ a) #endif #define runops_standard() Perl_runops_standard(aTHX) #define runops_debug() Perl_runops_debug(aTHX) #define sv_vcatpvf_mg(a,b,c) Perl_sv_vcatpvf_mg(aTHX_ a,b,c) #define sv_catpv_mg(a,b) Perl_sv_catpv_mg(aTHX_ a,b) #define sv_vsetpvf_mg(a,b,c) Perl_sv_vsetpvf_mg(aTHX_ a,b,c) #define sv_setiv_mg(a,b) Perl_sv_setiv_mg(aTHX_ a,b) #define sv_setpviv_mg(a,b) Perl_sv_setpviv_mg(aTHX_ a,b) #define sv_setuv_mg(a,b) Perl_sv_setuv_mg(aTHX_ a,b) #define sv_setnv_mg(a,b) Perl_sv_setnv_mg(aTHX_ a,b) #define sv_setpv_mg(a,b) Perl_sv_setpv_mg(aTHX_ a,b) #define sv_setpvn_mg(a,b,c) Perl_sv_setpvn_mg(aTHX_ a,b,c) #define sv_setsv_mg(a,b) Perl_sv_setsv_mg(aTHX_ a,b) #define get_vtbl(a) Perl_get_vtbl(aTHX_ a) #define pv_display(a,b,c,d,e) Perl_pv_display(aTHX_ a,b,c,d,e) #define pv_escape(a,b,c,d,e,f) Perl_pv_escape(aTHX_ a,b,c,d,e,f) #define pv_pretty(a,b,c,d,e,f,g) Perl_pv_pretty(aTHX_ a,b,c,d,e,f,g) #define dump_vindent(a,b,c,d) Perl_dump_vindent(aTHX_ a,b,c,d) #define do_gv_dump(a,b,c,d) Perl_do_gv_dump(aTHX_ a,b,c,d) #define do_gvgv_dump(a,b,c,d) Perl_do_gvgv_dump(aTHX_ a,b,c,d) #define do_hv_dump(a,b,c,d) Perl_do_hv_dump(aTHX_ a,b,c,d) #define do_magic_dump(a,b,c,d,e,f,g) Perl_do_magic_dump(aTHX_ a,b,c,d,e,f,g) #define do_op_dump(a,b,c) Perl_do_op_dump(aTHX_ a,b,c) #define do_pmop_dump(a,b,c) Perl_do_pmop_dump(aTHX_ a,b,c) #define do_sv_dump(a,b,c,d,e,f,g) Perl_do_sv_dump(aTHX_ a,b,c,d,e,f,g) #define magic_dump(a) Perl_magic_dump(aTHX_ a) #define reginitcolors() Perl_reginitcolors(aTHX) #define sv_utf8_downgrade(a,b) Perl_sv_utf8_downgrade(aTHX_ a,b) #define sv_utf8_encode(a) Perl_sv_utf8_encode(aTHX_ a) #define sv_utf8_decode(a) Perl_sv_utf8_decode(aTHX_ a) #define sv_force_normal_flags(a,b) Perl_sv_force_normal_flags(aTHX_ a,b) #define tmps_grow(a) Perl_tmps_grow(aTHX_ a) #define sv_rvweaken(a) Perl_sv_rvweaken(aTHX_ a) #ifdef PERL_CORE #define magic_killbackrefs(a,b) Perl_magic_killbackrefs(aTHX_ a,b) #endif #define newANONATTRSUB(a,b,c,d) Perl_newANONATTRSUB(aTHX_ a,b,c,d) #define newATTRSUB(a,b,c,d,e) Perl_newATTRSUB(aTHX_ a,b,c,d,e) #ifdef PERL_MAD #define newMYSUB(a,b,c,d,e) Perl_newMYSUB(aTHX_ a,b,c,d,e) #else #define newMYSUB(a,b,c,d,e) Perl_newMYSUB(aTHX_ a,b,c,d,e) #endif #ifdef PERL_CORE #define my_attrs(a,b) Perl_my_attrs(aTHX_ a,b) #endif #if defined(USE_ITHREADS) #define cx_dup(a,b,c,d) Perl_cx_dup(aTHX_ a,b,c,d) #define si_dup(a,b) Perl_si_dup(aTHX_ a,b) #define ss_dup(a,b) Perl_ss_dup(aTHX_ a,b) #define any_dup(a,b) Perl_any_dup(aTHX_ a,b) #define he_dup(a,b,c) Perl_he_dup(aTHX_ a,b,c) #define hek_dup(a,b) Perl_hek_dup(aTHX_ a,b) #define re_dup_guts(a,b,c) Perl_re_dup_guts(aTHX_ a,b,c) #define fp_dup(a,b,c) Perl_fp_dup(aTHX_ a,b,c) #define dirp_dup(a) Perl_dirp_dup(aTHX_ a) #define gp_dup(a,b) Perl_gp_dup(aTHX_ a,b) #define mg_dup(a,b) Perl_mg_dup(aTHX_ a,b) #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define sv_dup_inc_multiple(a,b,c,d) S_sv_dup_inc_multiple(aTHX_ a,b,c,d) #endif #endif #define sv_dup(a,b) Perl_sv_dup(aTHX_ a,b) #define rvpv_dup(a,b,c) Perl_rvpv_dup(aTHX_ a,b,c) #define parser_dup(a,b) Perl_parser_dup(aTHX_ a,b) #endif #define ptr_table_new() Perl_ptr_table_new(aTHX) #define ptr_table_fetch(a,b) Perl_ptr_table_fetch(aTHX_ a,b) #define ptr_table_store(a,b,c) Perl_ptr_table_store(aTHX_ a,b,c) #define ptr_table_split(a) Perl_ptr_table_split(aTHX_ a) #define ptr_table_clear(a) Perl_ptr_table_clear(aTHX_ a) #define ptr_table_free(a) Perl_ptr_table_free(aTHX_ a) #if defined(USE_ITHREADS) # if defined(HAVE_INTERP_INTERN) #define sys_intern_dup(a,b) Perl_sys_intern_dup(aTHX_ a,b) # endif #endif #if defined(HAVE_INTERP_INTERN) #define sys_intern_clear() Perl_sys_intern_clear(aTHX) #define sys_intern_init() Perl_sys_intern_init(aTHX) #endif #define custom_op_name(a) Perl_custom_op_name(aTHX_ a) #define custom_op_desc(a) Perl_custom_op_desc(aTHX_ a) #define sv_nosharing(a) Perl_sv_nosharing(aTHX_ a) #define sv_destroyable(a) Perl_sv_destroyable(aTHX_ a) #ifdef NO_MATHOMS #else #define sv_nounlocking(a) Perl_sv_nounlocking(aTHX_ a) #endif #define nothreadhook() Perl_nothreadhook(aTHX) #if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define do_trans_simple(a) S_do_trans_simple(aTHX_ a) #define do_trans_count(a) S_do_trans_count(aTHX_ a) #define do_trans_complex(a) S_do_trans_complex(aTHX_ a) #define do_trans_simple_utf8(a) S_do_trans_simple_utf8(aTHX_ a) #define do_trans_count_utf8(a) S_do_trans_count_utf8(aTHX_ a) #define do_trans_complex_utf8(a) S_do_trans_complex_utf8(aTHX_ a) #endif #endif #if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define gv_init_sv(a,b) S_gv_init_sv(aTHX_ a,b) #define gv_get_super_pkg(a,b) S_gv_get_super_pkg(aTHX_ a,b) #define require_tie_mod(a,b,c,d,e) S_require_tie_mod(aTHX_ a,b,c,d,e) #endif #endif #ifdef PERL_CORE #endif #if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define hsplit(a) S_hsplit(aTHX_ a) #define hfreeentries(a) S_hfreeentries(aTHX_ a) #define anonymise_cv(a,b) S_anonymise_cv(aTHX_ a,b) #define new_he() S_new_he(aTHX) #define save_hek_flags S_save_hek_flags #define hv_magic_check S_hv_magic_check #define unshare_hek_or_pvn(a,b,c,d) S_unshare_hek_or_pvn(aTHX_ a,b,c,d) #define share_hek_flags(a,b,c,d) S_share_hek_flags(aTHX_ a,b,c,d) #define hv_notallowed(a,b,c,d) S_hv_notallowed(aTHX_ a,b,c,d) #define hv_auxinit S_hv_auxinit #define hv_delete_common(a,b,c,d,e,f,g) S_hv_delete_common(aTHX_ a,b,c,d,e,f,g) #define clear_placeholders(a,b) S_clear_placeholders(aTHX_ a,b) #define refcounted_he_value(a) S_refcounted_he_value(aTHX_ a) #endif #endif #if defined(PERL_IN_MG_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define save_magic(a,b) S_save_magic(aTHX_ a,b) #define magic_methpack(a,b,c) S_magic_methpack(aTHX_ a,b,c) #define magic_methcall(a,b,c,d,e,f) S_magic_methcall(aTHX_ a,b,c,d,e,f) #define restore_magic(a) S_restore_magic(aTHX_ a) #define unwind_handler_stack(a) S_unwind_handler_stack(aTHX_ a) #endif #endif #if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define ck_anoncode(a) Perl_ck_anoncode(aTHX_ a) #define ck_bitop(a) Perl_ck_bitop(aTHX_ a) #define ck_concat(a) Perl_ck_concat(aTHX_ a) #define ck_defined(a) Perl_ck_defined(aTHX_ a) #define ck_delete(a) Perl_ck_delete(aTHX_ a) #define ck_die(a) Perl_ck_die(aTHX_ a) #define ck_eof(a) Perl_ck_eof(aTHX_ a) #define ck_eval(a) Perl_ck_eval(aTHX_ a) #define ck_exec(a) Perl_ck_exec(aTHX_ a) #define ck_exists(a) Perl_ck_exists(aTHX_ a) #define ck_exit(a) Perl_ck_exit(aTHX_ a) #define ck_ftst(a) Perl_ck_ftst(aTHX_ a) #define ck_fun(a) Perl_ck_fun(aTHX_ a) #define ck_glob(a) Perl_ck_glob(aTHX_ a) #define ck_grep(a) Perl_ck_grep(aTHX_ a) #define ck_index(a) Perl_ck_index(aTHX_ a) #define ck_join(a) Perl_ck_join(aTHX_ a) #define ck_lfun(a) Perl_ck_lfun(aTHX_ a) #define ck_listiob(a) Perl_ck_listiob(aTHX_ a) #define ck_match(a) Perl_ck_match(aTHX_ a) #define ck_method(a) Perl_ck_method(aTHX_ a) #define ck_null(a) Perl_ck_null(aTHX_ a) #define ck_open(a) Perl_ck_open(aTHX_ a) #define ck_readline(a) Perl_ck_readline(aTHX_ a) #define ck_repeat(a) Perl_ck_repeat(aTHX_ a) #define ck_require(a) Perl_ck_require(aTHX_ a) #define ck_return(a) Perl_ck_return(aTHX_ a) #define ck_rfun(a) Perl_ck_rfun(aTHX_ a) #define ck_rvconst(a) Perl_ck_rvconst(aTHX_ a) #define ck_sassign(a) Perl_ck_sassign(aTHX_ a) #define ck_select(a) Perl_ck_select(aTHX_ a) #define ck_shift(a) Perl_ck_shift(aTHX_ a) #define ck_sort(a) Perl_ck_sort(aTHX_ a) #define ck_spair(a) Perl_ck_spair(aTHX_ a) #define ck_split(a) Perl_ck_split(aTHX_ a) #define ck_subr(a) Perl_ck_subr(aTHX_ a) #define ck_substr(a) Perl_ck_substr(aTHX_ a) #define ck_svconst(a) Perl_ck_svconst(aTHX_ a) #define ck_trunc(a) Perl_ck_trunc(aTHX_ a) #define ck_unpack(a) Perl_ck_unpack(aTHX_ a) #define ck_each(a) Perl_ck_each(aTHX_ a) #define is_handle_constructor S_is_handle_constructor #define is_list_assignment(a) S_is_list_assignment(aTHX_ a) #endif # ifdef USE_ITHREADS #ifdef PERL_CORE #endif # else #ifdef PERL_CORE #endif # endif #ifdef PERL_CORE #define find_and_forget_pmops(a) S_find_and_forget_pmops(aTHX_ a) #define cop_free(a) S_cop_free(aTHX_ a) #define modkids(a,b) S_modkids(aTHX_ a,b) #define scalarboolean(a) S_scalarboolean(aTHX_ a) #define newDEFSVOP() S_newDEFSVOP(aTHX) #define search_const(a) S_search_const(aTHX_ a) #define new_logop(a,b,c,d) S_new_logop(aTHX_ a,b,c,d) #define simplify_sort(a) S_simplify_sort(aTHX_ a) #define gv_ename(a) S_gv_ename(aTHX_ a) #define scalar_mod_type S_scalar_mod_type #define my_kid(a,b,c) S_my_kid(aTHX_ a,b,c) #define dup_attrlist(a) S_dup_attrlist(aTHX_ a) #define apply_attrs(a,b,c,d) S_apply_attrs(aTHX_ a,b,c,d) #define apply_attrs_my(a,b,c,d) S_apply_attrs_my(aTHX_ a,b,c,d) #define bad_type(a,b,c,d) S_bad_type(aTHX_ a,b,c,d) #define no_bareword_allowed(a) S_no_bareword_allowed(aTHX_ a) #define no_fh_allowed(a) S_no_fh_allowed(aTHX_ a) #define too_few_arguments(a,b) S_too_few_arguments(aTHX_ a,b) #define too_many_arguments(a,b) S_too_many_arguments(aTHX_ a,b) #define looks_like_bool(a) S_looks_like_bool(aTHX_ a) #define newGIVWHENOP(a,b,c,d,e) S_newGIVWHENOP(aTHX_ a,b,c,d,e) #define ref_array_or_hash(a) S_ref_array_or_hash(aTHX_ a) #define process_special_blocks(a,b,c) S_process_special_blocks(aTHX_ a,b,c) #endif #endif #if defined(PL_OP_SLAB_ALLOC) #define Slab_Alloc(a) Perl_Slab_Alloc(aTHX_ a) #define Slab_Free(a) Perl_Slab_Free(aTHX_ a) # if defined(PERL_DEBUG_READONLY_OPS) #ifdef PERL_CORE #endif # if defined(PERL_IN_OP_C) #ifdef PERL_CORE #define Slab_to_rw(a) S_Slab_to_rw(aTHX_ a) #endif # endif # endif #endif #if defined(PERL_IN_PERL_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define find_beginning(a,b) S_find_beginning(aTHX_ a,b) #define forbid_setid(a,b) S_forbid_setid(aTHX_ a,b) #define incpush(a,b,c) S_incpush(aTHX_ a,b,c) #define incpush_use_sep(a,b,c) S_incpush_use_sep(aTHX_ a,b,c) #define init_interp() S_init_interp(aTHX) #define init_ids() S_init_ids(aTHX) #define init_main_stash() S_init_main_stash(aTHX) #define init_perllib() S_init_perllib(aTHX) #define init_postdump_symbols(a,b,c) S_init_postdump_symbols(aTHX_ a,b,c) #define init_predump_symbols() S_init_predump_symbols(aTHX) #define my_exit_jump() S_my_exit_jump(aTHX) #define nuke_stacks() S_nuke_stacks(aTHX) #define open_script(a,b,c,d) S_open_script(aTHX_ a,b,c,d) #define usage(a) S_usage(aTHX_ a) #endif #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW #ifdef PERL_CORE #endif #endif #ifdef PERL_CORE #define parse_body(a,b) S_parse_body(aTHX_ a,b) #define run_body(a) S_run_body(aTHX_ a) #define incpush_if_exists(a,b,c) S_incpush_if_exists(aTHX_ a,b,c) #endif #endif #if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define do_delete_local() S_do_delete_local(aTHX) #define refto(a) S_refto(aTHX_ a) #endif #endif #if defined(PERL_IN_PP_C) || defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #endif #endif #if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define unpack_rec(a,b,c,d,e) S_unpack_rec(aTHX_ a,b,c,d,e) #define pack_rec(a,b,c,d) S_pack_rec(aTHX_ a,b,c,d) #define mul128(a,b) S_mul128(aTHX_ a,b) #define measure_struct(a) S_measure_struct(aTHX_ a) #define next_symbol(a) S_next_symbol(aTHX_ a) #define is_an_int(a,b) S_is_an_int(aTHX_ a,b) #define div128(a,b) S_div128(aTHX_ a,b) #define group_end(a,b,c) S_group_end(aTHX_ a,b,c) #define get_num(a,b) S_get_num(aTHX_ a,b) #define need_utf8 S_need_utf8 #define first_symbol S_first_symbol #define sv_exp_grow(a,b) S_sv_exp_grow(aTHX_ a,b) #define bytes_to_uni S_bytes_to_uni #endif #endif #if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define docatch(a) S_docatch(aTHX_ a) #define dofindlabel(a,b,c,d) S_dofindlabel(aTHX_ a,b,c,d) #define doparseform(a) S_doparseform(aTHX_ a) #define num_overflow S_num_overflow #define dopoptoeval(a) S_dopoptoeval(aTHX_ a) #define dopoptogiven(a) S_dopoptogiven(aTHX_ a) #define dopoptolabel(a) S_dopoptolabel(aTHX_ a) #define dopoptoloop(a) S_dopoptoloop(aTHX_ a) #define dopoptosub_at(a,b) S_dopoptosub_at(aTHX_ a,b) #define dopoptowhen(a) S_dopoptowhen(aTHX_ a) #define save_lines(a,b) S_save_lines(aTHX_ a,b) #define doeval(a,b,c,d) S_doeval(aTHX_ a,b,c,d) #define check_type_and_open(a) S_check_type_and_open(aTHX_ a) #endif #ifndef PERL_DISABLE_PMC #ifdef PERL_CORE #define doopen_pm(a,b) S_doopen_pm(aTHX_ a,b) #endif #endif #ifdef PERL_CORE #define path_is_absolute S_path_is_absolute #define run_user_filter(a,b,c) S_run_user_filter(aTHX_ a,b,c) #define make_matcher(a) S_make_matcher(aTHX_ a) #define matcher_matches_sv(a,b) S_matcher_matches_sv(aTHX_ a,b) #define destroy_matcher(a) S_destroy_matcher(aTHX_ a) #define do_smartmatch(a,b) S_do_smartmatch(aTHX_ a,b) #endif #endif #if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define do_oddball(a,b,c) S_do_oddball(aTHX_ a,b,c) #define method_common(a,b) S_method_common(aTHX_ a,b) #endif #endif #if defined(PERL_IN_PP_SORT_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define sv_ncmp(a,b) S_sv_ncmp(aTHX_ a,b) #define sv_i_ncmp(a,b) S_sv_i_ncmp(aTHX_ a,b) #define amagic_ncmp(a,b) S_amagic_ncmp(aTHX_ a,b) #define amagic_i_ncmp(a,b) S_amagic_i_ncmp(aTHX_ a,b) #define amagic_cmp(a,b) S_amagic_cmp(aTHX_ a,b) #define amagic_cmp_locale(a,b) S_amagic_cmp_locale(aTHX_ a,b) #define sortcv(a,b) S_sortcv(aTHX_ a,b) #define sortcv_xsub(a,b) S_sortcv_xsub(aTHX_ a,b) #define sortcv_stacked(a,b) S_sortcv_stacked(aTHX_ a,b) #define qsortsvu(a,b,c) S_qsortsvu(aTHX_ a,b,c) #endif #endif #if defined(PERL_IN_PP_SYS_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define doform(a,b,c) S_doform(aTHX_ a,b,c) #endif # if !defined(HAS_MKDIR) || !defined(HAS_RMDIR) #ifdef PERL_CORE #define dooneliner(a,b) S_dooneliner(aTHX_ a,b) #endif # endif #ifdef PERL_CORE #define space_join_names_mortal(a) S_space_join_names_mortal(aTHX_ a) #endif #endif #if defined(PERL_IN_REGCOMP_C) || defined(PERL_DECL_PROT) #if defined(PERL_CORE) || defined(PERL_EXT) #define reg(a,b,c,d) S_reg(aTHX_ a,b,c,d) #define reganode(a,b,c) S_reganode(aTHX_ a,b,c) #define regatom(a,b,c) S_regatom(aTHX_ a,b,c) #define regbranch(a,b,c,d) S_regbranch(aTHX_ a,b,c,d) #define reguni(a,b,c) S_reguni(aTHX_ a,b,c) #define regclass(a,b) S_regclass(aTHX_ a,b) #define reg_node(a,b) S_reg_node(aTHX_ a,b) #define reg_recode(a,b) S_reg_recode(aTHX_ a,b) #define regpiece(a,b,c) S_regpiece(aTHX_ a,b,c) #define reg_namedseq(a,b,c) S_reg_namedseq(aTHX_ a,b,c) #define reginsert(a,b,c,d) S_reginsert(aTHX_ a,b,c,d) #define regtail(a,b,c,d) S_regtail(aTHX_ a,b,c,d) #define reg_scan_name(a,b) S_reg_scan_name(aTHX_ a,b) #define join_exact(a,b,c,d,e,f) S_join_exact(aTHX_ a,b,c,d,e,f) #define regwhite S_regwhite #define nextchar(a) S_nextchar(aTHX_ a) #define reg_skipcomment(a) S_reg_skipcomment(aTHX_ a) #define scan_commit(a,b,c,d) S_scan_commit(aTHX_ a,b,c,d) #define cl_anything S_cl_anything #define cl_is_anything S_cl_is_anything #define cl_init S_cl_init #define cl_init_zero S_cl_init_zero #define cl_and S_cl_and #define cl_or S_cl_or #define study_chunk(a,b,c,d,e,f,g,h,i,j,k) S_study_chunk(aTHX_ a,b,c,d,e,f,g,h,i,j,k) #define add_data S_add_data #endif #ifdef PERL_CORE #endif #if defined(PERL_CORE) || defined(PERL_EXT) #define regpposixcc(a,b) S_regpposixcc(aTHX_ a,b) #define checkposixcc(a) S_checkposixcc(aTHX_ a) #define make_trie(a,b,c,d,e,f,g,h) S_make_trie(aTHX_ a,b,c,d,e,f,g,h) #define make_trie_failtable(a,b,c,d) S_make_trie_failtable(aTHX_ a,b,c,d) #endif # ifdef DEBUGGING #if defined(PERL_CORE) || defined(PERL_EXT) #define regdump_extflags(a,b) S_regdump_extflags(aTHX_ a,b) #define dumpuntil(a,b,c,d,e,f,g,h) S_dumpuntil(aTHX_ a,b,c,d,e,f,g,h) #define put_byte(a,b) S_put_byte(aTHX_ a,b) #define dump_trie(a,b,c,d) S_dump_trie(aTHX_ a,b,c,d) #define dump_trie_interim_list(a,b,c,d,e) S_dump_trie_interim_list(aTHX_ a,b,c,d,e) #define dump_trie_interim_table(a,b,c,d,e) S_dump_trie_interim_table(aTHX_ a,b,c,d,e) #define regtail_study(a,b,c,d) S_regtail_study(aTHX_ a,b,c,d) #endif # endif #endif #if defined(PERL_IN_REGEXEC_C) || defined(PERL_DECL_PROT) #if defined(PERL_CORE) || defined(PERL_EXT) #define regmatch(a,b) S_regmatch(aTHX_ a,b) #define regrepeat(a,b,c,d) S_regrepeat(aTHX_ a,b,c,d) #define regtry(a,b) S_regtry(aTHX_ a,b) #define reginclass(a,b,c,d,e) S_reginclass(aTHX_ a,b,c,d,e) #define regcppush(a) S_regcppush(aTHX_ a) #define regcppop(a) S_regcppop(aTHX_ a) #define reghop3 S_reghop3 #endif #ifdef XXX_dmq #if defined(PERL_CORE) || defined(PERL_EXT) #define reghop4 S_reghop4 #endif #endif #if defined(PERL_CORE) || defined(PERL_EXT) #define reghopmaybe3 S_reghopmaybe3 #define find_byclass(a,b,c,d,e) S_find_byclass(aTHX_ a,b,c,d,e) #define to_utf8_substr(a) S_to_utf8_substr(aTHX_ a) #define to_byte_substr(a) S_to_byte_substr(aTHX_ a) #define reg_check_named_buff_matched(a,b) S_reg_check_named_buff_matched(aTHX_ a,b) #endif # ifdef DEBUGGING #if defined(PERL_CORE) || defined(PERL_EXT) #define dump_exec_pos(a,b,c,d,e,f) S_dump_exec_pos(aTHX_ a,b,c,d,e,f) #define debug_start_match(a,b,c,d,e) S_debug_start_match(aTHX_ a,b,c,d,e) #endif # endif #endif #if defined(PERL_IN_DUMP_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define deb_curcv(a) S_deb_curcv(aTHX_ a) #define debprof(a) S_debprof(aTHX_ a) #define sequence(a) S_sequence(aTHX_ a) #define sequence_tail(a) S_sequence_tail(aTHX_ a) #define sequence_num(a) S_sequence_num(aTHX_ a) #define pm_description(a) S_pm_description(aTHX_ a) #endif #endif #if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define save_scalar_at(a,b) S_save_scalar_at(aTHX_ a,b) #endif #endif #if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #endif #endif #if defined(PERL_IN_HV_C) || defined(PERL_IN_MG_C) || defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #endif #endif #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define uiv_2buf S_uiv_2buf #define sv_unglob(a) S_sv_unglob(aTHX_ a) #define not_a_number(a) S_not_a_number(aTHX_ a) #define visit(a,b,c) S_visit(aTHX_ a,b,c) #define sv_del_backref(a,b) S_sv_del_backref(aTHX_ a,b) #define varname(a,b,c,d,e,f) S_varname(aTHX_ a,b,c,d,e,f) #endif # ifdef DEBUGGING #ifdef PERL_CORE #define del_sv(a) S_del_sv(aTHX_ a) #endif # endif # if !defined(NV_PRESERVES_UV) # ifdef DEBUGGING #ifdef PERL_CORE #define sv_2iuv_non_preserve(a,b) S_sv_2iuv_non_preserve(aTHX_ a,b) #endif # else #ifdef PERL_CORE #define sv_2iuv_non_preserve(a) S_sv_2iuv_non_preserve(aTHX_ a) #endif # endif # endif #ifdef PERL_CORE #define expect_number(a) S_expect_number(aTHX_ a) #endif #ifdef PERL_CORE #define sv_pos_u2b_forwards S_sv_pos_u2b_forwards #define sv_pos_u2b_midway S_sv_pos_u2b_midway #define sv_pos_u2b_cached(a,b,c,d,e,f,g) S_sv_pos_u2b_cached(aTHX_ a,b,c,d,e,f,g) #define utf8_mg_pos_cache_update(a,b,c,d,e) S_utf8_mg_pos_cache_update(aTHX_ a,b,c,d,e) #define sv_pos_b2u_midway(a,b,c,d) S_sv_pos_b2u_midway(aTHX_ a,b,c,d) #define F0convert S_F0convert #endif # if defined(PERL_OLD_COPY_ON_WRITE) #ifdef PERL_CORE #define sv_release_COW(a,b,c) S_sv_release_COW(aTHX_ a,b,c) #endif # endif #ifdef PERL_CORE #define more_sv() S_more_sv(aTHX) #define more_bodies(a) S_more_bodies(aTHX_ a) #define sv_2iuv_common(a) S_sv_2iuv_common(aTHX_ a) #define glob_assign_glob(a,b,c) S_glob_assign_glob(aTHX_ a,b,c) #define glob_assign_ref(a,b) S_glob_assign_ref(aTHX_ a,b) #define ptr_table_find S_ptr_table_find #endif #endif #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define check_uni() S_check_uni(aTHX) #define force_next(a) S_force_next(aTHX_ a) #define force_version(a,b) S_force_version(aTHX_ a,b) #define force_strict_version(a) S_force_strict_version(aTHX_ a) #define force_word(a,b,c,d,e) S_force_word(aTHX_ a,b,c,d,e) #define tokeq(a) S_tokeq(aTHX_ a) #define readpipe_override() S_readpipe_override(aTHX) #define scan_const(a) S_scan_const(aTHX_ a) #define scan_formline(a) S_scan_formline(aTHX_ a) #define scan_heredoc(a) S_scan_heredoc(aTHX_ a) #define scan_ident(a,b,c,d,e) S_scan_ident(aTHX_ a,b,c,d,e) #define scan_inputsymbol(a) S_scan_inputsymbol(aTHX_ a) #define scan_pat(a,b) S_scan_pat(aTHX_ a,b) #define scan_str(a,b,c) S_scan_str(aTHX_ a,b,c) #define scan_subst(a) S_scan_subst(aTHX_ a) #define scan_trans(a) S_scan_trans(aTHX_ a) #define scan_word(a,b,c,d,e) S_scan_word(aTHX_ a,b,c,d,e) #define update_debugger_info(a,b,c) S_update_debugger_info(aTHX_ a,b,c) #define skipspace(a) S_skipspace(aTHX_ a) #define swallow_bom(a) S_swallow_bom(aTHX_ a) #endif #ifndef PERL_NO_UTF16_FILTER #ifdef PERL_CORE #define utf16_textfilter(a,b,c) S_utf16_textfilter(aTHX_ a,b,c) #define add_utf16_textfilter(a,b) S_add_utf16_textfilter(aTHX_ a,b) #endif #endif #ifdef PERL_CORE #define checkcomma(a,b,c) S_checkcomma(aTHX_ a,b,c) #define feature_is_enabled(a,b) S_feature_is_enabled(aTHX_ a,b) #define force_ident(a,b) S_force_ident(aTHX_ a,b) #define incline(a) S_incline(aTHX_ a) #define intuit_method(a,b,c) S_intuit_method(aTHX_ a,b,c) #define intuit_more(a) S_intuit_more(aTHX_ a) #define lop(a,b,c) S_lop(aTHX_ a,b,c) #define missingterm(a) S_missingterm(aTHX_ a) #define no_op(a,b) S_no_op(aTHX_ a,b) #define sublex_done() S_sublex_done(aTHX) #define sublex_push() S_sublex_push(aTHX) #define sublex_start() S_sublex_start(aTHX) #define filter_gets(a,b) S_filter_gets(aTHX_ a,b) #define find_in_my_stash(a,b) S_find_in_my_stash(aTHX_ a,b) #define tokenize_use(a,b) S_tokenize_use(aTHX_ a,b) #define deprecate_commaless_var_list() S_deprecate_commaless_var_list(aTHX) #define ao(a) S_ao(aTHX_ a) #endif # if defined(PERL_CR_FILTER) #ifdef PERL_CORE #define cr_textfilter(a,b,c) S_cr_textfilter(aTHX_ a,b,c) #define strip_return(a) S_strip_return(aTHX_ a) #endif # endif # if defined(DEBUGGING) #ifdef PERL_CORE #define tokereport(a,b) S_tokereport(aTHX_ a,b) #define printbuf(a,b) S_printbuf(aTHX_ a,b) #endif # endif #endif #if defined(PERL_IN_UNIVERSAL_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define isa_lookup(a,b) S_isa_lookup(aTHX_ a,b) #endif #endif #if defined(PERL_IN_LOCALE_C) || defined(PERL_DECL_PROT) #if defined(USE_LOCALE_NUMERIC) || defined(USE_LOCALE_COLLATE) #ifdef PERL_CORE #define stdize_locale(a) S_stdize_locale(aTHX_ a) #endif #endif #endif #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define closest_cop(a,b) S_closest_cop(aTHX_ a,b) #define mess_alloc() S_mess_alloc(aTHX) #define vdie_croak_common(a,b) S_vdie_croak_common(aTHX_ a,b) #define vdie_common(a,b) S_vdie_common(aTHX_ a,b) #define write_no_mem() S_write_no_mem(aTHX) #endif #if defined(PERL_MEM_LOG) && !defined(PERL_MEM_LOG_NOIMPL) #ifdef PERL_CORE #define mem_log_common S_mem_log_common #endif #endif #endif #if defined(PERL_IN_NUMERIC_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define mulexp10 S_mulexp10 #endif #endif #if defined(PERL_IN_UTF8_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define is_utf8_char_slow S_is_utf8_char_slow #define is_utf8_common(a,b,c) S_is_utf8_common(aTHX_ a,b,c) #define swash_get(a,b,c) S_swash_get(aTHX_ a,b,c) #endif #endif #define sv_setsv_flags(a,b,c) Perl_sv_setsv_flags(aTHX_ a,b,c) #define sv_catpvn_flags(a,b,c,d) Perl_sv_catpvn_flags(aTHX_ a,b,c,d) #define sv_catsv_flags(a,b,c) Perl_sv_catsv_flags(aTHX_ a,b,c) #define sv_utf8_upgrade_flags_grow(a,b,c) Perl_sv_utf8_upgrade_flags_grow(aTHX_ a,b,c) #define sv_pvn_force_flags(a,b,c) Perl_sv_pvn_force_flags(aTHX_ a,b,c) #define sv_copypv(a,b) Perl_sv_copypv(aTHX_ a,b) #define my_atof2(a,b) Perl_my_atof2(aTHX_ a,b) #define my_socketpair Perl_my_socketpair #define my_dirfd(a) Perl_my_dirfd(aTHX_ a) #ifdef PERL_OLD_COPY_ON_WRITE #if defined(PERL_CORE) || defined(PERL_EXT) #define sv_setsv_cow(a,b) Perl_sv_setsv_cow(aTHX_ a,b) #endif #endif #if defined(USE_PERLIO) && !defined(USE_SFIO) #define PerlIO_close(a) Perl_PerlIO_close(aTHX_ a) #define PerlIO_fill(a) Perl_PerlIO_fill(aTHX_ a) #define PerlIO_fileno(a) Perl_PerlIO_fileno(aTHX_ a) #define PerlIO_eof(a) Perl_PerlIO_eof(aTHX_ a) #define PerlIO_error(a) Perl_PerlIO_error(aTHX_ a) #define PerlIO_flush(a) Perl_PerlIO_flush(aTHX_ a) #define PerlIO_clearerr(a) Perl_PerlIO_clearerr(aTHX_ a) #define PerlIO_set_cnt(a,b) Perl_PerlIO_set_cnt(aTHX_ a,b) #define PerlIO_set_ptrcnt(a,b,c) Perl_PerlIO_set_ptrcnt(aTHX_ a,b,c) #define PerlIO_setlinebuf(a) Perl_PerlIO_setlinebuf(aTHX_ a) #define PerlIO_read(a,b,c) Perl_PerlIO_read(aTHX_ a,b,c) #define PerlIO_write(a,b,c) Perl_PerlIO_write(aTHX_ a,b,c) #define PerlIO_unread(a,b,c) Perl_PerlIO_unread(aTHX_ a,b,c) #define PerlIO_tell(a) Perl_PerlIO_tell(aTHX_ a) #define PerlIO_seek(a,b,c) Perl_PerlIO_seek(aTHX_ a,b,c) #define PerlIO_get_base(a) Perl_PerlIO_get_base(aTHX_ a) #define PerlIO_get_ptr(a) Perl_PerlIO_get_ptr(aTHX_ a) #define PerlIO_get_bufsiz(a) Perl_PerlIO_get_bufsiz(aTHX_ a) #define PerlIO_get_cnt(a) Perl_PerlIO_get_cnt(aTHX_ a) #define PerlIO_stdin() Perl_PerlIO_stdin(aTHX) #define PerlIO_stdout() Perl_PerlIO_stdout(aTHX) #define PerlIO_stderr() Perl_PerlIO_stderr(aTHX) #endif /* PERLIO_LAYERS */ #ifdef PERL_CORE #define deb_stack_all() Perl_deb_stack_all(aTHX) #endif #if defined(PERL_IN_DEB_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define deb_stack_n(a,b,c,d,e) S_deb_stack_n(aTHX_ a,b,c,d,e) #endif #endif #ifdef PERL_CORE #define pad_new(a) Perl_pad_new(aTHX_ a) #define pad_undef(a) Perl_pad_undef(aTHX_ a) #define pad_add_name(a,b,c,d,e) Perl_pad_add_name(aTHX_ a,b,c,d,e) #define pad_add_anon(a,b) Perl_pad_add_anon(aTHX_ a,b) #endif #if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define pad_check_dup(a,b,c) S_pad_check_dup(aTHX_ a,b,c) #endif #endif #ifdef DEBUGGING #ifdef PERL_CORE #define pad_setsv(a,b) Perl_pad_setsv(aTHX_ a,b) #endif #endif #ifdef PERL_CORE #define pad_block_start(a) Perl_pad_block_start(aTHX_ a) #define pad_tidy(a) Perl_pad_tidy(aTHX_ a) #define do_dump_pad(a,b,c,d) Perl_do_dump_pad(aTHX_ a,b,c,d) #define pad_fixup_inner_anons(a,b,c) Perl_pad_fixup_inner_anons(aTHX_ a,b,c) #endif #ifdef PERL_CORE #define pad_push(a,b) Perl_pad_push(aTHX_ a,b) #define pad_compname_type(a) Perl_pad_compname_type(aTHX_ a) #endif #if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define pad_findlex(a,b,c,d,e,f,g) S_pad_findlex(aTHX_ a,b,c,d,e,f,g) #define pad_add_name_sv(a,b,c,d) S_pad_add_name_sv(aTHX_ a,b,c,d) #endif # if defined(DEBUGGING) #ifdef PERL_CORE #define cv_dump(a,b) S_cv_dump(aTHX_ a,b) #endif # endif #endif #define find_runcv(a) Perl_find_runcv(aTHX_ a) #ifdef PERL_CORE #define free_tied_hv_pool() Perl_free_tied_hv_pool(aTHX) #endif #if defined(DEBUGGING) #ifdef PERL_CORE #define get_debug_opts(a,b) Perl_get_debug_opts(aTHX_ a,b) #endif #endif #define save_set_svflags(a,b,c) Perl_save_set_svflags(aTHX_ a,b,c) #ifdef DEBUGGING #endif #define hv_scalar(a) Perl_hv_scalar(aTHX_ a) #define hv_name_set(a,b,c,d) Perl_hv_name_set(aTHX_ a,b,c,d) #ifdef PERL_CORE #endif #if defined(PERL_IN_DUMP_C) || defined(PERL_IN_HV_C) || defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #endif #endif #define hv_clear_placeholders(a) Perl_hv_clear_placeholders(aTHX_ a) #ifdef PERL_CORE #define magic_scalarpack(a,b) Perl_magic_scalarpack(aTHX_ a,b) #endif #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define find_hash_subscript(a,b) S_find_hash_subscript(aTHX_ a,b) #define find_array_subscript(a,b) S_find_array_subscript(aTHX_ a,b) #define find_uninit_var(a,b,c) S_find_uninit_var(aTHX_ a,b,c) #endif #endif #ifdef PERL_NEED_MY_HTOLE16 #ifdef PERL_CORE #define my_htole16 Perl_my_htole16 #endif #endif #ifdef PERL_NEED_MY_LETOH16 #ifdef PERL_CORE #define my_letoh16 Perl_my_letoh16 #endif #endif #ifdef PERL_NEED_MY_HTOBE16 #ifdef PERL_CORE #define my_htobe16 Perl_my_htobe16 #endif #endif #ifdef PERL_NEED_MY_BETOH16 #ifdef PERL_CORE #define my_betoh16 Perl_my_betoh16 #endif #endif #ifdef PERL_NEED_MY_HTOLE32 #ifdef PERL_CORE #define my_htole32 Perl_my_htole32 #endif #endif #ifdef PERL_NEED_MY_LETOH32 #ifdef PERL_CORE #define my_letoh32 Perl_my_letoh32 #endif #endif #ifdef PERL_NEED_MY_HTOBE32 #ifdef PERL_CORE #define my_htobe32 Perl_my_htobe32 #endif #endif #ifdef PERL_NEED_MY_BETOH32 #ifdef PERL_CORE #define my_betoh32 Perl_my_betoh32 #endif #endif #ifdef PERL_NEED_MY_HTOLE64 #ifdef PERL_CORE #define my_htole64 Perl_my_htole64 #endif #endif #ifdef PERL_NEED_MY_LETOH64 #ifdef PERL_CORE #define my_letoh64 Perl_my_letoh64 #endif #endif #ifdef PERL_NEED_MY_HTOBE64 #ifdef PERL_CORE #define my_htobe64 Perl_my_htobe64 #endif #endif #ifdef PERL_NEED_MY_BETOH64 #ifdef PERL_CORE #define my_betoh64 Perl_my_betoh64 #endif #endif #ifdef PERL_NEED_MY_HTOLES #ifdef PERL_CORE #define my_htoles Perl_my_htoles #endif #endif #ifdef PERL_NEED_MY_LETOHS #ifdef PERL_CORE #define my_letohs Perl_my_letohs #endif #endif #ifdef PERL_NEED_MY_HTOBES #ifdef PERL_CORE #define my_htobes Perl_my_htobes #endif #endif #ifdef PERL_NEED_MY_BETOHS #ifdef PERL_CORE #define my_betohs Perl_my_betohs #endif #endif #ifdef PERL_NEED_MY_HTOLEI #ifdef PERL_CORE #define my_htolei Perl_my_htolei #endif #endif #ifdef PERL_NEED_MY_LETOHI #ifdef PERL_CORE #define my_letohi Perl_my_letohi #endif #endif #ifdef PERL_NEED_MY_HTOBEI #ifdef PERL_CORE #define my_htobei Perl_my_htobei #endif #endif #ifdef PERL_NEED_MY_BETOHI #ifdef PERL_CORE #define my_betohi Perl_my_betohi #endif #endif #ifdef PERL_NEED_MY_HTOLEL #ifdef PERL_CORE #define my_htolel Perl_my_htolel #endif #endif #ifdef PERL_NEED_MY_LETOHL #ifdef PERL_CORE #define my_letohl Perl_my_letohl #endif #endif #ifdef PERL_NEED_MY_HTOBEL #ifdef PERL_CORE #define my_htobel Perl_my_htobel #endif #endif #ifdef PERL_NEED_MY_BETOHL #ifdef PERL_CORE #define my_betohl Perl_my_betohl #endif #endif #ifdef PERL_CORE #define my_swabn Perl_my_swabn #endif #define gv_fetchpvn_flags(a,b,c,d) Perl_gv_fetchpvn_flags(aTHX_ a,b,c,d) #define gv_fetchsv(a,b,c) Perl_gv_fetchsv(aTHX_ a,b,c) #ifdef PERL_CORE #define is_gv_magical_sv(a,b) Perl_is_gv_magical_sv(aTHX_ a,b) #endif #define stashpv_hvname_match(a,b) Perl_stashpv_hvname_match(aTHX_ a,b) #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP #ifdef PERL_CORE #define dump_sv_child(a) Perl_dump_sv_child(aTHX_ a) #endif #endif #ifdef PERL_DONT_CREATE_GVSV #endif #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define ckwarn_common(a) S_ckwarn_common(aTHX_ a) #endif #endif #if defined(PERL_CORE) || defined(PERL_EXT) #endif #ifdef PERL_CORE #define offer_nice_chunk(a,b) Perl_offer_nice_chunk(aTHX_ a,b) #endif #ifndef SPRINTF_RETURNS_STRLEN #endif #ifdef PERL_CORE #define my_clearenv() Perl_my_clearenv(aTHX) #endif #ifdef PERL_IMPLICIT_CONTEXT #ifdef PERL_GLOBAL_STRUCT_PRIVATE #else #endif #endif #ifndef HAS_STRLCAT #endif #ifndef HAS_STRLCPY #endif #ifdef PERL_MAD #ifdef PERL_CORE #define pad_peg Perl_pad_peg #endif #if defined(PERL_IN_DUMP_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #endif #endif #ifdef PERL_CORE #define xmldump_vindent(a,b,c,d) Perl_xmldump_vindent(aTHX_ a,b,c,d) #define xmldump_all() Perl_xmldump_all(aTHX) #define xmldump_all_perl(a) Perl_xmldump_all_perl(aTHX_ a) #define xmldump_packsubs(a) Perl_xmldump_packsubs(aTHX_ a) #define xmldump_packsubs_perl(a,b) Perl_xmldump_packsubs_perl(aTHX_ a,b) #define xmldump_sub(a) Perl_xmldump_sub(aTHX_ a) #define xmldump_sub_perl(a,b) Perl_xmldump_sub_perl(aTHX_ a,b) #define xmldump_form(a) Perl_xmldump_form(aTHX_ a) #define xmldump_eval() Perl_xmldump_eval(aTHX) #define sv_catxmlsv(a,b) Perl_sv_catxmlsv(aTHX_ a,b) #define sv_catxmlpvn(a,b,c,d) Perl_sv_catxmlpvn(aTHX_ a,b,c,d) #define sv_xmlpeek(a) Perl_sv_xmlpeek(aTHX_ a) #define do_pmop_xmldump(a,b,c) Perl_do_pmop_xmldump(aTHX_ a,b,c) #define pmop_xmldump(a) Perl_pmop_xmldump(aTHX_ a) #define do_op_xmldump(a,b,c) Perl_do_op_xmldump(aTHX_ a,b,c) #define op_xmldump(a) Perl_op_xmldump(aTHX_ a) #endif #ifdef PERL_CORE #define newTOKEN(a,b,c) Perl_newTOKEN(aTHX_ a,b,c) #define token_free(a) Perl_token_free(aTHX_ a) #define token_getmad(a,b,c) Perl_token_getmad(aTHX_ a,b,c) #define op_getmad_weak(a,b,c) Perl_op_getmad_weak(aTHX_ a,b,c) #define op_getmad(a,b,c) Perl_op_getmad(aTHX_ a,b,c) #define prepend_madprops(a,b,c) Perl_prepend_madprops(aTHX_ a,b,c) #define append_madprops(a,b,c) Perl_append_madprops(aTHX_ a,b,c) #define addmad(a,b,c) Perl_addmad(aTHX_ a,b,c) #define newMADsv(a,b) Perl_newMADsv(aTHX_ a,b) #define newMADPROP(a,b,c,d) Perl_newMADPROP(aTHX_ a,b,c,d) #define mad_free(a) Perl_mad_free(aTHX_ a) #endif # if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define skipspace0(a) S_skipspace0(aTHX_ a) #define skipspace1(a) S_skipspace1(aTHX_ a) #define skipspace2(a,b) S_skipspace2(aTHX_ a,b) #define start_force(a) S_start_force(aTHX_ a) #define curmad(a,b) S_curmad(aTHX_ a,b) #endif # endif #ifdef PERL_CORE #define madlex() Perl_madlex(aTHX) #define madparse() Perl_madparse(aTHX) #endif #endif #if !defined(HAS_SIGNBIT) #endif #if defined(PERL_CORE) || defined(PERL_EXT) #endif #ifdef PERL_CORE #endif #if defined(USE_ITHREADS) #ifdef PERL_CORE #define mro_meta_dup(a,b) Perl_mro_meta_dup(aTHX_ a,b) #endif #endif #define mro_get_linear_isa(a) Perl_mro_get_linear_isa(aTHX_ a) #if defined(PERL_IN_MRO_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define mro_get_linear_isa_dfs(a,b) S_mro_get_linear_isa_dfs(aTHX_ a,b) #endif #endif #ifdef PERL_CORE #define mro_isa_changed_in(a) Perl_mro_isa_changed_in(aTHX_ a) #endif #define mro_method_changed_in(a) Perl_mro_method_changed_in(aTHX_ a) #ifdef PERL_CORE #define boot_core_mro() Perl_boot_core_mro(aTHX) #endif #ifdef PERL_CORE #endif #ifdef PERL_CORE #endif #define ck_anoncode(a) Perl_ck_anoncode(aTHX_ a) #define ck_bitop(a) Perl_ck_bitop(aTHX_ a) #define ck_chdir(a) Perl_ck_chdir(aTHX_ a) #define ck_concat(a) Perl_ck_concat(aTHX_ a) #define ck_defined(a) Perl_ck_defined(aTHX_ a) #define ck_delete(a) Perl_ck_delete(aTHX_ a) #define ck_die(a) Perl_ck_die(aTHX_ a) #define ck_each(a) Perl_ck_each(aTHX_ a) #define ck_eof(a) Perl_ck_eof(aTHX_ a) #define ck_eval(a) Perl_ck_eval(aTHX_ a) #define ck_exec(a) Perl_ck_exec(aTHX_ a) #define ck_exists(a) Perl_ck_exists(aTHX_ a) #define ck_exit(a) Perl_ck_exit(aTHX_ a) #define ck_ftst(a) Perl_ck_ftst(aTHX_ a) #define ck_fun(a) Perl_ck_fun(aTHX_ a) #define ck_glob(a) Perl_ck_glob(aTHX_ a) #define ck_grep(a) Perl_ck_grep(aTHX_ a) #define ck_index(a) Perl_ck_index(aTHX_ a) #define ck_join(a) Perl_ck_join(aTHX_ a) #define ck_lfun(a) Perl_ck_lfun(aTHX_ a) #define ck_listiob(a) Perl_ck_listiob(aTHX_ a) #define ck_match(a) Perl_ck_match(aTHX_ a) #define ck_method(a) Perl_ck_method(aTHX_ a) #define ck_null(a) Perl_ck_null(aTHX_ a) #define ck_open(a) Perl_ck_open(aTHX_ a) #define ck_readline(a) Perl_ck_readline(aTHX_ a) #define ck_repeat(a) Perl_ck_repeat(aTHX_ a) #define ck_require(a) Perl_ck_require(aTHX_ a) #define ck_return(a) Perl_ck_return(aTHX_ a) #define ck_rfun(a) Perl_ck_rfun(aTHX_ a) #define ck_rvconst(a) Perl_ck_rvconst(aTHX_ a) #define ck_sassign(a) Perl_ck_sassign(aTHX_ a) #define ck_select(a) Perl_ck_select(aTHX_ a) #define ck_shift(a) Perl_ck_shift(aTHX_ a) #define ck_smartmatch(a) Perl_ck_smartmatch(aTHX_ a) #define ck_sort(a) Perl_ck_sort(aTHX_ a) #define ck_spair(a) Perl_ck_spair(aTHX_ a) #define ck_split(a) Perl_ck_split(aTHX_ a) #define ck_subr(a) Perl_ck_subr(aTHX_ a) #define ck_substr(a) Perl_ck_substr(aTHX_ a) #define ck_svconst(a) Perl_ck_svconst(aTHX_ a) #define ck_trunc(a) Perl_ck_trunc(aTHX_ a) #define ck_unpack(a) Perl_ck_unpack(aTHX_ a) #define pp_aassign() Perl_pp_aassign(aTHX) #define pp_abs() Perl_pp_abs(aTHX) #define pp_accept() Perl_pp_accept(aTHX) #define pp_add() Perl_pp_add(aTHX) #define pp_aeach() Perl_pp_aeach(aTHX) #define pp_aelem() Perl_pp_aelem(aTHX) #define pp_aelemfast() Perl_pp_aelemfast(aTHX) #define pp_akeys() Perl_pp_akeys(aTHX) #define pp_alarm() Perl_pp_alarm(aTHX) #define pp_and() Perl_pp_and(aTHX) #define pp_andassign() Perl_pp_andassign(aTHX) #define pp_anoncode() Perl_pp_anoncode(aTHX) #define pp_anonhash() Perl_pp_anonhash(aTHX) #define pp_anonlist() Perl_pp_anonlist(aTHX) #define pp_aslice() Perl_pp_aslice(aTHX) #define pp_atan2() Perl_pp_atan2(aTHX) #define pp_av2arylen() Perl_pp_av2arylen(aTHX) #define pp_avalues() Perl_pp_avalues(aTHX) #define pp_backtick() Perl_pp_backtick(aTHX) #define pp_bind() Perl_pp_bind(aTHX) #define pp_binmode() Perl_pp_binmode(aTHX) #define pp_bit_and() Perl_pp_bit_and(aTHX) #define pp_bit_or() Perl_pp_bit_or(aTHX) #define pp_bit_xor() Perl_pp_bit_xor(aTHX) #define pp_bless() Perl_pp_bless(aTHX) #define pp_boolkeys() Perl_pp_boolkeys(aTHX) #define pp_break() Perl_pp_break(aTHX) #define pp_caller() Perl_pp_caller(aTHX) #define pp_chdir() Perl_pp_chdir(aTHX) #define pp_chmod() Perl_pp_chmod(aTHX) #define pp_chomp() Perl_pp_chomp(aTHX) #define pp_chop() Perl_pp_chop(aTHX) #define pp_chown() Perl_pp_chown(aTHX) #define pp_chr() Perl_pp_chr(aTHX) #define pp_chroot() Perl_pp_chroot(aTHX) #define pp_close() Perl_pp_close(aTHX) #define pp_closedir() Perl_pp_closedir(aTHX) #define pp_complement() Perl_pp_complement(aTHX) #define pp_concat() Perl_pp_concat(aTHX) #define pp_cond_expr() Perl_pp_cond_expr(aTHX) #define pp_connect() Perl_pp_connect(aTHX) #define pp_const() Perl_pp_const(aTHX) #define pp_continue() Perl_pp_continue(aTHX) #define pp_cos() Perl_pp_cos(aTHX) #define pp_crypt() Perl_pp_crypt(aTHX) #define pp_dbmclose() Perl_pp_dbmclose(aTHX) #define pp_dbmopen() Perl_pp_dbmopen(aTHX) #define pp_dbstate() Perl_pp_dbstate(aTHX) #define pp_defined() Perl_pp_defined(aTHX) #define pp_delete() Perl_pp_delete(aTHX) #define pp_die() Perl_pp_die(aTHX) #define pp_divide() Perl_pp_divide(aTHX) #define pp_dofile() Perl_pp_dofile(aTHX) #define pp_dor() Perl_pp_dor(aTHX) #define pp_dorassign() Perl_pp_dorassign(aTHX) #define pp_dump() Perl_pp_dump(aTHX) #define pp_each() Perl_pp_each(aTHX) #define pp_egrent() Perl_pp_egrent(aTHX) #define pp_ehostent() Perl_pp_ehostent(aTHX) #define pp_enetent() Perl_pp_enetent(aTHX) #define pp_enter() Perl_pp_enter(aTHX) #define pp_entereval() Perl_pp_entereval(aTHX) #define pp_entergiven() Perl_pp_entergiven(aTHX) #define pp_enteriter() Perl_pp_enteriter(aTHX) #define pp_enterloop() Perl_pp_enterloop(aTHX) #define pp_entersub() Perl_pp_entersub(aTHX) #define pp_entertry() Perl_pp_entertry(aTHX) #define pp_enterwhen() Perl_pp_enterwhen(aTHX) #define pp_enterwrite() Perl_pp_enterwrite(aTHX) #define pp_eof() Perl_pp_eof(aTHX) #define pp_eprotoent() Perl_pp_eprotoent(aTHX) #define pp_epwent() Perl_pp_epwent(aTHX) #define pp_eq() Perl_pp_eq(aTHX) #define pp_eservent() Perl_pp_eservent(aTHX) #define pp_exec() Perl_pp_exec(aTHX) #define pp_exists() Perl_pp_exists(aTHX) #define pp_exit() Perl_pp_exit(aTHX) #define pp_exp() Perl_pp_exp(aTHX) #define pp_fcntl() Perl_pp_fcntl(aTHX) #define pp_fileno() Perl_pp_fileno(aTHX) #define pp_flip() Perl_pp_flip(aTHX) #define pp_flock() Perl_pp_flock(aTHX) #define pp_flop() Perl_pp_flop(aTHX) #define pp_fork() Perl_pp_fork(aTHX) #define pp_formline() Perl_pp_formline(aTHX) #define pp_ftatime() Perl_pp_ftatime(aTHX) #define pp_ftbinary() Perl_pp_ftbinary(aTHX) #define pp_ftblk() Perl_pp_ftblk(aTHX) #define pp_ftchr() Perl_pp_ftchr(aTHX) #define pp_ftctime() Perl_pp_ftctime(aTHX) #define pp_ftdir() Perl_pp_ftdir(aTHX) #define pp_fteexec() Perl_pp_fteexec(aTHX) #define pp_fteowned() Perl_pp_fteowned(aTHX) #define pp_fteread() Perl_pp_fteread(aTHX) #define pp_ftewrite() Perl_pp_ftewrite(aTHX) #define pp_ftfile() Perl_pp_ftfile(aTHX) #define pp_ftis() Perl_pp_ftis(aTHX) #define pp_ftlink() Perl_pp_ftlink(aTHX) #define pp_ftmtime() Perl_pp_ftmtime(aTHX) #define pp_ftpipe() Perl_pp_ftpipe(aTHX) #define pp_ftrexec() Perl_pp_ftrexec(aTHX) #define pp_ftrowned() Perl_pp_ftrowned(aTHX) #define pp_ftrread() Perl_pp_ftrread(aTHX) #define pp_ftrwrite() Perl_pp_ftrwrite(aTHX) #define pp_ftsgid() Perl_pp_ftsgid(aTHX) #define pp_ftsize() Perl_pp_ftsize(aTHX) #define pp_ftsock() Perl_pp_ftsock(aTHX) #define pp_ftsuid() Perl_pp_ftsuid(aTHX) #define pp_ftsvtx() Perl_pp_ftsvtx(aTHX) #define pp_fttext() Perl_pp_fttext(aTHX) #define pp_fttty() Perl_pp_fttty(aTHX) #define pp_ftzero() Perl_pp_ftzero(aTHX) #define pp_ge() Perl_pp_ge(aTHX) #define pp_gelem() Perl_pp_gelem(aTHX) #define pp_getc() Perl_pp_getc(aTHX) #define pp_getlogin() Perl_pp_getlogin(aTHX) #define pp_getpeername() Perl_pp_getpeername(aTHX) #define pp_getpgrp() Perl_pp_getpgrp(aTHX) #define pp_getppid() Perl_pp_getppid(aTHX) #define pp_getpriority() Perl_pp_getpriority(aTHX) #define pp_getsockname() Perl_pp_getsockname(aTHX) #define pp_ggrent() Perl_pp_ggrent(aTHX) #define pp_ggrgid() Perl_pp_ggrgid(aTHX) #define pp_ggrnam() Perl_pp_ggrnam(aTHX) #define pp_ghbyaddr() Perl_pp_ghbyaddr(aTHX) #define pp_ghbyname() Perl_pp_ghbyname(aTHX) #define pp_ghostent() Perl_pp_ghostent(aTHX) #define pp_glob() Perl_pp_glob(aTHX) #define pp_gmtime() Perl_pp_gmtime(aTHX) #define pp_gnbyaddr() Perl_pp_gnbyaddr(aTHX) #define pp_gnbyname() Perl_pp_gnbyname(aTHX) #define pp_gnetent() Perl_pp_gnetent(aTHX) #define pp_goto() Perl_pp_goto(aTHX) #define pp_gpbyname() Perl_pp_gpbyname(aTHX) #define pp_gpbynumber() Perl_pp_gpbynumber(aTHX) #define pp_gprotoent() Perl_pp_gprotoent(aTHX) #define pp_gpwent() Perl_pp_gpwent(aTHX) #define pp_gpwnam() Perl_pp_gpwnam(aTHX) #define pp_gpwuid() Perl_pp_gpwuid(aTHX) #define pp_grepstart() Perl_pp_grepstart(aTHX) #define pp_grepwhile() Perl_pp_grepwhile(aTHX) #define pp_gsbyname() Perl_pp_gsbyname(aTHX) #define pp_gsbyport() Perl_pp_gsbyport(aTHX) #define pp_gservent() Perl_pp_gservent(aTHX) #define pp_gsockopt() Perl_pp_gsockopt(aTHX) #define pp_gt() Perl_pp_gt(aTHX) #define pp_gv() Perl_pp_gv(aTHX) #define pp_gvsv() Perl_pp_gvsv(aTHX) #define pp_helem() Perl_pp_helem(aTHX) #define pp_hex() Perl_pp_hex(aTHX) #define pp_hintseval() Perl_pp_hintseval(aTHX) #define pp_hslice() Perl_pp_hslice(aTHX) #define pp_i_add() Perl_pp_i_add(aTHX) #define pp_i_divide() Perl_pp_i_divide(aTHX) #define pp_i_eq() Perl_pp_i_eq(aTHX) #define pp_i_ge() Perl_pp_i_ge(aTHX) #define pp_i_gt() Perl_pp_i_gt(aTHX) #define pp_i_le() Perl_pp_i_le(aTHX) #define pp_i_lt() Perl_pp_i_lt(aTHX) #define pp_i_modulo() Perl_pp_i_modulo(aTHX) #define pp_i_multiply() Perl_pp_i_multiply(aTHX) #define pp_i_ncmp() Perl_pp_i_ncmp(aTHX) #define pp_i_ne() Perl_pp_i_ne(aTHX) #define pp_i_negate() Perl_pp_i_negate(aTHX) #define pp_i_subtract() Perl_pp_i_subtract(aTHX) #define pp_index() Perl_pp_index(aTHX) #define pp_int() Perl_pp_int(aTHX) #define pp_ioctl() Perl_pp_ioctl(aTHX) #define pp_iter() Perl_pp_iter(aTHX) #define pp_join() Perl_pp_join(aTHX) #define pp_keys() Perl_pp_keys(aTHX) #define pp_kill() Perl_pp_kill(aTHX) #define pp_last() Perl_pp_last(aTHX) #define pp_lc() Perl_pp_lc(aTHX) #define pp_lcfirst() Perl_pp_lcfirst(aTHX) #define pp_le() Perl_pp_le(aTHX) #define pp_leave() Perl_pp_leave(aTHX) #define pp_leaveeval() Perl_pp_leaveeval(aTHX) #define pp_leavegiven() Perl_pp_leavegiven(aTHX) #define pp_leaveloop() Perl_pp_leaveloop(aTHX) #define pp_leavesub() Perl_pp_leavesub(aTHX) #define pp_leavesublv() Perl_pp_leavesublv(aTHX) #define pp_leavetry() Perl_pp_leavetry(aTHX) #define pp_leavewhen() Perl_pp_leavewhen(aTHX) #define pp_leavewrite() Perl_pp_leavewrite(aTHX) #define pp_left_shift() Perl_pp_left_shift(aTHX) #define pp_length() Perl_pp_length(aTHX) #define pp_lineseq() Perl_pp_lineseq(aTHX) #define pp_link() Perl_pp_link(aTHX) #define pp_list() Perl_pp_list(aTHX) #define pp_listen() Perl_pp_listen(aTHX) #define pp_localtime() Perl_pp_localtime(aTHX) #define pp_lock() Perl_pp_lock(aTHX) #define pp_log() Perl_pp_log(aTHX) #define pp_lslice() Perl_pp_lslice(aTHX) #define pp_lstat() Perl_pp_lstat(aTHX) #define pp_lt() Perl_pp_lt(aTHX) #define pp_mapstart() Perl_pp_mapstart(aTHX) #define pp_mapwhile() Perl_pp_mapwhile(aTHX) #define pp_match() Perl_pp_match(aTHX) #define pp_method() Perl_pp_method(aTHX) #define pp_method_named() Perl_pp_method_named(aTHX) #define pp_mkdir() Perl_pp_mkdir(aTHX) #define pp_modulo() Perl_pp_modulo(aTHX) #define pp_msgctl() Perl_pp_msgctl(aTHX) #define pp_msgget() Perl_pp_msgget(aTHX) #define pp_msgrcv() Perl_pp_msgrcv(aTHX) #define pp_msgsnd() Perl_pp_msgsnd(aTHX) #define pp_multiply() Perl_pp_multiply(aTHX) #define pp_ncmp() Perl_pp_ncmp(aTHX) #define pp_ne() Perl_pp_ne(aTHX) #define pp_negate() Perl_pp_negate(aTHX) #define pp_next() Perl_pp_next(aTHX) #define pp_nextstate() Perl_pp_nextstate(aTHX) #define pp_not() Perl_pp_not(aTHX) #define pp_null() Perl_pp_null(aTHX) #define pp_oct() Perl_pp_oct(aTHX) #define pp_once() Perl_pp_once(aTHX) #define pp_open() Perl_pp_open(aTHX) #define pp_open_dir() Perl_pp_open_dir(aTHX) #define pp_or() Perl_pp_or(aTHX) #define pp_orassign() Perl_pp_orassign(aTHX) #define pp_ord() Perl_pp_ord(aTHX) #define pp_pack() Perl_pp_pack(aTHX) #define pp_padany() Perl_pp_padany(aTHX) #define pp_padav() Perl_pp_padav(aTHX) #define pp_padhv() Perl_pp_padhv(aTHX) #define pp_padsv() Perl_pp_padsv(aTHX) #define pp_pipe_op() Perl_pp_pipe_op(aTHX) #define pp_pop() Perl_pp_pop(aTHX) #define pp_pos() Perl_pp_pos(aTHX) #define pp_postdec() Perl_pp_postdec(aTHX) #define pp_postinc() Perl_pp_postinc(aTHX) #define pp_pow() Perl_pp_pow(aTHX) #define pp_predec() Perl_pp_predec(aTHX) #define pp_preinc() Perl_pp_preinc(aTHX) #define pp_print() Perl_pp_print(aTHX) #define pp_prototype() Perl_pp_prototype(aTHX) #define pp_prtf() Perl_pp_prtf(aTHX) #define pp_push() Perl_pp_push(aTHX) #define pp_pushmark() Perl_pp_pushmark(aTHX) #define pp_pushre() Perl_pp_pushre(aTHX) #define pp_qr() Perl_pp_qr(aTHX) #define pp_quotemeta() Perl_pp_quotemeta(aTHX) #define pp_rand() Perl_pp_rand(aTHX) #define pp_range() Perl_pp_range(aTHX) #define pp_rcatline() Perl_pp_rcatline(aTHX) #define pp_read() Perl_pp_read(aTHX) #define pp_readdir() Perl_pp_readdir(aTHX) #define pp_readline() Perl_pp_readline(aTHX) #define pp_readlink() Perl_pp_readlink(aTHX) #define pp_recv() Perl_pp_recv(aTHX) #define pp_redo() Perl_pp_redo(aTHX) #define pp_ref() Perl_pp_ref(aTHX) #define pp_refgen() Perl_pp_refgen(aTHX) #define pp_regcmaybe() Perl_pp_regcmaybe(aTHX) #define pp_regcomp() Perl_pp_regcomp(aTHX) #define pp_regcreset() Perl_pp_regcreset(aTHX) #define pp_rename() Perl_pp_rename(aTHX) #define pp_repeat() Perl_pp_repeat(aTHX) #define pp_require() Perl_pp_require(aTHX) #define pp_reset() Perl_pp_reset(aTHX) #define pp_return() Perl_pp_return(aTHX) #define pp_reverse() Perl_pp_reverse(aTHX) #define pp_rewinddir() Perl_pp_rewinddir(aTHX) #define pp_right_shift() Perl_pp_right_shift(aTHX) #define pp_rindex() Perl_pp_rindex(aTHX) #define pp_rmdir() Perl_pp_rmdir(aTHX) #define pp_rv2av() Perl_pp_rv2av(aTHX) #define pp_rv2cv() Perl_pp_rv2cv(aTHX) #define pp_rv2gv() Perl_pp_rv2gv(aTHX) #define pp_rv2hv() Perl_pp_rv2hv(aTHX) #define pp_rv2sv() Perl_pp_rv2sv(aTHX) #define pp_sassign() Perl_pp_sassign(aTHX) #define pp_say() Perl_pp_say(aTHX) #define pp_scalar() Perl_pp_scalar(aTHX) #define pp_schomp() Perl_pp_schomp(aTHX) #define pp_schop() Perl_pp_schop(aTHX) #define pp_scmp() Perl_pp_scmp(aTHX) #define pp_scope() Perl_pp_scope(aTHX) #define pp_seek() Perl_pp_seek(aTHX) #define pp_seekdir() Perl_pp_seekdir(aTHX) #define pp_select() Perl_pp_select(aTHX) #define pp_semctl() Perl_pp_semctl(aTHX) #define pp_semget() Perl_pp_semget(aTHX) #define pp_semop() Perl_pp_semop(aTHX) #define pp_send() Perl_pp_send(aTHX) #define pp_seq() Perl_pp_seq(aTHX) #define pp_setpgrp() Perl_pp_setpgrp(aTHX) #define pp_setpriority() Perl_pp_setpriority(aTHX) #define pp_sge() Perl_pp_sge(aTHX) #define pp_sgrent() Perl_pp_sgrent(aTHX) #define pp_sgt() Perl_pp_sgt(aTHX) #define pp_shift() Perl_pp_shift(aTHX) #define pp_shmctl() Perl_pp_shmctl(aTHX) #define pp_shmget() Perl_pp_shmget(aTHX) #define pp_shmread() Perl_pp_shmread(aTHX) #define pp_shmwrite() Perl_pp_shmwrite(aTHX) #define pp_shostent() Perl_pp_shostent(aTHX) #define pp_shutdown() Perl_pp_shutdown(aTHX) #define pp_sin() Perl_pp_sin(aTHX) #define pp_sle() Perl_pp_sle(aTHX) #define pp_sleep() Perl_pp_sleep(aTHX) #define pp_slt() Perl_pp_slt(aTHX) #define pp_smartmatch() Perl_pp_smartmatch(aTHX) #define pp_sne() Perl_pp_sne(aTHX) #define pp_snetent() Perl_pp_snetent(aTHX) #define pp_socket() Perl_pp_socket(aTHX) #define pp_sockpair() Perl_pp_sockpair(aTHX) #define pp_sort() Perl_pp_sort(aTHX) #define pp_splice() Perl_pp_splice(aTHX) #define pp_split() Perl_pp_split(aTHX) #define pp_sprintf() Perl_pp_sprintf(aTHX) #define pp_sprotoent() Perl_pp_sprotoent(aTHX) #define pp_spwent() Perl_pp_spwent(aTHX) #define pp_sqrt() Perl_pp_sqrt(aTHX) #define pp_srand() Perl_pp_srand(aTHX) #define pp_srefgen() Perl_pp_srefgen(aTHX) #define pp_sselect() Perl_pp_sselect(aTHX) #define pp_sservent() Perl_pp_sservent(aTHX) #define pp_ssockopt() Perl_pp_ssockopt(aTHX) #define pp_stat() Perl_pp_stat(aTHX) #define pp_stringify() Perl_pp_stringify(aTHX) #define pp_stub() Perl_pp_stub(aTHX) #define pp_study() Perl_pp_study(aTHX) #define pp_subst() Perl_pp_subst(aTHX) #define pp_substcont() Perl_pp_substcont(aTHX) #define pp_substr() Perl_pp_substr(aTHX) #define pp_subtract() Perl_pp_subtract(aTHX) #define pp_symlink() Perl_pp_symlink(aTHX) #define pp_syscall() Perl_pp_syscall(aTHX) #define pp_sysopen() Perl_pp_sysopen(aTHX) #define pp_sysread() Perl_pp_sysread(aTHX) #define pp_sysseek() Perl_pp_sysseek(aTHX) #define pp_system() Perl_pp_system(aTHX) #define pp_syswrite() Perl_pp_syswrite(aTHX) #define pp_tell() Perl_pp_tell(aTHX) #define pp_telldir() Perl_pp_telldir(aTHX) #define pp_tie() Perl_pp_tie(aTHX) #define pp_tied() Perl_pp_tied(aTHX) #define pp_time() Perl_pp_time(aTHX) #define pp_tms() Perl_pp_tms(aTHX) #define pp_trans() Perl_pp_trans(aTHX) #define pp_truncate() Perl_pp_truncate(aTHX) #define pp_uc() Perl_pp_uc(aTHX) #define pp_ucfirst() Perl_pp_ucfirst(aTHX) #define pp_umask() Perl_pp_umask(aTHX) #define pp_undef() Perl_pp_undef(aTHX) #define pp_unlink() Perl_pp_unlink(aTHX) #define pp_unpack() Perl_pp_unpack(aTHX) #define pp_unshift() Perl_pp_unshift(aTHX) #define pp_unstack() Perl_pp_unstack(aTHX) #define pp_untie() Perl_pp_untie(aTHX) #define pp_utime() Perl_pp_utime(aTHX) #define pp_values() Perl_pp_values(aTHX) #define pp_vec() Perl_pp_vec(aTHX) #define pp_wait() Perl_pp_wait(aTHX) #define pp_waitpid() Perl_pp_waitpid(aTHX) #define pp_wantarray() Perl_pp_wantarray(aTHX) #define pp_warn() Perl_pp_warn(aTHX) #define pp_xor() Perl_pp_xor(aTHX) #endif /* PERL_IMPLICIT_CONTEXT */ #endif /* #ifndef PERL_NO_SHORT_NAMES */ /* Compatibility stubs. Compile extensions with -DPERL_NOCOMPAT to disable them. */ #if !defined(PERL_CORE) # define sv_setptrobj(rv,ptr,name) sv_setref_iv(rv,name,PTR2IV(ptr)) # define sv_setptrref(rv,ptr) sv_setref_iv(rv,NULL,PTR2IV(ptr)) #endif #if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) /* Compatibility for various misnamed functions. All functions in the API that begin with "perl_" (not "Perl_") take an explicit interpreter context pointer. The following are not like that, but since they had a "perl_" prefix in previous versions, we provide compatibility macros. */ # define perl_atexit(a,b) call_atexit(a,b) # define perl_call_argv(a,b,c) call_argv(a,b,c) # define perl_call_pv(a,b) call_pv(a,b) # define perl_call_method(a,b) call_method(a,b) # define perl_call_sv(a,b) call_sv(a,b) # define perl_eval_sv(a,b) eval_sv(a,b) # define perl_eval_pv(a,b) eval_pv(a,b) # define perl_require_pv(a) require_pv(a) # define perl_get_sv(a,b) get_sv(a,b) # define perl_get_av(a,b) get_av(a,b) # define perl_get_hv(a,b) get_hv(a,b) # define perl_get_cv(a,b) get_cv(a,b) # define perl_init_i18nl10n(a) init_i18nl10n(a) # define perl_init_i18nl14n(a) init_i18nl14n(a) # define perl_new_ctype(a) new_ctype(a) # define perl_new_collate(a) new_collate(a) # define perl_new_numeric(a) new_numeric(a) /* varargs functions can't be handled with CPP macros. :-( This provides a set of compatibility functions that don't take an extra argument but grab the context pointer using the macro dTHX. */ #if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_NO_SHORT_NAMES) # define croak Perl_croak_nocontext # define deb Perl_deb_nocontext # define die Perl_die_nocontext # define form Perl_form_nocontext # define load_module Perl_load_module_nocontext # define mess Perl_mess_nocontext # define newSVpvf Perl_newSVpvf_nocontext # define sv_catpvf Perl_sv_catpvf_nocontext # define sv_setpvf Perl_sv_setpvf_nocontext # define warn Perl_warn_nocontext # define warner Perl_warner_nocontext # define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext # define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext #endif #endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */ #if !defined(PERL_IMPLICIT_CONTEXT) /* undefined symbols, point them back at the usual ones */ # define Perl_croak_nocontext Perl_croak # define Perl_die_nocontext Perl_die # define Perl_deb_nocontext Perl_deb # define Perl_form_nocontext Perl_form # define Perl_load_module_nocontext Perl_load_module # define Perl_mess_nocontext Perl_mess # define Perl_newSVpvf_nocontext Perl_newSVpvf # define Perl_sv_catpvf_nocontext Perl_sv_catpvf # define Perl_sv_setpvf_nocontext Perl_sv_setpvf # define Perl_warn_nocontext Perl_warn # define Perl_warner_nocontext Perl_warner # define Perl_sv_catpvf_mg_nocontext Perl_sv_catpvf_mg # define Perl_sv_setpvf_mg_nocontext Perl_sv_setpvf_mg #endif /* ex: set ro: */ perl-5.12.0-RC0/uconfig.sh0000444000175000017500000003653111347250766014136 0ustar jessejesse#!/bin/sh _a='.a' _o='.o' afs='false' afsroot='/afs' alignbytes='4' aphostname='/bin/hostname' archlib='/usr/local/lib/perl5/5.12/unknown' archlibexp='/usr/local/lib/perl5/5.12/unknown' archname='unknown' asctime_r_proto='0' bin='/usr/local/bin' binexp='/usr/local/bin' byteorder='1234' castflags='0' cf_by='root@localhost' cf_time='Thu Jan 1 00:00:00 GMT 1970' charbits='8' clocktype='clock_t' cpplast='-' cppminus='-' cpprun='cc -E' cppstdin='cc -E' cpp_stuff='42' crypt_r_proto='0' ctermid_r_proto='0' ctime_r_proto='0' d_Gconvert='sprintf((b),"%.*g",(n),(x))' d_PRIEUldbl='undef' d_PRIFUldbl='undef' d_PRIGUldbl='undef' d_PRIXU64='undef' d_PRId64='undef' d_PRIeldbl='undef' d_PRIfldbl='undef' d_PRIgldbl='undef' d_PRIi64='undef' d_PRIo64='undef' d_PRIu64='undef' d_PRIx64='undef' d_SCNfldbl='undef' d__fwalk='undef' d_access='undef' d_accessx='undef' d_aintl='undef' d_alarm='undef' d_archlib='undef' d_asctime64='undef' d_asctime_r='undef' d_atolf='undef' d_atoll='undef' d_attribute_deprecated='undef' d_attribute_format='undef' d_attribute_malloc='undef' d_attribute_nonnull='undef' d_attribute_noreturn='undef' d_attribute_pure='undef' d_attribute_unused='undef' d_attribute_warn_unused_result='undef' d_bcmp='undef' d_bcopy='undef' d_bsdgetpgrp='undef' d_bsdsetpgrp='undef' d_bsd='undef' d_builtin_choose_expr='undef' d_builtin_expect='undef' d_bzero='undef' d_c99_variadic_macros='undef' d_casti32='undef' d_castneg='undef' d_charvspr='undef' d_chown='undef' d_chroot='undef' d_chsize='undef' d_class='undef' d_clearenv='undef' d_closedir='define' d_cmsghdr_s='undef' d_const='undef' d_copysignl='undef' d_cplusplus='undef' d_crypt_r='undef' d_crypt='undef' d_csh='undef' d_ctermid_r='undef' d_ctermid='undef' d_ctime64='undef' d_ctime_r='undef' d_cuserid='undef' d_dbl_dig='undef' d_dbminitproto='undef' d_difftime64='undef' d_difftime='undef' d_dir_dd_fd='undef' d_dirfd='undef' d_dirnamlen='undef' d_dlerror='undef' d_dlopen='undef' d_dlsymun='undef' d_dosuid='undef' d_drand48proto='undef' d_drand48_r='undef' d_dup2='undef' d_eaccess='undef' d_endgrent_r='undef' d_endgrent='undef' d_endhent='undef' d_endhostent_r='undef' d_endnent='undef' d_endnetent_r='undef' d_endpent='undef' d_endprotoent_r='undef' d_endpwent_r='undef' d_endpwent='undef' d_endsent='undef' d_endservent_r='undef' d_eofnblk='undef' d_eunice='undef' d_faststdio='undef' d_fchdir='undef' d_fchmod='undef' d_fchown='undef' d_fcntl_can_lock='undef' d_fcntl='undef' d_fd_macros='undef' d_fds_bits='undef' d_fd_set='undef' d_fgetpos='undef' d_finitel='undef' d_finite='undef' d_flexfnam='undef' d_flockproto='undef' d_flock='undef' d_fork='define' d_fpathconf='undef' d_fpclassify='undef' d_fpclassl='undef' d_fp_class='undef' d_fpclass='undef' d_fpos64_t='undef' d_frexpl='undef' d_fs_data_s='undef' d_fseeko='undef' d_fsetpos='undef' d_fstatfs='undef' d_fstatvfs='undef' d_fsync='undef' d_ftello='undef' d_ftime='undef' d_futimes='undef' d_gdbm_ndbm_h_uses_prototypes='undef' d_gdbmndbm_h_uses_prototypes='undef' d_getaddrinfo='undef' d_getcwd='undef' d_getespwnam='undef' d_getfsstat='undef' d_getgrent_r='undef' d_getgrent='undef' d_getgrgid_r='undef' d_getgrnam_r='undef' d_getgrps='undef' d_gethbyaddr='undef' d_gethbyname='undef' d_gethent='undef' d_gethname='undef' d_gethostbyaddr_r='undef' d_gethostbyname_r='undef' d_gethostent_r='undef' d_gethostprotos='undef' d_getitimer='undef' d_getlogin_r='undef' d_getlogin='undef' d_getmntent='undef' d_getmnt='undef' d_getnameinfo='undef' d_getnbyaddr='undef' d_getnbyname='undef' d_getnent='undef' d_getnetbyaddr_r='undef' d_getnetbyname_r='undef' d_getnetent_r='undef' d_getnetprotos='undef' d_getpagsz='undef' d_getpbyname='undef' d_getpbynumber='undef' d_getpent='undef' d_getpgid='undef' d_getpgrp2='undef' d_getpgrp='undef' d_getppid='undef' d_getprior='undef' d_getprotobyname_r='undef' d_getprotobynumber_r='undef' d_getprotoent_r='undef' d_getprotoprotos='undef' d_getprpwnam='undef' d_getpwent_r='undef' d_getpwent='undef' d_getpwnam_r='undef' d_getpwuid_r='undef' d_getsbyname='undef' d_getsbyport='undef' d_getsent='undef' d_getservbyname_r='undef' d_getservbyport_r='undef' d_getservent_r='undef' d_getservprotos='undef' d_getspent='undef' d_getspnam_r='undef' d_getspnam='undef' d_gettimeod='undef' d_gmtime64='undef' d_gmtime_r='undef' d_gnulibc='undef' d_grpasswd='undef' d_hasmntopt='undef' d_htonl='undef' d_ilogbl='undef' d_inc_version_list='undef' d_index='undef' d_inetaton='undef' d_inetntop='undef' d_inetpton='undef' d_int64_t='undef' d_isascii='undef' d_isfinite='undef' d_isinf='undef' d_isnanl='undef' d_isnan='undef' d_killpg='undef' d_lchown='undef' d_ldbl_dig='undef' d_libm_lib_version='undef' d_link='undef' d_localtime64='undef' d_localtime_r_needs_tzset='undef' d_localtime_r='undef' d_locconv='undef' d_lockf='undef' d_longdbl='undef' d_longlong='undef' d_lseekproto='undef' d_lstat='undef' d_madvise='undef' d_malloc_good_size='undef' d_malloc_size='undef' d_mblen='undef' d_mbstowcs='undef' d_mbtowc='undef' d_memchr='define' d_memcmp='define' d_memcpy='define' d_memmove='undef' d_memset='undef' d_mkdir='undef' d_mkdtemp='undef' d_mkfifo='undef' d_mkstemps='undef' d_mkstemp='undef' d_mktime64='undef' d_mktime='undef' d_mmap='undef' d_modfl_pow32_bug='undef' d_modflproto='undef' d_modfl='undef' d_mprotect='undef' d_msgctl='undef' d_msg_ctrunc='undef' d_msg_dontroute='undef' d_msgget='undef' d_msghdr_s='undef' d_msg_oob='undef' d_msg_peek='undef' d_msg_proxy='undef' d_msgrcv='undef' d_msgsnd='undef' d_msg='undef' d_msync='undef' d_munmap='undef' d_mymalloc='undef' d_ndbm_h_uses_prototypes='undef' d_nice='undef' d_nl_langinfo='undef' d_nv_preserves_uv='undef' d_nv_zero_is_allbits_zero='undef' d_off64_t='undef' d_old_pthread_create_joinable='undef' d_oldpthreads='undef' d_oldsock='undef' d_open3='undef' nv_overflows_integers_at='256.0*256.0*256.0*256.0*256.0*256.0*2.0*2.0*2.0*2.0*2.0' nv_preserves_uv_bits='0' d_pathconf='undef' d_pause='undef' d_perl_otherlibdirs='undef' d_phostname='undef' d_pipe='undef' d_poll='undef' d_portable='undef' d_printf_format_null='undef' d_procselfexe='undef' d_pseudofork='undef' d_pthread_atfork='undef' d_pthread_attr_setscope='undef' d_pthread_yield='undef' d_pwage='undef' d_pwchange='undef' d_pwclass='undef' d_pwcomment='undef' d_pwexpire='undef' d_pwgecos='undef' d_pwpasswd='undef' d_pwquota='undef' d_qgcvt='undef' d_quad='undef' d_random_r='undef' d_readdir64_r='undef' d_readdir='define' d_readdir_r='undef' d_readlink='undef' d_readv='undef' d_recvmsg='undef' d_rename='define' d_rewinddir='undef' d_rmdir='undef' d_safebcpy='undef' d_safemcpy='undef' d_sanemcmp='undef' d_sbrkproto='undef' d_scalbnl='undef' d_sched_yield='undef' d_scm_rights='undef' d_seekdir='undef' d_select='undef' d_sem='undef' d_semctl='undef' d_semctl_semid_ds='undef' d_semctl_semun='undef' d_semget='undef' d_semop='undef' d_sendmsg='undef' d_setegid='undef' d_seteuid='undef' d_setgrent='undef' d_setgrent_r='undef' d_setgrps='undef' d_sethent='undef' d_sethostent_r='undef' d_setitimer='undef' d_setlinebuf='undef' d_setlocale='undef' d_setlocale_r='undef' d_setnent='undef' d_setnetent_r='undef' d_setpent='undef' d_setpgid='undef' d_setpgrp2='undef' d_setpgrp='undef' d_setprior='undef' d_setproctitle='undef' d_setprotoent_r='undef' d_setpwent='undef' d_setpwent_r='undef' d_setregid='undef' d_setresgid='undef' d_setresuid='undef' d_setreuid='undef' d_setrgid='undef' d_setruid='undef' d_setsent='undef' d_setservent_r='undef' d_setsid='undef' d_setvbuf='undef' d_sfio='undef' d_shm='undef' d_shmat='undef' d_shmatprototype='undef' d_shmctl='undef' d_shmdt='undef' d_shmget='undef' d_sigaction='undef' d_signbit='undef' d_sigprocmask='undef' d_sigsetjmp='undef' d_sitearch='undef' d_sockatmark='undef' d_snprintf='undef' d_sockatmarkproto='undef' d_socket='undef' d_socklen_t='undef' d_sockpair='undef' d_socks5_init='undef' d_sprintf_returns_strlen='undef' d_sqrtl='undef' d_srand48_r='undef' d_srandom_r='undef' d_sresgproto='undef' d_sresuproto='undef' d_statblks='undef' d_statfs_f_flags='undef' d_statfs_s='undef' d_statvfs='undef' d_stdio_cnt_lval='undef' d_stdio_ptr_lval='undef' d_stdio_ptr_lval_nochange_cnt='undef' d_stdio_ptr_lval_sets_cnt='undef' d_stdio_stream_array='undef' d_stdiobase='undef' d_stdstdio='undef' d_strchr='undef' d_strcoll='undef' d_strctcpy='undef' d_strerrm='strerror(e)' d_strerror='undef' d_strerror_r='undef' d_strftime='undef' d_strlcat='undef' d_strlcpy='undef' d_strtod='undef' d_strtol='undef' d_strtold='undef' d_strtoll='undef' d_strtoq='undef' d_strtoul='define' d_strtoull='undef' d_strtouq='undef' d_strxfrm='undef' d_suidsafe='undef' d_symlink='undef' d_syscall='undef' d_syscallproto='undef' d_sysconf='undef' d_sysernlst='' d_syserrlst='undef' d_system='undef' d_tcgetpgrp='undef' d_tcsetpgrp='undef' d_telldir='undef' d_telldirproto='undef' d_time='define' d_timegm='undef' d_times='undef' d_tm_tm_gmtoff='undef' d_tm_tm_zone='undef' d_tmpnam_r='undef' d_truncate='undef' d_ttyname_r='undef' d_tzname='undef' d_u32align='define' d_ualarm='undef' d_umask='undef' d_uname='undef' d_union_semun='undef' d_unordered='undef' d_unsetenv='undef' d_usleep='undef' d_usleepproto='undef' d_ustat='undef' d_vendorarch='undef' d_vendorbin='undef' d_vendorlib='undef' d_vfork='undef' d_void_closedir='undef' d_voidsig='undef' d_voidtty='' d_volatile='undef' d_vprintf='define' d_vsnprintf='undef' d_wait4='undef' d_waitpid='undef' d_wcstombs='undef' d_wctomb='undef' d_writev='undef' d_xenix='undef' db_hashtype='u_int32_t' db_prefixtype='size_t' db_version_major='0' db_version_minor='0' db_version_patch='0' defvoidused=1 direntrytype='struct dirent' doublesize='8' drand01="((rand() & 0x7FFF) / (double) ((unsigned long)1 << 15))" drand48_r_proto='0' dtrace='' eagain='EAGAIN' ebcdic='undef' endgrent_r_proto='0' endhostent_r_proto='0' endnetent_r_proto='0' endprotoent_r_proto='0' endpwent_r_proto='0' endservent_r_proto='0' fflushNULL='undef' fflushall='undef' firstmakefile='makefile' fpossize='4' fpostype=int freetype=void full_csh='' full_sed='' getgrent_r_proto='0' getgrgid_r_proto='0' getgrnam_r_proto='0' gethostbyaddr_r_proto='0' gethostbyname_r_proto='0' gethostent_r_proto='0' getlogin_r_proto='0' getnetbyaddr_r_proto='0' getnetbyname_r_proto='0' getnetent_r_proto='0' getprotobyname_r_proto='0' getprotobynumber_r_proto='0' getprotoent_r_proto='0' getpwent_r_proto='0' getpwnam_r_proto='0' getpwuid_r_proto='0' getservbyname_r_proto='0' getservbyport_r_proto='0' getservent_r_proto='0' getspnam_r_proto='0' gidformat='"lu"' gidsign='1' gidsize='4' gidtype=int gmtime_r_proto='0' groupstype=int h_fcntl='false' h_sysfile='true' i16size='2' i16type='short' i32size='4' i32type='long' i64size='8' i64type='int64_t' i8size='1' i8type='char' i_arpainet='undef' i_assert='define' i_bsdioctl='' i_crypt='undef' i_db='undef' i_dbm='undef' i_dirent='define' i_dld='undef' i_dlfcn='undef' i_fcntl='undef' i_float='undef' i_fp='undef' i_fp_class='undef' i_gdbm='undef' i_gdbm_ndbm='undef' i_gdbmndbm='undef' i_grp='undef' i_ieeefp='undef' i_inttypes='undef' i_langinfo='undef' i_libutil='undef' i_limits='undef' i_locale='undef' i_machcthr='undef' i_malloc='undef' i_mallocmalloc='undef' i_math='define' i_memory='undef' i_mntent='undef' i_ndbm='undef' i_netdb='undef' i_neterrno='undef' i_netinettcp='undef' i_niin='undef' i_poll='undef' i_prot='undef' i_pthread='undef' i_pwd='undef' i_rpcsvcdbm='undef' i_sfio='undef' i_sgtty='undef' i_shadow='undef' i_socks='undef' i_stdarg='define' i_stddef='undef' i_stdlib='define' i_string='define' i_sunmath='undef' i_sysaccess='undef' i_sysdir='undef' i_sysfile='undef' i_sysfilio='undef' i_sysin='undef' i_sysioctl='undef' i_syslog='undef' i_sysmman='undef' i_sysmode='undef' i_sysmount='undef' i_sysndir='undef' i_sysparam='undef' i_syspoll='undef' i_sysresrc='undef' i_syssecrt='undef' i_sysselct='undef' i_syssockio='undef' i_sysstat='define' i_sysstatfs='undef' i_sysstatvfs='undef' i_systime='undef' i_systimek='undef' i_systimes='undef' i_systypes='undef' i_sysuio='undef' i_sysun='undef' i_sysutsname='undef' i_sysvfs='undef' i_syswait='undef' i_termio='undef' i_termios='undef' i_time='define' i_unistd='undef' i_ustat='undef' i_utime='undef' i_values='undef' i_varargs='undef' i_varhdr='stdarg.h' i_vfork='undef' ignore_versioned_solibs='y' inc_version_list_init='NULL' installstyle='lib/perl5' installusrbinperl='undef' intsize='4' ivdformat='"ld"' ivsize='4' ivtype='long' lib_ext='.a' localtime_r_proto='0' longdblsize=8 longlongsize=8 longsize='4' lseeksize=4 lseektype=int mad='undef' malloctype='int*' malloctype='void *' mmaptype='void *' modetype='mode_t' modetype=int multiarch='undef' myarchname='unknown' myuname='unknown' need_va_copy='undef' netdb_hlen_type='int' netdb_host_type='const char *' netdb_name_type='const char *' netdb_net_type='unsigned long' nroff='nroff' nveformat='"e"' nvfformat='"f"' nvgformat='"g"' nvsize='8' nvtype='double' o_nonblock='O_NONBLOCK' obj_ext='.o' old_pthread_create_joinable='' optimize='-O2' orderlib='false' osname='unknown' osvers='unknown' otherlibdirs=' ' package='perl5' phostname='hostname' pidtype=int privlib='/usr/local/lib/perl5/5.12' privlibexp='/usr/local/lib/perl5/5.12' procselfexe='' prototype='undef' ptrsize='4' quadkind='4' quadtype='int64_t' randbits='48' randfunc='drand48' random_r_proto='0' randseedtype='int' rd_nodata='-1' readdir64_r_proto='0' readdir_r_proto='0' sGMTIME_max='2147483647' sGMTIME_min='0' sLOCALTIME_max='2147483647' sLOCALTIME_min='0' sPRId64='"Ld"' sPRIeldbl='"lle"' sPRIEUldbl='"llE"' sPRIfldbl='"llf"' sPRIFUldbl='"llF"' sPRIgldbl='"llg"' sPRIGUldbl='"llG"' sPRIi64='"Li"' sPRIo64='"Lo"' sPRIu64='"Lu"' sPRIx64='"Lx"' sPRIXU64='"LX"' sSCNfldbl='"llf"' sched_yield='sched_yield()' scriptdir='/usr/local/bin' scriptdirexp='/usr/local/bin' seedfunc='srand' selectminbits='32' selecttype=int setgrent_r_proto='0' sethostent_r_proto='0' setlocale_r_proto='0' setnetent_r_proto='0' setprotoent_r_proto='0' setpwent_r_proto='0' setservent_r_proto='0' sh='/bin/sh' shmattype='void *' shortsize='2' sig_name_init='0' sig_num_init='0' sig_size='1' signal_t=int sitearch='/usr/local/lib/perl5/5.12/unknown' sitearchexp='/usr/local/lib/perl5/5.12/unknown' sitelib='/usr/local/lib/perl5/5.12' sitelib_stem='/usr/local/lib/perl5' sitelibexp='/usr/local/lib/perl5/5.12' sizesize=4 sizetype='size_t' socksizetype='int' srand48_r_proto='0' srandom_r_proto='0' src='.' ssizetype=int startperl='#!perl' stdchar=char stdio_base='((fp)->_IO_read_base)' stdio_bufsiz='((fp)->_IO_read_end - (fp)->_IO_read_base)' stdio_cnt='((fp)->_IO_read_end - (fp)->_IO_read_ptr)' stdio_filbuf='' stdio_ptr='((fp)->_IO_read_ptr)' stdio_stream_array='' strerror_r_proto='0' targetarch='' timetype=time_t tmpnam_r_proto='0' touch='touch' ttyname_r_proto='0' u16size='2' u16type='unsigned short' u32size='4' u32type='unsigned long' u64size='8' u64type='uint64_t' u8size='1' u8type='unsigned char' uidformat='"lu"' uidsign='1' uidsize='4' uidtype=int uquadtype='uint64_t' use5005threads='undef' use64bitall='undef' use64bitint='undef' usecrosscompile='undef' usedevel='undef' usedl='undef' usedtrace='undef' usefaststdio='undef' useithreads='undef' uselargefiles='undef' uselongdouble='undef' usemallocwrap='undef' usemorebits='undef' usemultiplicity='undef' usemymalloc='n' usenm='false' useopcode='true' useperlio='undef' useposix='true' usereentrant='undef' userelocatableinc='undef' usesfio='false' useshrplib='false' usesitecustomize='undef' usesocks='undef' usethreads='undef' usevendorprefix='undef' usevfork='false' uvXUformat='"lX"' uvoformat='"lo"' uvsize='4' uvtype='unsigned long' uvuformat='"lu"' uvxformat='"lx"' vaproto='undef' vendorarch='' vendorarchexp='' vendorlib_stem='' vendorlibexp='' versiononly='undef' voidflags=1 perl-5.12.0-RC0/hv.h0000444000175000017500000005022011340037012012701 0ustar jessejesse/* hv.h * * Copyright (C) 1991, 1992, 1993, 1996, 1997, 1998, 1999, * 2000, 2001, 2002, 2003, 2005, 2006, 2007, 2008, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* entry in hash value chain */ struct he { /* Keep hent_next first in this structure, because sv_free_arenas take advantage of this to share code between the he arenas and the SV body arenas */ 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 */ } he_valu; }; /* hash key -- defined separately for use as shared pointer */ struct hek { U32 hek_hash; /* hash of key */ I32 hek_len; /* length of hash key */ char hek_key[1]; /* variable-length hash key */ /* the hash-key is \0-terminated */ /* after the \0 there is a byte for flags, such as whether the key is UTF-8 */ }; struct shared_he { struct he shared_he_he; struct hek shared_he_hek; }; /* Subject to change. Don't access this directly. Use the funcs in mro.c */ struct mro_alg { AV *(*resolve)(pTHX_ HV* stash, U32 level); const char *name; U16 length; U16 kflags; /* For the hash API - set HVhek_UTF8 if name is UTF-8 */ U32 hash; /* or 0 */ }; struct mro_meta { /* a hash holding the different MROs private data. */ HV *mro_linear_all; /* a pointer directly to the current MROs private data. If mro_linear_all is NULL, this owns the SV reference, else it is just a pointer to a value stored in and owned by mro_linear_all. */ SV *mro_linear_current; HV *mro_nextmethod; /* next::method caching */ U32 cache_gen; /* Bumping this invalidates our method cache */ U32 pkg_gen; /* Bumps when local methods/@ISA change */ const struct mro_alg *mro_which; /* which mro alg is in use? */ HV *isa; /* Everything this class @ISA */ }; #define MRO_GET_PRIVATE_DATA(smeta, which) \ (((smeta)->mro_which && (which) == (smeta)->mro_which) \ ? (smeta)->mro_linear_current \ : Perl_mro_get_private_data(aTHX_ (smeta), (which))) /* Subject to change. Don't access this directly. */ struct xpvhv_aux { HEK *xhv_name; /* name, if a symbol table */ AV *xhv_backreferences; /* back references for weak references */ HE *xhv_eiter; /* current entry of iterator */ I32 xhv_riter; /* current root of iterator */ struct mro_meta *xhv_mro_meta; }; /* hash structure: */ /* This structure must match the beginning of struct xpvmg in sv.h. */ struct xpvhv { union _xnvu xnv_u; STRLEN xhv_fill; /* how full xhv_array currently is */ STRLEN xhv_max; /* subscript of last element of xhv_array */ _XPVMG_HEAD; }; #define xhv_keys xiv_u.xivu_iv /* hash a key */ /* FYI: This is the "One-at-a-Time" algorithm by Bob Jenkins * from requirements by Colin Plumb. * (http://burtleburtle.net/bob/hash/doobs.html) */ /* The use of a temporary pointer and the casting games * is needed to serve the dual purposes of * (a) the hashed data being interpreted as "unsigned char" (new since 5.8, * a "char" can be either signed or unsigned, depending on the compiler) * (b) catering for old code that uses a "char" * * The "hash seed" feature was added in Perl 5.8.1 to perturb the results * to avoid "algorithmic complexity attacks". * * If USE_HASH_SEED is defined, hash randomisation is done by default * If USE_HASH_SEED_EXPLICIT is defined, hash randomisation is done * only if the environment variable PERL_HASH_SEED is set. * For maximal control, one can define PERL_HASH_SEED. * (see also perl.c:perl_parse()). */ #ifndef PERL_HASH_SEED # if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) # define PERL_HASH_SEED PL_hash_seed # else # define PERL_HASH_SEED 0 # endif #endif #define PERL_HASH(hash,str,len) \ STMT_START { \ register const char * const s_PeRlHaSh_tmp = str; \ register const unsigned char *s_PeRlHaSh = (const unsigned char *)s_PeRlHaSh_tmp; \ register I32 i_PeRlHaSh = len; \ register U32 hash_PeRlHaSh = PERL_HASH_SEED; \ while (i_PeRlHaSh--) { \ hash_PeRlHaSh += *s_PeRlHaSh++; \ hash_PeRlHaSh += (hash_PeRlHaSh << 10); \ hash_PeRlHaSh ^= (hash_PeRlHaSh >> 6); \ } \ hash_PeRlHaSh += (hash_PeRlHaSh << 3); \ hash_PeRlHaSh ^= (hash_PeRlHaSh >> 11); \ (hash) = (hash_PeRlHaSh + (hash_PeRlHaSh << 15)); \ } STMT_END /* Only hv.c and mod_perl should be doing this. */ #ifdef PERL_HASH_INTERNAL_ACCESS #define PERL_HASH_INTERNAL(hash,str,len) \ STMT_START { \ register const char * const s_PeRlHaSh_tmp = str; \ register const unsigned char *s_PeRlHaSh = (const unsigned char *)s_PeRlHaSh_tmp; \ register I32 i_PeRlHaSh = len; \ register U32 hash_PeRlHaSh = PL_rehash_seed; \ while (i_PeRlHaSh--) { \ hash_PeRlHaSh += *s_PeRlHaSh++; \ hash_PeRlHaSh += (hash_PeRlHaSh << 10); \ hash_PeRlHaSh ^= (hash_PeRlHaSh >> 6); \ } \ hash_PeRlHaSh += (hash_PeRlHaSh << 3); \ hash_PeRlHaSh ^= (hash_PeRlHaSh >> 11); \ (hash) = (hash_PeRlHaSh + (hash_PeRlHaSh << 15)); \ } STMT_END #endif /* =head1 Hash Manipulation Functions =for apidoc AmU||HEf_SVKEY This flag, used in the length slot of hash entries and magic structures, specifies the structure contains an C pointer where a C pointer is to be expected. (For information only--not to be used). =head1 Handy Values =for apidoc AmU||Nullhv Null HV pointer. (deprecated - use C<(HV *)NULL> instead) =head1 Hash Manipulation Functions =for apidoc Am|char*|HvNAME|HV* stash Returns the package name of a stash, or NULL if C isn't a stash. See C, C. =for apidoc Am|void*|HeKEY|HE* he Returns the actual pointer stored in the key slot of the hash entry. The pointer may be either C or C, depending on the value of C. Can be assigned to. The C or C macros are usually preferable for finding the value of a key. =for apidoc Am|STRLEN|HeKLEN|HE* he If this is negative, and amounts to C, it indicates the entry holds an C key. Otherwise, holds the actual length of the key. Can be assigned to. The C macro is usually preferable for finding key lengths. =for apidoc Am|SV*|HeVAL|HE* he Returns the value slot (type C) stored in the hash entry. =for apidoc Am|U32|HeHASH|HE* he Returns the computed hash stored in the hash entry. =for apidoc Am|char*|HePV|HE* he|STRLEN len Returns the key slot of the hash entry as a C value, doing any necessary dereferencing of possibly C keys. The length of the string is placed in C (this is a macro, so do I use C<&len>). If you do not care about what the length of the key is, you may use the global variable C, though this is rather less efficient than using a local variable. Remember though, that hash keys in perl are free to contain embedded nulls, so using C or similar is not a good way to find the length of hash keys. This is very similar to the C macro described elsewhere in this document. See also C. If you are using C to get values to pass to C to create a new SV, you should consider using C as it is more efficient. =for apidoc Am|char*|HeUTF8|HE* he Returns whether the C value returned by C is encoded in UTF-8, doing any necessary dereferencing of possibly C keys. The value returned will be 0 or non-0, not necessarily 1 (or even a value with any low bits set), so B blindly assign this to a C variable, as C may be a typedef for C. =for apidoc Am|SV*|HeSVKEY|HE* he Returns the key as an C, or C if the hash entry does not contain an C key. =for apidoc Am|SV*|HeSVKEY_force|HE* he Returns the key as an C. Will create and return a temporary mortal C if the hash entry contains only a C key. =for apidoc Am|SV*|HeSVKEY_set|HE* he|SV* sv Sets the key to a given C, taking care to set the appropriate flags to indicate the presence of an C key, and returns the same C. =cut */ /* these hash entry flags ride on hent_klen (for use only in magic/tied HVs) */ #define HEf_SVKEY -2 /* hent_key is an SV* */ #ifndef PERL_CORE # define Nullhv Null(HV*) #endif #define HvARRAY(hv) ((hv)->sv_u.svu_hash) #define HvFILL(hv) ((XPVHV*) SvANY(hv))->xhv_fill #define HvMAX(hv) ((XPVHV*) SvANY(hv))->xhv_max /* This quite intentionally does no flag checking first. That's your responsibility. */ #define HvAUX(hv) ((struct xpvhv_aux*)&(HvARRAY(hv)[HvMAX(hv)+1])) #define HvRITER(hv) (*Perl_hv_riter_p(aTHX_ MUTABLE_HV(hv))) #define HvEITER(hv) (*Perl_hv_eiter_p(aTHX_ MUTABLE_HV(hv))) #define HvRITER_set(hv,r) Perl_hv_riter_set(aTHX_ MUTABLE_HV(hv), r) #define HvEITER_set(hv,e) Perl_hv_eiter_set(aTHX_ MUTABLE_HV(hv), e) #define HvRITER_get(hv) (SvOOK(hv) ? HvAUX(hv)->xhv_riter : -1) #define HvEITER_get(hv) (SvOOK(hv) ? HvAUX(hv)->xhv_eiter : NULL) #define HvNAME(hv) HvNAME_get(hv) /* Checking that hv is a valid package stash is the caller's responsibility */ #define HvMROMETA(hv) (HvAUX(hv)->xhv_mro_meta \ ? HvAUX(hv)->xhv_mro_meta \ : Perl_mro_meta_init(aTHX_ hv)) /* FIXME - all of these should use a UTF8 aware API, which should also involve getting the length. */ /* This macro may go away without notice. */ #define HvNAME_HEK(hv) (SvOOK(hv) ? HvAUX(hv)->xhv_name : NULL) #define HvNAME_get(hv) ((SvOOK(hv) && (HvAUX(hv)->xhv_name)) \ ? HEK_KEY(HvAUX(hv)->xhv_name) : NULL) #define HvNAMELEN_get(hv) ((SvOOK(hv) && (HvAUX(hv)->xhv_name)) \ ? HEK_LEN(HvAUX(hv)->xhv_name) : 0) /* the number of keys (including any placeholers) */ #define XHvTOTALKEYS(xhv) ((xhv)->xhv_keys) /* * HvKEYS gets the number of keys that actually exist(), and is provided * for backwards compatibility with old XS code. The core uses HvUSEDKEYS * (keys, excluding placeholdes) and HvTOTALKEYS (including placeholders) */ #define HvKEYS(hv) HvUSEDKEYS(hv) #define HvUSEDKEYS(hv) (HvTOTALKEYS(hv) - HvPLACEHOLDERS_get(hv)) #define HvTOTALKEYS(hv) XHvTOTALKEYS((XPVHV*) SvANY(hv)) #define HvPLACEHOLDERS(hv) (*Perl_hv_placeholders_p(aTHX_ MUTABLE_HV(hv))) #define HvPLACEHOLDERS_get(hv) (SvMAGIC(hv) ? Perl_hv_placeholders_get(aTHX_ (const HV *)hv) : 0) #define HvPLACEHOLDERS_set(hv,p) Perl_hv_placeholders_set(aTHX_ MUTABLE_HV(hv), p) #define HvSHAREKEYS(hv) (SvFLAGS(hv) & SVphv_SHAREKEYS) #define HvSHAREKEYS_on(hv) (SvFLAGS(hv) |= SVphv_SHAREKEYS) #define HvSHAREKEYS_off(hv) (SvFLAGS(hv) &= ~SVphv_SHAREKEYS) /* This is an optimisation flag. It won't be set if all hash keys have a 0 * flag. Currently the only flags relate to utf8. * Hence it won't be set if all keys are 8 bit only. It will be set if any key * is utf8 (including 8 bit keys that were entered as utf8, and need upgrading * when retrieved during iteration. It may still be set when there are no longer * any utf8 keys. * See HVhek_ENABLEHVKFLAGS for the trigger. */ #define HvHASKFLAGS(hv) (SvFLAGS(hv) & SVphv_HASKFLAGS) #define HvHASKFLAGS_on(hv) (SvFLAGS(hv) |= SVphv_HASKFLAGS) #define HvHASKFLAGS_off(hv) (SvFLAGS(hv) &= ~SVphv_HASKFLAGS) #define HvLAZYDEL(hv) (SvFLAGS(hv) & SVphv_LAZYDEL) #define HvLAZYDEL_on(hv) (SvFLAGS(hv) |= SVphv_LAZYDEL) #define HvLAZYDEL_off(hv) (SvFLAGS(hv) &= ~SVphv_LAZYDEL) #define HvREHASH(hv) (SvFLAGS(hv) & SVphv_REHASH) #define HvREHASH_on(hv) (SvFLAGS(hv) |= SVphv_REHASH) #define HvREHASH_off(hv) (SvFLAGS(hv) &= ~SVphv_REHASH) #ifndef PERL_CORE # define Nullhe Null(HE*) #endif #define HeNEXT(he) (he)->hent_next #define HeKEY_hek(he) (he)->hent_hek #define HeKEY(he) HEK_KEY(HeKEY_hek(he)) #define HeKEY_sv(he) (*(SV**)HeKEY(he)) #define HeKLEN(he) HEK_LEN(HeKEY_hek(he)) #define HeKUTF8(he) HEK_UTF8(HeKEY_hek(he)) #define HeKWASUTF8(he) HEK_WASUTF8(HeKEY_hek(he)) #define HeKREHASH(he) HEK_REHASH(HeKEY_hek(he)) #define HeKLEN_UTF8(he) (HeKUTF8(he) ? -HeKLEN(he) : HeKLEN(he)) #define HeKFLAGS(he) HEK_FLAGS(HeKEY_hek(he)) #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))) #define HeUTF8(he) ((HeKLEN(he) == HEf_SVKEY) ? \ SvUTF8(HeKEY_sv(he)) : \ (U32)HeKUTF8(he)) #define HeSVKEY(he) ((HeKEY(he) && \ 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), SVs_TEMP)) : \ &PL_sv_undef) #define HeSVKEY_set(he,sv) ((HeKLEN(he) = HEf_SVKEY), (HeKEY_sv(he) = sv)) #ifndef PERL_CORE # define Nullhek Null(HEK*) #endif #define HEK_BASESIZE STRUCT_OFFSET(HEK, hek_key[0]) #define HEK_HASH(hek) (hek)->hek_hash #define HEK_LEN(hek) (hek)->hek_len #define HEK_KEY(hek) (hek)->hek_key #define HEK_FLAGS(hek) (*((unsigned char *)(HEK_KEY(hek))+HEK_LEN(hek)+1)) #define HVhek_UTF8 0x01 /* Key is utf8 encoded. */ #define HVhek_WASUTF8 0x02 /* Key is bytes here, but was supplied as utf8. */ #define HVhek_REHASH 0x04 /* This key is in an hv using a custom HASH . */ #define HVhek_UNSHARED 0x08 /* This key isn't a shared hash key. */ #define HVhek_FREEKEY 0x100 /* Internal flag to say key is malloc()ed. */ #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. */ #define HVhek_MASK 0xFF /* Which flags enable HvHASKFLAGS? Somewhat a hack on a hack, as HVhek_REHASH is only needed because the rehash flag has to be duplicated into all keys as hv_iternext has no access to the hash flags. At this point Storable's tests get upset, because sometimes hashes are "keyed" and sometimes not, depending on the order of data insertion, and whether it triggered rehashing. So currently HVhek_REHASH is exempt. Similarly UNSHARED */ #define HVhek_ENABLEHVKFLAGS (HVhek_MASK & ~(HVhek_REHASH|HVhek_UNSHARED)) #define HEK_UTF8(hek) (HEK_FLAGS(hek) & HVhek_UTF8) #define HEK_UTF8_on(hek) (HEK_FLAGS(hek) |= HVhek_UTF8) #define HEK_UTF8_off(hek) (HEK_FLAGS(hek) &= ~HVhek_UTF8) #define HEK_WASUTF8(hek) (HEK_FLAGS(hek) & HVhek_WASUTF8) #define HEK_WASUTF8_on(hek) (HEK_FLAGS(hek) |= HVhek_WASUTF8) #define HEK_WASUTF8_off(hek) (HEK_FLAGS(hek) &= ~HVhek_WASUTF8) #define HEK_REHASH(hek) (HEK_FLAGS(hek) & HVhek_REHASH) #define HEK_REHASH_on(hek) (HEK_FLAGS(hek) |= HVhek_REHASH) /* calculate HV array allocation */ #ifndef PERL_USE_LARGE_HV_ALLOC /* Default to allocating the correct size - default to assuming that malloc() is not broken and is efficient at allocating blocks sized at powers-of-two. */ # define PERL_HV_ARRAY_ALLOC_BYTES(size) ((size) * sizeof(HE*)) #else # define MALLOC_OVERHEAD 16 # define PERL_HV_ARRAY_ALLOC_BYTES(size) \ (((size) < 64) \ ? (size) * sizeof(HE*) \ : (size) * sizeof(HE*) * 2 - MALLOC_OVERHEAD) #endif /* Flags for hv_iternext_flags. */ #define HV_ITERNEXT_WANTPLACEHOLDERS 0x01 /* Don't skip placeholders. */ #define hv_iternext(hv) hv_iternext_flags(hv, 0) #define hv_magic(hv, gv, how) sv_magic(MUTABLE_SV(hv), MUTABLE_SV(gv), how, NULL, 0) /* available as a function in hv.c */ #define Perl_sharepvn(sv, len, hash) HEK_KEY(share_hek(sv, len, hash)) #define sharepvn(sv, len, hash) Perl_sharepvn(sv, len, hash) #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), \ hek) #define hv_store_ent(hv, keysv, val, hash) \ ((HE *) hv_common((hv), (keysv), NULL, 0, 0, HV_FETCH_ISSTORE, \ (val), (hash))) #define hv_exists_ent(hv, keysv, hash) \ (hv_common((hv), (keysv), NULL, 0, 0, HV_FETCH_ISEXISTS, 0, (hash)) \ ? TRUE : FALSE) #define hv_fetch_ent(hv, keysv, lval, hash) \ ((HE *) hv_common((hv), (keysv), NULL, 0, 0, \ ((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)))) #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))) #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))) #define hv_exists(hv, key, klen) \ (hv_common_key_len((hv), (key), (klen), HV_FETCH_ISEXISTS, NULL, 0) \ ? TRUE : FALSE) #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)) #define hv_delete(hv, key, klen, flags) \ (MUTABLE_SV(hv_common_key_len((hv), (key), (klen), \ (flags) | HV_DELETE, NULL, 0))) /* This refcounted he structure is used for storing the hints used for lexical pragmas. Without threads, it's basically struct he + refcount. With threads, life gets more complex as the structure needs to be shared between threads (because it hangs from OPs, which are shared), hence the alternate definition and mutex. */ struct refcounted_he; #ifdef PERL_CORE /* Gosh. This really isn't a good name any longer. */ struct refcounted_he { struct refcounted_he *refcounted_he_next; /* next entry in chain */ #ifdef USE_ITHREADS U32 refcounted_he_hash; U32 refcounted_he_keylen; #else 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 */ } refcounted_he_val; U32 refcounted_he_refcnt; /* reference count */ /* First byte is flags. Then NUL-terminated value. Then for ithreads, non-NUL terminated key. */ char refcounted_he_data[1]; }; /* Flag bits are HVhek_UTF8, HVhek_WASUTF8, then */ #define HVrhek_undef 0x00 /* Value is undef. */ #define HVrhek_delete 0x10 /* Value is placeholder - signifies delete. */ #define HVrhek_IV 0x20 /* Value is IV. */ #define HVrhek_UV 0x30 /* Value is UV. */ #define HVrhek_PV 0x40 /* Value is a (byte) string. */ #define HVrhek_PV_UTF8 0x50 /* Value is a (utf8) string. */ /* Two spare. As these have to live in the optree, you can't store anything interpreter specific, such as SVs. :-( */ #define HVrhek_typemask 0x70 #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) #endif # ifdef USE_ITHREADS # define HINTS_REFCNT_LOCK MUTEX_LOCK(&PL_hints_mutex) # define HINTS_REFCNT_UNLOCK MUTEX_UNLOCK(&PL_hints_mutex) # else # define HINTS_REFCNT_LOCK NOOP # define HINTS_REFCNT_UNLOCK NOOP # endif #endif #ifdef USE_ITHREADS # define HINTS_REFCNT_INIT MUTEX_INIT(&PL_hints_mutex) # define HINTS_REFCNT_TERM MUTEX_DESTROY(&PL_hints_mutex) #else # define HINTS_REFCNT_INIT NOOP # define HINTS_REFCNT_TERM NOOP #endif /* Hash actions * Passed in PERL_MAGIC_uvar calls */ #define HV_DISABLE_UVAR_XKEY 0x01 /* We need to ensure that these don't clash with G_DISCARD, which is 2, as it is documented as being passed to hv_delete(). */ #define HV_FETCH_ISSTORE 0x04 #define HV_FETCH_ISEXISTS 0x08 #define HV_FETCH_LVALUE 0x10 #define HV_FETCH_JUST_SV 0x20 #define HV_DELETE 0x40 /* =for apidoc newHV Creates a new HV. The reference count is set to 1. =cut */ #define newHV() MUTABLE_HV(newSV_type(SVt_PVHV)) /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */ perl-5.12.0-RC0/perlsfio.h0000444000175000017500000000521711325125742014130 0ustar jessejesse/* perlsfio.h * * Copyright (C) 1996, 1999, 2000, 2001, 2002, 2003, 2005, 2007, * by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* The next #ifdef should be redundant if Configure behaves ... */ #ifndef FILE #define FILE FILE #endif #ifdef I_SFIO #include #endif /* sfio 2000 changed _stdopen to _stdfdopen */ #if SFIO_VERSION >= 20000101L #define _stdopen _stdfdopen #endif extern Sfio_t* _stdopen _ARG_((int, const char*)); extern int _stdprintf _ARG_((const char*, ...)); #define PerlIO Sfio_t #define PerlIO_stderr() sfstderr #define PerlIO_stdout() sfstdout #define PerlIO_stdin() sfstdin #define PerlIO_isutf8(f) 0 #define PerlIO_printf sfprintf #define PerlIO_stdoutf _stdprintf #define PerlIO_vprintf(f,fmt,a) sfvprintf(f,fmt,a) #define PerlIO_read(f,buf,count) sfread(f,buf,count) #define PerlIO_write(f,buf,count) sfwrite(f,buf,count) #define PerlIO_open(path,mode) sfopen(NULL,path,mode) #define PerlIO_fdopen(fd,mode) _stdopen(fd,mode) #define PerlIO_reopen(path,mode,f) sfopen(f,path,mode) #define PerlIO_close(f) sfclose(f) #define PerlIO_puts(f,s) sfputr(f,s,-1) #define PerlIO_putc(f,c) sfputc(f,c) #define PerlIO_ungetc(f,c) sfungetc(f,c) #define PerlIO_sprintf sfsprintf #define PerlIO_getc(f) sfgetc(f) #define PerlIO_eof(f) sfeof(f) #define PerlIO_error(f) sferror(f) #define PerlIO_fileno(f) sffileno(f) #define PerlIO_clearerr(f) sfclrerr(f) #define PerlIO_flush(f) sfsync(f) #define PerlIO_tell(f) sftell(f) #define PerlIO_seek(f,o,w) sfseek(f,o,w) #define PerlIO_rewind(f) (void) sfseek((f),0L,0) #define PerlIO_tmpfile() sftmp(0) #define PerlIO_exportFILE(f,fl) Perl_croak(aTHX_ "Export to FILE * unimplemented") #define PerlIO_releaseFILE(p,f) Perl_croak(aTHX_ "Release of FILE * unimplemented") #define PerlIO_setlinebuf(f) sfset(f,SF_LINE,1) /* Now our interface to equivalent of Configure's FILE_xxx macros */ #define PerlIO_has_cntptr(f) 1 #define PerlIO_get_ptr(f) ((f)->next) #define PerlIO_get_cnt(f) ((f)->endr - (f)->next) #define PerlIO_canset_cnt(f) 1 #define PerlIO_fast_gets(f) 1 #define PerlIO_set_ptrcnt(f,p,c) STMT_START {(f)->next = (unsigned char *)(p); assert(PerlIO_get_cnt(f) == (c));} STMT_END #define PerlIO_set_cnt(f,c) STMT_START {(f)->next = (f)->endr - (c);} STMT_END #define PerlIO_has_base(f) 1 #define PerlIO_get_base(f) ((f)->data) #define PerlIO_get_bufsiz(f) ((f)->endr - (f)->data) /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */ perl-5.12.0-RC0/README.dgux0000444000175000017500000000540511143650473013763 0ustar jessejesseIf you read this file _as_is_, just ignore the funny characters you see. It is written in the POD format (see perlpod manpage) which is specially designed to be readable as is. =head1 NAME perldgux - Perl under DG/UX. =head1 SYNOPSIS One can read this document in the following formats: man perldgux view perl perldgux explorer perldgux.html info perldgux to list some (not all may be available simultaneously), or it may be read I: as F. =cut Contents perldgux - Perl under DG/UX. NAME SYNOPSIS DESCRIPTION BUILD - Non-threaded Case - Threaded Case - Testing - Installing the built perl AUTHOR SEE ALSO =head1 DESCRIPTION Perl 5.7/8.x for DG/UX ix86 R4.20MU0x =head1 BUILDING PERL ON DG/UX =head2 Non-threaded Perl on DG/UX Just run ./Configure script from the top directory. Then give "make" to compile. =head2 Threaded Perl on DG/UX If you are using as compiler GCC-2.95.x rev(DG/UX) an easy solution for configuring perl in your DG/UX machine is to run the command: ./Configure -Dusethreads -Duseithreads -Dusedevel -des This will automatically accept all the defaults and in particular /usr/local/ as installation directory. Note that GCC-2.95.x rev(DG/UX) knows the switch -pthread which allows it to link correctly DG/UX's -lthread library. If you want to change the installation directory or have a standard DG/UX with C compiler GCC-2.7.2.x then you have no choice than to do an interactive build by issuing the command: ./Configure -Dusethreads -Duseithreads In particular with GCC-2.7.2.x accept all the defaults and *watch* out for the message: Any additional ld flags (NOT including libraries)? [ -pthread] Instead of -pthread put here -lthread. CGCC-2.7.2.x that comes with the DG/UX OS does NOT know the -pthread switch. So your build will fail if you choose the defaults. After configuration is done correctly give "make" to compile. =head2 Testing Perl on DG/UX Issuing a "make test" will run all the tests. If the test lib/ftmp-security gives you as a result something like lib/ftmp-security....File::Temp::_gettemp: Parent directory (/tmp/) is not safe (sticky bit not set when world writable?) at lib/ftmp-security.t line 100 don't panic and just set the sticky bit in your /tmp directory by doing the following as root: cd / chmod +t /tmp (=set the sticky bit to /tmp). Then rerun the tests. This time all must be OK. =head2 Installing the built perl on DG/UX Run the command "make install" =head1 AUTHOR Takis Psarogiannakopoulos Universirty of Cambridge Centre for Mathematical Sciences Department of Pure Mathematics Wilberforce road Cambridge CB3 0WB , UK email =head1 SEE ALSO perl(1). =cut perl-5.12.0-RC0/plan9/0000755000175000017500000000000011351321566013155 5ustar jessejesseperl-5.12.0-RC0/plan9/mkfile0000444000175000017500000001326211325127001014336 0ustar jessejesseAPE=/sys/src/ape < $APE/config $target cp ext/IO/*.pm $privlib if (test !-d $privlib/IO) { mkdir $privlib/IO cp ext/IO/lib/IO/*.pm $privlib/IO } Socket.$O: config.h Socket.c $CCCMD -I plan9 Socket.c Socket.c: miniperl ext/Socket/Socket.xs ./miniperl $privlib/ExtUtils/xsubpp -noprototypes -typemap $privlib/ExtUtils/typemap ext/Socket/Socket.xs > $target cp ext/Socket/Socket.pm $privlib Opcode.c: miniperl ext/Opcode/Opcode.xs ./miniperl $privlib/ExtUtils/xsubpp -noprototypes -typemap $privlib/ExtUtils/typemap ext/Opcode/Opcode.xs > $target cp ext/Opcode/*.pm $privlib Fcntl.c: miniperl ext/Fcntl/Fcntl.xs ./miniperl $privlib/ExtUtils/xsubpp -noprototypes -typemap $privlib/ExtUtils/typemap ext/Fcntl/Fcntl.xs > $target cp ext/Fcntl/Fcntl.pm $privlib POSIX.c: miniperl ext/POSIX/POSIX.xs ./miniperl $privlib/ExtUtils/xsubpp -noprototypes -typemap $privlib/ExtUtils/typemap ext/POSIX/POSIX.xs > $target cp ext/POSIX/POSIX.pm $privlib dl_none.c: miniperl ext/DynaLoader/dl_none.xs ./miniperl $privlib/ExtUtils/xsubpp -noprototypes -typemap $privlib/ExtUtils/typemap ext/DynaLoader/dl_none.xs > $target cp ext/DynaLoader/DynaLoader.pm $privlib test:V: bind -b $privlib $sourcedir/lib bind -b $archlib $sourcedir/lib cd $sourcedir/t rm -f perl cp /$objtype/bin/perl $sourcedir/t perl TEST `{ ls */*.t | comm -23 - ../plan9/exclude } plan9.$O: config.h ./plan9/plan9.c cp ./plan9/plan9.c ./plan9.c $CCCMD plan9.c %.$O: config.h %.c $CCCMD $stem.c $archlib/Config.pm: miniperl config.sh ./miniperl configpm $archlib/Config.pm config.sh: miniperl config.h ./miniperl ./plan9/genconfig.pl installall:V: for (objtype in 386 mips 68020 sparc) mk install man:V: $perlpods pod/pod2man.PL perl perl pod/pod2man.PL for (i in $podnames) pod/pod2man pod/$i.pod > $installman3dir/$i for (i in $faqpodnames) pod/pod2man pod/$i.pod > $installman3dir/$i for (i in $advpodnames) pod/pod2man pod/$i.pod > $installman3dir/$i for (i in $archpodnames) pod/pod2man pod/$i.pod > $installman3dir/$i for (i in $histpodnames) pod/pod2man pod/$i.pod > $installman3dir/$i nuke clean:V: rm -f *.$O $extensions^.pm config.sh $perllib config.h $perlshr perlmain.c perl miniperl $archlib/Config.pm $ext_c rm -rf $privlib/IO deleteman:V: rm -f $installman1dir/perl* $installman3dir/perl* perl-5.12.0-RC0/plan9/plan9ish.h0000444000175000017500000001023411325125742015052 0ustar jessejesse#ifndef __PLAN9ISH_H__ #define __PLAN9ISH_H__ /* * The following symbols are defined if your operating system supports * functions by that name. All Unixes I know of support them, thus they * are not checked by the configuration script, but are directly defined * here. */ /* HAS_IOCTL: * This symbol, if defined, indicates that the ioctl() routine is * available to set I/O characteristics */ #define HAS_IOCTL /**/ /* HAS_UTIME: * This symbol, if defined, indicates that the routine utime() is * available to update the access and modification times of files. */ #define HAS_UTIME /**/ /* HAS_GROUP * This symbol, if defined, indicates that the getgrnam() and * getgrgid() routines are available to get group entries. * The getgrent() has a separate definition, HAS_GETGRENT. */ /*#define HAS_GROUP /**/ /* HAS_PASSWD * This symbol, if defined, indicates that the getpwnam() and * getpwuid() routines are available to get password entries. * The getpwent() has a separate definition, HAS_GETPWENT. */ /*#define HAS_PASSWD /**/ #define HAS_KILL #define HAS_WAIT /* UNLINK_ALL_VERSIONS: * This symbol, if defined, indicates that the program should arrange * to remove all versions of a file if unlink() is called. This is * probably only relevant for VMS. */ /* #define UNLINK_ALL_VERSIONS /**/ /* PLAN9: * This symbol, if defined, indicates that the program is running under * Plan 9. */ #ifndef PLAN9 #define PLAN9 /**/ #endif /* USEMYBINMODE * This symbol, if defined, indicates that the program should * use the routine my_binmode(FILE *fp, char iotype, int mode) to insure * that a file is in "binary" mode -- that is, that no translation * of bytes occurs on read or write operations. */ #undef USEMYBINMODE /* Stat_t: * This symbol holds the type used to declare buffers for information * returned by stat(). It's usually just struct stat. It may be necessary * to include and to get any typedef'ed * information. */ #define Stat_t struct stat /* USE_STAT_RDEV: * This symbol is defined if this system has a stat structure declaring * st_rdev */ #undef USE_STAT_RDEV /**/ /* ACME_MESS: * This symbol, if defined, indicates that error messages should be * should be generated in a format that allows the use of the Acme * GUI/editor's autofind feature. */ #define ACME_MESS /**/ /* ALTERNATE_SHEBANG: * This symbol, if defined, contains a "magic" string which may be used * as the first line of a Perl program designed to be executed directly * by name, instead of the standard Unix #!. If ALTERNATE_SHEBANG * begins with a character other then #, then Perl will only treat * it as a command line if if finds the string "perl" in the first * word; otherwise it's treated as the first line of code in the script. * (IOW, Perl won't hand off to another interpreter via an alternate * shebang sequence that might be legal Perl code.) */ /* #define ALTERNATE_SHEBANG "#!" / **/ #include #ifndef SIGABRT # define SIGABRT SIGILL #endif #ifndef SIGILL # define SIGILL 6 /* blech */ #endif #define ABORT() kill(PerlProc_getpid(),SIGABRT); #define BIT_BUCKET "/dev/null" #define PERL_SYS_INIT_BODY(c,v) \ MALLOC_CHECK_TAINT2(*c,*v) PERLIO_INIT; MALLOC_INIT #define dXSUB_SYS #define PERL_SYS_TERM_BODY() PERLIO_TERM; MALLOC_TERM /* * fwrite1() should be a routine with the same calling sequence as fwrite(), * but which outputs all of the bytes requested as a single stream (unlike * fwrite() itself, which on some systems outputs several distinct records * if the number_of_items parameter is >1). */ #define fwrite1 fwrite #define Stat(fname,bufptr) stat((fname),(bufptr)) #define Fstat(fd,bufptr) fstat((fd),(bufptr)) #define Fflush(fp) fflush(fp) #define Mkdir(path,mode) mkdir((path),(mode)) /* getenv related stuff */ #define my_getenv(var) getenv(var) /* Plan 9 prefers getenv("home") to getenv("HOME") #define HOME home /* For use by POSIX.xs */ extern int tcsendbreak(int, int); #define CONDOP_SIZE 4 /* The Plan 9 compiler cannot return quads from ?: */ #undef HAS_SYMLINK /* Plan 9 doesn't really have these. */ #undef HAS_LSTAT #undef HAS_READLINK #endif /* __PLAN9ISH_H__ */ perl-5.12.0-RC0/plan9/fndvers0000444000175000017500000000031511143650500014534 0ustar jessejesse#!/bin/rc . plan9/buildinfo ed plan9/config.plan9 < but not implemented */ int getsockopt(int a, int b, int c, void *d, int *e) { croak("Function \"getsockopt\" not implemented in this version of perl."); return (int)NULL; } int setsockopt(int a, int b, int c, void *d, int *e) { croak("Function \"setsockopt\" not implemented in this version of perl."); return (int)NULL; } int recvmsg(int a, struct msghdr *b, int c) { croak("Function \"recvmsg\" not implemented in this version of perl."); return (int)NULL; } int sendmsg(int a, struct msghdr *b, int c) { croak("Function \"sendmsg\" not implemented in this version of perl."); return (int)NULL; } /* Functions mentioned in but not implemented */ struct netent *getnetbyname(const char *a) { croak("Function \"getnetbyname\" not implemented in this version of perl."); return (struct netent *)NULL; } struct netent *getnetbyaddr(long a, int b) { croak("Function \"getnetbyaddr\" not implemented in this version of perl."); return (struct netent *)NULL; } struct netent *getnetent() { croak("Function \"getnetent\" not implemented in this version of perl."); return (struct netent *)NULL; } struct protoent *getprotobyname(const char *a) { croak("Function \"getprotobyname\" not implemented in this version of perl."); return (struct protoent *)NULL; } struct protoent *getprotobynumber(int a) { croak("Function \"getprotobynumber\" not implemented in this version of perl."); return (struct protoent *)NULL; } struct protoent *getprotoent() { croak("Function \"getprotoent\" not implemented in this version of perl."); return (struct protoent *)NULL; } struct servent *getservbyport(int a, const char *b) { croak("Function \"getservbyport\" not implemented in this version of perl."); return (struct servent *)NULL; } struct servent *getservent() { croak("Function \"getservent\" not implemented in this version of perl."); return (struct servent *)NULL; } void sethostent(int a) { croak("Function \"sethostent\" not implemented in this version of perl."); } void setnetent(int a) { croak("Function \"setnetent\" not implemented in this version of perl."); } void setprotoent(int a) { croak("Function \"setprotoent\" not implemented in this version of perl."); } void setservent(int a) { croak("Function \"setservent\" not implemented in this version of perl."); } void endnetent() { croak("Function \"endnetent\" not implemented in this version of perl."); } void endprotoent() { croak("Function \"endprotoent\" not implemented in this version of perl."); } void endservent() { croak("Function \"endservent\" not implemented in this version of perl."); } int tcdrain(int) { croak("Function \"tcdrain\" not implemented in this version of perl."); } int tcflow(int, int) { croak("Function \"tcflow\" not implemented in this version of perl."); } int tcflush(int, int) { croak("Function \"tcflush\" not implemented in this version of perl."); } int tcsendbreak(int, int) { croak("Function \"tcsendbreak\" not implemented in this version of perl."); } perl-5.12.0-RC0/plan9/config.plan90000444000175000017500000040752111347250766015406 0ustar jessejesse/* * This file is mangled by fndvers (and perhaps other scripts) to produce * the config.h for Plan 9. It was handwritten because the standard * configuration scripts were written in a shell dialect incomprehensible * to Plan 9. * config.h for Plan 9 * Version: 5.8.0 */ /* Configuration time: 21-Oct-1996 15:11 * Configured by: Luther Huffman, lutherh@stratcom.com * Target system: Plan 9 */ /* * Mangled by Jarkko Hietaniemi 2003-02-02 based on Russ Cox' * blood, sweat, and tears. * */ #ifndef _config_h_ #define _config_h_ /* CAT2: * This macro catenates 2 tokens together. */ #define CAT2(a,b)a ## b #define CAT3(a,b,c)a ## b ## c #define CAT4(a,b,c,d)a ## b ## c ## d #define CAT5(a,b,c,d,e)a ## b ## c ## d ## e #define StGiFy(a)# a #define STRINGIFY(a)StGiFy(a) #define SCAT2(a,b)StGiFy(a) StGiFy(b) #define SCAT3(a,b,c)StGiFy(a) StGiFy(b) StGiFy(c) #define SCAT4(a,b,c,d)StGiFy(a) StGiFy(b) StGiFy(c) StGiFy(d) #define SCAT5(a,b,c,d,e)StGiFy(a) StGiFy(b) StGiFy(c) StGiFy(d) StGiFy(e) /* config-start */ /* MEM_ALIGNBYTES: * This symbol contains the number of bytes required to align a * double. Usual values are 2, 4 and 8. */ #if (_P9P_OBJTYPE == 386) || (_P9P_OBJTYPE==power) # define MEM_ALIGNBYTES 4 /* config-skip */ #else # if _P9P_OBJTYPE == 68020 # define MEM_ALIGNBYTES 2 /* config-skip */ # else # define MEM_ALIGNBYTES 8 /* config-skip */ # endif #endif /* BIN: * This symbol holds the path of the bin directory where the package will * be installed. Program must be prepared to deal with ~name substitution. */ /* BIN_EXP: * This symbol is the filename expanded version of the BIN symbol, for * programs that do not want to deal with that at run-time. */ #define BIN "/_P9P_OBJTYPE/bin" /* */ #define BIN_EXP "/_P9P_OBJTYPE/bin" /* */ /* LOC_SED: * This symbol holds the complete pathname to the sed program. */ #define LOC_SED "/bin/sed" /**/ /* HAS_AINTL: * This symbol, if defined, indicates that the aintl routine is * available. If copysignl is also present we can emulate modfl. */ /*#define HAS_AINTL / **/ /* HAS_ALARM: * This symbol, if defined, indicates that the alarm routine is * available. */ #define HAS_ALARM /**/ /* HASATTRIBUTE: * This symbol indicates the C compiler can check for function attributes, * such as printf formats. This is normally only supported by GNU cc. */ /*#define HASATTRIBUTE /* config-skip */ #ifndef HASATTRIBUTE #ifdef __attribute__ #undef __attribute__ #endif #define __attribute__(_arg_) #endif /* HAS_BCMP: * This symbol is defined if the bcmp() routine is available to * compare blocks of memory. */ #define HAS_BCMP /**/ /* HAS_BCOPY: * This symbol is defined if the bcopy() routine is available to * copy blocks of memory. */ #define HAS_BCOPY /**/ /* HAS_BZERO: * This symbol is defined if the bzero() routine is available to * set a memory block to 0. */ #define HAS_BZERO /**/ /* HAS_CHOWN: * This symbol, if defined, indicates that the chown routine is * available. */ #define HAS_CHOWN /**/ /* HAS_CHROOT: * This symbol, if defined, indicates that the chroot routine is * available. */ /*#define HAS_CHROOT / **/ /* HAS_CHSIZE: * This symbol, if defined, indicates that the chsize routine is available * to truncate files. You might need a -lx to get this routine. */ /*#define HAS_CHSIZE / **/ /* HASCONST: * This symbol, if defined, indicates that this C compiler knows about * the const type. There is no need to actually test for that symbol * within your programs. The mere use of the "const" keyword will * trigger the necessary tests. */ #define HASCONST /**/ #ifndef HASCONST #define const #endif /* HAS_CUSERID: * This symbol, if defined, indicates that the cuserid routine is * available to get character login names. */ #define HAS_CUSERID /**/ /* HAS_DBL_DIG: * This symbol, if defined, indicates that this system's * or defines the symbol DBL_DIG, which is the number * of significant digits in a double precision number. If this * symbol is not defined, a guess of 15 is usually pretty good. */ #define HAS_DBL_DIG /* */ /* HAS_DIFFTIME: * This symbol, if defined, indicates that the difftime routine is * available. */ #define HAS_DIFFTIME /**/ /* HAS_DLERROR: * This symbol, if defined, indicates that the dlerror routine is * available to return a string describing the last error that * occurred from a call to dlopen(), dlclose() or dlsym(). */ /*#define HAS_DLERROR / **/ /* HAS_DUP2: * This symbol, if defined, indicates that the dup2 routine is * available to duplicate file descriptors. */ #define HAS_DUP2 /**/ /* HAS_FCHMOD: * This symbol, if defined, indicates that the fchmod routine is available * to change mode of opened files. If unavailable, use chmod(). */ #define HAS_FCHMOD /**/ /* HAS_FCHOWN: * This symbol, if defined, indicates that the fchown routine is available * to change ownership of opened files. If unavailable, use chown(). */ /*#define HAS_FCHOWN / **/ /* HAS_FCNTL: * This symbol, if defined, indicates to the C program that * the fcntl() function exists. */ #define HAS_FCNTL /**/ /* HAS_FGETPOS: * This symbol, if defined, indicates that the fgetpos routine is * available to get the file position indicator, similar to ftell(). */ #define HAS_FGETPOS /**/ /* HAS_FLOCK: * This symbol, if defined, indicates that the flock routine is * available to do file locking. */ /*#define HAS_FLOCK / **/ /* HAS_FORK: * This symbol, if defined, indicates that the fork routine is * available. */ #define HAS_FORK /**/ /* HAS_FSETPOS: * This symbol, if defined, indicates that the fsetpos routine is * available to set the file position indicator, similar to fseek(). */ #define HAS_FSETPOS /**/ /* HAS_GETTIMEOFDAY: * This symbol, if defined, indicates that the gettimeofday() system * call is available for a sub-second accuracy clock. Usually, the file * needs to be included (see I_SYS_RESOURCE). * The type "Timeval" should be used to refer to "struct timeval". */ #define HAS_GETTIMEOFDAY /**/ #ifdef HAS_GETTIMEOFDAY #define Timeval struct timeval /* Structure used by gettimeofday() */ /* config-skip */ #endif /* HAS_GETGROUPS: * This symbol, if defined, indicates that the getgroups() routine is * available to get the list of process groups. If unavailable, multiple * groups are probably not supported. */ #define HAS_GETGROUPS /* config-skip */ /* HAS_GETLOGIN: * This symbol, if defined, indicates that the getlogin routine is * available to get the login name. */ #define HAS_GETLOGIN /**/ /* HAS_GETPGID: * This symbol, if defined, indicates to the C program that * the getpgid(pid) function is available to get the * process group id. */ /*#define HAS_GETPGID / **/ /* HAS_GETPGRP2: * This symbol, if defined, indicates that the getpgrp2() (as in DG/UX) * routine is available to get the current process group. */ /*#define HAS_GETPGRP2 / **/ /* HAS_GETPPID: * This symbol, if defined, indicates that the getppid routine is * available to get the parent process ID. */ #define HAS_GETPPID /**/ /* HAS_GETPRIORITY: * This symbol, if defined, indicates that the getpriority routine is * available to get a process's priority. */ /*#define HAS_GETPRIORITY / **/ /* HAS_INET_ATON: * This symbol, if defined, indicates to the C program that the * inet_aton() function is available to parse IP address "dotted-quad" * strings. */ /*#define HAS_INET_ATON / **/ /* HAS_KILLPG: * This symbol, if defined, indicates that the killpg routine is available * to kill process groups. If unavailable, you probably should use kill * with a negative process number. */ /*#define HAS_KILLPG / **/ /* HAS_LINK: * This symbol, if defined, indicates that the link routine is * available to create hard links. */ /* #define HAS_LINK /**/ /* HAS_LOCALECONV: * This symbol, if defined, indicates that the localeconv routine is * available for numeric and monetary formatting conventions. */ #define HAS_LOCALECONV /**/ /* HAS_LOCKF: * This symbol, if defined, indicates that the lockf routine is * available to do file locking. */ /*#define HAS_LOCKF / **/ /* HAS_LSTAT: * This symbol, if defined, indicates that the lstat routine is * available to do file stats on symbolic links. */ /*#define HAS_LSTAT /**/ /* HAS_MBLEN: * This symbol, if defined, indicates that the mblen routine is available * to find the number of bytes in a multibye character. */ #define HAS_MBLEN /**/ /* HAS_MBSTOWCS: * This symbol, if defined, indicates that the mbstowcs routine is * available to covert a multibyte string into a wide character string. */ #define HAS_MBSTOWCS /**/ /* HAS_MBTOWC: * This symbol, if defined, indicates that the mbtowc routine is available * to covert a multibyte to a wide character. */ #define HAS_MBTOWC /**/ /* HAS_MEMCMP: * This symbol, if defined, indicates that the memcmp routine is available * to compare blocks of memory. */ #define HAS_MEMCMP /**/ /* HAS_MEMCPY: * This symbol, if defined, indicates that the memcpy routine is available * to copy blocks of memory. */ #define HAS_MEMCPY /**/ /* HAS_MEMMOVE: * This symbol, if defined, indicates that the memmove routine is available * to copy potentially overlapping blocks of memory. This should be used * only when HAS_SAFE_BCOPY is not defined. If neither is there, roll your * own version. */ #define HAS_MEMMOVE /**/ /* HAS_MEMSET: * This symbol, if defined, indicates that the memset routine is available * to set blocks of memory. */ #define HAS_MEMSET /**/ /* HAS_MKDIR: * This symbol, if defined, indicates that the mkdir routine is available * to create directories. Otherwise you should fork off a new process to * exec /bin/mkdir. */ #define HAS_MKDIR /**/ /* HAS_MKFIFO: * This symbol, if defined, indicates that the mkfifo routine is * available to create FIFOs. Otherwise, mknod should be able to * do it for you. However, if mkfifo is there, mknod might require * super-user privileges which mkfifo will not. */ #define HAS_MKFIFO /**/ /* HAS_MKTIME: * This symbol, if defined, indicates that the mktime routine is * available. */ #define HAS_MKTIME /**/ /* HAS_MSYNC: * This symbol, if defined, indicates that the msync system call is * available to synchronize a mapped file. */ /*#define HAS_MSYNC / **/ /* HAS_MUNMAP: * This symbol, if defined, indicates that the munmap system call is * available to unmap a region, usually mapped by mmap(). */ /*#define HAS_MUNMAP / **/ /* HAS_NICE: * This symbol, if defined, indicates that the nice routine is * available. */ /*#define HAS_NICE / **/ /* HAS_PATHCONF: * This symbol, if defined, indicates that pathconf() is available * to determine file-system related limits and options associated * with a given filename. */ /* HAS_FPATHCONF: * This symbol, if defined, indicates that pathconf() is available * to determine file-system related limits and options associated * with a given open file descriptor. */ #define HAS_PATHCONF /**/ #define HAS_FPATHCONF /**/ /* HAS_PAUSE: * This symbol, if defined, indicates that the pause routine is * available to suspend a process until a signal is received. */ #define HAS_PAUSE /**/ /* HAS_PIPE: * This symbol, if defined, indicates that the pipe routine is * available to create an inter-process channel. */ #define HAS_PIPE /**/ /* HAS_POLL: * This symbol, if defined, indicates that the poll routine is * available to poll active file descriptors. You may safely * include when this symbol is defined. */ /*#define HAS_POLL / **/ /* HAS_READDIR: * This symbol, if defined, indicates that the readdir routine is * available to read directory entries. You may have to include * . See I_DIRENT. */ #define HAS_READDIR /**/ /* HAS_SEEKDIR: * This symbol, if defined, indicates that the seekdir routine is * available. You may have to include . See I_DIRENT. */ /*#define HAS_SEEKDIR / **/ /* HAS_TELLDIR: * This symbol, if defined, indicates that the telldir routine is * available. You may have to include . See I_DIRENT. */ /*#define HAS_TELLDIR / **/ /* HAS_REWINDDIR: * This symbol, if defined, indicates that the rewinddir routine is * available. You may have to include . See I_DIRENT. */ #define HAS_REWINDDIR /**/ /* HAS_READLINK: * This symbol, if defined, indicates that the readlink routine is * available to read the value of a symbolic link. */ /*#define HAS_READLINK /**/ /* HAS_RENAME: * This symbol, if defined, indicates that the rename routine is available * to rename files. Otherwise you should do the unlink(), link(), unlink() * trick. */ #define HAS_RENAME /**/ /* HAS_RMDIR: * This symbol, if defined, indicates that the rmdir routine is * available to remove directories. Otherwise you should fork off a * new process to exec /bin/rmdir. */ #define HAS_RMDIR /**/ /* HAS_SELECT: * This symbol, if defined, indicates that the select routine is * available to select active file descriptors. If the timeout field * is used, may need to be included. */ #define HAS_SELECT /* config-skip */ /* HAS_SETEGID: * This symbol, if defined, indicates that the setegid routine is available * to change the effective gid of the current program. */ /*#define HAS_SETEGID / **/ /* HAS_SETEUID: * This symbol, if defined, indicates that the seteuid routine is available * to change the effective uid of the current program. */ /*#define HAS_SETEUID / **/ /* HAS_SETLINEBUF: * This symbol, if defined, indicates that the setlinebuf routine is * available to change stderr or stdout from block-buffered or unbuffered * to a line-buffered mode. */ #define HAS_SETLINEBUF /**/ /* HAS_SETLOCALE: * This symbol, if defined, indicates that the setlocale routine is * available to handle locale-specific ctype implementations. */ #define HAS_SETLOCALE /**/ /* HAS_SETPGID: * This symbol, if defined, indicates that the setpgid(pid, gpid) * routine is available to set process group ID. */ #define HAS_SETPGID /**/ /* HAS_SETPGRP2: * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX) * routine is available to set the current process group. */ /*#define HAS_SETPGRP2 / **/ /* HAS_SETPRIORITY: * This symbol, if defined, indicates that the setpriority routine is * available to set a process's priority. */ /*#define HAS_SETPRIORITY / **/ /* HAS_SETREGID: * This symbol, if defined, indicates that the setregid routine is * available to change the real and effective gid of the current * process. */ /* HAS_SETRESGID: * This symbol, if defined, indicates that the setresgid routine is * available to change the real, effective and saved gid of the current * process. */ /*#define HAS_SETREGID / **/ /*#define HAS_SETRESGID / **/ /* HAS_SETREUID: * This symbol, if defined, indicates that the setreuid routine is * available to change the real and effective uid of the current * process. */ /* HAS_SETRESUID: * This symbol, if defined, indicates that the setresuid routine is * available to change the real, effective and saved uid of the current * process. */ /*#define HAS_SETREUID / **/ /*#define HAS_SETRESUID / **/ /* HAS_SETRGID: * This symbol, if defined, indicates that the setrgid routine is available * to change the real gid of the current program. */ /*#define HAS_SETRGID / **/ /* HAS_SETRUID: * This symbol, if defined, indicates that the setruid routine is available * to change the real uid of the current program. */ /*#define HAS_SETRUID / **/ /* HAS_SETSID: * This symbol, if defined, indicates that the setsid routine is * available to set the process group ID. */ #define HAS_SETSID /**/ /* HAS_STRCHR: * This symbol is defined to indicate that the strchr()/strrchr() * functions are available for string searching. If not, try the * index()/rindex() pair. */ /* HAS_INDEX: * This symbol is defined to indicate that the index()/rindex() * functions are available for string searching. */ #define HAS_STRCHR /**/ /*#define HAS_INDEX / **/ /* HAS_STRCOLL: * This symbol, if defined, indicates that the strcoll routine is * available to compare strings using collating information. */ #define HAS_STRCOLL /**/ /* USE_STRUCT_COPY: * This symbol, if defined, indicates that this C compiler knows how * to copy structures. If undefined, you'll need to use a block copy * routine of some sort instead. */ #define USE_STRUCT_COPY /**/ /* HAS_STRTOD: * This symbol, if defined, indicates that the strtod routine is * available to provide better numeric string conversion than atof(). */ #define HAS_STRTOD /**/ /* HAS_STRTOL: * This symbol, if defined, indicates that the strtol routine is available * to provide better numeric string conversion than atoi() and friends. */ #define HAS_STRTOL /**/ /* HAS_STRXFRM: * This symbol, if defined, indicates that the strxfrm() routine is * available to transform strings. */ #define HAS_STRXFRM /**/ /* HAS_SYMLINK: * This symbol, if defined, indicates that the symlink routine is available * to create symbolic links. */ /*#define HAS_SYMLINK /**/ /* HAS_SYSCALL: * This symbol, if defined, indicates that the syscall routine is * available to call arbitrary system calls. If undefined, that's tough. */ /*#define HAS_SYSCALL / **/ /* HAS_SYSCONF: * This symbol, if defined, indicates that sysconf() is available * to determine system related limits and options. */ #define HAS_SYSCONF /**/ /* HAS_SYSTEM: * This symbol, if defined, indicates that the system routine is * available to issue a shell command. */ #define HAS_SYSTEM /**/ /* HAS_TCGETPGRP: * This symbol, if defined, indicates that the tcgetpgrp routine is * available to get foreground process group ID. */ #define HAS_TCGETPGRP /**/ /* HAS_TCSETPGRP: * This symbol, if defined, indicates that the tcsetpgrp routine is * available to set foreground process group ID. */ #define HAS_TCSETPGRP /**/ /* HAS_TRUNCATE: * This symbol, if defined, indicates that the truncate routine is * available to truncate files. */ /*#define HAS_TRUNCATE / **/ /* HAS_TZNAME: * This symbol, if defined, indicates that the tzname[] array is * available to access timezone names. */ #define HAS_TZNAME /**/ /* HAS_UMASK: * This symbol, if defined, indicates that the umask routine is * available to set and get the value of the file creation mask. */ #define HAS_UMASK /**/ /* HAS_USLEEP: * This symbol, if defined, indicates that the usleep routine is * available to let the process sleep on a sub-second accuracy. */ /*#define HAS_USLEEP / **/ /* HASVOLATILE: * This symbol, if defined, indicates that this C compiler knows about * the volatile declaration. */ #define HASVOLATILE /**/ #ifndef HASVOLATILE #define volatile /* config-skip */ #endif /* HAS_WAIT4: * This symbol, if defined, indicates that wait4() exists. */ /*#define HAS_WAIT4 / **/ /* HAS_WAITPID: * This symbol, if defined, indicates that the waitpid routine is * available to wait for child process. */ #define HAS_WAITPID /**/ /* HAS_WCSTOMBS: * This symbol, if defined, indicates that the wcstombs routine is * available to convert wide character strings to multibyte strings. */ #define HAS_WCSTOMBS /**/ /* HAS_WCTOMB: * This symbol, if defined, indicates that the wctomb routine is available * to covert a wide character to a multibyte. */ #define HAS_WCTOMB /**/ /* I_ARPA_INET: * This symbol, if defined, indicates to the C program that it should * include to get inet_addr and friends declarations. */ #define I_ARPA_INET /**/ /* I_DBM: * This symbol, if defined, indicates that exists and should * be included. */ /* I_RPCSVC_DBM: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_DBM / **/ /*#define I_RPCSVC_DBM / **/ /* I_DIRENT: * This symbol, if defined, indicates to the C program that it should * include . Using this symbol also triggers the definition * of the Direntry_t define which ends up being 'struct dirent' or * 'struct direct' depending on the availability of . */ /* DIRNAMLEN: * This symbol, if defined, indicates to the C program that the length * of directory entry names is provided by a d_namlen field. Otherwise * you need to do strlen() on the d_name field. */ /* Direntry_t: * This symbol is set to 'struct direct' or 'struct dirent' depending on * whether dirent is available or not. You should use this pseudo type to * portably declare your directory entries. */ #define I_DIRENT /**/ /*#define DIRNAMLEN / **/ #define Direntry_t struct dirent /* I_DLFCN: * This symbol, if defined, indicates that exists and should * be included. */ /*#define I_DLFCN / **/ /* I_FCNTL: * This manifest constant tells the C program to include . */ #define I_FCNTL /**/ /* I_FLOAT: * This symbol, if defined, indicates to the C program that it should * include to get definition of symbols like DBL_MAX or * DBL_MIN, i.e. machine dependent floating point values. */ #define I_FLOAT /**/ /* I_LIMITS: * This symbol, if defined, indicates to the C program that it should * include to get definition of symbols like WORD_BIT or * LONG_MAX, i.e. machine dependant limitations. */ #define I_LIMITS /**/ /* I_LOCALE: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_LOCALE /**/ /* I_MATH: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_MATH /**/ /* I_MEMORY: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_MEMORY / **/ /* I_NET_ERRNO: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_NET_ERRNO /* config-skip */ /* I_NETINET_IN: * This symbol, if defined, indicates to the C program that it should * include . Otherwise, you may try . */ #define I_NETINET_IN /* config-skip */ /* I_SFIO: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SFIO / **/ /* I_STDDEF: * This symbol, if defined, indicates that exists and should * be included. */ #define I_STDDEF /**/ /* I_STDLIB: * This symbol, if defined, indicates that exists and should * be included. */ #define I_STDLIB /**/ /* I_STRING: * This symbol, if defined, indicates to the C program that it should * include (USG systems) instead of (BSD systems). */ #define I_STRING /**/ /* I_SYS_DIR: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_DIR / **/ /* I_SYS_FILE: * This symbol, if defined, indicates to the C program that it should * include to get definition of R_OK and friends. */ /*#define I_SYS_FILE / **/ /* I_SYS_IOCTL: * This symbol, if defined, indicates that exists and should * be included. Otherwise, include or . */ /* I_SYS_SOCKIO: * This symbol, if defined, indicates the should be included * to get socket ioctl options, like SIOCATMARK. */ #define I_SYS_IOCTL /**/ /*#define I_SYS_SOCKIO / **/ /* I_SYS_NDIR: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_NDIR / **/ /* I_SYS_PARAM: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_PARAM /**/ /* I_SYS_RESOURCE: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_RESOURCE /**/ /* Plan 9: file position in Plan 9 is */ /* I_SYS_SELECT: * This symbol, if defined, indicates to the C program that it should * include in order to get definition of struct timeval. */ #define I_SYS_SELECT /**/ /* I_SYS_STAT: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_STAT /**/ /* I_SYS_TIMES: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_TIMES /**/ /* I_SYS_TYPES: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_TYPES /**/ /* I_SYS_UN: * This symbol, if defined, indicates to the C program that it should * include to get UNIX domain socket definitions. */ #define I_SYS_UN /**/ /* I_SYS_WAIT: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_WAIT /**/ /* I_TERMIO: * This symbol, if defined, indicates that the program should include * rather than . There are also differences in * the ioctl() calls that depend on the value of this symbol. */ /* I_TERMIOS: * This symbol, if defined, indicates that the program should include * the POSIX termios.h rather than sgtty.h or termio.h. * There are also differences in the ioctl() calls that depend on the * value of this symbol. */ /* I_SGTTY: * This symbol, if defined, indicates that the program should include * rather than . There are also differences in * the ioctl() calls that depend on the value of this symbol. */ /*#define I_TERMIO / **/ #define I_TERMIOS /**/ /*#define I_SGTTY / **/ /* I_UNISTD: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_UNISTD /**/ /* I_UTIME: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_UTIME /**/ /* I_VALUES: * This symbol, if defined, indicates to the C program that it should * include to get definition of symbols like MINFLOAT or * MAXLONG, i.e. machine dependant limitations. Probably, you * should use instead, if it is available. */ /*#define I_VALUES / **/ /* I_VFORK: * This symbol, if defined, indicates to the C program that it should * include vfork.h. */ /*#define I_VFORK / **/ /* INTSIZE: * This symbol contains the value of sizeof(int) so that the C * preprocessor can make decisions based on it. */ /* LONGSIZE: * This symbol contains the value of sizeof(long) so that the C * preprocessor can make decisions based on it. */ /* SHORTSIZE: * This symbol contains the value of sizeof(short) so that the C * preprocessor can make decisions based on it. */ #define INTSIZE 4 /**/ #define LONGSIZE 4 /**/ #define SHORTSIZE 2 /**/ /* MULTIARCH: * This symbol, if defined, signifies that the build * process will produce some binary files that are going to be * used in a cross-platform environment. This is the case for * example with the NeXT "fat" binaries that contain executables * for several CPUs. */ /*#define MULTIARCH / **/ /* HAS_QUAD: * This symbol, if defined, tells that there's a 64-bit integer type, * Quad_t, and its unsigned counterpar, Uquad_t. QUADKIND will be one * of QUAD_IS_INT, QUAD_IS_LONG, QUAD_IS_LONG_LONG, or QUAD_IS_INT64_T. */ #define HAS_QUAD /**/ #ifdef HAS_QUAD # define Quad_t long long /**/ # define Uquad_t unsigned long long /**/ # define QUADKIND 3 /**/ # define QUAD_IS_INT 1 # define QUAD_IS_LONG 2 # define QUAD_IS_LONG_LONG 3 # define QUAD_IS_INT64_T 4 #endif /* HAS_ACCESSX: * This symbol, if defined, indicates that the accessx routine is * available to do extended access checks. */ /*#define HAS_ACCESSX / **/ /* HAS_EACCESS: * This symbol, if defined, indicates that the eaccess routine is * available to do extended access checks. */ /*#define HAS_EACCESS / **/ /* I_SYS_ACCESS: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_ACCESS / **/ /* I_SYS_SECURITY: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_SECURITY / **/ /* OSNAME: * This symbol contains the name of the operating system, as determined * by Configure. You shouldn't rely on it too much; the specific * feature tests from Configure are generally more reliable. */ /* OSVERS: * This symbol contains the version of the operating system, as determined * by Configure. You shouldn't rely on it too much; the specific * feature tests from Configure are generally more reliable. */ #define OSNAME "plan9" /**/ #define OSVERS "1" /**/ /* PLAN9: * This symbol, if defined, indicates that the program is running under the * Plan 9 operating system. */ #define PLAN9 /**/ /* MEM_ALIGNBYTES: * This symbol contains the number of bytes required to align a * double, or a long double when applicable. Usual values are 2, * 4 and 8. The default is eight, for safety. */ #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH) # define MEM_ALIGNBYTES 8 #else #define MEM_ALIGNBYTES 4 #endif /* ARCHLIB: * This variable, if defined, holds the name of the directory in * which the user wants to put architecture-dependent public * library files for perl. It is most often a local directory * such as /usr/local/lib. Programs using this variable must be * prepared to deal with filename expansion. If ARCHLIB is the * same as PRIVLIB, it is not defined, since presumably the * program already searches PRIVLIB. */ /* ARCHLIB_EXP: * This symbol contains the ~name expanded version of ARCHLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ #define ARCHLIB_EXP "/_P9P_OBJTYPE/lib/perl/_P9P_VERSION" #define ARCHLIB "/_P9P_OBJTYPE/lib/perl/_P9P_VERSION" /* ARCHNAME: * This symbol holds a string representing the architecture name. * It may be used to construct an architecture-dependant pathname * where library files may be held under a private library, for * instance. */ #define ARCHNAME "plan9__P9P_OBJTYPE" /**/ /* HAS_ATOLF: * This symbol, if defined, indicates that the atolf routine is * available to convert strings into long doubles. */ /*#define HAS_ATOLF / **/ /* HAS_ATOLL: * This symbol, if defined, indicates that the atoll routine is * available to convert strings into long longs. */ #define HAS_ATOLL /**/ /* BIN: * This symbol holds the path of the bin directory where the package will * be installed. Program must be prepared to deal with ~name substitution. */ /* BIN_EXP: * This symbol is the filename expanded version of the BIN symbol, for * programs that do not want to deal with that at run-time. */ #define BIN "/usr/bin" /**/ #define BIN_EXP "/usr/bin" /**/ /* BYTEORDER: * This symbol holds the hexadecimal constant defined in byteorder, * in a UV, i.e. 0x1234 or 0x4321 or 0x12345678, etc... * If the compiler supports cross-compiling or multiple-architecture * binaries (eg. on NeXT systems), use compiler-defined macros to * determine the byte order. * On NeXT 3.2 (and greater), you can build "Fat" Multiple Architecture * Binaries (MAB) on either big endian or little endian machines. * The endian-ness is available at compile-time. This only matters * for perl, where the config.h can be generated and installed on * one system, and used by a different architecture to build an * extension. Older versions of NeXT that might not have * defined either *_ENDIAN__ were all on Motorola 680x0 series, * so the default case (for NeXT) is big endian to catch them. * This might matter for NeXT 3.0. */ #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH) # ifdef __LITTLE_ENDIAN__ # if LONGSIZE == 4 # define BYTEORDER 0x1234 /* config-skip */ # else # if LONGSIZE == 8 # define BYTEORDER 0x12345678 /* config-skip */ # endif # endif # else # ifdef __BIG_ENDIAN__ # if LONGSIZE == 4 # define BYTEORDER 0x4321 # else # if LONGSIZE == 8 # define BYTEORDER 0x87654321 # endif # endif # endif # endif # if !defined(BYTEORDER) && (defined(NeXT) || defined(__NeXT__)) # define BYTEORDER 0x4321 # endif #else #define BYTEORDER 0x1234 /* large digits for MSB */ #endif /* NeXT */ /* CAT2: * This macro catenates 2 tokens together. */ /* STRINGIFY: * This macro surrounds its token with double quotes. */ #if 42 == 1 #define CAT2(a,b) a/**/b #define STRINGIFY(a) "a" /* If you can get stringification with catify, tell me how! */ #endif #if 42 == 42 #define PeRl_CaTiFy(a, b) a ## b #define PeRl_StGiFy(a) #a /* the additional level of indirection enables these macros to be * used as arguments to other macros. See K&R 2nd ed., page 231. */ #define CAT2(a,b) PeRl_CaTiFy(a,b) #define StGiFy(a) PeRl_StGiFy(a) #define STRINGIFY(a) PeRl_StGiFy(a) #endif #if 42 != 1 && 42 != 42 # include "Bletch: How does this C preprocessor concatenate tokens?" #endif /* CPPSTDIN: * This symbol contains the first part of the string which will invoke * the C preprocessor on the standard input and produce to standard * output. Typical value of "cc -E" or "/lib/cpp", but it can also * call a wrapper. See CPPRUN. */ /* CPPMINUS: * This symbol contains the second part of the string which will invoke * the C preprocessor on the standard input and produce to standard * output. This symbol will have the value "-" if CPPSTDIN needs a minus * to specify standard input, otherwise the value is "". */ /* CPPRUN: * This symbol contains the string which will invoke a C preprocessor on * the standard input and produce to standard output. It needs to end * with CPPLAST, after all other preprocessor flags have been specified. * The main difference with CPPSTDIN is that this program will never be a * pointer to a shell wrapper, i.e. it will be empty if no preprocessor is * available directly to the user. Note that it may well be different from * the preprocessor used to compile the C program. */ /* CPPLAST: * This symbol is intended to be used along with CPPRUN in the same manner * symbol CPPMINUS is used with CPPSTDIN. It contains either "-" or "". */ #define CPPSTDIN "cppstdin" #define CPPMINUS "" #define CPPRUN "/bin/cpp" #define CPPLAST "" /* HAS__FWALK: * This symbol, if defined, indicates that the _fwalk system call is * available to apply a function to all the file handles. */ /*#define HAS__FWALK / **/ /* HAS_ACCESS: * This manifest constant lets the C program know that the access() * system call is available to check for accessibility using real UID/GID. * (always present on UNIX.) */ #define HAS_ACCESS /**/ /* HAS_ASCTIME_R: * This symbol, if defined, indicates that the asctime_r routine * is available to asctime re-entrantly. */ /* ASCTIME_R_PROTO: * This symbol encodes the prototype of asctime_r. * It is zero if d_asctime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_asctime_r * is defined. */ /*#define HAS_ASCTIME_R / **/ #define ASCTIME_R_PROTO 0 /**/ /* CASTI32: * This symbol is defined if the C compiler can cast negative * or large floating point numbers to 32-bit ints. */ /*#define CASTI32 / **/ /* CASTNEGFLOAT: * This symbol is defined if the C compiler can cast negative * numbers to unsigned longs, ints and shorts. */ /* CASTFLAGS: * This symbol contains flags that say what difficulties the compiler * has casting odd floating values to unsigned long: * 0 = ok * 1 = couldn't cast < 0 * 2 = couldn't cast >= 0x80000000 * 4 = couldn't cast in argument expression list */ /*#define CASTNEGFLOAT /* config-skip */ #if _P9P_OBJTYPE == 386 # define CASTFLAGS 3 /**/ /* config-skip */ #else # define CASTFLAGS 0 /**/ /* config-skip */ #endif /* HAS_CLASS: * This symbol, if defined, indicates that the class routine is * available to classify doubles. Available for example in AIX. * The returned values are defined in and are: * * FP_PLUS_NORM Positive normalized, nonzero * FP_MINUS_NORM Negative normalized, nonzero * FP_PLUS_DENORM Positive denormalized, nonzero * FP_MINUS_DENORM Negative denormalized, nonzero * FP_PLUS_ZERO +0.0 * FP_MINUS_ZERO -0.0 * FP_PLUS_INF +INF * FP_MINUS_INF -INF * FP_NANS Signaling Not a Number (NaNS) * FP_NANQ Quiet Not a Number (NaNQ) */ /*#define HAS_CLASS / **/ /* VOID_CLOSEDIR: * This symbol, if defined, indicates that the closedir() routine * does not return a value. */ /*#define VOID_CLOSEDIR / **/ /* HAS_STRUCT_CMSGHDR: * This symbol, if defined, indicates that the struct cmsghdr * is supported. */ /*#define HAS_STRUCT_CMSGHDR / **/ /* HAS_CRYPT_R: * This symbol, if defined, indicates that the crypt_r routine * is available to crypt re-entrantly. */ /* CRYPT_R_PROTO: * This symbol encodes the prototype of crypt_r. * It is zero if d_crypt_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_crypt_r * is defined. */ /*#define HAS_CRYPT_R / **/ #define CRYPT_R_PROTO 0 /**/ /* HAS_CSH: * This symbol, if defined, indicates that the C-shell exists. */ /* CSH: * This symbol, if defined, contains the full pathname of csh. */ /*#define HAS_CSH / **/ #ifdef HAS_CSH #define CSH "csh" /**/ #endif /* HAS_CTIME_R: * This symbol, if defined, indicates that the ctime_r routine * is available to ctime re-entrantly. */ /* CTIME_R_PROTO: * This symbol encodes the prototype of ctime_r. * It is zero if d_ctime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ctime_r * is defined. */ /*#define HAS_CTIME_R / **/ #define CTIME_R_PROTO 0 /**/ /* DLSYM_NEEDS_UNDERSCORE: * This symbol, if defined, indicates that we need to prepend an * underscore to the symbol name before calling dlsym(). This only * makes sense if you *have* dlsym, which we will presume is the * case if you're using dl_dlopen.xs. */ /*#define DLSYM_NEEDS_UNDERSCORE / **/ /* HAS_DRAND48_R: * This symbol, if defined, indicates that the drand48_r routine * is available to drand48 re-entrantly. */ /* DRAND48_R_PROTO: * This symbol encodes the prototype of drand48_r. * It is zero if d_drand48_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_drand48_r * is defined. */ /*#define HAS_DRAND48_R / **/ #define DRAND48_R_PROTO 0 /**/ /* HAS_DRAND48_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the drand48() function. Otherwise, it is up * to the program to supply one. A good guess is * extern double drand48(void); */ /*#define HAS_DRAND48_PROTO / **/ /* HAS_ENDGRENT: * This symbol, if defined, indicates that the getgrent routine is * available for finalizing sequential access of the group database. */ #define HAS_ENDGRENT /**/ /* HAS_ENDGRENT_R: * This symbol, if defined, indicates that the endgrent_r routine * is available to endgrent re-entrantly. */ /* ENDGRENT_R_PROTO: * This symbol encodes the prototype of endgrent_r. * It is zero if d_endgrent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endgrent_r * is defined. */ /*#define HAS_ENDGRENT_R / **/ #define ENDGRENT_R_PROTO 0 /**/ /* HAS_ENDHOSTENT: * This symbol, if defined, indicates that the endhostent() routine is * available to close whatever was being used for host queries. */ #define HAS_ENDHOSTENT /**/ /* HAS_ENDNETENT: * This symbol, if defined, indicates that the endnetent() routine is * available to close whatever was being used for network queries. */ /*#define HAS_ENDNETENT / **/ /* HAS_ENDPROTOENT: * This symbol, if defined, indicates that the endprotoent() routine is * available to close whatever was being used for protocol queries. */ /*#define HAS_ENDPROTOENT / **/ /* HAS_ENDPWENT: * This symbol, if defined, indicates that the getgrent routine is * available for finalizing sequential access of the passwd database. */ #define HAS_ENDPWENT /**/ /* HAS_ENDPWENT_R: * This symbol, if defined, indicates that the endpwent_r routine * is available to endpwent re-entrantly. */ /* ENDPWENT_R_PROTO: * This symbol encodes the prototype of endpwent_r. * It is zero if d_endpwent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endpwent_r * is defined. */ /*#define HAS_ENDPWENT_R / **/ #define ENDPWENT_R_PROTO 0 /**/ /* HAS_ENDSERVENT: * This symbol, if defined, indicates that the endservent() routine is * available to close whatever was being used for service queries. */ /*#define HAS_ENDSERVENT / **/ /* HAS_FAST_STDIO: * This symbol, if defined, indicates that the "fast stdio" * is available to manipulate the stdio buffers directly. */ /*#define HAS_FAST_STDIO /**/ /* HAS_FCHDIR: * This symbol, if defined, indicates that the fchdir routine is * available to change directory using a file descriptor. */ /*#define HAS_FCHDIR / **/ /* FCNTL_CAN_LOCK: * This symbol, if defined, indicates that fcntl() can be used * for file locking. Normally on Unix systems this is defined. * It may be undefined on VMS. */ /*#define FCNTL_CAN_LOCK / **/ /* HAS_FD_SET: * This symbol, when defined, indicates presence of the fd_set typedef * in */ /*#define HAS_FD_SET / **/ /* HAS_FINITE: * This symbol, if defined, indicates that the finite routine is * available to check whether a double is finite (non-infinity non-NaN). */ /*#define HAS_FINITE / **/ /* HAS_FINITEL: * This symbol, if defined, indicates that the finitel routine is * available to check whether a long double is finite * (non-infinity non-NaN). */ /*#define HAS_FINITEL / **/ /* FLEXFILENAMES: * This symbol, if defined, indicates that the system supports filenames * longer than 14 characters. */ #define FLEXFILENAMES /**/ /* HAS_FP_CLASS: * This symbol, if defined, indicates that the fp_class routine is * available to classify doubles. Available for example in Digital UNIX. * The returned values are defined in and are: * * FP_SNAN Signaling NaN (Not-a-Number) * FP_QNAN Quiet NaN (Not-a-Number) * FP_POS_INF +infinity * FP_NEG_INF -infinity * FP_POS_NORM Positive normalized * FP_NEG_NORM Negative normalized * FP_POS_DENORM Positive denormalized * FP_NEG_DENORM Negative denormalized * FP_POS_ZERO +0.0 (positive zero) * FP_NEG_ZERO -0.0 (negative zero) */ /*#define HAS_FP_CLASS / **/ /* HAS_FPCLASS: * This symbol, if defined, indicates that the fpclass routine is * available to classify doubles. Available for example in Solaris/SVR4. * The returned values are defined in and are: * * FP_SNAN signaling NaN * FP_QNAN quiet NaN * FP_NINF negative infinity * FP_PINF positive infinity * FP_NDENORM negative denormalized non-zero * FP_PDENORM positive denormalized non-zero * FP_NZERO negative zero * FP_PZERO positive zero * FP_NNORM negative normalized non-zero * FP_PNORM positive normalized non-zero */ /*#define HAS_FPCLASS / **/ /* HAS_FPCLASSIFY: * This symbol, if defined, indicates that the fpclassify routine is * available to classify doubles. Available for example in HP-UX. * The returned values are defined in and are * * FP_NORMAL Normalized * FP_ZERO Zero * FP_INFINITE Infinity * FP_SUBNORMAL Denormalized * FP_NAN NaN * */ /*#define HAS_FPCLASSIFY / **/ /* HAS_FPOS64_T: * This symbol will be defined if the C compiler supports fpos64_t. */ /*#define HAS_FPOS64_T / **/ /* HAS_FREXPL: * This symbol, if defined, indicates that the frexpl routine is * available to break a long double floating-point number into * a normalized fraction and an integral power of 2. */ /*#define HAS_FREXPL / **/ /* HAS_STRUCT_FS_DATA: * This symbol, if defined, indicates that the struct fs_data * to do statfs() is supported. */ /*#define HAS_STRUCT_FS_DATA / **/ /* HAS_FSEEKO: * This symbol, if defined, indicates that the fseeko routine is * available to fseek beyond 32 bits (useful for ILP32 hosts). */ /*#define HAS_FSEEKO / **/ /* HAS_FSTATFS: * This symbol, if defined, indicates that the fstatfs routine is * available to stat filesystems by file descriptors. */ /*#define HAS_FSTATFS / **/ /* HAS_FSYNC: * This symbol, if defined, indicates that the fsync routine is * available to write a file's modified data and attributes to * permanent storage. */ #define HAS_FSYNC /**/ /* HAS_FTELLO: * This symbol, if defined, indicates that the ftello routine is * available to ftell beyond 32 bits (useful for ILP32 hosts). */ /*#define HAS_FTELLO / **/ /* Gconvert: * This preprocessor macro is defined to convert a floating point * number to a string without a trailing decimal point. This * emulates the behavior of sprintf("%g"), but is sometimes much more * efficient. If gconvert() is not available, but gcvt() drops the * trailing decimal point, then gcvt() is used. If all else fails, * a macro using sprintf("%g") is used. Arguments for the Gconvert * macro are: value, number of digits, whether trailing zeros should * be retained, and the output buffer. * The usual values are: * d_Gconvert='gconvert((x),(n),(t),(b))' * d_Gconvert='gcvt((x),(n),(b))' * d_Gconvert='sprintf((b),"%.*g",(n),(x))' * The last two assume trailing zeros should not be kept. */ #define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(x)) /* HAS_GETCWD: * This symbol, if defined, indicates that the getcwd routine is * available to get the current working directory. */ #define HAS_GETCWD /**/ /* HAS_GETESPWNAM: * This symbol, if defined, indicates that the getespwnam system call is * available to retrieve enchanced (shadow) password entries by name. */ /*#define HAS_GETESPWNAM / **/ /* HAS_GETFSSTAT: * This symbol, if defined, indicates that the getfsstat routine is * available to stat filesystems in bulk. */ /*#define HAS_GETFSSTAT / **/ /* HAS_GETGRENT: * This symbol, if defined, indicates that the getgrent routine is * available for sequential access of the group database. */ #define HAS_GETGRENT /**/ /* HAS_GETGRENT_R: * This symbol, if defined, indicates that the getgrent_r routine * is available to getgrent re-entrantly. */ /* GETGRENT_R_PROTO: * This symbol encodes the prototype of getgrent_r. * It is zero if d_getgrent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrent_r * is defined. */ /*#define HAS_GETGRENT_R / **/ #define GETGRENT_R_PROTO 0 /**/ /* HAS_GETGRGID_R: * This symbol, if defined, indicates that the getgrgid_r routine * is available to getgrgid re-entrantly. */ /* GETGRGID_R_PROTO: * This symbol encodes the prototype of getgrgid_r. * It is zero if d_getgrgid_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrgid_r * is defined. */ /*#define HAS_GETGRGID_R / **/ #define GETGRGID_R_PROTO 0 /**/ /* HAS_GETGRNAM_R: * This symbol, if defined, indicates that the getgrnam_r routine * is available to getgrnam re-entrantly. */ /* GETGRNAM_R_PROTO: * This symbol encodes the prototype of getgrnam_r. * It is zero if d_getgrnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrnam_r * is defined. */ /*#define HAS_GETGRNAM_R / **/ #define GETGRNAM_R_PROTO 0 /**/ /* HAS_GETHOSTBYADDR: * This symbol, if defined, indicates that the gethostbyaddr() routine is * available to look up hosts by their IP addresses. */ #define HAS_GETHOSTBYADDR /**/ /* HAS_GETHOSTBYNAME: * This symbol, if defined, indicates that the gethostbyname() routine is * available to look up host names in some data base or other. */ #define HAS_GETHOSTBYNAME /**/ /* HAS_GETHOSTENT: * This symbol, if defined, indicates that the gethostent() routine is * available to look up host names in some data base or another. */ /*#define HAS_GETHOSTENT / **/ /* HAS_GETHOSTNAME: * This symbol, if defined, indicates that the C program may use the * gethostname() routine to derive the host name. See also HAS_UNAME * and PHOSTNAME. */ /* HAS_UNAME: * This symbol, if defined, indicates that the C program may use the * uname() routine to derive the host name. See also HAS_GETHOSTNAME * and PHOSTNAME. */ /* PHOSTNAME: * This symbol, if defined, indicates the command to feed to the * popen() routine to derive the host name. See also HAS_GETHOSTNAME * and HAS_UNAME. Note that the command uses a fully qualified path, * so that it is safe even if used by a process with super-user * privileges. */ /* HAS_PHOSTNAME: * This symbol, if defined, indicates that the C program may use the * contents of PHOSTNAME as a command to feed to the popen() routine * to derive the host name. */ #define HAS_GETHOSTNAME /**/ #define HAS_UNAME /**/ /*#define HAS_PHOSTNAME / **/ #ifdef HAS_PHOSTNAME #define PHOSTNAME "/bin/uname -n" /* How to get the host name */ #endif /* HAS_GETHOST_PROTOS: * This symbol, if defined, indicates that includes * prototypes for gethostent(), gethostbyname(), and * gethostbyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ /*#define HAS_GETHOST_PROTOS / **/ /* HAS_GETITIMER: * This symbol, if defined, indicates that the getitimer routine is * available to return interval timers. */ /*#define HAS_GETITIMER / **/ /* HAS_GETLOGIN_R: * This symbol, if defined, indicates that the getlogin_r routine * is available to getlogin re-entrantly. */ /* GETLOGIN_R_PROTO: * This symbol encodes the prototype of getlogin_r. * It is zero if d_getlogin_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getlogin_r * is defined. */ /*#define HAS_GETLOGIN_R / **/ #define GETLOGIN_R_PROTO 0 /**/ /* HAS_GETMNT: * This symbol, if defined, indicates that the getmnt routine is * available to get filesystem mount info by filename. */ /*#define HAS_GETMNT / **/ /* HAS_GETMNTENT: * This symbol, if defined, indicates that the getmntent routine is * available to iterate through mounted file systems to get their info. */ /*#define HAS_GETMNTENT / **/ /* HAS_GETNETBYADDR: * This symbol, if defined, indicates that the getnetbyaddr() routine is * available to look up networks by their IP addresses. */ /*#define HAS_GETNETBYADDR / **/ /* HAS_GETNETBYNAME: * This symbol, if defined, indicates that the getnetbyname() routine is * available to look up networks by their names. */ /*#define HAS_GETNETBYNAME / **/ /* HAS_GETNETENT: * This symbol, if defined, indicates that the getnetent() routine is * available to look up network names in some data base or another. */ /*#define HAS_GETNETENT / **/ /* HAS_GETNET_PROTOS: * This symbol, if defined, indicates that includes * prototypes for getnetent(), getnetbyname(), and * getnetbyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ /*#define HAS_GETNET_PROTOS / **/ /* HAS_GETPAGESIZE: * This symbol, if defined, indicates that the getpagesize system call * is available to get system page size, which is the granularity of * many memory management calls. */ /*#define HAS_GETPAGESIZE / **/ /* HAS_GETPROTOENT: * This symbol, if defined, indicates that the getprotoent() routine is * available to look up protocols in some data base or another. */ /*#define HAS_GETPROTOENT / **/ /* HAS_GETPGRP: * This symbol, if defined, indicates that the getpgrp routine is * available to get the current process group. */ /* USE_BSD_GETPGRP: * This symbol, if defined, indicates that getpgrp needs one * arguments whereas USG one needs none. */ #define HAS_GETPGRP /**/ /*#define USE_BSD_GETPGRP / **/ /* HAS_GETPROTOBYNAME: * This symbol, if defined, indicates that the getprotobyname() * routine is available to look up protocols by their name. */ /* HAS_GETPROTOBYNUMBER: * This symbol, if defined, indicates that the getprotobynumber() * routine is available to look up protocols by their number. */ #define HAS_GETPROTOBYNAME /**/ /*#define HAS_GETPROTOBYNUMBER / **/ /* HAS_GETPROTO_PROTOS: * This symbol, if defined, indicates that includes * prototypes for getprotoent(), getprotobyname(), and * getprotobyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ /*#define HAS_GETPROTO_PROTOS / **/ /* HAS_GETPRPWNAM: * This symbol, if defined, indicates that the getprpwnam system call is * available to retrieve protected (shadow) password entries by name. */ /*#define HAS_GETPRPWNAM / **/ /* HAS_GETPWENT: * This symbol, if defined, indicates that the getpwent routine is * available for sequential access of the passwd database. * If this is not available, the older getpw() function may be available. */ #define HAS_GETPWENT /**/ /* HAS_GETPWENT_R: * This symbol, if defined, indicates that the getpwent_r routine * is available to getpwent re-entrantly. */ /* GETPWENT_R_PROTO: * This symbol encodes the prototype of getpwent_r. * It is zero if d_getpwent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwent_r * is defined. */ /*#define HAS_GETPWENT_R / **/ #define GETPWENT_R_PROTO 0 /**/ /* HAS_GETPWNAM_R: * This symbol, if defined, indicates that the getpwnam_r routine * is available to getpwnam re-entrantly. */ /* GETPWNAM_R_PROTO: * This symbol encodes the prototype of getpwnam_r. * It is zero if d_getpwnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwnam_r * is defined. */ /*#define HAS_GETPWNAM_R / **/ #define GETPWNAM_R_PROTO 0 /**/ /* HAS_GETPWUID_R: * This symbol, if defined, indicates that the getpwuid_r routine * is available to getpwuid re-entrantly. */ /* GETPWUID_R_PROTO: * This symbol encodes the prototype of getpwuid_r. * It is zero if d_getpwuid_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwuid_r * is defined. */ /*#define HAS_GETPWUID_R / **/ #define GETPWUID_R_PROTO 0 /**/ /* HAS_GETSERVENT: * This symbol, if defined, indicates that the getservent() routine is * available to look up network services in some data base or another. */ /*#define HAS_GETSERVENT / **/ /* HAS_GETSERV_PROTOS: * This symbol, if defined, indicates that includes * prototypes for getservent(), getservbyname(), and * getservbyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ /*#define HAS_GETSERV_PROTOS / **/ /* HAS_GETSPNAM: * This symbol, if defined, indicates that the getspnam system call is * available to retrieve SysV shadow password entries by name. */ /*#define HAS_GETSPNAM / **/ /* HAS_GETSPNAM_R: * This symbol, if defined, indicates that the getspnam_r routine * is available to getspnam re-entrantly. */ /* GETSPNAM_R_PROTO: * This symbol encodes the prototype of getspnam_r. * It is zero if d_getspnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getspnam_r * is defined. */ /*#define HAS_GETSPNAM_R / **/ #define GETSPNAM_R_PROTO 0 /**/ /* HAS_GETSERVBYNAME: * This symbol, if defined, indicates that the getservbyname() * routine is available to look up services by their name. */ /* HAS_GETSERVBYPORT: * This symbol, if defined, indicates that the getservbyport() * routine is available to look up services by their port. */ #define HAS_GETSERVBYNAME /**/ /*#define HAS_GETSERVBYPORT / **/ /* HAS_GMTIME_R: * This symbol, if defined, indicates that the gmtime_r routine * is available to gmtime re-entrantly. */ /* GMTIME_R_PROTO: * This symbol encodes the prototype of gmtime_r. * It is zero if d_gmtime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gmtime_r * is defined. */ /*#define HAS_GMTIME_R / **/ #define GMTIME_R_PROTO 0 /**/ /* HAS_GNULIBC: * This symbol, if defined, indicates to the C program that * the GNU C library is being used. A better check is to use * the __GLIBC__ and __GLIBC_MINOR__ symbols supplied with glibc. */ /*#define HAS_GNULIBC / **/ #if defined(HAS_GNULIBC) && !defined(_GNU_SOURCE) # define _GNU_SOURCE #endif /* HAS_HASMNTOPT: * This symbol, if defined, indicates that the hasmntopt routine is * available to query the mount options of file systems. */ /*#define HAS_HASMNTOPT / **/ /* HAS_HTONL: * This symbol, if defined, indicates that the htonl() routine (and * friends htons() ntohl() ntohs()) are available to do network * order byte swapping. */ /* HAS_HTONS: * This symbol, if defined, indicates that the htons() routine (and * friends htonl() ntohl() ntohs()) are available to do network * order byte swapping. */ /* HAS_NTOHL: * This symbol, if defined, indicates that the ntohl() routine (and * friends htonl() htons() ntohs()) are available to do network * order byte swapping. */ /* HAS_NTOHS: * This symbol, if defined, indicates that the ntohs() routine (and * friends htonl() htons() ntohl()) are available to do network * order byte swapping. */ #define HAS_HTONL /**/ #define HAS_HTONS /**/ #define HAS_NTOHL /**/ #define HAS_NTOHS /**/ /* HAS_ILOGBL: * This symbol, if defined, indicates that the ilogbl routine is * available. If scalbnl is also present we can emulate frexpl. */ /*#define HAS_ILOGBL /**/ /* HAS_INT64_T: * This symbol will defined if the C compiler supports int64_t. * Usually the needs to be included, but sometimes * is enough. */ #define HAS_INT64_T /**/ /* HAS_ISASCII: * This manifest constant lets the C program know that isascii * is available. */ /*#define HAS_ISASCII / **/ /* HAS_ISFINITE: * This symbol, if defined, indicates that the isfinite routine is * available to check whether a double is finite (non-infinity non-NaN). */ /*#define HAS_ISFINITE / **/ /* HAS_ISINF: * This symbol, if defined, indicates that the isinf routine is * available to check whether a double is an infinity. */ /*#define HAS_ISINF / **/ /* HAS_ISNAN: * This symbol, if defined, indicates that the isnan routine is * available to check whether a double is a NaN. */ /*#define HAS_ISNAN / **/ /* HAS_ISNANL: * This symbol, if defined, indicates that the isnanl routine is * available to check whether a long double is a NaN. */ /*#define HAS_ISNANL / **/ /* HAS_LCHOWN: * This symbol, if defined, indicates that the lchown routine is * available to operate on a symbolic link (instead of following the * link). */ /*#define HAS_LCHOWN / **/ /* HAS_LDBL_DIG: * This symbol, if defined, indicates that this system's * or defines the symbol LDBL_DIG, which is the number * of significant digits in a long double precision number. Unlike * for DBL_DIG, there's no good guess for LDBL_DIG if it is undefined. */ #define HAS_LDBL_DIG /* */ /* HAS_LOCALTIME_R: * This symbol, if defined, indicates that the localtime_r routine * is available to localtime re-entrantly. */ /* LOCALTIME_R_NEEDS_TZSET: * Many libc's localtime_r implementations do not call tzset, * making them differ from localtime(), and making timezone * changes using $ENV{TZ} without explicitly calling tzset * impossible. This symbol makes us call tzset before localtime_r */ /* LOCALTIME_R_PROTO: * This symbol encodes the prototype of localtime_r. * It is zero if d_localtime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_localtime_r * is defined. */ /*#define HAS_LOCALTIME_R / **/ /*#define LOCALTIME_R_NEEDS_TZSET / **/ #define LOCALTIME_R_PROTO 0 /**/ /* HAS_LONG_DOUBLE: * This symbol will be defined if the C compiler supports long * doubles. */ /* LONG_DOUBLESIZE: * This symbol contains the size of a long double, so that the * C preprocessor can make decisions based on it. It is only * defined if the system supports long doubles. */ #define HAS_LONG_DOUBLE /**/ #ifdef HAS_LONG_DOUBLE #define LONG_DOUBLESIZE 8 /**/ #endif /* HAS_LONG_LONG: * This symbol will be defined if the C compiler supports long long. */ /* LONGLONGSIZE: * This symbol contains the size of a long long, so that the * C preprocessor can make decisions based on it. It is only * defined if the system supports long long. */ #define HAS_LONG_LONG /**/ #ifdef HAS_LONG_LONG #define LONGLONGSIZE 8 /**/ #endif /* HAS_LSEEK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the lseek() function. Otherwise, it is up * to the program to supply one. A good guess is * extern off_t lseek(int, off_t, int); */ /*#define HAS_LSEEK_PROTO / **/ /* HAS_MADVISE: * This symbol, if defined, indicates that the madvise system call is * available to map a file into memory. */ /*#define HAS_MADVISE / **/ /* HAS_MEMCHR: * This symbol, if defined, indicates that the memchr routine is available * to locate characters within a C string. */ #define HAS_MEMCHR /**/ /* HAS_MKDTEMP: * This symbol, if defined, indicates that the mkdtemp routine is * available to exclusively create a uniquely named temporary directory. */ /*#define HAS_MKDTEMP / **/ /* HAS_MKSTEMP: * This symbol, if defined, indicates that the mkstemp routine is * available to exclusively create and open a uniquely named * temporary file. */ /*#define HAS_MKSTEMP / **/ /* HAS_MKSTEMPS: * This symbol, if defined, indicates that the mkstemps routine is * available to excluslvely create and open a uniquely named * (with a suffix) temporary file. */ /*#define HAS_MKSTEMPS / **/ /* HAS_MMAP: * This symbol, if defined, indicates that the mmap system call is * available to map a file into memory. */ /* Mmap_t: * This symbol holds the return type of the mmap() system call * (and simultaneously the type of the first argument). * Usually set to 'void *' or 'cadd_t'. */ /*#define HAS_MMAP / **/ #define Mmap_t void * /**/ /* HAS_MODFL: * This symbol, if defined, indicates that the modfl routine is * available to split a long double x into a fractional part f and * an integer part i such that |f| < 1.0 and (f + i) = x. */ /* HAS_MODFL_POW32_BUG: * This symbol, if defined, indicates that the modfl routine is * broken for long doubles >= pow(2, 32). * For example from 4294967303.150000 one would get 4294967302.000000 * and 1.150000. The bug has been seen in certain versions of glibc, * release 2.2.2 is known to be okay. */ /*#define HAS_MODFL / **/ /*#define HAS_MODFL_POW32_BUG / **/ /* HAS_MPROTECT: * This symbol, if defined, indicates that the mprotect system call is * available to modify the access protection of a memory mapped file. */ /*#define HAS_MPROTECT / **/ /* HAS_MSG: * This symbol, if defined, indicates that the entire msg*(2) library is * supported (IPC mechanism based on message queues). */ /*#define HAS_MSG / **/ /* HAS_STRUCT_MSGHDR: * This symbol, if defined, indicates that the struct msghdr * is supported. */ /*#define HAS_STRUCT_MSGHDR / **/ /* HAS_OFF64_T: * This symbol will be defined if the C compiler supports off64_t. */ /*#define HAS_OFF64_T / **/ /* HAS_OPEN3: * This manifest constant lets the C program know that the three * argument form of open(2) is available. */ #define HAS_OPEN3 /**/ /* OLD_PTHREAD_CREATE_JOINABLE: * This symbol, if defined, indicates how to create pthread * in joinable (aka undetached) state. NOTE: not defined * if pthread.h already has defined PTHREAD_CREATE_JOINABLE * (the new version of the constant). * If defined, known values are PTHREAD_CREATE_UNDETACHED * and __UNDETACHED. */ /*#define OLD_PTHREAD_CREATE_JOINABLE / **/ /* HAS_PTHREAD_YIELD: * This symbol, if defined, indicates that the pthread_yield * routine is available to yield the execution of the current * thread. sched_yield is preferable to pthread_yield. */ /* SCHED_YIELD: * This symbol defines the way to yield the execution of * the current thread. Known ways are sched_yield, * pthread_yield, and pthread_yield with NULL. */ /* HAS_SCHED_YIELD: * This symbol, if defined, indicates that the sched_yield * routine is available to yield the execution of the current * thread. sched_yield is preferable to pthread_yield. */ /*#define HAS_PTHREAD_YIELD / **/ #define SCHED_YIELD undef /**/ /*#define HAS_SCHED_YIELD / **/ /* HAS_RANDOM_R: * This symbol, if defined, indicates that the random_r routine * is available to random re-entrantly. */ /* RANDOM_R_PROTO: * This symbol encodes the prototype of random_r. * It is zero if d_random_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_random_r * is defined. */ /*#define HAS_RANDOM_R / **/ #define RANDOM_R_PROTO 0 /**/ /* HAS_READDIR_R: * This symbol, if defined, indicates that the readdir_r routine * is available to readdir re-entrantly. */ /* READDIR_R_PROTO: * This symbol encodes the prototype of readdir_r. * It is zero if d_readdir_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_readdir_r * is defined. */ /*#define HAS_READDIR_R / **/ #define READDIR_R_PROTO 0 /**/ /* HAS_READV: * This symbol, if defined, indicates that the readv routine is * available to do gather reads. You will also need * and there I_SYSUIO. */ #define HAS_READV /**/ /* HAS_RECVMSG: * This symbol, if defined, indicates that the recvmsg routine is * available to send structured socket messages. */ /*#define HAS_RECVMSG / **/ /* HAS_SAFE_BCOPY: * This symbol, if defined, indicates that the bcopy routine is available * to copy potentially overlapping memory blocks. Normally, you should * probably use memmove() or memcpy(). If neither is defined, roll your * own version. */ /*#define HAS_SAFE_BCOPY / **/ /* HAS_SAFE_MEMCPY: * This symbol, if defined, indicates that the memcpy routine is available * to copy potentially overlapping memory blocks. If you need to * copy overlapping memory blocks, you should check HAS_MEMMOVE and * use memmove() instead, if available. */ /*#define HAS_SAFE_MEMCPY / **/ /* HAS_SANE_MEMCMP: * This symbol, if defined, indicates that the memcmp routine is available * and can be used to compare relative magnitudes of chars with their high * bits set. If it is not defined, roll your own version. */ #define HAS_SANE_MEMCMP /**/ /* HAS_SBRK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the sbrk() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern void* sbrk(int); * extern void* sbrk(size_t); */ /*#define HAS_SBRK_PROTO / **/ /* HAS_SEM: * This symbol, if defined, indicates that the entire sem*(2) library is * supported. */ /*#define HAS_SEM / **/ /* HAS_SCALBNL: * This symbol, if defined, indicates that the scalbnl routine is * available. If ilogbl is also present we can emulate frexpl. */ /*#define HAS_SCALBNL /**/ /* HAS_SENDMSG: * This symbol, if defined, indicates that the sendmsg routine is * available to send structured socket messages. */ /*#define HAS_SENDMSG / **/ /* HAS_SETGRENT: * This symbol, if defined, indicates that the setgrent routine is * available for initializing sequential access of the group database. */ #define HAS_SETGRENT /**/ /* HAS_SETGRENT_R: * This symbol, if defined, indicates that the setgrent_r routine * is available to setgrent re-entrantly. */ /* SETGRENT_R_PROTO: * This symbol encodes the prototype of setgrent_r. * It is zero if d_setgrent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setgrent_r * is defined. */ /*#define HAS_SETGRENT_R / **/ #define SETGRENT_R_PROTO 0 /**/ /* HAS_SETGROUPS: * This symbol, if defined, indicates that the setgroups() routine is * available to set the list of process groups. If unavailable, multiple * groups are probably not supported. */ /*#define HAS_SETGROUPS /* config-skip */ /* HAS_SETHOSTENT: * This symbol, if defined, indicates that the sethostent() routine is * available. */ /*#define HAS_SETHOSTENT / **/ /* HAS_SETITIMER: * This symbol, if defined, indicates that the setitimer routine is * available to set interval timers. */ /*#define HAS_SETITIMER / **/ /* HAS_SETNETENT: * This symbol, if defined, indicates that the setnetent() routine is * available. */ /*#define HAS_SETNETENT / **/ /* HAS_SETPROTOENT: * This symbol, if defined, indicates that the setprotoent() routine is * available. */ /*#define HAS_SETPROTOENT / **/ /* HAS_SETPGRP: * This symbol, if defined, indicates that the setpgrp routine is * available to set the current process group. */ /* USE_BSD_SETPGRP: * This symbol, if defined, indicates that setpgrp needs two * arguments whereas USG one needs none. See also HAS_SETPGID * for a POSIX interface. */ /*#define HAS_SETPGRP / **/ /*#define USE_BSD_SETPGRP / **/ /* HAS_SETPROCTITLE: * This symbol, if defined, indicates that the setproctitle routine is * available to set process title. */ /*#define HAS_SETPROCTITLE / **/ /* HAS_SETPWENT: * This symbol, if defined, indicates that the setpwent routine is * available for initializing sequential access of the passwd database. */ #define HAS_SETPWENT /**/ /* HAS_SETPWENT_R: * This symbol, if defined, indicates that the setpwent_r routine * is available to setpwent re-entrantly. */ /* SETPWENT_R_PROTO: * This symbol encodes the prototype of setpwent_r. * It is zero if d_setpwent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setpwent_r * is defined. */ /*#define HAS_SETPWENT_R / **/ #define SETPWENT_R_PROTO 0 /**/ /* HAS_SETSERVENT: * This symbol, if defined, indicates that the setservent() routine is * available. */ /*#define HAS_SETSERVENT / **/ /* HAS_SETVBUF: * This symbol, if defined, indicates that the setvbuf routine is * available to change buffering on an open stdio stream. * to a line-buffered mode. */ #define HAS_SETVBUF /**/ /* USE_SFIO: * This symbol, if defined, indicates that sfio should * be used. */ /*#define USE_SFIO / **/ /* HAS_SHM: * This symbol, if defined, indicates that the entire shm*(2) library is * supported. */ /*#define HAS_SHM / **/ /* HAS_SIGACTION: * This symbol, if defined, indicates that Vr4's sigaction() routine * is available. */ #define HAS_SIGACTION /**/ /* HAS_SIGSETJMP: * This variable indicates to the C program that the sigsetjmp() * routine is available to save the calling process's registers * and stack environment for later use by siglongjmp(), and * to optionally save the process's signal mask. See * Sigjmp_buf, Sigsetjmp, and Siglongjmp. */ /* Sigjmp_buf: * This is the buffer type to be used with Sigsetjmp and Siglongjmp. */ /* Sigsetjmp: * This macro is used in the same way as sigsetjmp(), but will invoke * traditional setjmp() if sigsetjmp isn't available. * See HAS_SIGSETJMP. */ /* Siglongjmp: * This macro is used in the same way as siglongjmp(), but will invoke * traditional longjmp() if siglongjmp isn't available. * See HAS_SIGSETJMP. */ #define HAS_SIGSETJMP /* config-skip */ #ifdef HAS_SIGSETJMP #define Sigjmp_buf sigjmp_buf /* config-skip */ #define Sigsetjmp(buf,save_mask) sigsetjmp((buf),(save_mask)) /* config-skip */ #define Siglongjmp(buf,retval) siglongjmp((buf),(retval)) /* config-skip */ #else #define Sigjmp_buf jmp_buf #define Sigsetjmp(buf,save_mask) setjmp((buf)) #define Siglongjmp(buf,retval) longjmp((buf),(retval)) #endif /* HAS_SOCKET: * This symbol, if defined, indicates that the BSD socket interface is * supported. */ /* HAS_SOCKETPAIR: * This symbol, if defined, indicates that the BSD socketpair() call is * supported. */ /* HAS_MSG_CTRUNC: * This symbol, if defined, indicates that the MSG_CTRUNC is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_DONTROUTE: * This symbol, if defined, indicates that the MSG_DONTROUTE is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_OOB: * This symbol, if defined, indicates that the MSG_OOB is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_PEEK: * This symbol, if defined, indicates that the MSG_PEEK is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_PROXY: * This symbol, if defined, indicates that the MSG_PROXY is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_SCM_RIGHTS: * This symbol, if defined, indicates that the SCM_RIGHTS is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ #define HAS_SOCKET /**/ #define HAS_SOCKETPAIR /**/ /*#define HAS_MSG_CTRUNC / **/ /*#define HAS_MSG_DONTROUTE / **/ /*#define HAS_MSG_OOB / **/ /*#define HAS_MSG_PEEK / **/ /*#define HAS_MSG_PROXY / **/ /*#define HAS_SCM_RIGHTS / **/ /* HAS_SOCKS5_INIT: * This symbol, if defined, indicates that the socks5_init routine is * available to initialize SOCKS 5. */ /*#define HAS_SOCKS5_INIT / **/ /* HAS_SQRTL: * This symbol, if defined, indicates that the sqrtl routine is * available to do long double square roots. */ /*#define HAS_SQRTL / **/ /* HAS_SRAND48_R: * This symbol, if defined, indicates that the srand48_r routine * is available to srand48 re-entrantly. */ /* SRAND48_R_PROTO: * This symbol encodes the prototype of srand48_r. * It is zero if d_srand48_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_srand48_r * is defined. */ /*#define HAS_SRAND48_R / **/ #define SRAND48_R_PROTO 0 /**/ /* HAS_SRANDOM_R: * This symbol, if defined, indicates that the srandom_r routine * is available to srandom re-entrantly. */ /* SRANDOM_R_PROTO: * This symbol encodes the prototype of srandom_r. * It is zero if d_srandom_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_srandom_r * is defined. */ /*#define HAS_SRANDOM_R / **/ #define SRANDOM_R_PROTO 0 /**/ /* USE_STAT_BLOCKS: * This symbol is defined if this system has a stat structure declaring * st_blksize and st_blocks. */ #ifndef USE_STAT_BLOCKS /*#define USE_STAT_BLOCKS / **/ #endif /* HAS_STRUCT_STATFS_F_FLAGS: * This symbol, if defined, indicates that the struct statfs * does have the f_flags member containing the mount flags of * the filesystem containing the file. * This kind of struct statfs is coming from (BSD 4.3), * not from (SYSV). Older BSDs (like Ultrix) do not * have statfs() and struct statfs, they have ustat() and getmnt() * with struct ustat and struct fs_data. */ /*#define HAS_STRUCT_STATFS_F_FLAGS / **/ /* HAS_STRUCT_STATFS: * This symbol, if defined, indicates that the struct statfs * to do statfs() is supported. */ /*#define HAS_STRUCT_STATFS / **/ /* HAS_FSTATVFS: * This symbol, if defined, indicates that the fstatvfs routine is * available to stat filesystems by file descriptors. */ /*#define HAS_FSTATVFS / **/ /* USE_STDIO_PTR: * This symbol is defined if the _ptr and _cnt fields (or similar) * of the stdio FILE structure can be used to access the stdio buffer * for a file handle. If this is defined, then the FILE_ptr(fp) * and FILE_cnt(fp) macros will also be defined and should be used * to access these fields. */ /* FILE_ptr: * This macro is used to access the _ptr field (or equivalent) of the * FILE structure pointed to by its argument. This macro will always be * defined if USE_STDIO_PTR is defined. */ /* STDIO_PTR_LVALUE: * This symbol is defined if the FILE_ptr macro can be used as an * lvalue. */ /* FILE_cnt: * This macro is used to access the _cnt field (or equivalent) of the * FILE structure pointed to by its argument. This macro will always be * defined if USE_STDIO_PTR is defined. */ /* STDIO_CNT_LVALUE: * This symbol is defined if the FILE_cnt macro can be used as an * lvalue. */ /* STDIO_PTR_LVAL_SETS_CNT: * This symbol is defined if using the FILE_ptr macro as an lvalue * to increase the pointer by n has the side effect of decreasing the * value of File_cnt(fp) by n. */ /* STDIO_PTR_LVAL_NOCHANGE_CNT: * This symbol is defined if using the FILE_ptr macro as an lvalue * to increase the pointer by n leaves File_cnt(fp) unchanged. */ /*#define USE_STDIO_PTR / **/ #ifdef USE_STDIO_PTR #define FILE_ptr(fp) ((fp)->_ptr) /*#define STDIO_PTR_LVALUE / **/ #define FILE_cnt(fp) ((fp)->_cnt) /*#define STDIO_CNT_LVALUE / **/ /*#define STDIO_PTR_LVAL_SETS_CNT / **/ /*#define STDIO_PTR_LVAL_NOCHANGE_CNT / **/ #endif /* USE_STDIO_BASE: * This symbol is defined if the _base field (or similar) of the * stdio FILE structure can be used to access the stdio buffer for * a file handle. If this is defined, then the FILE_base(fp) macro * will also be defined and should be used to access this field. * Also, the FILE_bufsiz(fp) macro will be defined and should be used * to determine the number of bytes in the buffer. USE_STDIO_BASE * will never be defined unless USE_STDIO_PTR is. */ /* FILE_base: * This macro is used to access the _base field (or equivalent) of the * FILE structure pointed to by its argument. This macro will always be * defined if USE_STDIO_BASE is defined. */ /* FILE_bufsiz: * This macro is used to determine the number of bytes in the I/O * buffer pointed to by _base field (or equivalent) of the FILE * structure pointed to its argument. This macro will always be defined * if USE_STDIO_BASE is defined. */ /*#define USE_STDIO_BASE / **/ #ifdef USE_STDIO_BASE #define FILE_base(fp) ((fp)->_base) #define FILE_bufsiz(fp) ((fp)->_cnt + (fp)->_ptr - (fp)->_base) #endif /* HAS_STRERROR: * This symbol, if defined, indicates that the strerror routine is * available to translate error numbers to strings. See the writeup * of Strerror() in this file before you try to define your own. */ /* HAS_SYS_ERRLIST: * This symbol, if defined, indicates that the sys_errlist array is * available to translate error numbers to strings. The extern int * sys_nerr gives the size of that table. */ /* Strerror: * This preprocessor symbol is defined as a macro if strerror() is * not available to translate error numbers to strings but sys_errlist[] * array is there. */ #define HAS_STRERROR /**/ #define HAS_SYS_ERRLIST /**/ #define Strerror(e) strerror(e) /* HAS_STRERROR_R: * This symbol, if defined, indicates that the strerror_r routine * is available to strerror re-entrantly. */ /* STRERROR_R_PROTO: * This symbol encodes the prototype of strerror_r. * It is zero if d_strerror_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_strerror_r * is defined. */ /*#define HAS_STRERROR_R / **/ #define STRERROR_R_PROTO 0 /**/ /* HAS_STRTOLD: * This symbol, if defined, indicates that the strtold routine is * available to convert strings to long doubles. */ /*#define HAS_STRTOLD / **/ /* HAS_STRTOLL: * This symbol, if defined, indicates that the strtoll routine is * available to convert strings to long longs. */ /*#define HAS_STRTOLL / **/ /* HAS_STRTOQ: * This symbol, if defined, indicates that the strtoq routine is * available to convert strings to long longs (quads). */ /*#define HAS_STRTOQ / **/ /* HAS_STRTOUL: * This symbol, if defined, indicates that the strtoul routine is * available to provide conversion of strings to unsigned long. */ #define HAS_STRTOUL /**/ /* HAS_STRTOULL: * This symbol, if defined, indicates that the strtoull routine is * available to convert strings to unsigned long longs. */ /*#define HAS_STRTOULL / **/ /* HAS_STRTOUQ: * This symbol, if defined, indicates that the strtouq routine is * available to convert strings to unsigned long longs (quads). */ /*#define HAS_STRTOUQ / **/ /* HAS_TELLDIR_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the telldir() function. Otherwise, it is up * to the program to supply one. A good guess is * extern long telldir(DIR*); */ /*#define HAS_TELLDIR_PROTO / **/ /* HAS_TIME: * This symbol, if defined, indicates that the time() routine exists. */ /* Time_t: * This symbol holds the type returned by time(). It can be long, * or time_t on BSD sites (in which case should be * included). */ #define HAS_TIME /**/ #define Time_t time_t /* Time type */ /* HAS_TIMES: * This symbol, if defined, indicates that the times() routine exists. * Note that this became obsolete on some systems (SUNOS), which now * use getrusage(). It may be necessary to include . */ #define HAS_TIMES /**/ /* HAS_TMPNAM_R: * This symbol, if defined, indicates that the tmpnam_r routine * is available to tmpnam re-entrantly. */ /* TMPNAM_R_PROTO: * This symbol encodes the prototype of tmpnam_r. * It is zero if d_tmpnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_tmpnam_r * is defined. */ /*#define HAS_TMPNAM_R / **/ #define TMPNAM_R_PROTO 0 /**/ /* HAS_UALARM: * This symbol, if defined, indicates that the ualarm routine is * available to do alarms with microsecond granularity. */ /*#define HAS_UALARM / **/ /* HAS_UNION_SEMUN: * This symbol, if defined, indicates that the union semun is * defined by including . If not, the user code * probably needs to define it as: * union semun { * int val; * struct semid_ds *buf; * unsigned short *array; * } */ /* USE_SEMCTL_SEMUN: * This symbol, if defined, indicates that union semun is * used for semctl IPC_STAT. */ /* USE_SEMCTL_SEMID_DS: * This symbol, if defined, indicates that struct semid_ds * is * used for semctl IPC_STAT. */ /*#define HAS_UNION_SEMUN / **/ /*#define USE_SEMCTL_SEMUN / **/ /*#define USE_SEMCTL_SEMID_DS / **/ /* HAS_UNORDERED: * This symbol, if defined, indicates that the unordered routine is * available to check whether two doubles are unordered * (effectively: whether either of them is NaN) */ /*#define HAS_UNORDERED / **/ /* HAS_USTAT: * This symbol, if defined, indicates that the ustat system call is * available to query file system statistics by dev_t. */ /*#define HAS_USTAT / **/ /* HAS_VFORK: * This symbol, if defined, indicates that vfork() exists. */ /*#define HAS_VFORK / **/ /* Signal_t: * This symbol's value is either "void" or "int", corresponding to the * appropriate return type of a signal handler. Thus, you can declare * a signal handler using "Signal_t (*handler)()", and define the * handler using "Signal_t handler(sig)". */ #define Signal_t void /* Signal handler's return type */ /* HAS_VPRINTF: * This symbol, if defined, indicates that the vprintf routine is available * to printf with a pointer to an argument list. If unavailable, you * may need to write your own, probably in terms of _doprnt(). */ /* USE_CHAR_VSPRINTF: * This symbol is defined if this system has vsprintf() returning type * (char*). The trend seems to be to declare it as "int vsprintf()". It * is up to the package author to declare vsprintf correctly based on the * symbol. */ #define HAS_VPRINTF /**/ #define USE_CHAR_VSPRINTF /**/ /* HAS_WRITEV: * This symbol, if defined, indicates that the writev routine is * available to do scatter writes. */ #define HAS_WRITEV /**/ /* USE_DYNAMIC_LOADING: * This symbol, if defined, indicates that dynamic loading of * some sort is available. */ /*#define USE_DYNAMIC_LOADING / **/ /* DOUBLESIZE: * This symbol contains the size of a double, so that the C preprocessor * can make decisions based on it. */ #define DOUBLESIZE 8 /**/ /* EBCDIC: * This symbol, if defined, indicates that this system uses * EBCDIC encoding. */ /*#define EBCDIC / **/ /* FFLUSH_NULL: * This symbol, if defined, tells that fflush(NULL) does flush * all pending stdio output. */ /* FFLUSH_ALL: * This symbol, if defined, tells that to flush * all pending stdio output one must loop through all * the stdio file handles stored in an array and fflush them. * Note that if fflushNULL is defined, fflushall will not * even be probed for and will be left undefined. */ #define FFLUSH_NULL /**/ /*#define FFLUSH_ALL / **/ /* Fpos_t: * This symbol holds the type used to declare file positions in libc. * It can be fpos_t, long, uint, etc... It may be necessary to include * to get any typedef'ed information. */ #define Fpos_t fpos_t /* File position type */ /* Gid_t_f: * This symbol defines the format string used for printing a Gid_t. */ #define Gid_t_f "hd" /**/ /* Gid_t_sign: * This symbol holds the signedess of a Gid_t. * 1 for unsigned, -1 for signed. */ #define Gid_t_sign -1 /* GID sign */ /* Gid_t_size: * This symbol holds the size of a Gid_t in bytes. */ #define Gid_t_size 2 /* GID size */ /* Gid_t: * This symbol holds the return type of getgid() and the type of * argument to setrgid() and related functions. Typically, * it is the type of group ids in the kernel. It can be int, ushort, * gid_t, etc... It may be necessary to include to get * any typedef'ed information. */ #define Gid_t gid_t /* Type for getgid(), etc... */ /* config-skip */ /* Groups_t: * This symbol holds the type used for the second argument to * getgroups() and setgroups(). Usually, this is the same as * gidtype (gid_t) , but sometimes it isn't. * It can be int, ushort, gid_t, etc... * It may be necessary to include to get any * typedef'ed information. This is only required if you have * getgroups() or setgroups().. */ #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS) #define Groups_t gid_t /* Type for 2nd arg to [sg]etgroups() */ #endif /* DB_Prefix_t: * This symbol contains the type of the prefix structure element * in the header file. In older versions of DB, it was * int, while in newer ones it is u_int32_t. */ /* DB_Hash_t: * This symbol contains the type of the prefix structure element * in the header file. In older versions of DB, it was * int, while in newer ones it is size_t. */ /* DB_VERSION_MAJOR_CFG: * This symbol, if defined, defines the major version number of * Berkeley DB found in the header when Perl was configured. */ /* DB_VERSION_MINOR_CFG: * This symbol, if defined, defines the minor version number of * Berkeley DB found in the header when Perl was configured. * For DB version 1 this is always 0. */ /* DB_VERSION_PATCH_CFG: * This symbol, if defined, defines the patch version number of * Berkeley DB found in the header when Perl was configured. * For DB version 1 this is always 0. */ #define DB_Hash_t u_int32_t /**/ #define DB_Prefix_t size_t /**/ #define DB_VERSION_MAJOR_CFG /**/ #define DB_VERSION_MINOR_CFG /**/ #define DB_VERSION_PATCH_CFG /**/ /* I_FP_CLASS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_FP_CLASS / **/ /* I_GRP: * This symbol, if defined, indicates to the C program that it should * include . */ /* GRPASSWD: * This symbol, if defined, indicates to the C program that struct group * in contains gr_passwd. */ #define I_GRP /**/ /*#define GRPASSWD / **/ /* I_IEEEFP: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_IEEEFP / **/ /* I_INTTYPES: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_INTTYPES /**/ /* I_LIBUTIL: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_LIBUTIL / **/ /* I_MACH_CTHREADS: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_MACH_CTHREADS / **/ /* I_MNTENT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_MNTENT / **/ /* I_NETDB: * This symbol, if defined, indicates that exists and * should be included. */ #define I_NETDB /**/ /* I_NETINET_TCP: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_NETINET_TCP /**/ /* I_POLL: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_POLL / **/ /* I_PROT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_PROT / **/ /* I_PTHREAD: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_PTHREAD / **/ /* I_PWD: * This symbol, if defined, indicates to the C program that it should * include . */ /* PWQUOTA: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_quota. */ /* PWAGE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_age. */ /* PWCHANGE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_change. */ /* PWCLASS: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_class. */ /* PWEXPIRE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_expire. */ /* PWCOMMENT: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_comment. */ /* PWGECOS: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_gecos. */ /* PWPASSWD: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_passwd. */ #define I_PWD /**/ /*#define PWQUOTA / **/ /*#define PWAGE / **/ /*#define PWCHANGE / **/ /*#define PWCLASS / **/ /*#define PWEXPIRE / **/ /*#define PWCOMMENT / **/ /*#define PWGECOS / **/ /*#define PWPASSWD / **/ /* I_SHADOW: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SHADOW / **/ /* I_SOCKS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SOCKS / **/ /* I_SUNMATH: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SUNMATH / **/ /* I_SYSLOG: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSLOG / **/ /* I_SYSMODE: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSMODE / **/ /* I_SYS_MOUNT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYS_MOUNT / **/ /* I_SYS_STATFS: * This symbol, if defined, indicates that exists. */ /*#define I_SYS_STATFS / **/ /* I_SYS_STATVFS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYS_STATVFS / **/ /* I_SYSUIO: * This symbol, if defined, indicates that exists and * should be included. */ #define I_SYSUIO /**/ /* I_SYSUTSNAME: * This symbol, if defined, indicates that exists and * should be included. */ #define I_SYSUTSNAME /**/ /* I_SYS_VFS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYS_VFS / **/ /* Plan 9: P9 has both and */ /* I_TIME: * This symbol, if defined, indicates to the C program that it should * include . */ /* I_SYS_TIME: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_TIME /**/ /* I_SYS_TIME_KERNEL: * This symbol, if defined, indicates to the C program that it should * include with KERNEL defined. */ /* HAS_TM_TM_ZONE: * This symbol, if defined, indicates to the C program that * the struct tm has a tm_zone field. */ #define I_TIME /**/ /*#define I_SYS_TIME / **/ /*#define I_SYS_TIME_KERNEL / **/ /*#define HAS_TM_TM_ZONE / **/ /* I_USTAT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_USTAT / **/ /* PERL_INC_VERSION_LIST: * This variable specifies the list of subdirectories in over * which perl.c:incpush() and lib/lib.pm will automatically * search when adding directories to @INC, in a format suitable * for a C initialization string. See the inc_version_list entry * in Porting/Glossary for more details. */ #define PERL_INC_VERSION_LIST 0 /**/ /* INSTALL_USR_BIN_PERL: * This symbol, if defined, indicates that Perl is to be installed * also as /usr/bin/perl. */ /*#define INSTALL_USR_BIN_PERL / **/ /* PERL_PRIfldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'f') for output. */ /* PERL_PRIgldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'g') for output. */ /* PERL_PRIeldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'e') for output. */ /* PERL_SCNfldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'f') for input. */ #define PERL_PRIfldbl "f" /**/ #define PERL_PRIgldbl "g" /**/ #define PERL_PRIeldbl "e" /**/ #define PERL_SCNfldbl "f" /**/ /* Off_t: * This symbol holds the type used to declare offsets in the kernel. * It can be int, long, off_t, etc... It may be necessary to include * to get any typedef'ed information. */ /* LSEEKSIZE: * This symbol holds the number of bytes used by the Off_t. */ /* Off_t_size: * This symbol holds the number of bytes used by the Off_t. */ #define Off_t off_t /* type */ #define LSEEKSIZE 8 /* size */ #define Off_t_size 8 /* size */ /* Free_t: * This variable contains the return type of free(). It is usually * void, but occasionally int. */ /* Malloc_t: * This symbol is the type of pointer returned by malloc and realloc. */ #define Malloc_t void * /**/ #define Free_t void /**/ /* MYMALLOC: * This symbol, if defined, indicates that we're using our own malloc. */ #define MYMALLOC /**/ /* Mode_t: * This symbol holds the type used to declare file modes * for systems calls. It is usually mode_t, but may be * int or unsigned short. It may be necessary to include * to get any typedef'ed information. */ #define Mode_t mode_t /* file mode parameter for system calls */ /* VAL_O_NONBLOCK: * This symbol is to be used during open() or fcntl(F_SETFL) to turn on * non-blocking I/O for the file descriptor. Note that there is no way * back, i.e. you cannot turn it blocking again this way. If you wish to * alternatively switch between blocking and non-blocking, use the * ioctl(FIOSNBIO) call instead, but that is not supported by all devices. */ /* VAL_EAGAIN: * This symbol holds the errno error code set by read() when no data was * present on the non-blocking file descriptor. */ /* RD_NODATA: * This symbol holds the return code from read() when no data is present * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is * not defined, then you can't distinguish between no data and EOF by * issuing a read(). You'll have to find another way to tell for sure! */ /* EOF_NONBLOCK: * This symbol, if defined, indicates to the C program that a read() on * a non-blocking file descriptor will return 0 on EOF, and not the value * held in RD_NODATA (-1 usually, in that case!). */ #define VAL_O_NONBLOCK O_NONBLOCK #define VAL_EAGAIN EAGAIN #define RD_NODATA -1 #define EOF_NONBLOCK /* NEED_VA_COPY: * This symbol, if defined, indicates that the system stores * the variable argument list datatype, va_list, in a format * that cannot be copied by simple assignment, so that some * other means must be used when copying is required. * As such systems vary in their provision (or non-provision) * of copying mechanisms, handy.h defines a platform- * independent macro, Perl_va_copy(src, dst), to do the job. */ /*#define NEED_VA_COPY / **/ /* Netdb_host_t: * This symbol holds the type used for the 1st argument * to gethostbyaddr(). */ /* Netdb_hlen_t: * This symbol holds the type used for the 2nd argument * to gethostbyaddr(). */ /* Netdb_name_t: * This symbol holds the type used for the argument to * gethostbyname(). */ /* Netdb_net_t: * This symbol holds the type used for the 1st argument to * getnetbyaddr(). */ #define Netdb_host_t char * /**/ #define Netdb_hlen_t size_t /**/ #define Netdb_name_t char * /**/ #define Netdb_net_t long /**/ /* PERL_OTHERLIBDIRS: * This variable contains a colon-separated set of paths for the perl * binary to search for additional library files or modules. * These directories will be tacked to the end of @INC. * Perl will automatically search below each path for version- * and architecture-specific directories. See PERL_INC_VERSION_LIST * for more details. */ /*#define PERL_OTHERLIBDIRS " " / **/ /* IVTYPE: * This symbol defines the C type used for Perl's IV. */ /* UVTYPE: * This symbol defines the C type used for Perl's UV. */ /* I8TYPE: * This symbol defines the C type used for Perl's I8. */ /* U8TYPE: * This symbol defines the C type used for Perl's U8. */ /* I16TYPE: * This symbol defines the C type used for Perl's I16. */ /* U16TYPE: * This symbol defines the C type used for Perl's U16. */ /* I32TYPE: * This symbol defines the C type used for Perl's I32. */ /* U32TYPE: * This symbol defines the C type used for Perl's U32. */ /* I64TYPE: * This symbol defines the C type used for Perl's I64. */ /* U64TYPE: * This symbol defines the C type used for Perl's U64. */ /* NVTYPE: * This symbol defines the C type used for Perl's NV. */ /* IVSIZE: * This symbol contains the sizeof(IV). */ /* UVSIZE: * This symbol contains the sizeof(UV). */ /* I8SIZE: * This symbol contains the sizeof(I8). */ /* U8SIZE: * This symbol contains the sizeof(U8). */ /* I16SIZE: * This symbol contains the sizeof(I16). */ /* U16SIZE: * This symbol contains the sizeof(U16). */ /* I32SIZE: * This symbol contains the sizeof(I32). */ /* U32SIZE: * This symbol contains the sizeof(U32). */ /* I64SIZE: * This symbol contains the sizeof(I64). */ /* U64SIZE: * This symbol contains the sizeof(U64). */ /* NVSIZE: * This symbol contains the sizeof(NV). */ /* NV_PRESERVES_UV: * This symbol, if defined, indicates that a variable of type NVTYPE * can preserve all the bits of a variable of type UVTYPE. */ /* NV_PRESERVES_UV_BITS: * This symbol contains the number of bits a variable of type NVTYPE * can preserve of a variable of type UVTYPE. */ #define IVTYPE long /**/ #define UVTYPE unsigned long /**/ #define I8TYPE char /**/ #define U8TYPE unsigned char /**/ #define I16TYPE short /**/ #define U16TYPE unsigned short /**/ #define I32TYPE long /**/ #define U32TYPE unsigned long /**/ #ifdef HAS_QUAD #define I64TYPE long long /**/ #define U64TYPE unsigned long long /**/ #endif #define NVTYPE double /**/ #define IVSIZE 4 /**/ #define UVSIZE 4 /**/ #define I8SIZE 1 /**/ #define U8SIZE 1 /**/ #define I16SIZE 2 /**/ #define U16SIZE 2 /**/ #define I32SIZE 4 /**/ #define U32SIZE 4 /**/ #ifdef HAS_QUAD #define I64SIZE 8 /**/ #define U64SIZE 8 /**/ #endif #define NVSIZE 8 /**/ /*#define NV_PRESERVES_UV #define NV_PRESERVES_UV_BITS 31 /* IVdf: * This symbol defines the format string used for printing a Perl IV * as a signed decimal integer. */ /* UVuf: * This symbol defines the format string used for printing a Perl UV * as an unsigned decimal integer. */ /* UVof: * This symbol defines the format string used for printing a Perl UV * as an unsigned octal integer. */ /* UVxf: * This symbol defines the format string used for printing a Perl UV * as an unsigned hexadecimal integer in lowercase abcdef. */ /* UVXf: * This symbol defines the format string used for printing a Perl UV * as an unsigned hexadecimal integer in uppercase ABCDEF. */ /* NVef: * This symbol defines the format string used for printing a Perl NV * using %e-ish floating point format. */ /* NVff: * This symbol defines the format string used for printing a Perl NV * using %f-ish floating point format. */ /* NVgf: * This symbol defines the format string used for printing a Perl NV * using %g-ish floating point format. */ #define IVdf "ld" /**/ #define UVuf "lu" /**/ #define UVof "lo" /**/ #define UVxf "lx" /**/ #define UVXf "lX" /**/ #define NVef "e" /**/ #define NVff "f" /**/ #define NVgf "g" /**/ /* Pid_t: * This symbol holds the type used to declare process ids in the kernel. * It can be int, uint, pid_t, etc... It may be necessary to include * to get any typedef'ed information. */ #define Pid_t pid_t /* PID type */ /* PRIVLIB: * This symbol contains the name of the private library for this package. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. The program * should be prepared to do ~ expansion. */ /* PRIVLIB_EXP: * This symbol contains the ~name expanded version of PRIVLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ #define PRIVLIB "/sys/lib/perl/5.12.0" /**/ #define PRIVLIB_EXP "/sys/lib/perl/5.12.0" /**/ /* PTRSIZE: * This symbol contains the size of a pointer, so that the C preprocessor * can make decisions based on it. It will be sizeof(void *) if * the compiler supports (void *); otherwise it will be * sizeof(char *). */ #define PTRSIZE 4 /**/ /* Drand01: * This macro is to be used to generate uniformly distributed * random numbers over the range [0., 1.[. You may have to supply * an 'extern double drand48();' in your program since SunOS 4.1.3 * doesn't provide you with anything relevant in its headers. * See HAS_DRAND48_PROTO. */ /* Rand_seed_t: * This symbol defines the type of the argument of the * random seed function. */ /* seedDrand01: * This symbol defines the macro to be used in seeding the * random number generator (see Drand01). */ /* RANDBITS: * This symbol indicates how many bits are produced by the * function used to generate normalized random numbers. * Values include 15, 16, 31, and 48. */ #define Drand01() (rand() / (double) ((unsigned long)1 << 15)) /**/ #define Rand_seed_t unsigned /**/ #define seedDrand01(x) srand((Rand_seed_t)x) /**/ #define RANDBITS 15 /**/ /* SELECT_MIN_BITS: * This symbol holds the minimum number of bits operated by select. * That is, if you do select(n, ...), how many bits at least will be * cleared in the masks if some activity is detected. Usually this * is either n or 32*ceil(n/32), especially many little-endians do * the latter. This is only useful if you have select(), naturally. */ #define SELECT_MIN_BITS 32 /**/ /* Select_fd_set_t: * This symbol holds the type used for the 2nd, 3rd, and 4th * arguments to select. Usually, this is 'fd_set *', if HAS_FD_SET * is defined, and 'int *' otherwise. This is only useful if you * have select(), of course. */ #define Select_fd_set_t fd_set* /**/ /* SIG_NAME: * This symbol contains a list of signal names in order of * signal number. This is intended * to be used as a static array initialization, like this: * char *sig_name[] = { SIG_NAME }; * The signals in the list are separated with commas, and each signal * is surrounded by double quotes. There is no leading SIG in the signal * name, i.e. SIGQUIT is known as "QUIT". * Gaps in the signal numbers (up to NSIG) are filled in with NUMnn, * etc., where nn is the actual signal number (e.g. NUM37). * The signal number for sig_name[i] is stored in sig_num[i]. * The last element is 0 to terminate the list with a NULL. This * corresponds to the 0 at the end of the sig_num list. */ /* SIG_NUM: * This symbol contains a list of signal numbers, in the same order as the * SIG_NAME list. It is suitable for static array initialization, as in: * int sig_num[] = { SIG_NUM }; * The signals in the list are separated with commas, and the indices * within that list and the SIG_NAME list match, so it's easy to compute * the signal name from a number or vice versa at the price of a small * dynamic linear lookup. * Duplicates are allowed, but are moved to the end of the list. * The signal number corresponding to sig_name[i] is sig_number[i]. * if (i < NSIG) then sig_number[i] == i. * The last element is 0, corresponding to the 0 at the end of * the sig_name list. */ /* SIG_SIZE: * This variable contains the number of elements of the SIG_NAME * and SIG_NUM arrays, excluding the final NULL entry. */ #define SIG_NAME "ZERO", "HUP", "INT", "QUIT", "ILL", "ABRT", "FPE", "KILL", "SEGV", "PIPE", "ALRM", "TERM", "USR1", "USR2", "BUS", "CHLD", "CONT", "STOP", "TSTP", "TTIN", "TTOU", "NUM21", "NUM22", "NUM23", "NUM24", "NUM25", "NUM26", "NUM27", "NUM28", "NUM29", "NUM30", "NUM31", "NUM32", "NUM33", "NUM34", "NUM35", "NUM36", "NUM37", "NUM38", "NUM39", "NUM40", "NUM41", "NUM42", "NUM43", "NUM44", "NUM45", "NUM46", "NUM47", "NUM48", "NUM49", 0 /**/ #define SIG_NUM 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 0 /**/ #define SIG_SIZE 50 /**/ /* SITEARCH: * This symbol contains the name of the private library for this package. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. The program * should be prepared to do ~ expansion. * The standard distribution will put nothing in this directory. * After perl has been installed, users may install their own local * architecture-dependent modules in this directory with * MakeMaker Makefile.PL * or equivalent. See INSTALL for details. */ /* SITEARCH_EXP: * This symbol contains the ~name expanded version of SITEARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ #define SITEARCH_EXP "/_P9P_OBJTYPE/lib/perl/_P9P_VERSION/site_perl" /* */ #define SITEARCH "/_P9P_OBJTYPE/lib/perl/_P9P_VERSION/site_perl" /* */ /* SITELIB: * This symbol contains the name of the private library for this package. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. The program * should be prepared to do ~ expansion. * The standard distribution will put nothing in this directory. * After perl has been installed, users may install their own local * architecture-independent modules in this directory with * MakeMaker Makefile.PL * or equivalent. See INSTALL for details. */ /* SITELIB_EXP: * This symbol contains the ~name expanded version of SITELIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ /* SITELIB_STEM: * This define is SITELIB_EXP with any trailing version-specific component * removed. The elements in inc_version_list (inc_version_list.U) can * be tacked onto this variable to generate a list of directories to search. */ #define SITELIB "/sys/lib/perl/5.12.0/site_perl" /**/ #define SITELIB_EXP "/sys/lib/perl/5.12.0/site_perl" /**/ #define SITELIB_STEM "/sys/lib/perl/5.12.0/site_perl" /**/ /* Size_t_size: * This symbol holds the size of a Size_t in bytes. */ #define Size_t_size 4 /* */ /* Size_t: * This symbol holds the type used to declare length parameters * for string functions. It is usually size_t, but may be * unsigned long, int, etc. It may be necessary to include * to get any typedef'ed information. */ #define Size_t size_t /* length paramater for string functions */ /* Sock_size_t: * This symbol holds the type used for the size argument of * various socket calls (just the base type, not the pointer-to). */ #define Sock_size_t int /**/ /* SSize_t: * This symbol holds the type used by functions that return * a count of bytes or an error condition. It must be a signed type. * It is usually ssize_t, but may be long or int, etc. * It may be necessary to include or * to get any typedef'ed information. * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t). */ #define SSize_t ssize_t /* signed count of bytes */ /* STARTPERL: * This variable contains the string to put in front of a perl * script to make sure (one hopes) that it runs with perl and not * some shell. */ #define STARTPERL "#!/bin/perl" /**/ /* STDCHAR: * This symbol is defined to be the type of char used in stdio.h. * It has the values "unsigned char" or "char". */ #define STDCHAR char /**/ /* HAS_STDIO_STREAM_ARRAY: * This symbol, if defined, tells that there is an array * holding the stdio streams. */ /* STDIO_STREAM_ARRAY: * This symbol tells the name of the array holding the stdio streams. * Usual values include _iob, __iob, and __sF. */ /*#define HAS_STDIO_STREAM_ARRAY / **/ #define STDIO_STREAM_ARRAY /* Uid_t_f: * This symbol defines the format string used for printing a Uid_t. */ #define Uid_t_f "hd" /**/ /* Uid_t_sign: * This symbol holds the signedess of a Uid_t. * 1 for unsigned, -1 for signed. */ #define Uid_t_sign -1 /* UID sign */ /* Uid_t_size: * This symbol holds the size of a Uid_t in bytes. */ #define Uid_t_size 2 /* UID size */ /* Uid_t: * This symbol holds the type used to declare user ids in the kernel. * It can be int, ushort, uid_t, etc... It may be necessary to include * to get any typedef'ed information. */ #define Uid_t uid_t /* UID type */ /* USE_64_BIT_INT: * This symbol, if defined, indicates that 64-bit integers should * be used when available. If not defined, the native integers * will be employed (be they 32 or 64 bits). The minimal possible * 64-bitness is used, just enough to get 64-bit integers into Perl. * This may mean using for example "long longs", while your memory * may still be limited to 2 gigabytes. */ /* USE_64_BIT_ALL: * This symbol, if defined, indicates that 64-bit integers should * be used when available. If not defined, the native integers * will be used (be they 32 or 64 bits). The maximal possible * 64-bitness is employed: LP64 or ILP64, meaning that you will * be able to use more than 2 gigabytes of memory. This mode is * even more binary incompatible than USE_64_BIT_INT. You may not * be able to run the resulting executable in a 32-bit CPU at all or * you may need at least to reboot your OS to 64-bit mode. */ #ifndef USE_64_BIT_INT /*#define USE_64_BIT_INT / **/ #endif #ifndef USE_64_BIT_ALL /*#define USE_64_BIT_ALL / **/ #endif /* USE_FAST_STDIO: * This symbol, if defined, indicates that Perl should * be built to use 'fast stdio'. * Defaults to define in Perls 5.8 and earlier, to undef later. */ #ifndef USE_FAST_STDIO /*#define USE_FAST_STDIO / **/ #endif /* USE_LARGE_FILES: * This symbol, if defined, indicates that large file support * should be used when available. */ #ifndef USE_LARGE_FILES #define USE_LARGE_FILES /**/ #endif /* USE_LONG_DOUBLE: * This symbol, if defined, indicates that long doubles should * be used when available. */ #ifndef USE_LONG_DOUBLE /*#define USE_LONG_DOUBLE / **/ #endif /* USE_MORE_BITS: * This symbol, if defined, indicates that 64-bit interfaces and * long doubles should be used when available. */ #ifndef USE_MORE_BITS /*#define USE_MORE_BITS / **/ #endif /* MULTIPLICITY: * This symbol, if defined, indicates that Perl should * be built to use multiplicity. */ #ifndef MULTIPLICITY /*#define MULTIPLICITY / **/ #endif /* USE_PERLIO: * This symbol, if defined, indicates that the PerlIO abstraction should * be used throughout. If not defined, stdio should be * used in a fully backward compatible manner. */ #ifndef USE_PERLIO #define USE_PERLIO /**/ #endif /* USE_SOCKS: * This symbol, if defined, indicates that Perl should * be built to use socks. */ #ifndef USE_SOCKS /*#define USE_SOCKS / **/ #endif /* USE_ITHREADS: * This symbol, if defined, indicates that Perl should be built to * use the interpreter-based threading implementation. */ /* USE_5005THREADS: * This symbol, if defined, indicates that Perl should be built to * use the 5.005-based threading implementation. */ /* OLD_PTHREADS_API: * This symbol, if defined, indicates that Perl should * be built to use the old draft POSIX threads API. */ /* USE_REENTRANT_API: * This symbol, if defined, indicates that Perl should * try to use the various _r versions of library functions. * This is extremely experimental. */ /*#define USE_5005THREADS / **/ /*#define USE_ITHREADS / **/ #if defined(USE_5005THREADS) && !defined(USE_ITHREADS) #define USE_THREADS /* until src is revised*/ #endif /*#define OLD_PTHREADS_API / **/ /*#define USE_REENTRANT_API / **/ /* PERL_VENDORARCH: * If defined, this symbol contains the name of a private library. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. * It may have a ~ on the front. * The standard distribution will put nothing in this directory. * Vendors who distribute perl may wish to place their own * architecture-dependent modules and extensions in this directory with * MakeMaker Makefile.PL INSTALLDIRS=vendor * or equivalent. See INSTALL for details. */ /* PERL_VENDORARCH_EXP: * This symbol contains the ~name expanded version of PERL_VENDORARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ /*#define PERL_VENDORARCH "" / **/ /*#define PERL_VENDORARCH_EXP "" / **/ /* PERL_VENDORLIB_EXP: * This symbol contains the ~name expanded version of VENDORLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ /* PERL_VENDORLIB_STEM: * This define is PERL_VENDORLIB_EXP with any trailing version-specific component * removed. The elements in inc_version_list (inc_version_list.U) can * be tacked onto this variable to generate a list of directories to search. */ /*#define PERL_VENDORLIB_EXP "" / **/ /*#define PERL_VENDORLIB_STEM "" / **/ /* VOIDFLAGS: * This symbol indicates how much support of the void type is given by this * compiler. What various bits mean: * * 1 = supports declaration of void * 2 = supports arrays of pointers to functions returning void * 4 = supports comparisons between pointers to void functions and * addresses of void functions * 8 = suports declaration of generic void pointers * * The package designer should define VOIDUSED to indicate the requirements * of the package. This can be done either by #defining VOIDUSED before * including config.h, or by defining defvoidused in Myinit.U. If the * latter approach is taken, only those flags will be tested. If the * level of void support necessary is not present, defines void to int. */ #ifndef VOIDUSED #define VOIDUSED 15 #endif #define VOIDFLAGS 15 #if (VOIDFLAGS & VOIDUSED) != VOIDUSED #define void int /* is void to be avoided? */ #define M_VOID /* Xenix strikes again */ #endif /* HAS_CRYPT: * This symbol, if defined, indicates that the crypt routine is available * to encrypt passwords and the like. */ /*#define HAS_CRYPT / **/ /* SETUID_SCRIPTS_ARE_SECURE_NOW: * This symbol, if defined, indicates that the bug that prevents * setuid scripts from being secure is not present in this kernel. */ /* DOSUID: * This symbol, if defined, indicates that the C program should * check the script that it is executing for setuid/setgid bits, and * attempt to emulate setuid/setgid on systems that have disabled * setuid #! scripts because the kernel can't do it securely. * It is up to the package designer to make sure that this emulation * is done securely. Among other things, it should do an fstat on * the script it just opened to make sure it really is a setuid/setgid * script, it should make sure the arguments passed correspond exactly * to the argument on the #! line, and it should not trust any * subprocesses to which it must pass the filename rather than the * file descriptor of the script to be executed. */ /*#define SETUID_SCRIPTS_ARE_SECURE_NOW / **/ /*#define DOSUID / **/ /* Shmat_t: * This symbol holds the return type of the shmat() system call. * Usually set to 'void *' or 'char *'. */ /* HAS_SHMAT_PROTOTYPE: * This symbol, if defined, indicates that the sys/shm.h includes * a prototype for shmat(). Otherwise, it is up to the program to * guess one. Shmat_t shmat(int, Shmat_t, int) is a good guess, * but not always right so it should be emitted by the program only * when HAS_SHMAT_PROTOTYPE is not defined to avoid conflicting defs. */ #define Shmat_t /* config-skip */ /*#define HAS_SHMAT_PROTOTYPE / **/ /* I_NDBM: * This symbol, if defined, indicates that exists and should * be included. */ /*#define I_NDBM / **/ /* I_STDARG: * This symbol, if defined, indicates that exists and should * be included. */ /* I_VARARGS: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_STDARG /**/ /*#define I_VARARGS / **/ /* CAN_PROTOTYPE: * If defined, this macro indicates that the C compiler can handle * function prototypes. */ /* _: * This macro is used to declare function parameters for folks who want * to make declarations with prototypes using a different style than * the above macros. Use double parentheses. For example: * * int main _((int argc, char *argv[])); */ #define CAN_PROTOTYPE /**/ #ifdef CAN_PROTOTYPE #define _(args) args #else #define _(args) () #endif /* SH_PATH: * This symbol contains the full pathname to the shell used on this * on this system to execute Bourne shell scripts. Usually, this will be * /bin/sh, though it's possible that some systems will have /bin/ksh, * /bin/pdksh, /bin/ash, /bin/bash, or even something such as * D:/bin/sh.exe. */ #define SH_PATH "/bin/sh" /* config-skip */ /* USE_CROSS_COMPILE: * This symbol, if defined, indicates that Perl is being cross-compiled. */ /* PERL_TARGETARCH: * This symbol, if defined, indicates the target architecture * Perl has been cross-compiled to. Undefined if not a cross-compile. */ #ifndef USE_CROSS_COMPILE /*#define USE_CROSS_COMPILE / **/ #define PERL_TARGETARCH "" /**/ #endif /* HAS_COPYSIGNL: * This symbol, if defined, indicates that the copysignl routine is * available. If aintl is also present we can emulate modfl. */ /*#define HAS_COPYSIGNL /**/ /* USE_CPLUSPLUS: * This symbol, if defined, indicates that a C++ compiler was * used to compiled Perl and will be used to compile extensions. */ /*#define USE_CPLUSPLUS /**/ /* HAS_DBMINIT_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the dbminit() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int dbminit(char *); */ /*#define HAS_DBMINIT_PROTO / **/ /* HAS_DIRFD: * This manifest constant lets the C program know that dirfd * is available. */ /*#define HAS_DIRFD / **/ /* HAS_FLOCK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the flock() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int flock(int, int); */ /*#define HAS_FLOCK_PROTO / **/ /* HAS_FPCLASSL: * This symbol, if defined, indicates that the fpclassl routine is * available to classify long doubles. Available for example in IRIX. * The returned values are defined in and are: * * FP_SNAN signaling NaN * FP_QNAN quiet NaN * FP_NINF negative infinity * FP_PINF positive infinity * FP_NDENORM negative denormalized non-zero * FP_PDENORM positive denormalized non-zero * FP_NZERO negative zero * FP_PZERO positive zero * FP_NNORM negative normalized non-zero * FP_PNORM positive normalized non-zero */ /*#define HAS_FPCLASSL / **/ /* HAS_NL_LANGINFO: * This symbol, if defined, indicates that the nl_langinfo routine is * available to return local data. You will also need * and therefore I_LANGINFO. */ /*#define HAS_NL_LANGINFO / **/ /* HAS_PROCSELFEXE: * This symbol is defined if PROCSELFEXE_PATH is a symlink * to the absolute pathname of the executing program. */ /* PROCSELFEXE_PATH: * If HAS_PROCSELFEXE is defined this symbol is the filename * of the symbolic link pointing to the absolute pathname of * the executing program. */ /*#define HAS_PROCSELFEXE / **/ #if defined(HAS_PROCSELFEXE) && !defined(PROCSELFEXE_PATH) #define PROCSELFEXE_PATH /**/ #endif /* HAS_PTHREAD_ATTR_SETSCOPE: * This symbol, if defined, indicates that the pthread_attr_setscope * system call is available to set the contention scope attribute of * a thread attribute object. */ /*#define HAS_PTHREAD_ATTR_SETSCOPE / **/ /* HAS_SIGPROCMASK: * This symbol, if defined, indicates that the sigprocmask * system call is available to examine or change the signal mask * of the calling process. */ #define HAS_SIGPROCMASK /**/ /* HAS_SOCKATMARK: * This symbol, if defined, indicates that the sockatmark routine is * available to test whether a socket is at the out-of-band mark. */ /*#define HAS_SOCKATMARK / **/ /* HAS_SOCKATMARK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the sockatmark() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int sockatmark(int); */ /*#define HAS_SOCKATMARK_PROTO / **/ /* HAS_SETRESGID_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the setresgid() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern int setresgid(uid_t ruid, uid_t euid, uid_t suid); */ /*#define HAS_SETRESGID_PROTO / **/ /* HAS_SETRESUID_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the setresuid() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern int setresuid(uid_t ruid, uid_t euid, uid_t suid); */ /*#define HAS_SETRESUID_PROTO / **/ /* HAS_STRFTIME: * This symbol, if defined, indicates that the strftime routine is * available to do time formatting. */ #define HAS_STRFTIME /**/ /* HAS_SYSCALL_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the syscall() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern int syscall(int, ...); * extern int syscall(long, ...); */ /*#define HAS_SYSCALL_PROTO / **/ /* U32_ALIGNMENT_REQUIRED: * This symbol, if defined, indicates that you must access * character data through U32-aligned pointers. */ #ifndef U32_ALIGNMENT_REQUIRED #define U32_ALIGNMENT_REQUIRED /**/ #endif /* HAS_USLEEP_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the usleep() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int usleep(useconds_t); */ /*#define HAS_USLEEP_PROTO / **/ /* I_CRYPT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_CRYPT / **/ /* I_FP: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_FP / **/ /* I_LANGINFO: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_LANGINFO / **/ /* HAS_CTERMID_R: * This symbol, if defined, indicates that the ctermid_r routine * is available to ctermid re-entrantly. */ /* CTERMID_R_PROTO: * This symbol encodes the prototype of ctermid_r. * It is zero if d_ctermid_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ctermid_r * is defined. */ /*#define HAS_CTERMID_R / **/ #define CTERMID_R_PROTO 0 /**/ /* HAS_ENDHOSTENT_R: * This symbol, if defined, indicates that the endhostent_r routine * is available to endhostent re-entrantly. */ /* ENDHOSTENT_R_PROTO: * This symbol encodes the prototype of endhostent_r. * It is zero if d_endhostent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endhostent_r * is defined. */ /*#define HAS_ENDHOSTENT_R / **/ #define ENDHOSTENT_R_PROTO 0 /**/ /* HAS_ENDNETENT_R: * This symbol, if defined, indicates that the endnetent_r routine * is available to endnetent re-entrantly. */ /* ENDNETENT_R_PROTO: * This symbol encodes the prototype of endnetent_r. * It is zero if d_endnetent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endnetent_r * is defined. */ /*#define HAS_ENDNETENT_R / **/ #define ENDNETENT_R_PROTO 0 /**/ /* HAS_ENDPROTOENT_R: * This symbol, if defined, indicates that the endprotoent_r routine * is available to endprotoent re-entrantly. */ /* ENDPROTOENT_R_PROTO: * This symbol encodes the prototype of endprotoent_r. * It is zero if d_endprotoent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endprotoent_r * is defined. */ /*#define HAS_ENDPROTOENT_R / **/ #define ENDPROTOENT_R_PROTO 0 /**/ /* HAS_ENDSERVENT_R: * This symbol, if defined, indicates that the endservent_r routine * is available to endservent re-entrantly. */ /* ENDSERVENT_R_PROTO: * This symbol encodes the prototype of endservent_r. * It is zero if d_endservent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endservent_r * is defined. */ /*#define HAS_ENDSERVENT_R / **/ #define ENDSERVENT_R_PROTO 0 /**/ /* HAS_GETHOSTBYADDR_R: * This symbol, if defined, indicates that the gethostbyaddr_r routine * is available to gethostbyaddr re-entrantly. */ /* GETHOSTBYADDR_R_PROTO: * This symbol encodes the prototype of gethostbyaddr_r. * It is zero if d_gethostbyaddr_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostbyaddr_r * is defined. */ /*#define HAS_GETHOSTBYADDR_R / **/ #define GETHOSTBYADDR_R_PROTO 0 /**/ /* HAS_GETHOSTBYNAME_R: * This symbol, if defined, indicates that the gethostbyname_r routine * is available to gethostbyname re-entrantly. */ /* GETHOSTBYNAME_R_PROTO: * This symbol encodes the prototype of gethostbyname_r. * It is zero if d_gethostbyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostbyname_r * is defined. */ /*#define HAS_GETHOSTBYNAME_R / **/ #define GETHOSTBYNAME_R_PROTO 0 /**/ /* HAS_GETHOSTENT_R: * This symbol, if defined, indicates that the gethostent_r routine * is available to gethostent re-entrantly. */ /* GETHOSTENT_R_PROTO: * This symbol encodes the prototype of gethostent_r. * It is zero if d_gethostent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostent_r * is defined. */ /*#define HAS_GETHOSTENT_R /* config-skip */ #define GETHOSTENT_R_PROTO 0 /**/ /* HAS_GETNETBYADDR_R: * This symbol, if defined, indicates that the getnetbyaddr_r routine * is available to getnetbyaddr re-entrantly. */ /* GETNETBYADDR_R_PROTO: * This symbol encodes the prototype of getnetbyaddr_r. * It is zero if d_getnetbyaddr_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetbyaddr_r * is defined. */ /*#define HAS_GETNETBYADDR_R / **/ #define GETNETBYADDR_R_PROTO 0 /**/ /* HAS_GETNETBYNAME_R: * This symbol, if defined, indicates that the getnetbyname_r routine * is available to getnetbyname re-entrantly. */ /* GETNETBYNAME_R_PROTO: * This symbol encodes the prototype of getnetbyname_r. * It is zero if d_getnetbyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetbyname_r * is defined. */ /*#define HAS_GETNETBYNAME_R / **/ #define GETNETBYNAME_R_PROTO 0 /**/ /* HAS_GETNETENT_R: * This symbol, if defined, indicates that the getnetent_r routine * is available to getnetent re-entrantly. */ /* GETNETENT_R_PROTO: * This symbol encodes the prototype of getnetent_r. * It is zero if d_getnetent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetent_r * is defined. */ /*#define HAS_GETNETENT_R / **/ #define GETNETENT_R_PROTO 0 /**/ /* HAS_GETPROTOBYNAME_R: * This symbol, if defined, indicates that the getprotobyname_r routine * is available to getprotobyname re-entrantly. */ /* GETPROTOBYNAME_R_PROTO: * This symbol encodes the prototype of getprotobyname_r. * It is zero if d_getprotobyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotobyname_r * is defined. */ /*#define HAS_GETPROTOBYNAME_R / **/ #define GETPROTOBYNAME_R_PROTO 0 /**/ /* HAS_GETPROTOBYNUMBER_R: * This symbol, if defined, indicates that the getprotobynumber_r routine * is available to getprotobynumber re-entrantly. */ /* GETPROTOBYNUMBER_R_PROTO: * This symbol encodes the prototype of getprotobynumber_r. * It is zero if d_getprotobynumber_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotobynumber_r * is defined. */ /*#define HAS_GETPROTOBYNUMBER_R / **/ #define GETPROTOBYNUMBER_R_PROTO 0 /**/ /* HAS_GETPROTOENT_R: * This symbol, if defined, indicates that the getprotoent_r routine * is available to getprotoent re-entrantly. */ /* GETPROTOENT_R_PROTO: * This symbol encodes the prototype of getprotoent_r. * It is zero if d_getprotoent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotoent_r * is defined. */ /*#define HAS_GETPROTOENT_R / **/ #define GETPROTOENT_R_PROTO 0 /**/ /* HAS_GETSERVBYNAME_R: * This symbol, if defined, indicates that the getservbyname_r routine * is available to getservbyname re-entrantly. */ /* GETSERVBYNAME_R_PROTO: * This symbol encodes the prototype of getservbyname_r. * It is zero if d_getservbyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservbyname_r * is defined. */ /*#define HAS_GETSERVBYNAME_R / **/ #define GETSERVBYNAME_R_PROTO 0 /**/ /* HAS_GETSERVBYPORT_R: * This symbol, if defined, indicates that the getservbyport_r routine * is available to getservbyport re-entrantly. */ /* GETSERVBYPORT_R_PROTO: * This symbol encodes the prototype of getservbyport_r. * It is zero if d_getservbyport_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservbyport_r * is defined. */ /*#define HAS_GETSERVBYPORT_R / **/ #define GETSERVBYPORT_R_PROTO 0 /**/ /* HAS_GETSERVENT_R: * This symbol, if defined, indicates that the getservent_r routine * is available to getservent re-entrantly. */ /* GETSERVENT_R_PROTO: * This symbol encodes the prototype of getservent_r. * It is zero if d_getservent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservent_r * is defined. */ /*#define HAS_GETSERVENT_R / **/ #define GETSERVENT_R_PROTO 0 /**/ /* HAS_PTHREAD_ATFORK: * This symbol, if defined, indicates that the pthread_atfork routine * is available to setup fork handlers. */ /*#define HAS_PTHREAD_ATFORK / **/ /* HAS_READDIR64_R: * This symbol, if defined, indicates that the readdir64_r routine * is available to readdir64 re-entrantly. */ /* READDIR64_R_PROTO: * This symbol encodes the prototype of readdir64_r. * It is zero if d_readdir64_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_readdir64_r * is defined. */ /*#define HAS_READDIR64_R / **/ #define READDIR64_R_PROTO 0 /**/ /* HAS_SETHOSTENT_R: * This symbol, if defined, indicates that the sethostent_r routine * is available to sethostent re-entrantly. */ /* SETHOSTENT_R_PROTO: * This symbol encodes the prototype of sethostent_r. * It is zero if d_sethostent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_sethostent_r * is defined. */ /*#define HAS_SETHOSTENT_R / **/ #define SETHOSTENT_R_PROTO 0 /**/ /* HAS_SETLOCALE_R: * This symbol, if defined, indicates that the setlocale_r routine * is available to setlocale re-entrantly. */ /* SETLOCALE_R_PROTO: * This symbol encodes the prototype of setlocale_r. * It is zero if d_setlocale_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setlocale_r * is defined. */ /*#define HAS_SETLOCALE_R / **/ #define SETLOCALE_R_PROTO 0 /**/ /* HAS_SETNETENT_R: * This symbol, if defined, indicates that the setnetent_r routine * is available to setnetent re-entrantly. */ /* SETNETENT_R_PROTO: * This symbol encodes the prototype of setnetent_r. * It is zero if d_setnetent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setnetent_r * is defined. */ /*#define HAS_SETNETENT_R / **/ #define SETNETENT_R_PROTO 0 /**/ /* HAS_SETPROTOENT_R: * This symbol, if defined, indicates that the setprotoent_r routine * is available to setprotoent re-entrantly. */ /* SETPROTOENT_R_PROTO: * This symbol encodes the prototype of setprotoent_r. * It is zero if d_setprotoent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setprotoent_r * is defined. */ /*#define HAS_SETPROTOENT_R / **/ #define SETPROTOENT_R_PROTO 0 /**/ /* HAS_SETSERVENT_R: * This symbol, if defined, indicates that the setservent_r routine * is available to setservent re-entrantly. */ /* SETSERVENT_R_PROTO: * This symbol encodes the prototype of setservent_r. * It is zero if d_setservent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setservent_r * is defined. */ /*#define HAS_SETSERVENT_R / **/ #define SETSERVENT_R_PROTO 0 /**/ /* HAS_TTYNAME_R: * This symbol, if defined, indicates that the ttyname_r routine * is available to ttyname re-entrantly. */ /* TTYNAME_R_PROTO: * This symbol encodes the prototype of ttyname_r. * It is zero if d_ttyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ttyname_r * is defined. */ /*#define HAS_TTYNAME_R / **/ #define TTYNAME_R_PROTO 0 /**/ #endif perl-5.12.0-RC0/plan9/buildinfo0000444000175000017500000000002011143650500015031 0ustar jessejessep9pvers = 5.008 perl-5.12.0-RC0/plan9/versnum0000444000175000017500000000031511143650500014564 0ustar jessejesse/PERL_VERSION/ {base = $3} /PERL_SUBVERSION/ {subvers = $3} END { if (subvers == 0) printf "p9pvers = 5.%03d\n", base> "buildinfo"; else printf "p9pvers = 5.%03d_%02d\n" , base, subvers> "buildinfo"; } perl-5.12.0-RC0/plan9/exclude0000444000175000017500000000032111143650500014513 0ustar jessejessecomp/cpp.t io/dup.t io/fs.t lib/anydbm.t lib/complex.t lib/filefind.t lib/io_dup.t lib/io_pipe.t lib/io_sock.t lib/io_udp.t lib/posix.t lib/socket.t op/exec.t op/goto.t op/misc.t op/oct.t op/split.t op/stat.t perl-5.12.0-RC0/plan9/setup.rc0000444000175000017500000000325311143650500014634 0ustar jessejesse#!/bin/rc # This is an rc shell script which unpacks the perl distribution, builds # directories, and puts files where they belong. # To use, just run it from within the plan9 subdirectory with the appropriate # permissions. # Last modified 6/30/96 by: # Luther Huffman, Strategic Computer Solutions, Inc., lutherh@stratcom.com awk -f versnum ../patchlevel.h . buildinfo builddir = `{ cd .. ; pwd } if (~ $#* 0) platforms = $objtype if not switch($1) { case -a ; platforms = (386 mips sparc 68020) case * ; echo 'Usage: setup.rc [-a]' >[1=2] ; exit } sourcedir=/sys/src/cmd/perl/$p9pvers privlib=/sys/lib/perl sitelib=$privlib/site_perl #Build source directory if (test ! -d /sys/src/cmd/perl) mkdir /sys/src/cmd/perl if (test ! -d $sourcedir) mkdir $sourcedir #Populate source directory echo Building source directories ... {cd $builddir ; tar c .} | { cd $sourcedir ; tar x} cp $builddir/plan9/plan9.c $builddir/plan9/plan9ish.h $builddir/plan9/mkfile $sourcedir cd $sourcedir/lib ; rm -rf * #Build library directories echo Building library directories ... if (test ! -d $privlib) mkdir $privlib if (test ! -d $privlib/auto) mkdir $privlib/auto if (test ! -d $sitelib) mkdir $sitelib for(i in $platforms){ archlib=/$i/lib/perl/$p9pvers sitearch=$archlib/site_perl corelib=$archlib/CORE arpalib=$corelib/arpa if (test ! -d /$i/lib/perl) mkdir /$i/lib/perl if (test ! -d $archlib) mkdir $archlib if (test ! -d $sitearch) mkdir $sitearch if (test ! -d $corelib) mkdir $corelib if (test ! -d $arpalib) mkdir $arpalib cp $builddir/*.h $builddir/plan9/*.h $corelib cp $builddir/plan9/arpa/*.h $arpalib } #Populate library directories {cd $builddir/lib ; tar c . } | {cd $privlib ; tar x } perl-5.12.0-RC0/plan9/aperl0000444000175000017500000000034511143650500014173 0ustar jessejesse#!/bin/rc # aperl: # Executes perl command and alters stderr to produce Acme-friendly error messages # Created 02-JUL-1996, Luther Huffman, lutherh@stratcom.com /bin/perl $* |[2] /bin/perl -pe 's/ line (\d+)/:$1/' >[1=2] perl-5.12.0-RC0/plan9/genconfig.pl0000444000175000017500000002025311143650500015441 0ustar jessejesse#!../miniperl # Habit . . . # # Extract info from config.h, and add extra data here, to generate config.sh # Edit the static information after __END__ to reflect your site and options # that went into your perl binary. In addition, values which change from run # to run may be supplied on the command line as key=val pairs. # # Last Modified: 28-Jun-1996 Luther Huffman lutherh@stratcom.com # #==== Locations of installed Perl components $p9pvers="_P9P_VERSION"; $prefix=''; $p9p_objtype=$ENV{'objtype'}; $builddir="/sys/src/cmd/perl/$p9pvers"; $installbin="/$p9p_objtype/bin"; $installman1dir="/sys/man/1"; $installman3dir="/sys/man/2"; $installprivlib="/sys/lib/perl"; $installarchlib = "/$p9p_objtype/lib/perl/$p9pvers"; $archname="plan9_$p9p_objtype"; $installsitelib="$installprivlib/site_perl"; $installsitearch="$installarchlib/site_perl"; $installscript="/bin"; unshift(@INC,'lib'); # In case someone didn't define Perl_Root # before the build if ($ARGV[0] eq '-f') { open(ARGS,$ARGV[1]) or die "Can't read data from $ARGV[1]: $!\n"; @ARGV = (); while () { push(@ARGV,split(/\|/,$_)); } close ARGS; } if (-f "config.h") { $infile = "config.h"; $outdir = "../"; } elsif (-f "plan9/config.h") { $infile = "plan9/config.h"; $outdir = "./"; } if ($infile) { print "Generating config.sh from $infile . . .\n"; } else { die <${outdir}config.sh") || die "Can't open ${outdir}config.sh: $!\n"; $time = localtime; $cf_by = $ENV{'user'}; ($vers = $]) =~ tr/./_/; # Plan 9 doesn't actually use version numbering. Following the original Unix # precedent of assigning a Unix edition number based on the edition number # of the manuals, I am referring to this as Plan 9, 1st edition. $osvers = '1'; print OUT <) { next unless m%^#(?!if).*\$%; s/^#//; s!(.*?)\s*/\*.*!$1!; my(@words) = split; $words[1] =~ s/\(.*//; # Clip off args from macro # Did we use a shell variable for the preprocessor directive? if ($words[0] =~ m!^\$(\w+)!) { $pp_vars{$words[1]} = $1; } if (@words > 2) { # We may also have a shell var in the value shift @words; # Discard preprocessor directive my($token) = shift @words; # and keep constant name my($word); foreach $word (@words) { next unless $word =~ m!\$(\w+)!; $val_vars{$token} = $1; last; } } } close SH; } else { warn "Couldn't read ${outfile}config_h.SH: $!\n"; } $pp_vars{PLAN9} = 'define'; #Plan 9 specific # OK, now read the C header file, and retcon statements into config.sh while () { # roll through the comment header in config.h last if /config-start/; } while () { chop; while (/\\\s*$/) { # pick up contination lines my $line = $_; $line =~ s/\\\s*$//; $_ = ; s/^\s*//; $_ = $line . $_; } next unless my ($blocked,$un,$token,$val) = m%^(\/\*)?\s*\#\s*(un)?def\w*\s+([A-Za-z0-9]\w+)\S*\s*(.*)%; if (/config-skip/) { delete $pp_vars{$token} if exists $pp_vars{$token}; delete $val_vars{$token} if exists $val_vars{$token}; next; } $val =~ s!\s*/\*.*!!; # strip off trailing comment my($had_val); # Maybe a macro with args that we just #undefd or commented if (!length($val) and $val_vars{$token} and ($un || $blocked)) { print OUT "$val_vars{$token}=''\n"; delete $val_vars{$token}; $had_val = 1; } $state = ($blocked || $un) ? 'undef' : 'define'; if ($pp_vars{$token}) { print OUT "$pp_vars{$token}='$state'\n"; delete $pp_vars{$token}; } elsif (not length $val and not $had_val) { # Wups -- should have been shell var for C preprocessor directive warn "Constant $token not found in config_h.SH\n"; $token =~ tr/A-Z/a-z/; $token = "d_$token" unless $token =~ /^i_/; print OUT "$token='$state'\n"; } next unless length $val; $val =~ s/^"//; $val =~ s/"$//; # remove end quotes $val =~ s/","/ /g; # make signal list look nice if ($val_vars{$token}) { print OUT "$val_vars{$token}='$val'\n"; if ($val_vars{$token} =~ s/exp$//) {print OUT "$val_vars{$token}='$val'\n";} delete $val_vars{$token}; } elsif (!$pp_vars{$token}) { # Haven't seen it previously, either warn "Constant $token not found in config_h.SH (val=|$val|)\n"; $token =~ tr/A-Z/a-z/; print OUT "$token='$val'\n"; if ($token =~ s/exp$//) {print OUT "$token='$val'\n";} } } close IN; foreach (sort keys %pp_vars) { warn "Didn't see $_ in $infile\n"; } foreach (sort keys %val_vars) { warn "Didn't see $_ in $infile(val)\n"; } # print OUT "libs='",join(' ',@libs),"'\n"; # print OUT "libc='",join(' ',@crtls),"'\n"; if (open(PL,"${outdir}patchlevel.h")) { while () { if (/^#define PERL_VERSION\s+(\S+)/) { print OUT "PERL_VERSION='$1'\n"; print OUT "PATCHLEVEL='$1'\n"; # XXX compat } elsif (/^#define PERL_SUBVERSION\s+(\S+)/) { print OUT "PERL_SUBVERSION='$1'\n"; print OUT "SUBVERSION='$1'\n"; # XXX compat } } close PL; } else { warn "Can't read ${outdir}patchlevel.h - skipping 'PERL_VERSION'"; } print OUT "pager='/bin/p'\n"; close OUT; perl-5.12.0-RC0/plan9/config_sh.sample0000444000175000017500000005343111347250766016333 0ustar jessejesse#!/bin/sh # # This file was produced by running the Configure script. It holds all the # definitions figured out by Configure. Should you modify one of these values, # do not forget to propagate your changes by running "Configure -der". You may # instead choose to run each of the .SH files by yourself, or "Configure -S". # # Package name : perl5 # Source directory : . # Configuration time: Sun Nov 24 20:57:48 EST 2002 # Configured by : unknown # Target system : plan9 17genr 1 0 generic pcfl Author='' Date='$Date' Header='' Id='$Id' Locker='' Log='$Log' Mcc='Mcc' RCSfile='$RCSfile' Revision='$Revision' Source='' State='' _a='.a' _exe='' _o='.o' afs='false' afsroot='/afs' alignbytes='4' ansi2knr='' aphostname='/bin/uname -n' api_revision='5' api_subversion='0' api_version='12' api_versionstring='5.12.0' ar='ar' archlib='/sys/lib/perl5/5.12.0/386' archlibexp='/sys/lib/perl5/5.12.0/386' archname64='' archname='386' archobjs='' asctime_r_proto='0' awk='awk' baserev='5.0' bash='' bin='/usr/bin' binexp='/usr/bin' bison='bison' byacc='byacc' byteorder='1234' c='' castflags='7' cat='cat' cc='cc' cccdlflags='' ccdlflags='' ccflags='' ccflags_uselargefiles='' ccname='cc' ccsymbols='_POSIX_SOURCE= _BSD_EXTENSION=' ccversion='' cf_by='9trouble' cf_email='9trouble@plan9.bell-labs.com' cf_time='Sun Nov 24 20:57:48 EST 2002' charbits='8' chgrp='' chmod='chmod' chown='' clocktype='clock_t' comm='comm' compress='' contains='grep' cp='cp' cpio='' cpp='cpp' cpp_stuff='42' cppccsymbols='__STDC__=1' cppflags='' cpplast='' cppminus='' cpprun='/bin/cpp' cppstdin='cppstdin' cppsymbols='_POSIX_SOURCE=1 _BSD_EXTENSION=1' crypt_r_proto='0' cryptlib='' csh='csh' ctermid_r_proto='0' ctime_r_proto='0' d_Gconvert='sprintf((b),"%.*g",(n),(x))' d_PRIEUldbl='define' d_PRIFUldbl='define' d_PRIGUldbl='define' d_PRIXU64='define' d_PRId64='define' d_PRIeldbl='define' d_PRIfldbl='define' d_PRIgldbl='define' d_PRIi64='define' d_PRIo64='define' d_PRIu64='define' d_PRIx64='define' d_SCNfldbl='define' d__fwalk='undef' d_access='define' d_accessx='undef' d_aintl='undef' d_alarm='define' d_archlib='define' d_asctime64='undef' d_asctime_r='undef' d_atolf='undef' d_atoll='define' d_attribute_deprecated='undef' d_attribute_format='undef' d_attribute_malloc='undef' d_attribute_nonnull='undef' d_attribute_noreturn='undef' d_attribute_pure='undef' d_attribute_unused='undef' d_attribute_warn_unused_result='undef' d_bcmp='define' d_bcopy='define' d_bsdgetpgrp='undef' d_bsdsetpgrp='undef' d_bsd='undef' d_builtin_choose_expr='undef' d_builtin_expect='undef' d_bzero='define' d_c99_variadic_macros='undef' d_casti32='undef' d_castneg='undef' d_charvspr='define' d_chown='define' d_chroot='undef' d_chsize='undef' d_class='undef' d_clearenv='undef' d_closedir='define' d_cmsghdr_s='undef' d_const='define' d_copysignl='undef' d_cplusplus='undef' d_crypt_r='undef' d_crypt='undef' d_csh='undef' d_ctermid_r='undef' d_ctermid='undef' d_ctime64='undef' d_ctime_r='undef' d_cuserid='define' d_dbl_dig='define' d_dbminitproto='undef' d_difftime64='undef' d_difftime='define' d_dir_dd_fd='undef' d_dirfd='undef' d_dirnamlen='undef' d_dlerror='undef' d_dlopen='undef' d_dlsymun='undef' d_dosuid='undef' d_drand48proto='undef' d_drand48_r='undef' d_dup2='define' d_eaccess='undef' d_endgrent='define' d_endgrent_r='undef' d_endhent='define' d_endhostent_r='undef' d_endnent='undef' d_endnetent_r='undef' d_endpent='undef' d_endprotoent_r='undef' d_endpwent='define' d_endpwent_r='undef' d_endsent='undef' d_endservent_r='undef' d_eofnblk='define' d_eunice='undef' d_faststdio='undef' d_fchdir='undef' d_fchmod='define' d_fchown='undef' d_fcntl_can_lock='undef' d_fcntl='define' d_fd_macros='undef' d_fds_bits='undef' d_fd_set='undef' d_fgetpos='define' d_finitel='undef' d_finite='undef' d_flexfnam='define' d_flockproto='undef' d_flock='undef' d_fork='define' d_fpathconf='define' d_fpclassify='undef' d_fpclassl='undef' d_fp_class='undef' d_fpclass='undef' d_fpos64_t='undef' d_frexpl='undef' d_fs_data_s='undef' d_fseeko='undef' d_fsetpos='define' d_fstatfs='undef' d_fstatvfs='undef' d_fsync='define' d_ftello='undef' d_ftime='undef' d_futimes='undef' d_gdbm_ndbm_h_uses_prototypes='undef' d_gdbmndbm_h_uses_prototypes='undef' d_getaddrinfo='undef' d_getcwd='define' d_getespwnam='undef' d_getfsstat='undef' d_getgrent='define' d_getgrent_r='undef' d_getgrgid_r='undef' d_getgrnam_r='undef' d_getgrps='define' d_gethbyaddr='define' d_gethbyname='define' d_gethent='undef' d_gethname='define' d_gethostbyaddr_r='undef' d_gethostbyname_r='undef' d_gethostent_r='undef' d_gethostprotos='undef' d_getitimer='undef' d_getlogin='define' d_getlogin_r='undef' d_getmntent='undef' d_getmnt='undef' d_getnameinfo='undef' d_getnbyaddr='undef' d_getnbyname='undef' d_getnent='undef' d_getnetbyaddr_r='undef' d_getnetbyname_r='undef' d_getnetent_r='undef' d_getnetprotos='undef' d_getpagsz='undef' d_getpbyname='define' d_getpbynumber='undef' d_getpent='undef' d_getpgid='undef' d_getpgrp2='undef' d_getpgrp='define' d_getppid='define' d_getprior='undef' d_getprotobyname_r='undef' d_getprotobynumber_r='undef' d_getprotoent_r='undef' d_getprotoprotos='undef' d_getprpwnam='undef' d_getpwent='define' d_getpwent_r='undef' d_getpwnam_r='undef' d_getpwuid_r='undef' d_getsbyname='define' d_getsbyport='undef' d_getsent='undef' d_getservbyname_r='undef' d_getservbyport_r='undef' d_getservent_r='undef' d_getservprotos='undef' d_getspnam_r='undef' d_getspnam='undef' d_gettimeod='define' d_gmtime64='undef' d_gmtime_r='undef' d_gnulibc='undef' d_grpasswd='undef' d_hasmntopt='undef' d_htonl='define' d_ilogbl='undef' d_inc_version_list='undef' d_index='undef' d_inetaton='undef' d_inetntop='undef' d_inetpton='undef' d_int64_t='define' d_isascii='undef' d_isfinite='undef' d_isinf='undef' d_isnanl='undef' d_isnan='undef' d_killpg='undef' d_lchown='undef' d_ldbl_dig='define' d_libm_lib_version='0' d_link='define' d_localtime64='undef' d_localtime_r_needs_tzset='undef' d_localtime_r='undef' d_locconv='define' d_lockf='undef' d_longdbl='define' d_longlong='define' d_lseekproto='undef' d_lstat='define' d_madvise='undef' d_malloc_good_size='undef' d_malloc_size='undef' d_mblen='define' d_mbstowcs='define' d_mbtowc='define' d_memchr='define' d_memcmp='define' d_memcpy='define' d_memmove='define' d_memset='define' d_mkdir='define' d_mkdtemp='undef' d_mkfifo='define' d_mkstemps='undef' d_mkstemp='undef' d_mktime64='undef' d_mktime='define' d_mmap='undef' d_modfl_pow32_bug='undef' d_modflproto='undef' d_modfl='undef' d_mprotect='undef' d_msgctl='undef' d_msg_ctrunc='undef' d_msg_dontroute='undef' d_msgget='undef' d_msghdr_s='undef' d_msg_oob='undef' d_msg_peek='undef' d_msg_proxy='undef' d_msgrcv='undef' d_msgsnd='undef' d_msg='undef' d_msync='undef' d_munmap='undef' d_mymalloc='define' d_ndbm_h_uses_prototypes='undef' d_nice='undef' d_nl_langinfo='undef' d_nv_preserves_uv='undef' d_nv_zero_is_allbits_zero='undef' d_off64_t='undef' d_old_pthread_create_joinable='undef' d_oldpthreads='undef' d_oldsock='undef' d_open3='define' d_pathconf='define' d_pause='define' d_perl_otherlibdirs='undef' d_phostname='undef' d_pipe='define' d_poll='undef' d_portable='define' d_printf_format_null='undef' d_procselfexe='undef' d_pseudofork='undef' d_pthread_atfork='undef' d_pthread_attr_setscope='undef' d_pthread_yield='undef' d_pwage='undef' d_pwchange='undef' d_pwclass='undef' d_pwcomment='undef' d_pwexpire='undef' d_pwgecos='undef' d_pwpasswd='undef' d_pwquota='undef' d_qgcvt='undef' d_quad='define' d_random_r='undef' d_readdir64_r='undef' d_readdir='define' d_readdir_r='undef' d_readlink='define' d_readv='define' d_recvmsg='undef' d_rename='define' d_rewinddir='define' d_rmdir='define' d_safebcpy='undef' d_safemcpy='undef' d_sanemcmp='define' d_sbrkproto='undef' d_scalbnl='undef' d_sched_yield='undef' d_scm_rights='undef' d_seekdir='undef' d_select='define' d_sem='undef' d_semctl='undef' d_semctl_semid_ds='undef' d_semctl_semun='undef' d_semget='undef' d_semop='undef' d_sendmsg='undef' d_setegid='undef' d_seteuid='undef' d_setgrent='define' d_setgrent_r='undef' d_setgrps='undef' d_sethent='undef' d_sethostent_r='undef' d_setitimer='undef' d_setlinebuf='define' d_setlocale='define' d_setlocale_r='undef' d_setnent='undef' d_setnetent_r='undef' d_setpent='undef' d_setpgid='define' d_setpgrp2='undef' d_setpgrp='undef' d_setprior='undef' d_setproctitle='undef' d_setprotoent_r='undef' d_setpwent='define' d_setpwent_r='undef' d_setregid='undef' d_setresgid='undef' d_setresuid='undef' d_setreuid='undef' d_setrgid='undef' d_setruid='undef' d_setsent='undef' d_setservent_r='undef' d_setsid='define' d_setvbuf='define' d_sfio='undef' d_shm='undef' d_shmat='undef' d_shmatprototype='undef' d_shmctl='undef' d_shmdt='undef' d_shmget='undef' d_sigaction='define' d_signbit='define' d_sigprocmask='define' d_sigsetjmp='define' d_sitearch='define' d_snprintf='undef' d_sockatmark='undef' d_sockatmarkproto='undef' d_socket='define' d_socklen_t='undef' d_sockpair='define' d_socks5_init='undef' d_sprintf_returns_strlen='undef' d_sqrtl='undef' d_srand48_r='undef' d_srandom_r='undef' d_sresgproto='undef' d_sresuproto='undef' d_statblks='undef' d_statfs_f_flags='undef' d_statfs_s='undef' d_statvfs='undef' d_stdio_cnt_lval='undef' d_stdio_ptr_lval='undef' d_stdio_ptr_lval_nochange_cnt='undef' d_stdio_ptr_lval_sets_cnt='undef' d_stdio_stream_array='undef' d_stdiobase='undef' d_stdstdio='undef' d_strchr='define' d_strcoll='define' d_strctcpy='define' d_strerrm='strerror(e)' d_strerror='define' d_strerror_r='undef' d_strftime='define' d_strlcat='undef' d_strlcpy='undef' d_strtod='define' d_strtol='define' d_strtold='undef' d_strtoll='undef' d_strtoq='undef' d_strtoul='define' d_strtoull='undef' d_strtouq='undef' d_strxfrm='define' d_suidsafe='undef' d_symlink='define' d_syscall='undef' d_syscallproto='undef' d_sysconf='define' d_sysernlst='' d_syserrlst='define' d_system='define' d_tcgetpgrp='define' d_tcsetpgrp='define' d_telldir='undef' d_telldirproto='undef' d_time='define' d_timegm='undef' d_times='define' d_tm_tm_gmtoff='undef' d_tm_tm_zone='undef' d_tmpnam_r='undef' d_truncate='undef' d_ttyname_r='undef' d_tzname='define' d_u32align='define' d_ualarm='undef' d_umask='define' d_uname='define' d_union_semun='undef' d_unordered='undef' d_unsetenv='undef' d_usleep='undef' d_usleepproto='undef' d_ustat='undef' d_vendorarch='undef' d_vendorbin='undef' d_vendorlib='undef' d_vfork='undef' d_void_closedir='undef' d_voidsig='define' d_voidtty='' d_volatile='define' d_vprintf='define' d_vsnprintf='undef' d_wait4='undef' d_waitpid='define' d_wcstombs='define' d_wctomb='define' d_writev='define' d_xenix='undef' date='date' db_hashtype='u_int32_t' db_prefixtype='size_t' db_version_major='' db_version_minor='' db_version_patch='' defvoidused='15' direntrytype='struct dirent' dlext='none' dlsrc='dl_none.xs' doublesize='8' drand01='(rand() / (double) ((unsigned long)1 << 15))' drand48_r_proto='0' dtrace='' dynamic_ext='' eagain='EAGAIN' ebcdic='undef' echo='echo' egrep='grep' emacs='' endgrent_r_proto='0' endhostent_r_proto='0' endnetent_r_proto='0' endprotoent_r_proto='0' endpwent_r_proto='0' endservent_r_proto='0' eunicefix=':' exe_ext='' expr='expr' extensions='B ByteLoader Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call IO List/Util MIME/Base64 Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize attributes re threads threads/shared Encode/Byte Encode/CN Encode/EBCDIC Encode/JP Encode/KR Encode/Symbol Encode/TW Encode/Unicode Errno' extras='' fflushNULL='define' fflushall='undef' find='' firstmakefile='makefile' flex='' fpossize='8' fpostype='fpos_t' freetype='void' from=':' full_ar='/bin/ar' full_csh='csh' full_sed='/bin/sed' gccosandvers='' gccversion='' getgrent_r_proto='0' getgrgid_r_proto='0' getgrnam_r_proto='0' gethostbyaddr_r_proto='0' gethostbyname_r_proto='0' gethostent_r_proto='0' getlogin_r_proto='0' getnetbyaddr_r_proto='0' getnetbyname_r_proto='0' getnetent_r_proto='0' getprotobyname_r_proto='0' getprotobynumber_r_proto='0' getprotoent_r_proto='0' getpwent_r_proto='0' getpwnam_r_proto='0' getpwuid_r_proto='0' getservbyname_r_proto='0' getservbyport_r_proto='0' getservent_r_proto='0' getspnam_r_proto='0' gidformat='"hd"' gidsign='-1' gidsize='2' gidtype='gid_t' glibpth='' gmake='gmake' gmtime_r_proto='0' gnulibc_version='' grep='grep' groupcat='' groupstype='gid_t' gzip='gzip' h_fcntl='true' h_sysfile='false' hint='recommended' hostcat='' i16size='2' i16type='short' i32size='4' i32type='long' i64size='8' i64type='long long' i8size='1' i8type='char' i_arpainet='define' i_assert='define' i_bsdioctl='' i_crypt='undef' i_db='undef' i_dbm='undef' i_dirent='define' i_dld='undef' i_dlfcn='undef' i_fcntl='define' i_float='define' i_fp='undef' i_fp_class='undef' i_gdbm='undef' i_gdbm_ndbm='undef' i_gdbmndbm='undef' i_grp='define' i_ieeefp='undef' i_inttypes='define' i_langinfo='undef' i_libutil='undef' i_limits='define' i_locale='define' i_machcthr='undef' i_malloc='undef' i_mallocmalloc='undef' i_math='define' i_memory='undef' i_mntent='undef' i_ndbm='undef' i_netdb='define' i_neterrno='undef' i_netinettcp='define' i_niin='define' i_poll='undef' i_prot='undef' i_pthread='undef' i_pwd='define' i_rpcsvcdbm='undef' i_sfio='undef' i_sgtty='undef' i_shadow='undef' i_socks='undef' i_stdarg='define' i_stddef='define' i_stdlib='define' i_string='define' i_sunmath='undef' i_sysaccess='undef' i_sysdir='undef' i_sysfile='undef' i_sysfilio='undef' i_sysin='undef' i_sysioctl='define' i_syslog='undef' i_sysmman='undef' i_sysmode='undef' i_sysmount='undef' i_sysndir='undef' i_sysparam='define' i_syspoll='undef' i_sysresrc='define' i_syssecrt='undef' i_sysselct='define' i_syssockio='undef' i_sysstat='define' i_sysstatfs='undef' i_sysstatvfs='undef' i_systime='undef' i_systimek='undef' i_systimes='define' i_systypes='define' i_sysuio='define' i_sysun='define' i_sysutsname='define' i_sysvfs='undef' i_syswait='define' i_termio='undef' i_termios='define' i_time='define' i_unistd='define' i_ustat='undef' i_utime='define' i_values='undef' i_varargs='undef' i_varhdr='stdarg.h' i_vfork='undef' ignore_versioned_solibs='' inc_version_list=' ' inc_version_list_init='0' incpath='' inews='' installarchlib='/sys/lib/perl/5.12.0/386' installbin='/usr/bin' installman1dir='/sys/man/1pub' installman3dir='/sys/man/2pub' installprefix='/usr' installprefixexp='/usr' installprivlib='/sys/lib/perl/5.12.0' installscript='/usr/bin' installsitearch='/sys/lib/perl/5.12.0/site_perl/386' installsitebin='/usr/bin' installsitelib='/sys/lib/perl/5.12.0/site_perl' installstyle='lib/perl5' installusrbinperl='undef' installvendorarch='' installvendorbin='' installvendorlib='' intsize='4' issymlink='/bin/test -h' ivdformat='"ld"' ivsize='4' ivtype='long' known_extensions='B ByteLoader Cwd DB_File Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call GDBM_File I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 NDBM_File ODBM_File Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/APItest/KeywordRPN XS/Typemap attributes re threads threads/shared' ksh='' ld='ld' lddlflags='' ldflags='' ldflags_uselargefiles='' ldlibpthname='LD_LIBRARY_PATH' less='less' lib_ext='.a' libc='' libperl='libperl.a' libpth='/lib' libs=' ' libsdirs='' libsfiles='' libsfound='' libspath=' /lib' libswanted='sfio socket bind inet nsl nm ndbm gdbm dbm db malloc dl dld ld sun m c cposix posix ndir dir crypt sec ucb bsd BSD PW x util' libswanted_uselargefiles='' line='' lint='' lkflags='' ln='ln' lns='/bin/ln -s' localtime_r_proto='0' locincpth='' loclibpth='' longdblsize='8' longlongsize='8' longsize='4' lp='' lpr='' ls='ls' lseeksize='8' lseektype='off_t' mad='undef' mail='' mailx='' make='make' make_set_make='#' mallocobj='malloc.o' mallocsrc='malloc.c' malloctype='void *' man1dir='/sys/man/1pub' man1direxp='/sys/man/1pub' man1ext='' man3dir='/sys/man/2pub' man3direxp='/sys/man/2pub' man3ext='' mips_type='' mkdir='mkdir' mmaptype='void *' modetype='mode_t' more='more' multiarch='undef' mv='' myarchname='386' mydomain='.nonet' myhostname='17genr' myuname='plan9 17genr 1 0 generic pcfl ' n='-n' need_va_copy='undef' netdb_hlen_type='size_t' netdb_host_type='char *' netdb_name_type='char *' netdb_net_type='long' nm='nm' nm_opt='' nm_so_opt='' nonxs_ext='Errno' nroff='nroff' nvEUformat='"E"' nvFUformat='"F"' nvGUformat='"G"' nv_preserves_uv_bits='31' nv_overflows_integers_at='256.0*256.0*256.0*256.0*256.0*256.0*2.0*2.0*2.0*2.0*2.0' nveformat='"e"' nvfformat='"f"' nvgformat='"g"' nvsize='8' nvtype='double' o_nonblock='O_NONBLOCK' obj_ext='.o' old_pthread_create_joinable='' optimize='-O' orderlib='false' osname='plan9' osvers='1' otherlibdirs=' ' package='perl5' pager='/usr/ucb/more' passcat='' patchlevel='8' path_sep=':' perl5='' perl='' perl_patchlevel='' perladmin='9trouble@plan9.bell-labs.com' perllibs=' ' perlpath='/bin/perl' pg='pg' phostname='uname -n' pidtype='pid_t' plibpth='' pmake='' pr='' prefix='/usr' prefixexp='/usr' privlib='/sys/lib/perl/5.12.0' privlibexp='/sys/lib/perl/5.12.0' procselfexe='' prototype='define' ptrsize='4' quadkind='3' quadtype='long long' randbits='15' randfunc='rand' random_r_proto='0' randseedtype='unsigned' ranlib=':' rd_nodata='-1' readdir64_r_proto='0' readdir_r_proto='0' revision='5' rm='rm' rmail='' run='' runnm='false' sGMTIME_max='2147483647' sGMTIME_min='0' sLOCALTIME_max='2147483647' sLOCALTIME_min='0' sPRIEUldbl='"E"' sPRIFUldbl='"F"' sPRIGUldbl='"G"' sPRIXU64='"llX"' sPRId64='"lld"' sPRIeldbl='"e"' sPRIfldbl='"f"' sPRIgldbl='"g"' sPRIi64='"lli"' sPRIo64='"llo"' sPRIu64='"llu"' sPRIx64='"llx"' sSCNfldbl='"f"' sched_yield='undef' scriptdir='/usr/bin' scriptdirexp='/usr/bin' sed='sed' seedfunc='srand' selectminbits='32' selecttype='int *' sendmail='' setgrent_r_proto='0' sethostent_r_proto='0' setlocale_r_proto='0' setnetent_r_proto='0' setprotoent_r_proto='0' setpwent_r_proto='0' setservent_r_proto='0' sh='/bin/sh' shar='' sharpbang='#!' shmattype='' shortsize='2' shrpenv='' shsharp='true' sig_count='50' sig_name='ZERO HUP INT QUIT ILL ABRT FPE KILL SEGV PIPE ALRM TERM USR1 USR2 BUS CHLD CONT STOP TSTP TTIN TTOU NUM21 NUM22 NUM23 NUM24 NUM25 NUM26 NUM27 NUM28 NUM29 NUM30 NUM31 NUM32 NUM33 NUM34 NUM35 NUM36 NUM37 NUM38 NUM39 NUM40 NUM41 NUM42 NUM43 NUM44 NUM45 NUM46 NUM47 NUM48 NUM49 ' sig_name_init='"ZERO", "HUP", "INT", "QUIT", "ILL", "ABRT", "FPE", "KILL", "SEGV", "PIPE", "ALRM", "TERM", "USR1", "USR2", "BUS", "CHLD", "CONT", "STOP", "TSTP", "TTIN", "TTOU", "NUM21", "NUM22", "NUM23", "NUM24", "NUM25", "NUM26", "NUM27", "NUM28", "NUM29", "NUM30", "NUM31", "NUM32", "NUM33", "NUM34", "NUM35", "NUM36", "NUM37", "NUM38", "NUM39", "NUM40", "NUM41", "NUM42", "NUM43", "NUM44", "NUM45", "NUM46", "NUM47", "NUM48", "NUM49", 0' sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 ' sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 0' sig_size='50' signal_t='void' sitearch='/sys/lib/perl/5.12.0/site_perl/386' sitearchexp='/sys/lib/perl/site_perl/386' sitebin='/usr/bin' sitebinexp='/usr/bin' sitelib='/sys/lib/perl/5.12.0/site_perl' sitelib_stem='/sys/lib/perl/5.12.0/site_perl' sitelibexp='/sys/lib/perl/5.12.0/site_perl' siteprefix='/usr' siteprefixexp='/usr' sizesize='4' sizetype='size_t' sleep='' smail='' so='so' sockethdr='' socketlib='' socksizetype='int' sort='sort' spackage='Perl5' spitshell='cat' srand48_r_proto='0' srandom_r_proto='0' src='.' ssizetype='ssize_t' startperl='#!/bin/perl' startsh='#!/bin/sh' static_ext='B ByteLoader Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call IO List/Util MIME/Base64 Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize attributes re threads threads/shared Encode/Byte Encode/CN Encode/EBCDIC Encode/JP Encode/KR Encode/Symbol Encode/TW Encode/Unicode' stdchar='char' stdio_base='((fp)->_base)' stdio_bufsiz='((fp)->_cnt + (fp)->_ptr - (fp)->_base)' stdio_cnt='((fp)->_cnt)' stdio_filbuf='' stdio_ptr='((fp)->_ptr)' stdio_stream_array='' strerror_r_proto='0' strings='/sys/include/ape/string.h' submit='' subversion='0' sysman='/sys/man/1pub' tail='' tar='' targetarch='' tbl='' tee='' test='test' timeincl='/sys/include/ape/time.h ' timetype='time_t' tmpnam_r_proto='0' to=':' touch='touch' tr='tr' trnl='\012' troff='' ttyname_r_proto='0' u16size='2' u16type='unsigned short' u32size='4' u32type='unsigned long' u64size='8' u64type='unsigned long long' u8size='1' u8type='unsigned char' uidformat='"hd"' uidsign='-1' uidsize='2' uidtype='uid_t' uname='uname' uniq='uniq' uquadtype='unsigned long long' use5005threads='undef' use64bitall='undef' use64bitint='undef' usecrosscompile='undef' usedevel='undef' usedl='undef' usedtrace='undef' usefaststdio='undef' useithreads='undef' uselargefiles='define' uselongdouble='undef' usemallocwrap='undef' usemorebits='undef' usemultiplicity='undef' usemymalloc='y' usenm='false' useopcode='true' useperlio='define' useposix='true' usereentrant='undef' userelocatableinc='undef' usesfio='false' useshrplib='false' usesitecustomize='undef' usesocks='undef' usethreads='undef' usevendorprefix='undef' usevfork='false' usrinc='/usr/include' uuname='' uvXUformat='"lX"' uvoformat='"lo"' uvsize='4' uvtype='unsigned long' uvuformat='"lu"' uvxformat='"lx"' vaproto='undef' vendorarch='' vendorarchexp='' vendorbin='' vendorbinexp='' vendorlib='' vendorlib_stem='' vendorlibexp='' vendorprefix='' vendorprefixexp='' version='5.12.0' version_patchlevel_string='version 12 subversion 0' versiononly='undef' vi='' voidflags='15' xlibpth='' yacc='yacc' yaccflags='' zcat='' zip='zip' # Configure command line arguments. config_arg0='./Configure' config_args='' config_argc=0 PERL_REVISION=5 PERL_VERSION=12 PERL_SUBVERSION=0 PERL_API_REVISION=5 PERL_API_VERSION=12 PERL_API_SUBVERSION=0 PERL_PATCHLEVEL= PERL_CONFIG_SH=true perl-5.12.0-RC0/plan9/arpa/0000755000175000017500000000000011351321566014100 5ustar jessejesseperl-5.12.0-RC0/plan9/arpa/inet.h0000444000175000017500000000035711143650500015203 0ustar jessejesse/* Declarations which would have been found in */ /* On Plan 9, these are found in */ /* extern unsigned long inet_addr(const char *); */ /* extern char *inet_ntoa(struct in_addr); */ #include perl-5.12.0-RC0/plan9/config_h.sample0000444000175000017500000040477211325125742016147 0ustar jessejesse/* * This file was produced by running the config_h.SH script, which * gets its values from config.sh, which is generally produced by * running Configure. * * Feel free to modify any of this as the need arises. Note, however, * that running config_h.SH again will wipe out any changes you've made. * For a more permanent change edit config.sh and rerun config_h.SH. * * $Id: Config_h.U,v 3.0.1.5 1997/02/28 14:57:43 ram Exp $ */ /* * Package name : perl * Source directory : . * Configuration time: Sun Nov 24 20:57:48 EST 2002 * Configured by : 9trouble * Target system : plan9 17genr 1 0 generic pcfl */ #ifndef _config_h_ #define _config_h_ /* LOC_SED: * This symbol holds the complete pathname to the sed program. */ #define LOC_SED "/bin/sed" /**/ /* HAS_AINTL: * This symbol, if defined, indicates that the aintl routine is * available. If copysignl is also present we can emulate modfl. */ /*#define HAS_AINTL / **/ /* HAS_ALARM: * This symbol, if defined, indicates that the alarm routine is * available. */ #define HAS_ALARM /**/ /* HASATTRIBUTE: * This symbol indicates the C compiler can check for function attributes, * such as printf formats. This is normally only supported by GNU cc. */ /*#define HASATTRIBUTE / **/ #ifndef HASATTRIBUTE #ifdef __attribute__ #undef __attribute__ #endif #define __attribute__(_arg_) #endif /* HAS_BCMP: * This symbol is defined if the bcmp() routine is available to * compare blocks of memory. */ #define HAS_BCMP /**/ /* HAS_BCOPY: * This symbol is defined if the bcopy() routine is available to * copy blocks of memory. */ #define HAS_BCOPY /**/ /* HAS_BZERO: * This symbol is defined if the bzero() routine is available to * set a memory block to 0. */ #define HAS_BZERO /**/ /* HAS_CHOWN: * This symbol, if defined, indicates that the chown routine is * available. */ #define HAS_CHOWN /**/ /* HAS_CHROOT: * This symbol, if defined, indicates that the chroot routine is * available. */ /*#define HAS_CHROOT / **/ /* HAS_CHSIZE: * This symbol, if defined, indicates that the chsize routine is available * to truncate files. You might need a -lx to get this routine. */ /*#define HAS_CHSIZE / **/ /* HASCONST: * This symbol, if defined, indicates that this C compiler knows about * the const type. There is no need to actually test for that symbol * within your programs. The mere use of the "const" keyword will * trigger the necessary tests. */ #define HASCONST /**/ #ifndef HASCONST #define const #endif /* HAS_CUSERID: * This symbol, if defined, indicates that the cuserid routine is * available to get character login names. */ #define HAS_CUSERID /**/ /* HAS_DBL_DIG: * This symbol, if defined, indicates that this system's * or defines the symbol DBL_DIG, which is the number * of significant digits in a double precision number. If this * symbol is not defined, a guess of 15 is usually pretty good. */ #define HAS_DBL_DIG /* */ /* HAS_DIFFTIME: * This symbol, if defined, indicates that the difftime routine is * available. */ #define HAS_DIFFTIME /**/ /* HAS_DLERROR: * This symbol, if defined, indicates that the dlerror routine is * available to return a string describing the last error that * occurred from a call to dlopen(), dlclose() or dlsym(). */ /*#define HAS_DLERROR / **/ /* HAS_DUP2: * This symbol, if defined, indicates that the dup2 routine is * available to duplicate file descriptors. */ #define HAS_DUP2 /**/ /* HAS_FCHMOD: * This symbol, if defined, indicates that the fchmod routine is available * to change mode of opened files. If unavailable, use chmod(). */ #define HAS_FCHMOD /**/ /* HAS_FCHOWN: * This symbol, if defined, indicates that the fchown routine is available * to change ownership of opened files. If unavailable, use chown(). */ /*#define HAS_FCHOWN / **/ /* HAS_FCNTL: * This symbol, if defined, indicates to the C program that * the fcntl() function exists. */ #define HAS_FCNTL /**/ /* HAS_FGETPOS: * This symbol, if defined, indicates that the fgetpos routine is * available to get the file position indicator, similar to ftell(). */ #define HAS_FGETPOS /**/ /* HAS_FLOCK: * This symbol, if defined, indicates that the flock routine is * available to do file locking. */ /*#define HAS_FLOCK / **/ /* HAS_FORK: * This symbol, if defined, indicates that the fork routine is * available. */ #define HAS_FORK /**/ /* HAS_FSETPOS: * This symbol, if defined, indicates that the fsetpos routine is * available to set the file position indicator, similar to fseek(). */ #define HAS_FSETPOS /**/ /* HAS_GETTIMEOFDAY: * This symbol, if defined, indicates that the gettimeofday() system * call is available for a sub-second accuracy clock. Usually, the file * needs to be included (see I_SYS_RESOURCE). * The type "Timeval" should be used to refer to "struct timeval". */ #define HAS_GETTIMEOFDAY /**/ #ifdef HAS_GETTIMEOFDAY #define Timeval struct timeval /* Structure used by gettimeofday() */ #endif /* HAS_GETGROUPS: * This symbol, if defined, indicates that the getgroups() routine is * available to get the list of process groups. If unavailable, multiple * groups are probably not supported. */ #define HAS_GETGROUPS /**/ /* HAS_GETLOGIN: * This symbol, if defined, indicates that the getlogin routine is * available to get the login name. */ #define HAS_GETLOGIN /**/ /* HAS_GETPGID: * This symbol, if defined, indicates to the C program that * the getpgid(pid) function is available to get the * process group id. */ /*#define HAS_GETPGID / **/ /* HAS_GETPGRP2: * This symbol, if defined, indicates that the getpgrp2() (as in DG/UX) * routine is available to get the current process group. */ /*#define HAS_GETPGRP2 / **/ /* HAS_GETPPID: * This symbol, if defined, indicates that the getppid routine is * available to get the parent process ID. */ #define HAS_GETPPID /**/ /* HAS_GETPRIORITY: * This symbol, if defined, indicates that the getpriority routine is * available to get a process's priority. */ /*#define HAS_GETPRIORITY / **/ /* HAS_INET_ATON: * This symbol, if defined, indicates to the C program that the * inet_aton() function is available to parse IP address "dotted-quad" * strings. */ /*#define HAS_INET_ATON / **/ /* HAS_KILLPG: * This symbol, if defined, indicates that the killpg routine is available * to kill process groups. If unavailable, you probably should use kill * with a negative process number. */ /*#define HAS_KILLPG / **/ /* HAS_LINK: * This symbol, if defined, indicates that the link routine is * available to create hard links. */ /* #define HAS_LINK /**/ /* HAS_LOCALECONV: * This symbol, if defined, indicates that the localeconv routine is * available for numeric and monetary formatting conventions. */ #define HAS_LOCALECONV /**/ /* HAS_LOCKF: * This symbol, if defined, indicates that the lockf routine is * available to do file locking. */ /*#define HAS_LOCKF / **/ /* HAS_LSTAT: * This symbol, if defined, indicates that the lstat routine is * available to do file stats on symbolic links. */ /*#define HAS_LSTAT / **/ /* HAS_MBLEN: * This symbol, if defined, indicates that the mblen routine is available * to find the number of bytes in a multibye character. */ #define HAS_MBLEN /**/ /* HAS_MBSTOWCS: * This symbol, if defined, indicates that the mbstowcs routine is * available to covert a multibyte string into a wide character string. */ #define HAS_MBSTOWCS /**/ /* HAS_MBTOWC: * This symbol, if defined, indicates that the mbtowc routine is available * to covert a multibyte to a wide character. */ #define HAS_MBTOWC /**/ /* HAS_MEMCMP: * This symbol, if defined, indicates that the memcmp routine is available * to compare blocks of memory. */ #define HAS_MEMCMP /**/ /* HAS_MEMCPY: * This symbol, if defined, indicates that the memcpy routine is available * to copy blocks of memory. */ #define HAS_MEMCPY /**/ /* HAS_MEMMOVE: * This symbol, if defined, indicates that the memmove routine is available * to copy potentially overlapping blocks of memory. This should be used * only when HAS_SAFE_BCOPY is not defined. If neither is there, roll your * own version. */ #define HAS_MEMMOVE /**/ /* HAS_MEMSET: * This symbol, if defined, indicates that the memset routine is available * to set blocks of memory. */ #define HAS_MEMSET /**/ /* HAS_MKDIR: * This symbol, if defined, indicates that the mkdir routine is available * to create directories. Otherwise you should fork off a new process to * exec /bin/mkdir. */ #define HAS_MKDIR /**/ /* HAS_MKFIFO: * This symbol, if defined, indicates that the mkfifo routine is * available to create FIFOs. Otherwise, mknod should be able to * do it for you. However, if mkfifo is there, mknod might require * super-user privileges which mkfifo will not. */ #define HAS_MKFIFO /**/ /* HAS_MKTIME: * This symbol, if defined, indicates that the mktime routine is * available. */ #define HAS_MKTIME /**/ /* HAS_MSYNC: * This symbol, if defined, indicates that the msync system call is * available to synchronize a mapped file. */ /*#define HAS_MSYNC / **/ /* HAS_MUNMAP: * This symbol, if defined, indicates that the munmap system call is * available to unmap a region, usually mapped by mmap(). */ /*#define HAS_MUNMAP / **/ /* HAS_NICE: * This symbol, if defined, indicates that the nice routine is * available. */ /*#define HAS_NICE / **/ /* HAS_PATHCONF: * This symbol, if defined, indicates that pathconf() is available * to determine file-system related limits and options associated * with a given filename. */ /* HAS_FPATHCONF: * This symbol, if defined, indicates that pathconf() is available * to determine file-system related limits and options associated * with a given open file descriptor. */ #define HAS_PATHCONF /**/ #define HAS_FPATHCONF /**/ /* HAS_PAUSE: * This symbol, if defined, indicates that the pause routine is * available to suspend a process until a signal is received. */ #define HAS_PAUSE /**/ /* HAS_PIPE: * This symbol, if defined, indicates that the pipe routine is * available to create an inter-process channel. */ #define HAS_PIPE /**/ /* HAS_POLL: * This symbol, if defined, indicates that the poll routine is * available to poll active file descriptors. You may safely * include when this symbol is defined. */ /*#define HAS_POLL / **/ /* HAS_READDIR: * This symbol, if defined, indicates that the readdir routine is * available to read directory entries. You may have to include * . See I_DIRENT. */ #define HAS_READDIR /**/ /* HAS_SEEKDIR: * This symbol, if defined, indicates that the seekdir routine is * available. You may have to include . See I_DIRENT. */ /*#define HAS_SEEKDIR / **/ /* HAS_TELLDIR: * This symbol, if defined, indicates that the telldir routine is * available. You may have to include . See I_DIRENT. */ /*#define HAS_TELLDIR / **/ /* HAS_REWINDDIR: * This symbol, if defined, indicates that the rewinddir routine is * available. You may have to include . See I_DIRENT. */ #define HAS_REWINDDIR /**/ /* HAS_READLINK: * This symbol, if defined, indicates that the readlink routine is * available to read the value of a symbolic link. */ /*#define HAS_READLINK /* */ /* HAS_RENAME: * This symbol, if defined, indicates that the rename routine is available * to rename files. Otherwise you should do the unlink(), link(), unlink() * trick. */ #define HAS_RENAME /**/ /* HAS_RMDIR: * This symbol, if defined, indicates that the rmdir routine is * available to remove directories. Otherwise you should fork off a * new process to exec /bin/rmdir. */ #define HAS_RMDIR /**/ /* HAS_SELECT: * This symbol, if defined, indicates that the select routine is * available to select active file descriptors. If the timeout field * is used, may need to be included. */ #define HAS_SELECT /**/ /* HAS_SETEGID: * This symbol, if defined, indicates that the setegid routine is available * to change the effective gid of the current program. */ /*#define HAS_SETEGID / **/ /* HAS_SETEUID: * This symbol, if defined, indicates that the seteuid routine is available * to change the effective uid of the current program. */ /*#define HAS_SETEUID / **/ /* HAS_SETLINEBUF: * This symbol, if defined, indicates that the setlinebuf routine is * available to change stderr or stdout from block-buffered or unbuffered * to a line-buffered mode. */ #define HAS_SETLINEBUF /**/ /* HAS_SETLOCALE: * This symbol, if defined, indicates that the setlocale routine is * available to handle locale-specific ctype implementations. */ #define HAS_SETLOCALE /**/ /* HAS_SETPGID: * This symbol, if defined, indicates that the setpgid(pid, gpid) * routine is available to set process group ID. */ #define HAS_SETPGID /**/ /* HAS_SETPGRP2: * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX) * routine is available to set the current process group. */ /*#define HAS_SETPGRP2 / **/ /* HAS_SETPRIORITY: * This symbol, if defined, indicates that the setpriority routine is * available to set a process's priority. */ /*#define HAS_SETPRIORITY / **/ /* HAS_SETREGID: * This symbol, if defined, indicates that the setregid routine is * available to change the real and effective gid of the current * process. */ /* HAS_SETRESGID: * This symbol, if defined, indicates that the setresgid routine is * available to change the real, effective and saved gid of the current * process. */ /*#define HAS_SETREGID / **/ /*#define HAS_SETRESGID / **/ /* HAS_SETREUID: * This symbol, if defined, indicates that the setreuid routine is * available to change the real and effective uid of the current * process. */ /* HAS_SETRESUID: * This symbol, if defined, indicates that the setresuid routine is * available to change the real, effective and saved uid of the current * process. */ /*#define HAS_SETREUID / **/ /*#define HAS_SETRESUID / **/ /* HAS_SETRGID: * This symbol, if defined, indicates that the setrgid routine is available * to change the real gid of the current program. */ /*#define HAS_SETRGID / **/ /* HAS_SETRUID: * This symbol, if defined, indicates that the setruid routine is available * to change the real uid of the current program. */ /*#define HAS_SETRUID / **/ /* HAS_SETSID: * This symbol, if defined, indicates that the setsid routine is * available to set the process group ID. */ #define HAS_SETSID /**/ /* HAS_STRCHR: * This symbol is defined to indicate that the strchr()/strrchr() * functions are available for string searching. If not, try the * index()/rindex() pair. */ /* HAS_INDEX: * This symbol is defined to indicate that the index()/rindex() * functions are available for string searching. */ #define HAS_STRCHR /**/ /*#define HAS_INDEX / **/ /* HAS_STRCOLL: * This symbol, if defined, indicates that the strcoll routine is * available to compare strings using collating information. */ #define HAS_STRCOLL /**/ /* USE_STRUCT_COPY: * This symbol, if defined, indicates that this C compiler knows how * to copy structures. If undefined, you'll need to use a block copy * routine of some sort instead. */ #define USE_STRUCT_COPY /**/ /* HAS_STRTOD: * This symbol, if defined, indicates that the strtod routine is * available to provide better numeric string conversion than atof(). */ #define HAS_STRTOD /**/ /* HAS_STRTOL: * This symbol, if defined, indicates that the strtol routine is available * to provide better numeric string conversion than atoi() and friends. */ #define HAS_STRTOL /**/ /* HAS_STRXFRM: * This symbol, if defined, indicates that the strxfrm() routine is * available to transform strings. */ #define HAS_STRXFRM /**/ /* HAS_SYMLINK: * This symbol, if defined, indicates that the symlink routine is available * to create symbolic links. */ /*#define HAS_SYMLINK / **/ /* HAS_SYSCALL: * This symbol, if defined, indicates that the syscall routine is * available to call arbitrary system calls. If undefined, that's tough. */ /*#define HAS_SYSCALL / **/ /* HAS_SYSCONF: * This symbol, if defined, indicates that sysconf() is available * to determine system related limits and options. */ #define HAS_SYSCONF /**/ /* HAS_SYSTEM: * This symbol, if defined, indicates that the system routine is * available to issue a shell command. */ #define HAS_SYSTEM /**/ /* HAS_TCGETPGRP: * This symbol, if defined, indicates that the tcgetpgrp routine is * available to get foreground process group ID. */ #define HAS_TCGETPGRP /**/ /* HAS_TCSETPGRP: * This symbol, if defined, indicates that the tcsetpgrp routine is * available to set foreground process group ID. */ #define HAS_TCSETPGRP /**/ /* HAS_TRUNCATE: * This symbol, if defined, indicates that the truncate routine is * available to truncate files. */ /*#define HAS_TRUNCATE / **/ /* HAS_TZNAME: * This symbol, if defined, indicates that the tzname[] array is * available to access timezone names. */ #define HAS_TZNAME /**/ /* HAS_UMASK: * This symbol, if defined, indicates that the umask routine is * available to set and get the value of the file creation mask. */ #define HAS_UMASK /**/ /* HAS_USLEEP: * This symbol, if defined, indicates that the usleep routine is * available to let the process sleep on a sub-second accuracy. */ /*#define HAS_USLEEP / **/ /* HASVOLATILE: * This symbol, if defined, indicates that this C compiler knows about * the volatile declaration. */ #define HASVOLATILE /**/ #ifndef HASVOLATILE #define volatile #endif /* HAS_WAIT4: * This symbol, if defined, indicates that wait4() exists. */ /*#define HAS_WAIT4 / **/ /* HAS_WAITPID: * This symbol, if defined, indicates that the waitpid routine is * available to wait for child process. */ #define HAS_WAITPID /**/ /* HAS_WCSTOMBS: * This symbol, if defined, indicates that the wcstombs routine is * available to convert wide character strings to multibyte strings. */ #define HAS_WCSTOMBS /**/ /* HAS_WCTOMB: * This symbol, if defined, indicates that the wctomb routine is available * to covert a wide character to a multibyte. */ #define HAS_WCTOMB /**/ /* I_ARPA_INET: * This symbol, if defined, indicates to the C program that it should * include to get inet_addr and friends declarations. */ #define I_ARPA_INET /**/ /* I_ASSERT: * This symbol, if defined, indicates to the C program that it could * include to get the assert() macro. */ #define I_ASSERT /**/ /* I_DBM: * This symbol, if defined, indicates that exists and should * be included. */ /* I_RPCSVC_DBM: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_DBM / **/ /*#define I_RPCSVC_DBM / **/ /* I_DIRENT: * This symbol, if defined, indicates to the C program that it should * include . Using this symbol also triggers the definition * of the Direntry_t define which ends up being 'struct dirent' or * 'struct direct' depending on the availability of . */ /* DIRNAMLEN: * This symbol, if defined, indicates to the C program that the length * of directory entry names is provided by a d_namlen field. Otherwise * you need to do strlen() on the d_name field. */ /* Direntry_t: * This symbol is set to 'struct direct' or 'struct dirent' depending on * whether dirent is available or not. You should use this pseudo type to * portably declare your directory entries. */ #define I_DIRENT /**/ /*#define DIRNAMLEN / **/ #define Direntry_t struct dirent /* I_DLFCN: * This symbol, if defined, indicates that exists and should * be included. */ /*#define I_DLFCN / **/ /* I_FCNTL: * This manifest constant tells the C program to include . */ #define I_FCNTL /**/ /* I_FLOAT: * This symbol, if defined, indicates to the C program that it should * include to get definition of symbols like DBL_MAX or * DBL_MIN, i.e. machine dependent floating point values. */ #define I_FLOAT /**/ /* I_LIMITS: * This symbol, if defined, indicates to the C program that it should * include to get definition of symbols like WORD_BIT or * LONG_MAX, i.e. machine dependant limitations. */ #define I_LIMITS /**/ /* I_LOCALE: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_LOCALE /**/ /* I_MATH: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_MATH /**/ /* I_MEMORY: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_MEMORY / **/ /* I_NET_ERRNO: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_NET_ERRNO / **/ /* I_NETINET_IN: * This symbol, if defined, indicates to the C program that it should * include . Otherwise, you may try . */ #define I_NETINET_IN /**/ /* I_SFIO: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SFIO / **/ /* I_STDDEF: * This symbol, if defined, indicates that exists and should * be included. */ #define I_STDDEF /**/ /* I_STDLIB: * This symbol, if defined, indicates that exists and should * be included. */ #define I_STDLIB /**/ /* I_STRING: * This symbol, if defined, indicates to the C program that it should * include (USG systems) instead of (BSD systems). */ #define I_STRING /**/ /* I_SYS_DIR: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_DIR / **/ /* I_SYS_FILE: * This symbol, if defined, indicates to the C program that it should * include to get definition of R_OK and friends. */ /*#define I_SYS_FILE / **/ /* I_SYS_IOCTL: * This symbol, if defined, indicates that exists and should * be included. Otherwise, include or . */ /* I_SYS_SOCKIO: * This symbol, if defined, indicates the should be included * to get socket ioctl options, like SIOCATMARK. */ #define I_SYS_IOCTL /**/ /*#define I_SYS_SOCKIO / **/ /* I_SYS_NDIR: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_NDIR / **/ /* I_SYS_PARAM: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_PARAM /**/ /* I_SYS_RESOURCE: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_RESOURCE /**/ /* I_SYS_SELECT: * This symbol, if defined, indicates to the C program that it should * include in order to get definition of struct timeval. */ #define I_SYS_SELECT /**/ /* I_SYS_STAT: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_STAT /**/ /* I_SYS_TIMES: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_TIMES /**/ /* I_SYS_TYPES: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_TYPES /**/ /* I_SYS_UN: * This symbol, if defined, indicates to the C program that it should * include to get UNIX domain socket definitions. */ #define I_SYS_UN /**/ /* I_SYS_WAIT: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_WAIT /**/ /* I_TERMIO: * This symbol, if defined, indicates that the program should include * rather than . There are also differences in * the ioctl() calls that depend on the value of this symbol. */ /* I_TERMIOS: * This symbol, if defined, indicates that the program should include * the POSIX termios.h rather than sgtty.h or termio.h. * There are also differences in the ioctl() calls that depend on the * value of this symbol. */ /* I_SGTTY: * This symbol, if defined, indicates that the program should include * rather than . There are also differences in * the ioctl() calls that depend on the value of this symbol. */ /*#define I_TERMIO / **/ #define I_TERMIOS /**/ /*#define I_SGTTY / **/ /* I_UNISTD: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_UNISTD /**/ /* I_UTIME: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_UTIME /**/ /* I_VALUES: * This symbol, if defined, indicates to the C program that it should * include to get definition of symbols like MINFLOAT or * MAXLONG, i.e. machine dependant limitations. Probably, you * should use instead, if it is available. */ /*#define I_VALUES / **/ /* I_VFORK: * This symbol, if defined, indicates to the C program that it should * include vfork.h. */ /*#define I_VFORK / **/ /* INTSIZE: * This symbol contains the value of sizeof(int) so that the C * preprocessor can make decisions based on it. */ /* LONGSIZE: * This symbol contains the value of sizeof(long) so that the C * preprocessor can make decisions based on it. */ /* SHORTSIZE: * This symbol contains the value of sizeof(short) so that the C * preprocessor can make decisions based on it. */ #define INTSIZE 4 /**/ #define LONGSIZE 4 /**/ #define SHORTSIZE 2 /**/ /* MULTIARCH: * This symbol, if defined, signifies that the build * process will produce some binary files that are going to be * used in a cross-platform environment. This is the case for * example with the NeXT "fat" binaries that contain executables * for several CPUs. */ /*#define MULTIARCH / **/ /* HAS_QUAD: * This symbol, if defined, tells that there's a 64-bit integer type, * Quad_t, and its unsigned counterpar, Uquad_t. QUADKIND will be one * of QUAD_IS_INT, QUAD_IS_LONG, QUAD_IS_LONG_LONG, or QUAD_IS_INT64_T. */ #define HAS_QUAD /**/ #ifdef HAS_QUAD # define Quad_t long long /**/ # define Uquad_t unsigned long long /**/ # define QUADKIND 3 /**/ # define QUAD_IS_INT 1 # define QUAD_IS_LONG 2 # define QUAD_IS_LONG_LONG 3 # define QUAD_IS_INT64_T 4 #endif /* HAS_ACCESSX: * This symbol, if defined, indicates that the accessx routine is * available to do extended access checks. */ /*#define HAS_ACCESSX / **/ /* HAS_EACCESS: * This symbol, if defined, indicates that the eaccess routine is * available to do extended access checks. */ /*#define HAS_EACCESS / **/ /* I_SYS_ACCESS: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_ACCESS / **/ /* I_SYS_SECURITY: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_SECURITY / **/ /* OSNAME: * This symbol contains the name of the operating system, as determined * by Configure. You shouldn't rely on it too much; the specific * feature tests from Configure are generally more reliable. */ /* OSVERS: * This symbol contains the version of the operating system, as determined * by Configure. You shouldn't rely on it too much; the specific * feature tests from Configure are generally more reliable. */ #define OSNAME "plan9" /**/ #define OSVERS "1" /**/ /* MEM_ALIGNBYTES: * This symbol contains the number of bytes required to align a * double, or a long double when applicable. Usual values are 2, * 4 and 8. The default is eight, for safety. */ #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH) # define MEM_ALIGNBYTES 8 #else #define MEM_ALIGNBYTES 4 #endif /* ARCHLIB: * This variable, if defined, holds the name of the directory in * which the user wants to put architecture-dependent public * library files for perl. It is most often a local directory * such as /usr/local/lib. Programs using this variable must be * prepared to deal with filename expansion. If ARCHLIB is the * same as PRIVLIB, it is not defined, since presumably the * program already searches PRIVLIB. */ /* ARCHLIB_EXP: * This symbol contains the ~name expanded version of ARCHLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ #define ARCHLIB "/sys/lib/perl/5.8.0/386" /**/ #define ARCHLIB_EXP "/sys/lib/perl/5.8.0/386" /**/ /* ARCHNAME: * This symbol holds a string representing the architecture name. * It may be used to construct an architecture-dependant pathname * where library files may be held under a private library, for * instance. */ #define ARCHNAME "386" /**/ /* HAS_ATOLF: * This symbol, if defined, indicates that the atolf routine is * available to convert strings into long doubles. */ /*#define HAS_ATOLF / **/ /* HAS_ATOLL: * This symbol, if defined, indicates that the atoll routine is * available to convert strings into long longs. */ #define HAS_ATOLL /**/ /* BIN: * This symbol holds the path of the bin directory where the package will * be installed. Program must be prepared to deal with ~name substitution. */ /* BIN_EXP: * This symbol is the filename expanded version of the BIN symbol, for * programs that do not want to deal with that at run-time. */ #define BIN "/usr/bin" /**/ #define BIN_EXP "/usr/bin" /**/ /* BYTEORDER: * This symbol holds the hexadecimal constant defined in byteorder, * in a UV, i.e. 0x1234 or 0x4321 or 0x12345678, etc... * If the compiler supports cross-compiling or multiple-architecture * binaries (eg. on NeXT systems), use compiler-defined macros to * determine the byte order. * On NeXT 3.2 (and greater), you can build "Fat" Multiple Architecture * Binaries (MAB) on either big endian or little endian machines. * The endian-ness is available at compile-time. This only matters * for perl, where the config.h can be generated and installed on * one system, and used by a different architecture to build an * extension. Older versions of NeXT that might not have * defined either *_ENDIAN__ were all on Motorola 680x0 series, * so the default case (for NeXT) is big endian to catch them. * This might matter for NeXT 3.0. */ #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH) # ifdef __LITTLE_ENDIAN__ # if LONGSIZE == 4 # define BYTEORDER 0x1234 # else # if LONGSIZE == 8 # define BYTEORDER 0x12345678 # endif # endif # else # ifdef __BIG_ENDIAN__ # if LONGSIZE == 4 # define BYTEORDER 0x4321 # else # if LONGSIZE == 8 # define BYTEORDER 0x87654321 # endif # endif # endif # endif # if !defined(BYTEORDER) && (defined(NeXT) || defined(__NeXT__)) # define BYTEORDER 0x4321 # endif #else #define BYTEORDER 0x1234 /* large digits for MSB */ #endif /* NeXT */ /* CAT2: * This macro catenates 2 tokens together. */ /* STRINGIFY: * This macro surrounds its token with double quotes. */ #if 42 == 1 #define CAT2(a,b) a/**/b #define STRINGIFY(a) "a" /* If you can get stringification with catify, tell me how! */ #endif #if 42 == 42 #define PeRl_CaTiFy(a, b) a ## b #define PeRl_StGiFy(a) #a /* the additional level of indirection enables these macros to be * used as arguments to other macros. See K&R 2nd ed., page 231. */ #define CAT2(a,b) PeRl_CaTiFy(a,b) #define StGiFy(a) PeRl_StGiFy(a) #define STRINGIFY(a) PeRl_StGiFy(a) #endif #if 42 != 1 && 42 != 42 # include "Bletch: How does this C preprocessor concatenate tokens?" #endif /* CPPSTDIN: * This symbol contains the first part of the string which will invoke * the C preprocessor on the standard input and produce to standard * output. Typical value of "cc -E" or "/lib/cpp", but it can also * call a wrapper. See CPPRUN. */ /* CPPMINUS: * This symbol contains the second part of the string which will invoke * the C preprocessor on the standard input and produce to standard * output. This symbol will have the value "-" if CPPSTDIN needs a minus * to specify standard input, otherwise the value is "". */ /* CPPRUN: * This symbol contains the string which will invoke a C preprocessor on * the standard input and produce to standard output. It needs to end * with CPPLAST, after all other preprocessor flags have been specified. * The main difference with CPPSTDIN is that this program will never be a * pointer to a shell wrapper, i.e. it will be empty if no preprocessor is * available directly to the user. Note that it may well be different from * the preprocessor used to compile the C program. */ /* CPPLAST: * This symbol is intended to be used along with CPPRUN in the same manner * symbol CPPMINUS is used with CPPSTDIN. It contains either "-" or "". */ #define CPPSTDIN "cppstdin" #define CPPMINUS "" #define CPPRUN "/bin/cpp" #define CPPLAST "" /* HAS__FWALK: * This symbol, if defined, indicates that the _fwalk system call is * available to apply a function to all the file handles. */ /*#define HAS__FWALK / **/ /* HAS_ACCESS: * This manifest constant lets the C program know that the access() * system call is available to check for accessibility using real UID/GID. * (always present on UNIX.) */ #define HAS_ACCESS /**/ /* HAS_ASCTIME_R: * This symbol, if defined, indicates that the asctime_r routine * is available to asctime re-entrantly. */ /* ASCTIME_R_PROTO: * This symbol encodes the prototype of asctime_r. * It is zero if d_asctime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_asctime_r * is defined. */ /*#define HAS_ASCTIME_R / **/ #define ASCTIME_R_PROTO 0 /**/ /* CASTI32: * This symbol is defined if the C compiler can cast negative * or large floating point numbers to 32-bit ints. */ /*#define CASTI32 / **/ /* CASTNEGFLOAT: * This symbol is defined if the C compiler can cast negative * numbers to unsigned longs, ints and shorts. */ /* CASTFLAGS: * This symbol contains flags that say what difficulties the compiler * has casting odd floating values to unsigned long: * 0 = ok * 1 = couldn't cast < 0 * 2 = couldn't cast >= 0x80000000 * 4 = couldn't cast in argument expression list */ /*#define CASTNEGFLOAT / **/ #define CASTFLAGS 7 /**/ /* HAS_CLASS: * This symbol, if defined, indicates that the class routine is * available to classify doubles. Available for example in AIX. * The returned values are defined in and are: * * FP_PLUS_NORM Positive normalized, nonzero * FP_MINUS_NORM Negative normalized, nonzero * FP_PLUS_DENORM Positive denormalized, nonzero * FP_MINUS_DENORM Negative denormalized, nonzero * FP_PLUS_ZERO +0.0 * FP_MINUS_ZERO -0.0 * FP_PLUS_INF +INF * FP_MINUS_INF -INF * FP_NANS Signaling Not a Number (NaNS) * FP_NANQ Quiet Not a Number (NaNQ) */ /*#define HAS_CLASS / **/ /* VOID_CLOSEDIR: * This symbol, if defined, indicates that the closedir() routine * does not return a value. */ /*#define VOID_CLOSEDIR / **/ /* HAS_STRUCT_CMSGHDR: * This symbol, if defined, indicates that the struct cmsghdr * is supported. */ /*#define HAS_STRUCT_CMSGHDR / **/ /* HAS_CRYPT_R: * This symbol, if defined, indicates that the crypt_r routine * is available to crypt re-entrantly. */ /* CRYPT_R_PROTO: * This symbol encodes the prototype of crypt_r. * It is zero if d_crypt_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_crypt_r * is defined. */ /*#define HAS_CRYPT_R / **/ #define CRYPT_R_PROTO 0 /**/ /* HAS_CSH: * This symbol, if defined, indicates that the C-shell exists. */ /* CSH: * This symbol, if defined, contains the full pathname of csh. */ /*#define HAS_CSH / **/ #ifdef HAS_CSH #define CSH "csh" /**/ #endif /* HAS_CTIME_R: * This symbol, if defined, indicates that the ctime_r routine * is available to ctime re-entrantly. */ /* CTIME_R_PROTO: * This symbol encodes the prototype of ctime_r. * It is zero if d_ctime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ctime_r * is defined. */ /*#define HAS_CTIME_R / **/ #define CTIME_R_PROTO 0 /**/ /* DLSYM_NEEDS_UNDERSCORE: * This symbol, if defined, indicates that we need to prepend an * underscore to the symbol name before calling dlsym(). This only * makes sense if you *have* dlsym, which we will presume is the * case if you're using dl_dlopen.xs. */ /*#define DLSYM_NEEDS_UNDERSCORE / **/ /* HAS_DRAND48_R: * This symbol, if defined, indicates that the drand48_r routine * is available to drand48 re-entrantly. */ /* DRAND48_R_PROTO: * This symbol encodes the prototype of drand48_r. * It is zero if d_drand48_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_drand48_r * is defined. */ /*#define HAS_DRAND48_R / **/ #define DRAND48_R_PROTO 0 /**/ /* HAS_DRAND48_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the drand48() function. Otherwise, it is up * to the program to supply one. A good guess is * extern double drand48(void); */ /*#define HAS_DRAND48_PROTO / **/ /* HAS_ENDGRENT: * This symbol, if defined, indicates that the getgrent routine is * available for finalizing sequential access of the group database. */ #define HAS_ENDGRENT /**/ /* HAS_ENDGRENT_R: * This symbol, if defined, indicates that the endgrent_r routine * is available to endgrent re-entrantly. */ /* ENDGRENT_R_PROTO: * This symbol encodes the prototype of endgrent_r. * It is zero if d_endgrent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endgrent_r * is defined. */ /*#define HAS_ENDGRENT_R / **/ #define ENDGRENT_R_PROTO 0 /**/ /* HAS_ENDHOSTENT: * This symbol, if defined, indicates that the endhostent() routine is * available to close whatever was being used for host queries. */ #define HAS_ENDHOSTENT /**/ /* HAS_ENDNETENT: * This symbol, if defined, indicates that the endnetent() routine is * available to close whatever was being used for network queries. */ /*#define HAS_ENDNETENT / **/ /* HAS_ENDPROTOENT: * This symbol, if defined, indicates that the endprotoent() routine is * available to close whatever was being used for protocol queries. */ /*#define HAS_ENDPROTOENT / **/ /* HAS_ENDPWENT: * This symbol, if defined, indicates that the getgrent routine is * available for finalizing sequential access of the passwd database. */ #define HAS_ENDPWENT /**/ /* HAS_ENDPWENT_R: * This symbol, if defined, indicates that the endpwent_r routine * is available to endpwent re-entrantly. */ /* ENDPWENT_R_PROTO: * This symbol encodes the prototype of endpwent_r. * It is zero if d_endpwent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endpwent_r * is defined. */ /*#define HAS_ENDPWENT_R / **/ #define ENDPWENT_R_PROTO 0 /**/ /* HAS_ENDSERVENT: * This symbol, if defined, indicates that the endservent() routine is * available to close whatever was being used for service queries. */ /*#define HAS_ENDSERVENT / **/ /* HAS_FAST_STDIO: * This symbol, if defined, indicates that the "fast stdio" * is available to manipulate the stdio buffers directly. */ /*#define HAS_FAST_STDIO /**/ /* HAS_FCHDIR: * This symbol, if defined, indicates that the fchdir routine is * available to change directory using a file descriptor. */ /*#define HAS_FCHDIR / **/ /* FCNTL_CAN_LOCK: * This symbol, if defined, indicates that fcntl() can be used * for file locking. Normally on Unix systems this is defined. * It may be undefined on VMS. */ /*#define FCNTL_CAN_LOCK / **/ /* HAS_FD_SET: * This symbol, when defined, indicates presence of the fd_set typedef * in */ /*#define HAS_FD_SET / **/ /* HAS_FINITE: * This symbol, if defined, indicates that the finite routine is * available to check whether a double is finite (non-infinity non-NaN). */ /*#define HAS_FINITE / **/ /* HAS_FINITEL: * This symbol, if defined, indicates that the finitel routine is * available to check whether a long double is finite * (non-infinity non-NaN). */ /*#define HAS_FINITEL / **/ /* FLEXFILENAMES: * This symbol, if defined, indicates that the system supports filenames * longer than 14 characters. */ #define FLEXFILENAMES /**/ /* HAS_FP_CLASS: * This symbol, if defined, indicates that the fp_class routine is * available to classify doubles. Available for example in Digital UNIX. * The returned values are defined in and are: * * FP_SNAN Signaling NaN (Not-a-Number) * FP_QNAN Quiet NaN (Not-a-Number) * FP_POS_INF +infinity * FP_NEG_INF -infinity * FP_POS_NORM Positive normalized * FP_NEG_NORM Negative normalized * FP_POS_DENORM Positive denormalized * FP_NEG_DENORM Negative denormalized * FP_POS_ZERO +0.0 (positive zero) * FP_NEG_ZERO -0.0 (negative zero) */ /*#define HAS_FP_CLASS / **/ /* HAS_FPCLASS: * This symbol, if defined, indicates that the fpclass routine is * available to classify doubles. Available for example in Solaris/SVR4. * The returned values are defined in and are: * * FP_SNAN signaling NaN * FP_QNAN quiet NaN * FP_NINF negative infinity * FP_PINF positive infinity * FP_NDENORM negative denormalized non-zero * FP_PDENORM positive denormalized non-zero * FP_NZERO negative zero * FP_PZERO positive zero * FP_NNORM negative normalized non-zero * FP_PNORM positive normalized non-zero */ /*#define HAS_FPCLASS / **/ /* HAS_FPCLASSIFY: * This symbol, if defined, indicates that the fpclassify routine is * available to classify doubles. Available for example in HP-UX. * The returned values are defined in and are * * FP_NORMAL Normalized * FP_ZERO Zero * FP_INFINITE Infinity * FP_SUBNORMAL Denormalized * FP_NAN NaN * */ /*#define HAS_FPCLASSIFY / **/ /* HAS_FPOS64_T: * This symbol will be defined if the C compiler supports fpos64_t. */ /*#define HAS_FPOS64_T / **/ /* HAS_FREXPL: * This symbol, if defined, indicates that the frexpl routine is * available to break a long double floating-point number into * a normalized fraction and an integral power of 2. */ /*#define HAS_FREXPL / **/ /* HAS_STRUCT_FS_DATA: * This symbol, if defined, indicates that the struct fs_data * to do statfs() is supported. */ /*#define HAS_STRUCT_FS_DATA / **/ /* HAS_FSEEKO: * This symbol, if defined, indicates that the fseeko routine is * available to fseek beyond 32 bits (useful for ILP32 hosts). */ /*#define HAS_FSEEKO / **/ /* HAS_FSTATFS: * This symbol, if defined, indicates that the fstatfs routine is * available to stat filesystems by file descriptors. */ /*#define HAS_FSTATFS / **/ /* HAS_FSYNC: * This symbol, if defined, indicates that the fsync routine is * available to write a file's modified data and attributes to * permanent storage. */ #define HAS_FSYNC /**/ /* HAS_FTELLO: * This symbol, if defined, indicates that the ftello routine is * available to ftell beyond 32 bits (useful for ILP32 hosts). */ /*#define HAS_FTELLO / **/ /* Gconvert: * This preprocessor macro is defined to convert a floating point * number to a string without a trailing decimal point. This * emulates the behavior of sprintf("%g"), but is sometimes much more * efficient. If gconvert() is not available, but gcvt() drops the * trailing decimal point, then gcvt() is used. If all else fails, * a macro using sprintf("%g") is used. Arguments for the Gconvert * macro are: value, number of digits, whether trailing zeros should * be retained, and the output buffer. * The usual values are: * d_Gconvert='gconvert((x),(n),(t),(b))' * d_Gconvert='gcvt((x),(n),(b))' * d_Gconvert='sprintf((b),"%.*g",(n),(x))' * The last two assume trailing zeros should not be kept. */ #define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(x)) /* HAS_GETCWD: * This symbol, if defined, indicates that the getcwd routine is * available to get the current working directory. */ #define HAS_GETCWD /**/ /* HAS_GETESPWNAM: * This symbol, if defined, indicates that the getespwnam system call is * available to retrieve enchanced (shadow) password entries by name. */ /*#define HAS_GETESPWNAM / **/ /* HAS_GETFSSTAT: * This symbol, if defined, indicates that the getfsstat routine is * available to stat filesystems in bulk. */ /*#define HAS_GETFSSTAT / **/ /* HAS_GETGRENT: * This symbol, if defined, indicates that the getgrent routine is * available for sequential access of the group database. */ #define HAS_GETGRENT /**/ /* HAS_GETGRENT_R: * This symbol, if defined, indicates that the getgrent_r routine * is available to getgrent re-entrantly. */ /* GETGRENT_R_PROTO: * This symbol encodes the prototype of getgrent_r. * It is zero if d_getgrent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrent_r * is defined. */ /*#define HAS_GETGRENT_R / **/ #define GETGRENT_R_PROTO 0 /**/ /* HAS_GETGRGID_R: * This symbol, if defined, indicates that the getgrgid_r routine * is available to getgrgid re-entrantly. */ /* GETGRGID_R_PROTO: * This symbol encodes the prototype of getgrgid_r. * It is zero if d_getgrgid_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrgid_r * is defined. */ /*#define HAS_GETGRGID_R / **/ #define GETGRGID_R_PROTO 0 /**/ /* HAS_GETGRNAM_R: * This symbol, if defined, indicates that the getgrnam_r routine * is available to getgrnam re-entrantly. */ /* GETGRNAM_R_PROTO: * This symbol encodes the prototype of getgrnam_r. * It is zero if d_getgrnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrnam_r * is defined. */ /*#define HAS_GETGRNAM_R / **/ #define GETGRNAM_R_PROTO 0 /**/ /* HAS_GETHOSTBYADDR: * This symbol, if defined, indicates that the gethostbyaddr() routine is * available to look up hosts by their IP addresses. */ #define HAS_GETHOSTBYADDR /**/ /* HAS_GETHOSTBYNAME: * This symbol, if defined, indicates that the gethostbyname() routine is * available to look up host names in some data base or other. */ #define HAS_GETHOSTBYNAME /**/ /* HAS_GETHOSTENT: * This symbol, if defined, indicates that the gethostent() routine is * available to look up host names in some data base or another. */ /*#define HAS_GETHOSTENT / **/ /* HAS_GETHOSTNAME: * This symbol, if defined, indicates that the C program may use the * gethostname() routine to derive the host name. See also HAS_UNAME * and PHOSTNAME. */ /* HAS_UNAME: * This symbol, if defined, indicates that the C program may use the * uname() routine to derive the host name. See also HAS_GETHOSTNAME * and PHOSTNAME. */ /* PHOSTNAME: * This symbol, if defined, indicates the command to feed to the * popen() routine to derive the host name. See also HAS_GETHOSTNAME * and HAS_UNAME. Note that the command uses a fully qualified path, * so that it is safe even if used by a process with super-user * privileges. */ /* HAS_PHOSTNAME: * This symbol, if defined, indicates that the C program may use the * contents of PHOSTNAME as a command to feed to the popen() routine * to derive the host name. */ #define HAS_GETHOSTNAME /**/ #define HAS_UNAME /**/ /*#define HAS_PHOSTNAME / **/ #ifdef HAS_PHOSTNAME #define PHOSTNAME "/bin/uname -n" /* How to get the host name */ #endif /* HAS_GETHOST_PROTOS: * This symbol, if defined, indicates that includes * prototypes for gethostent(), gethostbyname(), and * gethostbyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ /*#define HAS_GETHOST_PROTOS / **/ /* HAS_GETITIMER: * This symbol, if defined, indicates that the getitimer routine is * available to return interval timers. */ /*#define HAS_GETITIMER / **/ /* HAS_GETLOGIN_R: * This symbol, if defined, indicates that the getlogin_r routine * is available to getlogin re-entrantly. */ /* GETLOGIN_R_PROTO: * This symbol encodes the prototype of getlogin_r. * It is zero if d_getlogin_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getlogin_r * is defined. */ /*#define HAS_GETLOGIN_R / **/ #define GETLOGIN_R_PROTO 0 /**/ /* HAS_GETMNT: * This symbol, if defined, indicates that the getmnt routine is * available to get filesystem mount info by filename. */ /*#define HAS_GETMNT / **/ /* HAS_GETMNTENT: * This symbol, if defined, indicates that the getmntent routine is * available to iterate through mounted file systems to get their info. */ /*#define HAS_GETMNTENT / **/ /* HAS_GETNETBYADDR: * This symbol, if defined, indicates that the getnetbyaddr() routine is * available to look up networks by their IP addresses. */ /*#define HAS_GETNETBYADDR / **/ /* HAS_GETNETBYNAME: * This symbol, if defined, indicates that the getnetbyname() routine is * available to look up networks by their names. */ /*#define HAS_GETNETBYNAME / **/ /* HAS_GETNETENT: * This symbol, if defined, indicates that the getnetent() routine is * available to look up network names in some data base or another. */ /*#define HAS_GETNETENT / **/ /* HAS_GETNET_PROTOS: * This symbol, if defined, indicates that includes * prototypes for getnetent(), getnetbyname(), and * getnetbyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ /*#define HAS_GETNET_PROTOS / **/ /* HAS_GETPAGESIZE: * This symbol, if defined, indicates that the getpagesize system call * is available to get system page size, which is the granularity of * many memory management calls. */ /*#define HAS_GETPAGESIZE / **/ /* HAS_GETPROTOENT: * This symbol, if defined, indicates that the getprotoent() routine is * available to look up protocols in some data base or another. */ /*#define HAS_GETPROTOENT / **/ /* HAS_GETPGRP: * This symbol, if defined, indicates that the getpgrp routine is * available to get the current process group. */ /* USE_BSD_GETPGRP: * This symbol, if defined, indicates that getpgrp needs one * arguments whereas USG one needs none. */ #define HAS_GETPGRP /**/ /*#define USE_BSD_GETPGRP / **/ /* HAS_GETPROTOBYNAME: * This symbol, if defined, indicates that the getprotobyname() * routine is available to look up protocols by their name. */ /* HAS_GETPROTOBYNUMBER: * This symbol, if defined, indicates that the getprotobynumber() * routine is available to look up protocols by their number. */ #define HAS_GETPROTOBYNAME /**/ /*#define HAS_GETPROTOBYNUMBER / **/ /* HAS_GETPROTO_PROTOS: * This symbol, if defined, indicates that includes * prototypes for getprotoent(), getprotobyname(), and * getprotobyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ /*#define HAS_GETPROTO_PROTOS / **/ /* HAS_GETPRPWNAM: * This symbol, if defined, indicates that the getprpwnam system call is * available to retrieve protected (shadow) password entries by name. */ /*#define HAS_GETPRPWNAM / **/ /* HAS_GETPWENT: * This symbol, if defined, indicates that the getpwent routine is * available for sequential access of the passwd database. * If this is not available, the older getpw() function may be available. */ #define HAS_GETPWENT /**/ /* HAS_GETPWENT_R: * This symbol, if defined, indicates that the getpwent_r routine * is available to getpwent re-entrantly. */ /* GETPWENT_R_PROTO: * This symbol encodes the prototype of getpwent_r. * It is zero if d_getpwent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwent_r * is defined. */ /*#define HAS_GETPWENT_R / **/ #define GETPWENT_R_PROTO 0 /**/ /* HAS_GETPWNAM_R: * This symbol, if defined, indicates that the getpwnam_r routine * is available to getpwnam re-entrantly. */ /* GETPWNAM_R_PROTO: * This symbol encodes the prototype of getpwnam_r. * It is zero if d_getpwnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwnam_r * is defined. */ /*#define HAS_GETPWNAM_R / **/ #define GETPWNAM_R_PROTO 0 /**/ /* HAS_GETPWUID_R: * This symbol, if defined, indicates that the getpwuid_r routine * is available to getpwuid re-entrantly. */ /* GETPWUID_R_PROTO: * This symbol encodes the prototype of getpwuid_r. * It is zero if d_getpwuid_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwuid_r * is defined. */ /*#define HAS_GETPWUID_R / **/ #define GETPWUID_R_PROTO 0 /**/ /* HAS_GETSERVENT: * This symbol, if defined, indicates that the getservent() routine is * available to look up network services in some data base or another. */ /*#define HAS_GETSERVENT / **/ /* HAS_GETSERV_PROTOS: * This symbol, if defined, indicates that includes * prototypes for getservent(), getservbyname(), and * getservbyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ /*#define HAS_GETSERV_PROTOS / **/ /* HAS_GETSPNAM: * This symbol, if defined, indicates that the getspnam system call is * available to retrieve SysV shadow password entries by name. */ /*#define HAS_GETSPNAM / **/ /* HAS_GETSPNAM_R: * This symbol, if defined, indicates that the getspnam_r routine * is available to getspnam re-entrantly. */ /* GETSPNAM_R_PROTO: * This symbol encodes the prototype of getspnam_r. * It is zero if d_getspnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getspnam_r * is defined. */ /*#define HAS_GETSPNAM_R / **/ #define GETSPNAM_R_PROTO 0 /**/ /* HAS_GETSERVBYNAME: * This symbol, if defined, indicates that the getservbyname() * routine is available to look up services by their name. */ /* HAS_GETSERVBYPORT: * This symbol, if defined, indicates that the getservbyport() * routine is available to look up services by their port. */ #define HAS_GETSERVBYNAME /**/ /*#define HAS_GETSERVBYPORT / **/ /* HAS_GMTIME_R: * This symbol, if defined, indicates that the gmtime_r routine * is available to gmtime re-entrantly. */ /* GMTIME_R_PROTO: * This symbol encodes the prototype of gmtime_r. * It is zero if d_gmtime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gmtime_r * is defined. */ /*#define HAS_GMTIME_R / **/ #define GMTIME_R_PROTO 0 /**/ /* HAS_GNULIBC: * This symbol, if defined, indicates to the C program that * the GNU C library is being used. A better check is to use * the __GLIBC__ and __GLIBC_MINOR__ symbols supplied with glibc. */ /*#define HAS_GNULIBC / **/ #if defined(HAS_GNULIBC) && !defined(_GNU_SOURCE) # define _GNU_SOURCE #endif /* HAS_HASMNTOPT: * This symbol, if defined, indicates that the hasmntopt routine is * available to query the mount options of file systems. */ /*#define HAS_HASMNTOPT / **/ /* HAS_HTONL: * This symbol, if defined, indicates that the htonl() routine (and * friends htons() ntohl() ntohs()) are available to do network * order byte swapping. */ /* HAS_HTONS: * This symbol, if defined, indicates that the htons() routine (and * friends htonl() ntohl() ntohs()) are available to do network * order byte swapping. */ /* HAS_NTOHL: * This symbol, if defined, indicates that the ntohl() routine (and * friends htonl() htons() ntohs()) are available to do network * order byte swapping. */ /* HAS_NTOHS: * This symbol, if defined, indicates that the ntohs() routine (and * friends htonl() htons() ntohl()) are available to do network * order byte swapping. */ #define HAS_HTONL /**/ #define HAS_HTONS /**/ #define HAS_NTOHL /**/ #define HAS_NTOHS /**/ /* HAS_ILOGBL: * This symbol, if defined, indicates that the ilogbl routine is * available. If scalbnl is also present we can emulate frexpl. */ /*#define HAS_ILOGBL /**/ /* HAS_INT64_T: * This symbol will defined if the C compiler supports int64_t. * Usually the needs to be included, but sometimes * is enough. */ #define HAS_INT64_T /**/ /* HAS_ISASCII: * This manifest constant lets the C program know that isascii * is available. */ /*#define HAS_ISASCII / **/ /* HAS_ISFINITE: * This symbol, if defined, indicates that the isfinite routine is * available to check whether a double is finite (non-infinity non-NaN). */ /*#define HAS_ISFINITE / **/ /* HAS_ISINF: * This symbol, if defined, indicates that the isinf routine is * available to check whether a double is an infinity. */ /*#define HAS_ISINF / **/ /* HAS_ISNAN: * This symbol, if defined, indicates that the isnan routine is * available to check whether a double is a NaN. */ /*#define HAS_ISNAN / **/ /* HAS_ISNANL: * This symbol, if defined, indicates that the isnanl routine is * available to check whether a long double is a NaN. */ /*#define HAS_ISNANL / **/ /* HAS_LCHOWN: * This symbol, if defined, indicates that the lchown routine is * available to operate on a symbolic link (instead of following the * link). */ /*#define HAS_LCHOWN / **/ /* HAS_LDBL_DIG: * This symbol, if defined, indicates that this system's * or defines the symbol LDBL_DIG, which is the number * of significant digits in a long double precision number. Unlike * for DBL_DIG, there's no good guess for LDBL_DIG if it is undefined. */ #define HAS_LDBL_DIG /* */ /* HAS_LOCALTIME_R: * This symbol, if defined, indicates that the localtime_r routine * is available to localtime re-entrantly. */ /* LOCALTIME_R_NEEDS_TZSET: * Many libc's localtime_r implementations do not call tzset, * making them differ from localtime(), and making timezone * changes using $ENV{TZ} without explicitly calling tzset * impossible. This symbol makes us call tzset before localtime_r */ /* LOCALTIME_R_PROTO: * This symbol encodes the prototype of localtime_r. * It is zero if d_localtime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_localtime_r * is defined. */ /*#define HAS_LOCALTIME_R / **/ /*#define LOCALTIME_R_NEEDS_TZSET / **/ #define LOCALTIME_R_PROTO 0 /**/ /* HAS_LONG_DOUBLE: * This symbol will be defined if the C compiler supports long * doubles. */ /* LONG_DOUBLESIZE: * This symbol contains the size of a long double, so that the * C preprocessor can make decisions based on it. It is only * defined if the system supports long doubles. */ #define HAS_LONG_DOUBLE /**/ #ifdef HAS_LONG_DOUBLE #define LONG_DOUBLESIZE 8 /**/ #endif /* HAS_LONG_LONG: * This symbol will be defined if the C compiler supports long long. */ /* LONGLONGSIZE: * This symbol contains the size of a long long, so that the * C preprocessor can make decisions based on it. It is only * defined if the system supports long long. */ #define HAS_LONG_LONG /**/ #ifdef HAS_LONG_LONG #define LONGLONGSIZE 8 /**/ #endif /* HAS_LSEEK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the lseek() function. Otherwise, it is up * to the program to supply one. A good guess is * extern off_t lseek(int, off_t, int); */ /*#define HAS_LSEEK_PROTO / **/ /* HAS_MADVISE: * This symbol, if defined, indicates that the madvise system call is * available to map a file into memory. */ /*#define HAS_MADVISE / **/ /* HAS_MEMCHR: * This symbol, if defined, indicates that the memchr routine is available * to locate characters within a C string. */ #define HAS_MEMCHR /**/ /* HAS_MKDTEMP: * This symbol, if defined, indicates that the mkdtemp routine is * available to exclusively create a uniquely named temporary directory. */ /*#define HAS_MKDTEMP / **/ /* HAS_MKSTEMP: * This symbol, if defined, indicates that the mkstemp routine is * available to exclusively create and open a uniquely named * temporary file. */ /*#define HAS_MKSTEMP / **/ /* HAS_MKSTEMPS: * This symbol, if defined, indicates that the mkstemps routine is * available to excluslvely create and open a uniquely named * (with a suffix) temporary file. */ /*#define HAS_MKSTEMPS / **/ /* HAS_MMAP: * This symbol, if defined, indicates that the mmap system call is * available to map a file into memory. */ /* Mmap_t: * This symbol holds the return type of the mmap() system call * (and simultaneously the type of the first argument). * Usually set to 'void *' or 'cadd_t'. */ /*#define HAS_MMAP / **/ #define Mmap_t void * /**/ /* HAS_MODFL: * This symbol, if defined, indicates that the modfl routine is * available to split a long double x into a fractional part f and * an integer part i such that |f| < 1.0 and (f + i) = x. */ /* HAS_MODFL_POW32_BUG: * This symbol, if defined, indicates that the modfl routine is * broken for long doubles >= pow(2, 32). * For example from 4294967303.150000 one would get 4294967302.000000 * and 1.150000. The bug has been seen in certain versions of glibc, * release 2.2.2 is known to be okay. */ /*#define HAS_MODFL / **/ /*#define HAS_MODFL_POW32_BUG / **/ /* HAS_MPROTECT: * This symbol, if defined, indicates that the mprotect system call is * available to modify the access protection of a memory mapped file. */ /*#define HAS_MPROTECT / **/ /* HAS_MSG: * This symbol, if defined, indicates that the entire msg*(2) library is * supported (IPC mechanism based on message queues). */ /*#define HAS_MSG / **/ /* HAS_STRUCT_MSGHDR: * This symbol, if defined, indicates that the struct msghdr * is supported. */ /*#define HAS_STRUCT_MSGHDR / **/ /* HAS_OFF64_T: * This symbol will be defined if the C compiler supports off64_t. */ /*#define HAS_OFF64_T / **/ /* HAS_OPEN3: * This manifest constant lets the C program know that the three * argument form of open(2) is available. */ #define HAS_OPEN3 /**/ /* OLD_PTHREAD_CREATE_JOINABLE: * This symbol, if defined, indicates how to create pthread * in joinable (aka undetached) state. NOTE: not defined * if pthread.h already has defined PTHREAD_CREATE_JOINABLE * (the new version of the constant). * If defined, known values are PTHREAD_CREATE_UNDETACHED * and __UNDETACHED. */ /*#define OLD_PTHREAD_CREATE_JOINABLE / **/ /* HAS_PTHREAD_YIELD: * This symbol, if defined, indicates that the pthread_yield * routine is available to yield the execution of the current * thread. sched_yield is preferable to pthread_yield. */ /* SCHED_YIELD: * This symbol defines the way to yield the execution of * the current thread. Known ways are sched_yield, * pthread_yield, and pthread_yield with NULL. */ /* HAS_SCHED_YIELD: * This symbol, if defined, indicates that the sched_yield * routine is available to yield the execution of the current * thread. sched_yield is preferable to pthread_yield. */ /*#define HAS_PTHREAD_YIELD / **/ #define SCHED_YIELD undef /**/ /*#define HAS_SCHED_YIELD / **/ /* HAS_RANDOM_R: * This symbol, if defined, indicates that the random_r routine * is available to random re-entrantly. */ /* RANDOM_R_PROTO: * This symbol encodes the prototype of random_r. * It is zero if d_random_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_random_r * is defined. */ /*#define HAS_RANDOM_R / **/ #define RANDOM_R_PROTO 0 /**/ /* HAS_READDIR_R: * This symbol, if defined, indicates that the readdir_r routine * is available to readdir re-entrantly. */ /* READDIR_R_PROTO: * This symbol encodes the prototype of readdir_r. * It is zero if d_readdir_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_readdir_r * is defined. */ /*#define HAS_READDIR_R / **/ #define READDIR_R_PROTO 0 /**/ /* HAS_READV: * This symbol, if defined, indicates that the readv routine is * available to do gather reads. You will also need * and there I_SYSUIO. */ #define HAS_READV /**/ /* HAS_RECVMSG: * This symbol, if defined, indicates that the recvmsg routine is * available to send structured socket messages. */ /*#define HAS_RECVMSG / **/ /* HAS_SAFE_BCOPY: * This symbol, if defined, indicates that the bcopy routine is available * to copy potentially overlapping memory blocks. Normally, you should * probably use memmove() or memcpy(). If neither is defined, roll your * own version. */ /*#define HAS_SAFE_BCOPY / **/ /* HAS_SAFE_MEMCPY: * This symbol, if defined, indicates that the memcpy routine is available * to copy potentially overlapping memory blocks. If you need to * copy overlapping memory blocks, you should check HAS_MEMMOVE and * use memmove() instead, if available. */ /*#define HAS_SAFE_MEMCPY / **/ /* HAS_SANE_MEMCMP: * This symbol, if defined, indicates that the memcmp routine is available * and can be used to compare relative magnitudes of chars with their high * bits set. If it is not defined, roll your own version. */ #define HAS_SANE_MEMCMP /**/ /* HAS_SBRK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the sbrk() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern void* sbrk(int); * extern void* sbrk(size_t); */ /*#define HAS_SBRK_PROTO / **/ /* HAS_SEM: * This symbol, if defined, indicates that the entire sem*(2) library is * supported. */ /*#define HAS_SEM / **/ /* HAS_SCALBNL: * This symbol, if defined, indicates that the scalbnl routine is * available. If ilogbl is also present we can emulate frexpl. */ /*#define HAS_SCALBNL /**/ /* HAS_SENDMSG: * This symbol, if defined, indicates that the sendmsg routine is * available to send structured socket messages. */ /*#define HAS_SENDMSG / **/ /* HAS_SETGRENT: * This symbol, if defined, indicates that the setgrent routine is * available for initializing sequential access of the group database. */ #define HAS_SETGRENT /**/ /* HAS_SETGRENT_R: * This symbol, if defined, indicates that the setgrent_r routine * is available to setgrent re-entrantly. */ /* SETGRENT_R_PROTO: * This symbol encodes the prototype of setgrent_r. * It is zero if d_setgrent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setgrent_r * is defined. */ /*#define HAS_SETGRENT_R / **/ #define SETGRENT_R_PROTO 0 /**/ /* HAS_SETGROUPS: * This symbol, if defined, indicates that the setgroups() routine is * available to set the list of process groups. If unavailable, multiple * groups are probably not supported. */ /*#define HAS_SETGROUPS / **/ /* HAS_SETHOSTENT: * This symbol, if defined, indicates that the sethostent() routine is * available. */ /*#define HAS_SETHOSTENT / **/ /* HAS_SETITIMER: * This symbol, if defined, indicates that the setitimer routine is * available to set interval timers. */ /*#define HAS_SETITIMER / **/ /* HAS_SETNETENT: * This symbol, if defined, indicates that the setnetent() routine is * available. */ /*#define HAS_SETNETENT / **/ /* HAS_SETPROTOENT: * This symbol, if defined, indicates that the setprotoent() routine is * available. */ /*#define HAS_SETPROTOENT / **/ /* HAS_SETPGRP: * This symbol, if defined, indicates that the setpgrp routine is * available to set the current process group. */ /* USE_BSD_SETPGRP: * This symbol, if defined, indicates that setpgrp needs two * arguments whereas USG one needs none. See also HAS_SETPGID * for a POSIX interface. */ /*#define HAS_SETPGRP / **/ /*#define USE_BSD_SETPGRP / **/ /* HAS_SETPROCTITLE: * This symbol, if defined, indicates that the setproctitle routine is * available to set process title. */ /*#define HAS_SETPROCTITLE / **/ /* HAS_SETPWENT: * This symbol, if defined, indicates that the setpwent routine is * available for initializing sequential access of the passwd database. */ #define HAS_SETPWENT /**/ /* HAS_SETPWENT_R: * This symbol, if defined, indicates that the setpwent_r routine * is available to setpwent re-entrantly. */ /* SETPWENT_R_PROTO: * This symbol encodes the prototype of setpwent_r. * It is zero if d_setpwent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setpwent_r * is defined. */ /*#define HAS_SETPWENT_R / **/ #define SETPWENT_R_PROTO 0 /**/ /* HAS_SETSERVENT: * This symbol, if defined, indicates that the setservent() routine is * available. */ /*#define HAS_SETSERVENT / **/ /* HAS_SETVBUF: * This symbol, if defined, indicates that the setvbuf routine is * available to change buffering on an open stdio stream. * to a line-buffered mode. */ #define HAS_SETVBUF /**/ /* USE_SFIO: * This symbol, if defined, indicates that sfio should * be used. */ /*#define USE_SFIO / **/ /* HAS_SHM: * This symbol, if defined, indicates that the entire shm*(2) library is * supported. */ /*#define HAS_SHM / **/ /* HAS_SIGACTION: * This symbol, if defined, indicates that Vr4's sigaction() routine * is available. */ #define HAS_SIGACTION /**/ /* HAS_SIGSETJMP: * This variable indicates to the C program that the sigsetjmp() * routine is available to save the calling process's registers * and stack environment for later use by siglongjmp(), and * to optionally save the process's signal mask. See * Sigjmp_buf, Sigsetjmp, and Siglongjmp. */ /* Sigjmp_buf: * This is the buffer type to be used with Sigsetjmp and Siglongjmp. */ /* Sigsetjmp: * This macro is used in the same way as sigsetjmp(), but will invoke * traditional setjmp() if sigsetjmp isn't available. * See HAS_SIGSETJMP. */ /* Siglongjmp: * This macro is used in the same way as siglongjmp(), but will invoke * traditional longjmp() if siglongjmp isn't available. * See HAS_SIGSETJMP. */ #define HAS_SIGSETJMP /**/ #ifdef HAS_SIGSETJMP #define Sigjmp_buf sigjmp_buf #define Sigsetjmp(buf,save_mask) sigsetjmp((buf),(save_mask)) #define Siglongjmp(buf,retval) siglongjmp((buf),(retval)) #else #define Sigjmp_buf jmp_buf #define Sigsetjmp(buf,save_mask) setjmp((buf)) #define Siglongjmp(buf,retval) longjmp((buf),(retval)) #endif /* HAS_SOCKET: * This symbol, if defined, indicates that the BSD socket interface is * supported. */ /* HAS_SOCKETPAIR: * This symbol, if defined, indicates that the BSD socketpair() call is * supported. */ /* HAS_MSG_CTRUNC: * This symbol, if defined, indicates that the MSG_CTRUNC is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_DONTROUTE: * This symbol, if defined, indicates that the MSG_DONTROUTE is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_OOB: * This symbol, if defined, indicates that the MSG_OOB is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_PEEK: * This symbol, if defined, indicates that the MSG_PEEK is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_PROXY: * This symbol, if defined, indicates that the MSG_PROXY is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_SCM_RIGHTS: * This symbol, if defined, indicates that the SCM_RIGHTS is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ #define HAS_SOCKET /**/ #define HAS_SOCKETPAIR /**/ /*#define HAS_MSG_CTRUNC / **/ /*#define HAS_MSG_DONTROUTE / **/ /*#define HAS_MSG_OOB / **/ /*#define HAS_MSG_PEEK / **/ /*#define HAS_MSG_PROXY / **/ /*#define HAS_SCM_RIGHTS / **/ /* HAS_SOCKS5_INIT: * This symbol, if defined, indicates that the socks5_init routine is * available to initialize SOCKS 5. */ /*#define HAS_SOCKS5_INIT / **/ /* HAS_SQRTL: * This symbol, if defined, indicates that the sqrtl routine is * available to do long double square roots. */ /*#define HAS_SQRTL / **/ /* HAS_SRAND48_R: * This symbol, if defined, indicates that the srand48_r routine * is available to srand48 re-entrantly. */ /* SRAND48_R_PROTO: * This symbol encodes the prototype of srand48_r. * It is zero if d_srand48_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_srand48_r * is defined. */ /*#define HAS_SRAND48_R / **/ #define SRAND48_R_PROTO 0 /**/ /* HAS_SRANDOM_R: * This symbol, if defined, indicates that the srandom_r routine * is available to srandom re-entrantly. */ /* SRANDOM_R_PROTO: * This symbol encodes the prototype of srandom_r. * It is zero if d_srandom_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_srandom_r * is defined. */ /*#define HAS_SRANDOM_R / **/ #define SRANDOM_R_PROTO 0 /**/ /* USE_STAT_BLOCKS: * This symbol is defined if this system has a stat structure declaring * st_blksize and st_blocks. */ #ifndef USE_STAT_BLOCKS /*#define USE_STAT_BLOCKS / **/ #endif /* HAS_STRUCT_STATFS_F_FLAGS: * This symbol, if defined, indicates that the struct statfs * does have the f_flags member containing the mount flags of * the filesystem containing the file. * This kind of struct statfs is coming from (BSD 4.3), * not from (SYSV). Older BSDs (like Ultrix) do not * have statfs() and struct statfs, they have ustat() and getmnt() * with struct ustat and struct fs_data. */ /*#define HAS_STRUCT_STATFS_F_FLAGS / **/ /* HAS_STRUCT_STATFS: * This symbol, if defined, indicates that the struct statfs * to do statfs() is supported. */ /*#define HAS_STRUCT_STATFS / **/ /* HAS_FSTATVFS: * This symbol, if defined, indicates that the fstatvfs routine is * available to stat filesystems by file descriptors. */ /*#define HAS_FSTATVFS / **/ /* USE_STDIO_PTR: * This symbol is defined if the _ptr and _cnt fields (or similar) * of the stdio FILE structure can be used to access the stdio buffer * for a file handle. If this is defined, then the FILE_ptr(fp) * and FILE_cnt(fp) macros will also be defined and should be used * to access these fields. */ /* FILE_ptr: * This macro is used to access the _ptr field (or equivalent) of the * FILE structure pointed to by its argument. This macro will always be * defined if USE_STDIO_PTR is defined. */ /* STDIO_PTR_LVALUE: * This symbol is defined if the FILE_ptr macro can be used as an * lvalue. */ /* FILE_cnt: * This macro is used to access the _cnt field (or equivalent) of the * FILE structure pointed to by its argument. This macro will always be * defined if USE_STDIO_PTR is defined. */ /* STDIO_CNT_LVALUE: * This symbol is defined if the FILE_cnt macro can be used as an * lvalue. */ /* STDIO_PTR_LVAL_SETS_CNT: * This symbol is defined if using the FILE_ptr macro as an lvalue * to increase the pointer by n has the side effect of decreasing the * value of File_cnt(fp) by n. */ /* STDIO_PTR_LVAL_NOCHANGE_CNT: * This symbol is defined if using the FILE_ptr macro as an lvalue * to increase the pointer by n leaves File_cnt(fp) unchanged. */ /*#define USE_STDIO_PTR / **/ #ifdef USE_STDIO_PTR #define FILE_ptr(fp) ((fp)->_ptr) /*#define STDIO_PTR_LVALUE / **/ #define FILE_cnt(fp) ((fp)->_cnt) /*#define STDIO_CNT_LVALUE / **/ /*#define STDIO_PTR_LVAL_SETS_CNT / **/ /*#define STDIO_PTR_LVAL_NOCHANGE_CNT / **/ #endif /* USE_STDIO_BASE: * This symbol is defined if the _base field (or similar) of the * stdio FILE structure can be used to access the stdio buffer for * a file handle. If this is defined, then the FILE_base(fp) macro * will also be defined and should be used to access this field. * Also, the FILE_bufsiz(fp) macro will be defined and should be used * to determine the number of bytes in the buffer. USE_STDIO_BASE * will never be defined unless USE_STDIO_PTR is. */ /* FILE_base: * This macro is used to access the _base field (or equivalent) of the * FILE structure pointed to by its argument. This macro will always be * defined if USE_STDIO_BASE is defined. */ /* FILE_bufsiz: * This macro is used to determine the number of bytes in the I/O * buffer pointed to by _base field (or equivalent) of the FILE * structure pointed to its argument. This macro will always be defined * if USE_STDIO_BASE is defined. */ /*#define USE_STDIO_BASE / **/ #ifdef USE_STDIO_BASE #define FILE_base(fp) ((fp)->_base) #define FILE_bufsiz(fp) ((fp)->_cnt + (fp)->_ptr - (fp)->_base) #endif /* HAS_STRERROR: * This symbol, if defined, indicates that the strerror routine is * available to translate error numbers to strings. See the writeup * of Strerror() in this file before you try to define your own. */ /* HAS_SYS_ERRLIST: * This symbol, if defined, indicates that the sys_errlist array is * available to translate error numbers to strings. The extern int * sys_nerr gives the size of that table. */ /* Strerror: * This preprocessor symbol is defined as a macro if strerror() is * not available to translate error numbers to strings but sys_errlist[] * array is there. */ #define HAS_STRERROR /**/ #define HAS_SYS_ERRLIST /**/ #define Strerror(e) strerror(e) /* HAS_STRERROR_R: * This symbol, if defined, indicates that the strerror_r routine * is available to strerror re-entrantly. */ /* STRERROR_R_PROTO: * This symbol encodes the prototype of strerror_r. * It is zero if d_strerror_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_strerror_r * is defined. */ /*#define HAS_STRERROR_R / **/ #define STRERROR_R_PROTO 0 /**/ /* HAS_STRTOLD: * This symbol, if defined, indicates that the strtold routine is * available to convert strings to long doubles. */ /*#define HAS_STRTOLD / **/ /* HAS_STRTOLL: * This symbol, if defined, indicates that the strtoll routine is * available to convert strings to long longs. */ /*#define HAS_STRTOLL / **/ /* HAS_STRTOQ: * This symbol, if defined, indicates that the strtoq routine is * available to convert strings to long longs (quads). */ /*#define HAS_STRTOQ / **/ /* HAS_STRTOUL: * This symbol, if defined, indicates that the strtoul routine is * available to provide conversion of strings to unsigned long. */ #define HAS_STRTOUL /**/ /* HAS_STRTOULL: * This symbol, if defined, indicates that the strtoull routine is * available to convert strings to unsigned long longs. */ /*#define HAS_STRTOULL / **/ /* HAS_STRTOUQ: * This symbol, if defined, indicates that the strtouq routine is * available to convert strings to unsigned long longs (quads). */ /*#define HAS_STRTOUQ / **/ /* HAS_TELLDIR_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the telldir() function. Otherwise, it is up * to the program to supply one. A good guess is * extern long telldir(DIR*); */ /*#define HAS_TELLDIR_PROTO / **/ /* HAS_TIME: * This symbol, if defined, indicates that the time() routine exists. */ /* Time_t: * This symbol holds the type returned by time(). It can be long, * or time_t on BSD sites (in which case should be * included). */ #define HAS_TIME /**/ #define Time_t time_t /* Time type */ /* HAS_TIMES: * This symbol, if defined, indicates that the times() routine exists. * Note that this became obsolete on some systems (SUNOS), which now * use getrusage(). It may be necessary to include . */ #define HAS_TIMES /**/ /* HAS_TMPNAM_R: * This symbol, if defined, indicates that the tmpnam_r routine * is available to tmpnam re-entrantly. */ /* TMPNAM_R_PROTO: * This symbol encodes the prototype of tmpnam_r. * It is zero if d_tmpnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_tmpnam_r * is defined. */ /*#define HAS_TMPNAM_R / **/ #define TMPNAM_R_PROTO 0 /**/ /* HAS_UALARM: * This symbol, if defined, indicates that the ualarm routine is * available to do alarms with microsecond granularity. */ /*#define HAS_UALARM / **/ /* HAS_UNION_SEMUN: * This symbol, if defined, indicates that the union semun is * defined by including . If not, the user code * probably needs to define it as: * union semun { * int val; * struct semid_ds *buf; * unsigned short *array; * } */ /* USE_SEMCTL_SEMUN: * This symbol, if defined, indicates that union semun is * used for semctl IPC_STAT. */ /* USE_SEMCTL_SEMID_DS: * This symbol, if defined, indicates that struct semid_ds * is * used for semctl IPC_STAT. */ /*#define HAS_UNION_SEMUN / **/ /*#define USE_SEMCTL_SEMUN / **/ /*#define USE_SEMCTL_SEMID_DS / **/ /* HAS_UNORDERED: * This symbol, if defined, indicates that the unordered routine is * available to check whether two doubles are unordered * (effectively: whether either of them is NaN) */ /*#define HAS_UNORDERED / **/ /* HAS_USTAT: * This symbol, if defined, indicates that the ustat system call is * available to query file system statistics by dev_t. */ /*#define HAS_USTAT / **/ /* HAS_VFORK: * This symbol, if defined, indicates that vfork() exists. */ /*#define HAS_VFORK / **/ /* Signal_t: * This symbol's value is either "void" or "int", corresponding to the * appropriate return type of a signal handler. Thus, you can declare * a signal handler using "Signal_t (*handler)()", and define the * handler using "Signal_t handler(sig)". */ #define Signal_t void /* Signal handler's return type */ /* HAS_VPRINTF: * This symbol, if defined, indicates that the vprintf routine is available * to printf with a pointer to an argument list. If unavailable, you * may need to write your own, probably in terms of _doprnt(). */ /* USE_CHAR_VSPRINTF: * This symbol is defined if this system has vsprintf() returning type * (char*). The trend seems to be to declare it as "int vsprintf()". It * is up to the package author to declare vsprintf correctly based on the * symbol. */ #define HAS_VPRINTF /**/ #define USE_CHAR_VSPRINTF /**/ /* HAS_WRITEV: * This symbol, if defined, indicates that the writev routine is * available to do scatter writes. */ #define HAS_WRITEV /**/ /* USE_DYNAMIC_LOADING: * This symbol, if defined, indicates that dynamic loading of * some sort is available. */ /*#define USE_DYNAMIC_LOADING / **/ /* DOUBLESIZE: * This symbol contains the size of a double, so that the C preprocessor * can make decisions based on it. */ #define DOUBLESIZE 8 /**/ /* EBCDIC: * This symbol, if defined, indicates that this system uses * EBCDIC encoding. */ /*#define EBCDIC / **/ /* FFLUSH_NULL: * This symbol, if defined, tells that fflush(NULL) does flush * all pending stdio output. */ /* FFLUSH_ALL: * This symbol, if defined, tells that to flush * all pending stdio output one must loop through all * the stdio file handles stored in an array and fflush them. * Note that if fflushNULL is defined, fflushall will not * even be probed for and will be left undefined. */ #define FFLUSH_NULL /**/ /*#define FFLUSH_ALL / **/ /* Fpos_t: * This symbol holds the type used to declare file positions in libc. * It can be fpos_t, long, uint, etc... It may be necessary to include * to get any typedef'ed information. */ #define Fpos_t fpos_t /* File position type */ /* Gid_t_f: * This symbol defines the format string used for printing a Gid_t. */ #define Gid_t_f "hd" /**/ /* Gid_t_sign: * This symbol holds the signedess of a Gid_t. * 1 for unsigned, -1 for signed. */ #define Gid_t_sign -1 /* GID sign */ /* Gid_t_size: * This symbol holds the size of a Gid_t in bytes. */ #define Gid_t_size 2 /* GID size */ /* Gid_t: * This symbol holds the return type of getgid() and the type of * argument to setrgid() and related functions. Typically, * it is the type of group ids in the kernel. It can be int, ushort, * gid_t, etc... It may be necessary to include to get * any typedef'ed information. */ #define Gid_t gid_t /* Type for getgid(), etc... */ /* Groups_t: * This symbol holds the type used for the second argument to * getgroups() and setgroups(). Usually, this is the same as * gidtype (gid_t) , but sometimes it isn't. * It can be int, ushort, gid_t, etc... * It may be necessary to include to get any * typedef'ed information. This is only required if you have * getgroups() or setgroups().. */ #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS) #define Groups_t gid_t /* Type for 2nd arg to [sg]etgroups() */ #endif /* DB_Prefix_t: * This symbol contains the type of the prefix structure element * in the header file. In older versions of DB, it was * int, while in newer ones it is u_int32_t. */ /* DB_Hash_t: * This symbol contains the type of the prefix structure element * in the header file. In older versions of DB, it was * int, while in newer ones it is size_t. */ /* DB_VERSION_MAJOR_CFG: * This symbol, if defined, defines the major version number of * Berkeley DB found in the header when Perl was configured. */ /* DB_VERSION_MINOR_CFG: * This symbol, if defined, defines the minor version number of * Berkeley DB found in the header when Perl was configured. * For DB version 1 this is always 0. */ /* DB_VERSION_PATCH_CFG: * This symbol, if defined, defines the patch version number of * Berkeley DB found in the header when Perl was configured. * For DB version 1 this is always 0. */ #define DB_Hash_t u_int32_t /**/ #define DB_Prefix_t size_t /**/ #define DB_VERSION_MAJOR_CFG /**/ #define DB_VERSION_MINOR_CFG /**/ #define DB_VERSION_PATCH_CFG /**/ /* I_FP_CLASS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_FP_CLASS / **/ /* I_GRP: * This symbol, if defined, indicates to the C program that it should * include . */ /* GRPASSWD: * This symbol, if defined, indicates to the C program that struct group * in contains gr_passwd. */ #define I_GRP /**/ /*#define GRPASSWD / **/ /* I_IEEEFP: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_IEEEFP / **/ /* I_INTTYPES: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_INTTYPES /**/ /* I_LIBUTIL: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_LIBUTIL / **/ /* I_MACH_CTHREADS: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_MACH_CTHREADS / **/ /* I_MNTENT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_MNTENT / **/ /* I_NETDB: * This symbol, if defined, indicates that exists and * should be included. */ #define I_NETDB /**/ /* I_NETINET_TCP: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_NETINET_TCP /**/ /* I_POLL: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_POLL / **/ /* I_PROT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_PROT / **/ /* I_PTHREAD: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_PTHREAD / **/ /* I_PWD: * This symbol, if defined, indicates to the C program that it should * include . */ /* PWQUOTA: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_quota. */ /* PWAGE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_age. */ /* PWCHANGE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_change. */ /* PWCLASS: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_class. */ /* PWEXPIRE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_expire. */ /* PWCOMMENT: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_comment. */ /* PWGECOS: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_gecos. */ /* PWPASSWD: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_passwd. */ #define I_PWD /**/ /*#define PWQUOTA / **/ /*#define PWAGE / **/ /*#define PWCHANGE / **/ /*#define PWCLASS / **/ /*#define PWEXPIRE / **/ /*#define PWCOMMENT / **/ /*#define PWGECOS / **/ /*#define PWPASSWD / **/ /* I_SHADOW: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SHADOW / **/ /* I_SOCKS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SOCKS / **/ /* I_SUNMATH: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SUNMATH / **/ /* I_SYSLOG: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSLOG / **/ /* I_SYSMODE: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSMODE / **/ /* I_SYS_MOUNT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYS_MOUNT / **/ /* I_SYS_STATFS: * This symbol, if defined, indicates that exists. */ /*#define I_SYS_STATFS / **/ /* I_SYS_STATVFS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYS_STATVFS / **/ /* I_SYSUIO: * This symbol, if defined, indicates that exists and * should be included. */ #define I_SYSUIO /**/ /* I_SYSUTSNAME: * This symbol, if defined, indicates that exists and * should be included. */ #define I_SYSUTSNAME /**/ /* I_SYS_VFS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYS_VFS / **/ /* I_TIME: * This symbol, if defined, indicates to the C program that it should * include . */ /* I_SYS_TIME: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_TIME /**/ /* I_SYS_TIME_KERNEL: * This symbol, if defined, indicates to the C program that it should * include with KERNEL defined. */ /* HAS_TM_TM_ZONE: * This symbol, if defined, indicates to the C program that * the struct tm has a tm_zone field. */ #define I_TIME /**/ /*#define I_SYS_TIME / **/ /*#define I_SYS_TIME_KERNEL / **/ /*#define HAS_TM_TM_ZONE / **/ /* I_USTAT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_USTAT / **/ /* PERL_INC_VERSION_LIST: * This variable specifies the list of subdirectories in over * which perl.c:incpush() and lib/lib.pm will automatically * search when adding directories to @INC, in a format suitable * for a C initialization string. See the inc_version_list entry * in Porting/Glossary for more details. */ #define PERL_INC_VERSION_LIST 0 /**/ /* INSTALL_USR_BIN_PERL: * This symbol, if defined, indicates that Perl is to be installed * also as /usr/bin/perl. */ /*#define INSTALL_USR_BIN_PERL / **/ /* PERL_PRIfldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'f') for output. */ /* PERL_PRIgldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'g') for output. */ /* PERL_PRIeldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'e') for output. */ /* PERL_SCNfldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'f') for input. */ #define PERL_PRIfldbl "f" /**/ #define PERL_PRIgldbl "g" /**/ #define PERL_PRIeldbl "e" /**/ #define PERL_SCNfldbl "f" /**/ /* Off_t: * This symbol holds the type used to declare offsets in the kernel. * It can be int, long, off_t, etc... It may be necessary to include * to get any typedef'ed information. */ /* LSEEKSIZE: * This symbol holds the number of bytes used by the Off_t. */ /* Off_t_size: * This symbol holds the number of bytes used by the Off_t. */ #define Off_t off_t /* type */ #define LSEEKSIZE 8 /* size */ #define Off_t_size 8 /* size */ /* Free_t: * This variable contains the return type of free(). It is usually * void, but occasionally int. */ /* Malloc_t: * This symbol is the type of pointer returned by malloc and realloc. */ #define Malloc_t void * /**/ #define Free_t void /**/ /* MYMALLOC: * This symbol, if defined, indicates that we're using our own malloc. */ #define MYMALLOC /**/ /* Mode_t: * This symbol holds the type used to declare file modes * for systems calls. It is usually mode_t, but may be * int or unsigned short. It may be necessary to include * to get any typedef'ed information. */ #define Mode_t mode_t /* file mode parameter for system calls */ /* VAL_O_NONBLOCK: * This symbol is to be used during open() or fcntl(F_SETFL) to turn on * non-blocking I/O for the file descriptor. Note that there is no way * back, i.e. you cannot turn it blocking again this way. If you wish to * alternatively switch between blocking and non-blocking, use the * ioctl(FIOSNBIO) call instead, but that is not supported by all devices. */ /* VAL_EAGAIN: * This symbol holds the errno error code set by read() when no data was * present on the non-blocking file descriptor. */ /* RD_NODATA: * This symbol holds the return code from read() when no data is present * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is * not defined, then you can't distinguish between no data and EOF by * issuing a read(). You'll have to find another way to tell for sure! */ /* EOF_NONBLOCK: * This symbol, if defined, indicates to the C program that a read() on * a non-blocking file descriptor will return 0 on EOF, and not the value * held in RD_NODATA (-1 usually, in that case!). */ #define VAL_O_NONBLOCK O_NONBLOCK #define VAL_EAGAIN EAGAIN #define RD_NODATA -1 #define EOF_NONBLOCK /* NEED_VA_COPY: * This symbol, if defined, indicates that the system stores * the variable argument list datatype, va_list, in a format * that cannot be copied by simple assignment, so that some * other means must be used when copying is required. * As such systems vary in their provision (or non-provision) * of copying mechanisms, handy.h defines a platform- * independent macro, Perl_va_copy(src, dst), to do the job. */ /*#define NEED_VA_COPY / **/ /* Netdb_host_t: * This symbol holds the type used for the 1st argument * to gethostbyaddr(). */ /* Netdb_hlen_t: * This symbol holds the type used for the 2nd argument * to gethostbyaddr(). */ /* Netdb_name_t: * This symbol holds the type used for the argument to * gethostbyname(). */ /* Netdb_net_t: * This symbol holds the type used for the 1st argument to * getnetbyaddr(). */ #define Netdb_host_t char * /**/ #define Netdb_hlen_t size_t /**/ #define Netdb_name_t char * /**/ #define Netdb_net_t long /**/ /* PERL_OTHERLIBDIRS: * This variable contains a colon-separated set of paths for the perl * binary to search for additional library files or modules. * These directories will be tacked to the end of @INC. * Perl will automatically search below each path for version- * and architecture-specific directories. See PERL_INC_VERSION_LIST * for more details. */ /*#define PERL_OTHERLIBDIRS " " / **/ /* IVTYPE: * This symbol defines the C type used for Perl's IV. */ /* UVTYPE: * This symbol defines the C type used for Perl's UV. */ /* I8TYPE: * This symbol defines the C type used for Perl's I8. */ /* U8TYPE: * This symbol defines the C type used for Perl's U8. */ /* I16TYPE: * This symbol defines the C type used for Perl's I16. */ /* U16TYPE: * This symbol defines the C type used for Perl's U16. */ /* I32TYPE: * This symbol defines the C type used for Perl's I32. */ /* U32TYPE: * This symbol defines the C type used for Perl's U32. */ /* I64TYPE: * This symbol defines the C type used for Perl's I64. */ /* U64TYPE: * This symbol defines the C type used for Perl's U64. */ /* NVTYPE: * This symbol defines the C type used for Perl's NV. */ /* IVSIZE: * This symbol contains the sizeof(IV). */ /* UVSIZE: * This symbol contains the sizeof(UV). */ /* I8SIZE: * This symbol contains the sizeof(I8). */ /* U8SIZE: * This symbol contains the sizeof(U8). */ /* I16SIZE: * This symbol contains the sizeof(I16). */ /* U16SIZE: * This symbol contains the sizeof(U16). */ /* I32SIZE: * This symbol contains the sizeof(I32). */ /* U32SIZE: * This symbol contains the sizeof(U32). */ /* I64SIZE: * This symbol contains the sizeof(I64). */ /* U64SIZE: * This symbol contains the sizeof(U64). */ /* NVSIZE: * This symbol contains the sizeof(NV). */ /* NV_PRESERVES_UV: * This symbol, if defined, indicates that a variable of type NVTYPE * can preserve all the bits of a variable of type UVTYPE. */ /* NV_PRESERVES_UV_BITS: * This symbol contains the number of bits a variable of type NVTYPE * can preserve of a variable of type UVTYPE. */ #define IVTYPE long /**/ #define UVTYPE unsigned long /**/ #define I8TYPE char /**/ #define U8TYPE unsigned char /**/ #define I16TYPE short /**/ #define U16TYPE unsigned short /**/ #define I32TYPE long /**/ #define U32TYPE unsigned long /**/ #ifdef HAS_QUAD #define I64TYPE long long /**/ #define U64TYPE unsigned long long /**/ #endif #define NVTYPE double /**/ #define IVSIZE 4 /**/ #define UVSIZE 4 /**/ #define I8SIZE 1 /**/ #define U8SIZE 1 /**/ #define I16SIZE 2 /**/ #define U16SIZE 2 /**/ #define I32SIZE 4 /**/ #define U32SIZE 4 /**/ #ifdef HAS_QUAD #define I64SIZE 8 /**/ #define U64SIZE 8 /**/ #endif #define NVSIZE 8 /**/ #undef NV_PRESERVES_UV #define NV_PRESERVES_UV_BITS 31 /* IVdf: * This symbol defines the format string used for printing a Perl IV * as a signed decimal integer. */ /* UVuf: * This symbol defines the format string used for printing a Perl UV * as an unsigned decimal integer. */ /* UVof: * This symbol defines the format string used for printing a Perl UV * as an unsigned octal integer. */ /* UVxf: * This symbol defines the format string used for printing a Perl UV * as an unsigned hexadecimal integer in lowercase abcdef. */ /* UVXf: * This symbol defines the format string used for printing a Perl UV * as an unsigned hexadecimal integer in uppercase ABCDEF. */ /* NVef: * This symbol defines the format string used for printing a Perl NV * using %e-ish floating point format. */ /* NVff: * This symbol defines the format string used for printing a Perl NV * using %f-ish floating point format. */ /* NVgf: * This symbol defines the format string used for printing a Perl NV * using %g-ish floating point format. */ #define IVdf "ld" /**/ #define UVuf "lu" /**/ #define UVof "lo" /**/ #define UVxf "lx" /**/ #define UVXf "lX" /**/ #define NVef "e" /**/ #define NVff "f" /**/ #define NVgf "g" /**/ /* Pid_t: * This symbol holds the type used to declare process ids in the kernel. * It can be int, uint, pid_t, etc... It may be necessary to include * to get any typedef'ed information. */ #define Pid_t pid_t /* PID type */ /* PRIVLIB: * This symbol contains the name of the private library for this package. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. The program * should be prepared to do ~ expansion. */ /* PRIVLIB_EXP: * This symbol contains the ~name expanded version of PRIVLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ #define PRIVLIB "/sys/lib/perl/5.8.0" /**/ #define PRIVLIB_EXP "/sys/lib/perl/5.8.0" /**/ /* PTRSIZE: * This symbol contains the size of a pointer, so that the C preprocessor * can make decisions based on it. It will be sizeof(void *) if * the compiler supports (void *); otherwise it will be * sizeof(char *). */ #define PTRSIZE 4 /**/ /* Drand01: * This macro is to be used to generate uniformly distributed * random numbers over the range [0., 1.[. You may have to supply * an 'extern double drand48();' in your program since SunOS 4.1.3 * doesn't provide you with anything relevant in its headers. * See HAS_DRAND48_PROTO. */ /* Rand_seed_t: * This symbol defines the type of the argument of the * random seed function. */ /* seedDrand01: * This symbol defines the macro to be used in seeding the * random number generator (see Drand01). */ /* RANDBITS: * This symbol indicates how many bits are produced by the * function used to generate normalized random numbers. * Values include 15, 16, 31, and 48. */ #define Drand01() (rand() / (double) ((unsigned long)1 << 15)) /**/ #define Rand_seed_t unsigned /**/ #define seedDrand01(x) srand((Rand_seed_t)x) /**/ #define RANDBITS 15 /**/ /* SELECT_MIN_BITS: * This symbol holds the minimum number of bits operated by select. * That is, if you do select(n, ...), how many bits at least will be * cleared in the masks if some activity is detected. Usually this * is either n or 32*ceil(n/32), especially many little-endians do * the latter. This is only useful if you have select(), naturally. */ #define SELECT_MIN_BITS 32 /**/ /* Select_fd_set_t: * This symbol holds the type used for the 2nd, 3rd, and 4th * arguments to select. Usually, this is 'fd_set *', if HAS_FD_SET * is defined, and 'int *' otherwise. This is only useful if you * have select(), of course. */ #define Select_fd_set_t fd_set* /**/ /* SIG_NAME: * This symbol contains a list of signal names in order of * signal number. This is intended * to be used as a static array initialization, like this: * char *sig_name[] = { SIG_NAME }; * The signals in the list are separated with commas, and each signal * is surrounded by double quotes. There is no leading SIG in the signal * name, i.e. SIGQUIT is known as "QUIT". * Gaps in the signal numbers (up to NSIG) are filled in with NUMnn, * etc., where nn is the actual signal number (e.g. NUM37). * The signal number for sig_name[i] is stored in sig_num[i]. * The last element is 0 to terminate the list with a NULL. This * corresponds to the 0 at the end of the sig_num list. */ /* SIG_NUM: * This symbol contains a list of signal numbers, in the same order as the * SIG_NAME list. It is suitable for static array initialization, as in: * int sig_num[] = { SIG_NUM }; * The signals in the list are separated with commas, and the indices * within that list and the SIG_NAME list match, so it's easy to compute * the signal name from a number or vice versa at the price of a small * dynamic linear lookup. * Duplicates are allowed, but are moved to the end of the list. * The signal number corresponding to sig_name[i] is sig_number[i]. * if (i < NSIG) then sig_number[i] == i. * The last element is 0, corresponding to the 0 at the end of * the sig_name list. */ /* SIG_SIZE: * This variable contains the number of elements of the SIG_NAME * and SIG_NUM arrays, excluding the final NULL entry. */ #define SIG_NAME "ZERO", "HUP", "INT", "QUIT", "ILL", "ABRT", "FPE", "KILL", "SEGV", "PIPE", "ALRM", "TERM", "USR1", "USR2", "BUS", "CHLD", "CONT", "STOP", "TSTP", "TTIN", "TTOU", "NUM21", "NUM22", "NUM23", "NUM24", "NUM25", "NUM26", "NUM27", "NUM28", "NUM29", "NUM30", "NUM31", "NUM32", "NUM33", "NUM34", "NUM35", "NUM36", "NUM37", "NUM38", "NUM39", "NUM40", "NUM41", "NUM42", "NUM43", "NUM44", "NUM45", "NUM46", "NUM47", "NUM48", "NUM49", 0 /**/ #define SIG_NUM 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 0 /**/ #define SIG_SIZE 50 /**/ /* SITEARCH: * This symbol contains the name of the private library for this package. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. The program * should be prepared to do ~ expansion. * The standard distribution will put nothing in this directory. * After perl has been installed, users may install their own local * architecture-dependent modules in this directory with * MakeMaker Makefile.PL * or equivalent. See INSTALL for details. */ /* SITEARCH_EXP: * This symbol contains the ~name expanded version of SITEARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ #define SITEARCH "/sys/lib/perl/5.8.0/site_perl/386" /**/ #define SITEARCH_EXP "/sys/lib/perl/site_perl/386" /**/ /* SITELIB: * This symbol contains the name of the private library for this package. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. The program * should be prepared to do ~ expansion. * The standard distribution will put nothing in this directory. * After perl has been installed, users may install their own local * architecture-independent modules in this directory with * MakeMaker Makefile.PL * or equivalent. See INSTALL for details. */ /* SITELIB_EXP: * This symbol contains the ~name expanded version of SITELIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ /* SITELIB_STEM: * This define is SITELIB_EXP with any trailing version-specific component * removed. The elements in inc_version_list (inc_version_list.U) can * be tacked onto this variable to generate a list of directories to search. */ #define SITELIB "/sys/lib/perl/5.8.0/site_perl" /**/ #define SITELIB_EXP "/sys/lib/perl/5.8.0/site_perl" /**/ #define SITELIB_STEM "/sys/lib/perl/5.8.0/site_perl" /**/ /* Size_t_size: * This symbol holds the size of a Size_t in bytes. */ #define Size_t_size 4 /* */ /* Size_t: * This symbol holds the type used to declare length parameters * for string functions. It is usually size_t, but may be * unsigned long, int, etc. It may be necessary to include * to get any typedef'ed information. */ #define Size_t size_t /* length paramater for string functions */ /* Sock_size_t: * This symbol holds the type used for the size argument of * various socket calls (just the base type, not the pointer-to). */ #define Sock_size_t int /**/ /* SSize_t: * This symbol holds the type used by functions that return * a count of bytes or an error condition. It must be a signed type. * It is usually ssize_t, but may be long or int, etc. * It may be necessary to include or * to get any typedef'ed information. * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t). */ #define SSize_t ssize_t /* signed count of bytes */ /* STARTPERL: * This variable contains the string to put in front of a perl * script to make sure (one hopes) that it runs with perl and not * some shell. */ #define STARTPERL "#!/bin/perl" /**/ /* STDCHAR: * This symbol is defined to be the type of char used in stdio.h. * It has the values "unsigned char" or "char". */ #define STDCHAR char /**/ /* HAS_STDIO_STREAM_ARRAY: * This symbol, if defined, tells that there is an array * holding the stdio streams. */ /* STDIO_STREAM_ARRAY: * This symbol tells the name of the array holding the stdio streams. * Usual values include _iob, __iob, and __sF. */ /*#define HAS_STDIO_STREAM_ARRAY / **/ #define STDIO_STREAM_ARRAY /* Uid_t_f: * This symbol defines the format string used for printing a Uid_t. */ #define Uid_t_f "hd" /**/ /* Uid_t_sign: * This symbol holds the signedess of a Uid_t. * 1 for unsigned, -1 for signed. */ #define Uid_t_sign -1 /* UID sign */ /* Uid_t_size: * This symbol holds the size of a Uid_t in bytes. */ #define Uid_t_size 2 /* UID size */ /* Uid_t: * This symbol holds the type used to declare user ids in the kernel. * It can be int, ushort, uid_t, etc... It may be necessary to include * to get any typedef'ed information. */ #define Uid_t uid_t /* UID type */ /* USE_64_BIT_INT: * This symbol, if defined, indicates that 64-bit integers should * be used when available. If not defined, the native integers * will be employed (be they 32 or 64 bits). The minimal possible * 64-bitness is used, just enough to get 64-bit integers into Perl. * This may mean using for example "long longs", while your memory * may still be limited to 2 gigabytes. */ /* USE_64_BIT_ALL: * This symbol, if defined, indicates that 64-bit integers should * be used when available. If not defined, the native integers * will be used (be they 32 or 64 bits). The maximal possible * 64-bitness is employed: LP64 or ILP64, meaning that you will * be able to use more than 2 gigabytes of memory. This mode is * even more binary incompatible than USE_64_BIT_INT. You may not * be able to run the resulting executable in a 32-bit CPU at all or * you may need at least to reboot your OS to 64-bit mode. */ #ifndef USE_64_BIT_INT /*#define USE_64_BIT_INT / **/ #endif #ifndef USE_64_BIT_ALL /*#define USE_64_BIT_ALL / **/ #endif /* USE_FAST_STDIO: * This symbol, if defined, indicates that Perl should * be built to use 'fast stdio'. * Defaults to define in Perls 5.8 and earlier, to undef later. */ #ifndef USE_FAST_STDIO /*#define USE_FAST_STDIO / **/ #endif /* USE_LARGE_FILES: * This symbol, if defined, indicates that large file support * should be used when available. */ #ifndef USE_LARGE_FILES #define USE_LARGE_FILES /**/ #endif /* USE_LONG_DOUBLE: * This symbol, if defined, indicates that long doubles should * be used when available. */ #ifndef USE_LONG_DOUBLE /*#define USE_LONG_DOUBLE / **/ #endif /* USE_MORE_BITS: * This symbol, if defined, indicates that 64-bit interfaces and * long doubles should be used when available. */ #ifndef USE_MORE_BITS /*#define USE_MORE_BITS / **/ #endif /* MULTIPLICITY: * This symbol, if defined, indicates that Perl should * be built to use multiplicity. */ #ifndef MULTIPLICITY /*#define MULTIPLICITY / **/ #endif /* USE_PERLIO: * This symbol, if defined, indicates that the PerlIO abstraction should * be used throughout. If not defined, stdio should be * used in a fully backward compatible manner. */ #ifndef USE_PERLIO #define USE_PERLIO /**/ #endif /* USE_SOCKS: * This symbol, if defined, indicates that Perl should * be built to use socks. */ #ifndef USE_SOCKS /*#define USE_SOCKS / **/ #endif /* USE_ITHREADS: * This symbol, if defined, indicates that Perl should be built to * use the interpreter-based threading implementation. */ /* USE_5005THREADS: * This symbol, if defined, indicates that Perl should be built to * use the 5.005-based threading implementation. */ /* OLD_PTHREADS_API: * This symbol, if defined, indicates that Perl should * be built to use the old draft POSIX threads API. */ /* USE_REENTRANT_API: * This symbol, if defined, indicates that Perl should * try to use the various _r versions of library functions. * This is extremely experimental. */ /*#define USE_5005THREADS / **/ /*#define USE_ITHREADS / **/ #if defined(USE_5005THREADS) && !defined(USE_ITHREADS) #define USE_THREADS /* until src is revised*/ #endif /*#define OLD_PTHREADS_API / **/ /*#define USE_REENTRANT_API / **/ /* PERL_VENDORARCH: * If defined, this symbol contains the name of a private library. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. * It may have a ~ on the front. * The standard distribution will put nothing in this directory. * Vendors who distribute perl may wish to place their own * architecture-dependent modules and extensions in this directory with * MakeMaker Makefile.PL INSTALLDIRS=vendor * or equivalent. See INSTALL for details. */ /* PERL_VENDORARCH_EXP: * This symbol contains the ~name expanded version of PERL_VENDORARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ /*#define PERL_VENDORARCH "" / **/ /*#define PERL_VENDORARCH_EXP "" / **/ /* PERL_VENDORLIB_EXP: * This symbol contains the ~name expanded version of VENDORLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ /* PERL_VENDORLIB_STEM: * This define is PERL_VENDORLIB_EXP with any trailing version-specific component * removed. The elements in inc_version_list (inc_version_list.U) can * be tacked onto this variable to generate a list of directories to search. */ /*#define PERL_VENDORLIB_EXP "" / **/ /*#define PERL_VENDORLIB_STEM "" / **/ /* VOIDFLAGS: * This symbol indicates how much support of the void type is given by this * compiler. What various bits mean: * * 1 = supports declaration of void * 2 = supports arrays of pointers to functions returning void * 4 = supports comparisons between pointers to void functions and * addresses of void functions * 8 = suports declaration of generic void pointers * * The package designer should define VOIDUSED to indicate the requirements * of the package. This can be done either by #defining VOIDUSED before * including config.h, or by defining defvoidused in Myinit.U. If the * latter approach is taken, only those flags will be tested. If the * level of void support necessary is not present, defines void to int. */ #ifndef VOIDUSED #define VOIDUSED 15 #endif #define VOIDFLAGS 15 #if (VOIDFLAGS & VOIDUSED) != VOIDUSED #define void int /* is void to be avoided? */ #define M_VOID /* Xenix strikes again */ #endif /* HAS_CRYPT: * This symbol, if defined, indicates that the crypt routine is available * to encrypt passwords and the like. */ /*#define HAS_CRYPT / **/ /* SETUID_SCRIPTS_ARE_SECURE_NOW: * This symbol, if defined, indicates that the bug that prevents * setuid scripts from being secure is not present in this kernel. */ /* DOSUID: * This symbol, if defined, indicates that the C program should * check the script that it is executing for setuid/setgid bits, and * attempt to emulate setuid/setgid on systems that have disabled * setuid #! scripts because the kernel can't do it securely. * It is up to the package designer to make sure that this emulation * is done securely. Among other things, it should do an fstat on * the script it just opened to make sure it really is a setuid/setgid * script, it should make sure the arguments passed correspond exactly * to the argument on the #! line, and it should not trust any * subprocesses to which it must pass the filename rather than the * file descriptor of the script to be executed. */ /*#define SETUID_SCRIPTS_ARE_SECURE_NOW / **/ /*#define DOSUID / **/ /* Shmat_t: * This symbol holds the return type of the shmat() system call. * Usually set to 'void *' or 'char *'. */ /* HAS_SHMAT_PROTOTYPE: * This symbol, if defined, indicates that the sys/shm.h includes * a prototype for shmat(). Otherwise, it is up to the program to * guess one. Shmat_t shmat(int, Shmat_t, int) is a good guess, * but not always right so it should be emitted by the program only * when HAS_SHMAT_PROTOTYPE is not defined to avoid conflicting defs. */ #define Shmat_t /**/ /*#define HAS_SHMAT_PROTOTYPE / **/ /* I_NDBM: * This symbol, if defined, indicates that exists and should * be included. */ /*#define I_NDBM / **/ /* I_STDARG: * This symbol, if defined, indicates that exists and should * be included. */ /* I_VARARGS: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_STDARG /**/ /*#define I_VARARGS / **/ /* CAN_PROTOTYPE: * If defined, this macro indicates that the C compiler can handle * function prototypes. */ /* _: * This macro is used to declare function parameters for folks who want * to make declarations with prototypes using a different style than * the above macros. Use double parentheses. For example: * * int main _((int argc, char *argv[])); */ #define CAN_PROTOTYPE /**/ #ifdef CAN_PROTOTYPE #define _(args) args #else #define _(args) () #endif /* SH_PATH: * This symbol contains the full pathname to the shell used on this * on this system to execute Bourne shell scripts. Usually, this will be * /bin/sh, though it's possible that some systems will have /bin/ksh, * /bin/pdksh, /bin/ash, /bin/bash, or even something such as * D:/bin/sh.exe. */ #define SH_PATH "/bin/sh" /**/ /* USE_CROSS_COMPILE: * This symbol, if defined, indicates that Perl is being cross-compiled. */ /* PERL_TARGETARCH: * This symbol, if defined, indicates the target architecture * Perl has been cross-compiled to. Undefined if not a cross-compile. */ #ifndef USE_CROSS_COMPILE /*#define USE_CROSS_COMPILE / **/ #define PERL_TARGETARCH "" /**/ #endif /* HAS_COPYSIGNL: * This symbol, if defined, indicates that the copysignl routine is * available. If aintl is also present we can emulate modfl. */ /*#define HAS_COPYSIGNL /**/ /* USE_CPLUSPLUS: * This symbol, if defined, indicates that a C++ compiler was * used to compiled Perl and will be used to compile extensions. */ /*#define USE_CPLUSPLUS /**/ /* HAS_DBMINIT_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the dbminit() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int dbminit(char *); */ /*#define HAS_DBMINIT_PROTO / **/ /* HAS_DIRFD: * This manifest constant lets the C program know that dirfd * is available. */ /*#define HAS_DIRFD / **/ /* HAS_FLOCK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the flock() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int flock(int, int); */ /*#define HAS_FLOCK_PROTO / **/ /* HAS_FPCLASSL: * This symbol, if defined, indicates that the fpclassl routine is * available to classify long doubles. Available for example in IRIX. * The returned values are defined in and are: * * FP_SNAN signaling NaN * FP_QNAN quiet NaN * FP_NINF negative infinity * FP_PINF positive infinity * FP_NDENORM negative denormalized non-zero * FP_PDENORM positive denormalized non-zero * FP_NZERO negative zero * FP_PZERO positive zero * FP_NNORM negative normalized non-zero * FP_PNORM positive normalized non-zero */ /*#define HAS_FPCLASSL / **/ /* HAS_NL_LANGINFO: * This symbol, if defined, indicates that the nl_langinfo routine is * available to return local data. You will also need * and therefore I_LANGINFO. */ /*#define HAS_NL_LANGINFO / **/ /* HAS_PROCSELFEXE: * This symbol is defined if PROCSELFEXE_PATH is a symlink * to the absolute pathname of the executing program. */ /* PROCSELFEXE_PATH: * If HAS_PROCSELFEXE is defined this symbol is the filename * of the symbolic link pointing to the absolute pathname of * the executing program. */ /*#define HAS_PROCSELFEXE / **/ #if defined(HAS_PROCSELFEXE) && !defined(PROCSELFEXE_PATH) #define PROCSELFEXE_PATH /**/ #endif /* HAS_PTHREAD_ATTR_SETSCOPE: * This symbol, if defined, indicates that the pthread_attr_setscope * system call is available to set the contention scope attribute of * a thread attribute object. */ /*#define HAS_PTHREAD_ATTR_SETSCOPE / **/ /* HAS_SIGPROCMASK: * This symbol, if defined, indicates that the sigprocmask * system call is available to examine or change the signal mask * of the calling process. */ #define HAS_SIGPROCMASK /**/ /* HAS_SOCKATMARK: * This symbol, if defined, indicates that the sockatmark routine is * available to test whether a socket is at the out-of-band mark. */ /*#define HAS_SOCKATMARK / **/ /* HAS_SOCKATMARK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the sockatmark() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int sockatmark(int); */ /*#define HAS_SOCKATMARK_PROTO / **/ /* HAS_SETRESGID_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the setresgid() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern int setresgid(uid_t ruid, uid_t euid, uid_t suid); */ /*#define HAS_SETRESGID_PROTO / **/ /* HAS_SETRESUID_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the setresuid() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern int setresuid(uid_t ruid, uid_t euid, uid_t suid); */ /*#define HAS_SETRESUID_PROTO / **/ /* HAS_STRFTIME: * This symbol, if defined, indicates that the strftime routine is * available to do time formatting. */ #define HAS_STRFTIME /**/ /* HAS_STRLCAT * This symbol, if defined, indicates that the strlcat routine is * available to do string concatenation. */ /*#define HAS_STRLCAT /**/ /* HAS_STRLCPY: * This symbol, if defined, indicates that the strlcpy routine is * available to do string copying. */ /*#define HAS_STRLCPY /**/ /* HAS_SYSCALL_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the syscall() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern int syscall(int, ...); * extern int syscall(long, ...); */ /*#define HAS_SYSCALL_PROTO / **/ /* U32_ALIGNMENT_REQUIRED: * This symbol, if defined, indicates that you must access * character data through U32-aligned pointers. */ #ifndef U32_ALIGNMENT_REQUIRED #define U32_ALIGNMENT_REQUIRED /**/ #endif /* HAS_USLEEP_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the usleep() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int usleep(useconds_t); */ /*#define HAS_USLEEP_PROTO / **/ /* I_CRYPT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_CRYPT / **/ /* I_FP: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_FP / **/ /* I_LANGINFO: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_LANGINFO / **/ /* HAS_CTERMID_R: * This symbol, if defined, indicates that the ctermid_r routine * is available to ctermid re-entrantly. */ /* CTERMID_R_PROTO: * This symbol encodes the prototype of ctermid_r. * It is zero if d_ctermid_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ctermid_r * is defined. */ /*#define HAS_CTERMID_R / **/ #define CTERMID_R_PROTO 0 /**/ /* HAS_ENDHOSTENT_R: * This symbol, if defined, indicates that the endhostent_r routine * is available to endhostent re-entrantly. */ /* ENDHOSTENT_R_PROTO: * This symbol encodes the prototype of endhostent_r. * It is zero if d_endhostent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endhostent_r * is defined. */ /*#define HAS_ENDHOSTENT_R / **/ #define ENDHOSTENT_R_PROTO 0 /**/ /* HAS_ENDNETENT_R: * This symbol, if defined, indicates that the endnetent_r routine * is available to endnetent re-entrantly. */ /* ENDNETENT_R_PROTO: * This symbol encodes the prototype of endnetent_r. * It is zero if d_endnetent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endnetent_r * is defined. */ /*#define HAS_ENDNETENT_R / **/ #define ENDNETENT_R_PROTO 0 /**/ /* HAS_ENDPROTOENT_R: * This symbol, if defined, indicates that the endprotoent_r routine * is available to endprotoent re-entrantly. */ /* ENDPROTOENT_R_PROTO: * This symbol encodes the prototype of endprotoent_r. * It is zero if d_endprotoent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endprotoent_r * is defined. */ /*#define HAS_ENDPROTOENT_R / **/ #define ENDPROTOENT_R_PROTO 0 /**/ /* HAS_ENDSERVENT_R: * This symbol, if defined, indicates that the endservent_r routine * is available to endservent re-entrantly. */ /* ENDSERVENT_R_PROTO: * This symbol encodes the prototype of endservent_r. * It is zero if d_endservent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endservent_r * is defined. */ /*#define HAS_ENDSERVENT_R / **/ #define ENDSERVENT_R_PROTO 0 /**/ /* HAS_GETHOSTBYADDR_R: * This symbol, if defined, indicates that the gethostbyaddr_r routine * is available to gethostbyaddr re-entrantly. */ /* GETHOSTBYADDR_R_PROTO: * This symbol encodes the prototype of gethostbyaddr_r. * It is zero if d_gethostbyaddr_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostbyaddr_r * is defined. */ /*#define HAS_GETHOSTBYADDR_R / **/ #define GETHOSTBYADDR_R_PROTO 0 /**/ /* HAS_GETHOSTBYNAME_R: * This symbol, if defined, indicates that the gethostbyname_r routine * is available to gethostbyname re-entrantly. */ /* GETHOSTBYNAME_R_PROTO: * This symbol encodes the prototype of gethostbyname_r. * It is zero if d_gethostbyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostbyname_r * is defined. */ /*#define HAS_GETHOSTBYNAME_R / **/ #define GETHOSTBYNAME_R_PROTO 0 /**/ /* HAS_GETHOSTENT_R: * This symbol, if defined, indicates that the gethostent_r routine * is available to gethostent re-entrantly. */ /* GETHOSTENT_R_PROTO: * This symbol encodes the prototype of gethostent_r. * It is zero if d_gethostent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostent_r * is defined. */ /*#define HAS_GETHOSTENT_R / **/ #define GETHOSTENT_R_PROTO 0 /**/ /* HAS_GETNETBYADDR_R: * This symbol, if defined, indicates that the getnetbyaddr_r routine * is available to getnetbyaddr re-entrantly. */ /* GETNETBYADDR_R_PROTO: * This symbol encodes the prototype of getnetbyaddr_r. * It is zero if d_getnetbyaddr_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetbyaddr_r * is defined. */ /*#define HAS_GETNETBYADDR_R / **/ #define GETNETBYADDR_R_PROTO 0 /**/ /* HAS_GETNETBYNAME_R: * This symbol, if defined, indicates that the getnetbyname_r routine * is available to getnetbyname re-entrantly. */ /* GETNETBYNAME_R_PROTO: * This symbol encodes the prototype of getnetbyname_r. * It is zero if d_getnetbyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetbyname_r * is defined. */ /*#define HAS_GETNETBYNAME_R / **/ #define GETNETBYNAME_R_PROTO 0 /**/ /* HAS_GETNETENT_R: * This symbol, if defined, indicates that the getnetent_r routine * is available to getnetent re-entrantly. */ /* GETNETENT_R_PROTO: * This symbol encodes the prototype of getnetent_r. * It is zero if d_getnetent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetent_r * is defined. */ /*#define HAS_GETNETENT_R / **/ #define GETNETENT_R_PROTO 0 /**/ /* HAS_GETPROTOBYNAME_R: * This symbol, if defined, indicates that the getprotobyname_r routine * is available to getprotobyname re-entrantly. */ /* GETPROTOBYNAME_R_PROTO: * This symbol encodes the prototype of getprotobyname_r. * It is zero if d_getprotobyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotobyname_r * is defined. */ /*#define HAS_GETPROTOBYNAME_R / **/ #define GETPROTOBYNAME_R_PROTO 0 /**/ /* HAS_GETPROTOBYNUMBER_R: * This symbol, if defined, indicates that the getprotobynumber_r routine * is available to getprotobynumber re-entrantly. */ /* GETPROTOBYNUMBER_R_PROTO: * This symbol encodes the prototype of getprotobynumber_r. * It is zero if d_getprotobynumber_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotobynumber_r * is defined. */ /*#define HAS_GETPROTOBYNUMBER_R / **/ #define GETPROTOBYNUMBER_R_PROTO 0 /**/ /* HAS_GETPROTOENT_R: * This symbol, if defined, indicates that the getprotoent_r routine * is available to getprotoent re-entrantly. */ /* GETPROTOENT_R_PROTO: * This symbol encodes the prototype of getprotoent_r. * It is zero if d_getprotoent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotoent_r * is defined. */ /*#define HAS_GETPROTOENT_R / **/ #define GETPROTOENT_R_PROTO 0 /**/ /* HAS_GETSERVBYNAME_R: * This symbol, if defined, indicates that the getservbyname_r routine * is available to getservbyname re-entrantly. */ /* GETSERVBYNAME_R_PROTO: * This symbol encodes the prototype of getservbyname_r. * It is zero if d_getservbyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservbyname_r * is defined. */ /*#define HAS_GETSERVBYNAME_R / **/ #define GETSERVBYNAME_R_PROTO 0 /**/ /* HAS_GETSERVBYPORT_R: * This symbol, if defined, indicates that the getservbyport_r routine * is available to getservbyport re-entrantly. */ /* GETSERVBYPORT_R_PROTO: * This symbol encodes the prototype of getservbyport_r. * It is zero if d_getservbyport_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservbyport_r * is defined. */ /*#define HAS_GETSERVBYPORT_R / **/ #define GETSERVBYPORT_R_PROTO 0 /**/ /* HAS_GETSERVENT_R: * This symbol, if defined, indicates that the getservent_r routine * is available to getservent re-entrantly. */ /* GETSERVENT_R_PROTO: * This symbol encodes the prototype of getservent_r. * It is zero if d_getservent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservent_r * is defined. */ /*#define HAS_GETSERVENT_R / **/ #define GETSERVENT_R_PROTO 0 /**/ /* HAS_PTHREAD_ATFORK: * This symbol, if defined, indicates that the pthread_atfork routine * is available to setup fork handlers. */ /*#define HAS_PTHREAD_ATFORK / **/ /* HAS_READDIR64_R: * This symbol, if defined, indicates that the readdir64_r routine * is available to readdir64 re-entrantly. */ /* READDIR64_R_PROTO: * This symbol encodes the prototype of readdir64_r. * It is zero if d_readdir64_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_readdir64_r * is defined. */ /*#define HAS_READDIR64_R / **/ #define READDIR64_R_PROTO 0 /**/ /* HAS_SETHOSTENT_R: * This symbol, if defined, indicates that the sethostent_r routine * is available to sethostent re-entrantly. */ /* SETHOSTENT_R_PROTO: * This symbol encodes the prototype of sethostent_r. * It is zero if d_sethostent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_sethostent_r * is defined. */ /*#define HAS_SETHOSTENT_R / **/ #define SETHOSTENT_R_PROTO 0 /**/ /* HAS_SETLOCALE_R: * This symbol, if defined, indicates that the setlocale_r routine * is available to setlocale re-entrantly. */ /* SETLOCALE_R_PROTO: * This symbol encodes the prototype of setlocale_r. * It is zero if d_setlocale_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setlocale_r * is defined. */ /*#define HAS_SETLOCALE_R / **/ #define SETLOCALE_R_PROTO 0 /**/ /* HAS_SETNETENT_R: * This symbol, if defined, indicates that the setnetent_r routine * is available to setnetent re-entrantly. */ /* SETNETENT_R_PROTO: * This symbol encodes the prototype of setnetent_r. * It is zero if d_setnetent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setnetent_r * is defined. */ /*#define HAS_SETNETENT_R / **/ #define SETNETENT_R_PROTO 0 /**/ /* HAS_SETPROTOENT_R: * This symbol, if defined, indicates that the setprotoent_r routine * is available to setprotoent re-entrantly. */ /* SETPROTOENT_R_PROTO: * This symbol encodes the prototype of setprotoent_r. * It is zero if d_setprotoent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setprotoent_r * is defined. */ /*#define HAS_SETPROTOENT_R / **/ #define SETPROTOENT_R_PROTO 0 /**/ /* HAS_SETSERVENT_R: * This symbol, if defined, indicates that the setservent_r routine * is available to setservent re-entrantly. */ /* SETSERVENT_R_PROTO: * This symbol encodes the prototype of setservent_r. * It is zero if d_setservent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setservent_r * is defined. */ /*#define HAS_SETSERVENT_R / **/ #define SETSERVENT_R_PROTO 0 /**/ /* HAS_TTYNAME_R: * This symbol, if defined, indicates that the ttyname_r routine * is available to ttyname re-entrantly. */ /* TTYNAME_R_PROTO: * This symbol encodes the prototype of ttyname_r. * It is zero if d_ttyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ttyname_r * is defined. */ /*#define HAS_TTYNAME_R / **/ #define TTYNAME_R_PROTO 0 /**/ #endif perl-5.12.0-RC0/plan9/myconfig.plan90000444000175000017500000000255611143650500015733 0ustar jessejesse#!/bin/rc # This script is designed to provide a handy summary of the configuration # information being used to build perl. This is especially useful if you # are requesting help from comp.lang.perl.misc on usenet or via mail. #This script is the "myconfig" script altered to run on Plan 9. #Last Modified: 28-Jun-96 Luther Huffman lutherh@stratcom.com . config.sh # Note that the text lines /^Summary of/ .. /^\s*$/ are copied into Config.pm. # XXX Add d_sigaction (?) once it's defined. $spitshell<. */ #ifndef PERL_REENTR_API # if defined(PERL_CORE) || defined(PERL_EXT) # define PERL_REENTR_API 1 # else # define PERL_REENTR_API 0 # endif #endif #ifdef USE_REENTRANT_API /* Deprecations: some platforms have the said reentrant interfaces * but they are declared obsolete and are not to be used. Often this * means that the platform has threadsafed the interfaces (hopefully). * All this is OS version dependent, so we are of course fooling ourselves. * If you know of more deprecations on some platforms, please add your own * (by editing reentr.pl, mind!) */ #ifdef __hpux # undef HAS_CRYPT_R # undef HAS_DRAND48_R # undef HAS_ENDGRENT_R # undef HAS_ENDPWENT_R # undef HAS_GETGRENT_R # undef HAS_GETPWENT_R # undef HAS_SETLOCALE_R # undef HAS_SRAND48_R # undef HAS_STRERROR_R # define NETDB_R_OBSOLETE #endif #if defined(__osf__) && defined(__alpha) /* Tru64 aka Digital UNIX */ # undef HAS_CRYPT_R # undef HAS_STRERROR_R # define NETDB_R_OBSOLETE #endif /* * As of OpenBSD 3.7, reentrant functions are now working, they just are * incompatible with everyone else. To make OpenBSD happy, we have to * memzero out certain structures before calling the functions. */ #if defined(__OpenBSD__) # define REENTR_MEMZERO(a,b) memzero(a,b) #else # define REENTR_MEMZERO(a,b) 0 #endif #ifdef NETDB_R_OBSOLETE # undef HAS_ENDHOSTENT_R # undef HAS_ENDNETENT_R # undef HAS_ENDPROTOENT_R # undef HAS_ENDSERVENT_R # undef HAS_GETHOSTBYADDR_R # undef HAS_GETHOSTBYNAME_R # undef HAS_GETHOSTENT_R # undef HAS_GETNETBYADDR_R # undef HAS_GETNETBYNAME_R # undef HAS_GETNETENT_R # undef HAS_GETPROTOBYNAME_R # undef HAS_GETPROTOBYNUMBER_R # undef HAS_GETPROTOENT_R # undef HAS_GETSERVBYNAME_R # undef HAS_GETSERVBYPORT_R # undef HAS_GETSERVENT_R # undef HAS_SETHOSTENT_R # undef HAS_SETNETENT_R # undef HAS_SETPROTOENT_R # undef HAS_SETSERVENT_R #endif #ifdef I_PWD # include #endif #ifdef I_GRP # include #endif #ifdef I_NETDB # include #endif #ifdef I_STDLIB # include /* drand48_data */ #endif #ifdef I_CRYPT # ifdef I_CRYPT # include # endif #endif #ifdef HAS_GETSPNAM_R # ifdef I_SHADOW # include # endif #endif #define REENTRANT_PROTO_B_B 1 #define REENTRANT_PROTO_B_BI 2 #define REENTRANT_PROTO_B_BW 3 #define REENTRANT_PROTO_B_CCD 4 #define REENTRANT_PROTO_B_CCS 5 #define REENTRANT_PROTO_B_IBI 6 #define REENTRANT_PROTO_B_IBW 7 #define REENTRANT_PROTO_B_SB 8 #define REENTRANT_PROTO_B_SBI 9 #define REENTRANT_PROTO_I_BI 10 #define REENTRANT_PROTO_I_BW 11 #define REENTRANT_PROTO_I_CCSBWR 12 #define REENTRANT_PROTO_I_CCSD 13 #define REENTRANT_PROTO_I_CII 14 #define REENTRANT_PROTO_I_CIISD 15 #define REENTRANT_PROTO_I_CSBI 16 #define REENTRANT_PROTO_I_CSBIR 17 #define REENTRANT_PROTO_I_CSBWR 18 #define REENTRANT_PROTO_I_CSBWRE 19 #define REENTRANT_PROTO_I_CSD 20 #define REENTRANT_PROTO_I_CWISBWRE 21 #define REENTRANT_PROTO_I_CWISD 22 #define REENTRANT_PROTO_I_D 23 #define REENTRANT_PROTO_I_H 24 #define REENTRANT_PROTO_I_IBI 25 #define REENTRANT_PROTO_I_IBW 26 #define REENTRANT_PROTO_I_ICBI 27 #define REENTRANT_PROTO_I_ICSBWR 28 #define REENTRANT_PROTO_I_ICSD 29 #define REENTRANT_PROTO_I_ID 30 #define REENTRANT_PROTO_I_IISD 31 #define REENTRANT_PROTO_I_ISBWR 32 #define REENTRANT_PROTO_I_ISD 33 #define REENTRANT_PROTO_I_LISBI 34 #define REENTRANT_PROTO_I_LISD 35 #define REENTRANT_PROTO_I_LS 36 #define REENTRANT_PROTO_I_SB 37 #define REENTRANT_PROTO_I_SBI 38 #define REENTRANT_PROTO_I_SBIE 39 #define REENTRANT_PROTO_I_SBIH 40 #define REENTRANT_PROTO_I_SBIR 41 #define REENTRANT_PROTO_I_SBWR 42 #define REENTRANT_PROTO_I_SBWRE 43 #define REENTRANT_PROTO_I_SD 44 #define REENTRANT_PROTO_I_ST 45 #define REENTRANT_PROTO_I_St 46 #define REENTRANT_PROTO_I_TISD 47 #define REENTRANT_PROTO_I_TS 48 #define REENTRANT_PROTO_I_TSBI 49 #define REENTRANT_PROTO_I_TSBIR 50 #define REENTRANT_PROTO_I_TSBWR 51 #define REENTRANT_PROTO_I_TSR 52 #define REENTRANT_PROTO_I_TsISBWRE 53 #define REENTRANT_PROTO_I_UISBWRE 54 #define REENTRANT_PROTO_I_iS 55 #define REENTRANT_PROTO_I_lS 56 #define REENTRANT_PROTO_I_uISBWRE 57 #define REENTRANT_PROTO_S_CBI 58 #define REENTRANT_PROTO_S_CCSBI 59 #define REENTRANT_PROTO_S_CIISBIE 60 #define REENTRANT_PROTO_S_CSBI 61 #define REENTRANT_PROTO_S_CSBIE 62 #define REENTRANT_PROTO_S_CWISBIE 63 #define REENTRANT_PROTO_S_CWISBWIE 64 #define REENTRANT_PROTO_S_ICSBI 65 #define REENTRANT_PROTO_S_ISBI 66 #define REENTRANT_PROTO_S_LISBI 67 #define REENTRANT_PROTO_S_SBI 68 #define REENTRANT_PROTO_S_SBIE 69 #define REENTRANT_PROTO_S_SBW 70 #define REENTRANT_PROTO_S_TISBI 71 #define REENTRANT_PROTO_S_TSBI 72 #define REENTRANT_PROTO_S_TSBIE 73 #define REENTRANT_PROTO_S_TWISBIE 74 #define REENTRANT_PROTO_V_D 75 #define REENTRANT_PROTO_V_H 76 #define REENTRANT_PROTO_V_ID 77 /* Defines for indicating which special features are supported. */ /* The getgrent getgrgid getgrnam using buffer? */ #if defined(HAS_GETGRENT_R) && (GETGRENT_R_PROTO == REENTRANT_PROTO_I_SBWR || GETGRENT_R_PROTO == REENTRANT_PROTO_I_SBIR || GETGRENT_R_PROTO == REENTRANT_PROTO_S_SBW || GETGRENT_R_PROTO == REENTRANT_PROTO_S_SBI || GETGRENT_R_PROTO == REENTRANT_PROTO_I_SBI || GETGRENT_R_PROTO == REENTRANT_PROTO_I_SBIH) # define GETGRENT_R_HAS_BUFFER #else # undef GETGRENT_R_HAS_BUFFER #endif #if defined(HAS_GETGRGID_R) && (GETGRGID_R_PROTO == REENTRANT_PROTO_I_TSBWR || GETGRGID_R_PROTO == REENTRANT_PROTO_I_TSBIR || GETGRGID_R_PROTO == REENTRANT_PROTO_I_TSBI || GETGRGID_R_PROTO == REENTRANT_PROTO_S_TSBI) # define GETGRGID_R_HAS_BUFFER #else # undef GETGRGID_R_HAS_BUFFER #endif #if defined(HAS_GETGRNAM_R) && (GETGRNAM_R_PROTO == REENTRANT_PROTO_I_CSBWR || GETGRNAM_R_PROTO == REENTRANT_PROTO_I_CSBIR || GETGRNAM_R_PROTO == REENTRANT_PROTO_S_CBI || GETGRNAM_R_PROTO == REENTRANT_PROTO_I_CSBI || GETGRNAM_R_PROTO == REENTRANT_PROTO_S_CSBI) # define GETGRNAM_R_HAS_BUFFER #else # undef GETGRNAM_R_HAS_BUFFER #endif /* Any of the getgrent getgrgid getgrnam using buffer? */ #if (defined(GETGRENT_R_HAS_BUFFER) || defined(GETGRGID_R_HAS_BUFFER) || defined(GETGRNAM_R_HAS_BUFFER)) # define USE_GRENT_BUFFER #else # undef USE_GRENT_BUFFER #endif /* The getgrent getgrgid getgrnam using ptr? */ #if defined(HAS_GETGRENT_R) && (GETGRENT_R_PROTO == REENTRANT_PROTO_I_SBWR || GETGRENT_R_PROTO == REENTRANT_PROTO_I_SBIR) # define GETGRENT_R_HAS_PTR #else # undef GETGRENT_R_HAS_PTR #endif #if defined(HAS_GETGRGID_R) && (GETGRGID_R_PROTO == REENTRANT_PROTO_I_TSBWR || GETGRGID_R_PROTO == REENTRANT_PROTO_I_TSBIR) # define GETGRGID_R_HAS_PTR #else # undef GETGRGID_R_HAS_PTR #endif #if defined(HAS_GETGRNAM_R) && (GETGRNAM_R_PROTO == REENTRANT_PROTO_I_CSBWR || GETGRNAM_R_PROTO == REENTRANT_PROTO_I_CSBIR) # define GETGRNAM_R_HAS_PTR #else # undef GETGRNAM_R_HAS_PTR #endif /* Any of the getgrent getgrgid getgrnam using ptr? */ #if (defined(GETGRENT_R_HAS_PTR) || defined(GETGRGID_R_HAS_PTR) || defined(GETGRNAM_R_HAS_PTR)) # define USE_GRENT_PTR #else # undef USE_GRENT_PTR #endif /* The getpwent getpwnam getpwuid using ptr? */ #if defined(HAS_GETPWENT_R) && (GETPWENT_R_PROTO == REENTRANT_PROTO_I_SBWR || GETPWENT_R_PROTO == REENTRANT_PROTO_I_SBIR) # define GETPWENT_R_HAS_PTR #else # undef GETPWENT_R_HAS_PTR #endif #if defined(HAS_GETPWNAM_R) && (GETPWNAM_R_PROTO == REENTRANT_PROTO_I_CSBWR || GETPWNAM_R_PROTO == REENTRANT_PROTO_I_CSBIR) # define GETPWNAM_R_HAS_PTR #else # undef GETPWNAM_R_HAS_PTR #endif #if defined(HAS_GETPWUID_R) && (GETPWUID_R_PROTO == REENTRANT_PROTO_I_TSBWR || GETPWUID_R_PROTO == REENTRANT_PROTO_I_TSBIR) # define GETPWUID_R_HAS_PTR #else # undef GETPWUID_R_HAS_PTR #endif /* Any of the getpwent getpwnam getpwuid using ptr? */ #if (defined(GETPWENT_R_HAS_PTR) || defined(GETPWNAM_R_HAS_PTR) || defined(GETPWUID_R_HAS_PTR)) # define USE_PWENT_PTR #else # undef USE_PWENT_PTR #endif /* The getspent getspnam using ptr? */ #if defined(HAS_GETSPNAM_R) && (GETSPNAM_R_PROTO == REENTRANT_PROTO_I_CSBWR) # define GETSPNAM_R_HAS_PTR #else # undef GETSPNAM_R_HAS_PTR #endif /* Any of the getspent getspnam using ptr? */ #if (defined(GETSPENT_R_HAS_PTR) || defined(GETSPNAM_R_HAS_PTR)) # define USE_SPENT_PTR #else # undef USE_SPENT_PTR #endif /* The getgrent getgrgid getgrnam setgrent endgrent using fptr? */ #if defined(HAS_GETGRENT_R) && (GETGRENT_R_PROTO == REENTRANT_PROTO_I_SBIH) # define GETGRENT_R_HAS_FPTR #else # undef GETGRENT_R_HAS_FPTR #endif #if defined(HAS_SETGRENT_R) && (SETGRENT_R_PROTO == REENTRANT_PROTO_I_H || SETGRENT_R_PROTO == REENTRANT_PROTO_V_H) # define SETGRENT_R_HAS_FPTR #else # undef SETGRENT_R_HAS_FPTR #endif #if defined(HAS_ENDGRENT_R) && (ENDGRENT_R_PROTO == REENTRANT_PROTO_I_H || ENDGRENT_R_PROTO == REENTRANT_PROTO_V_H) # define ENDGRENT_R_HAS_FPTR #else # undef ENDGRENT_R_HAS_FPTR #endif /* Any of the getgrent getgrgid getgrnam setgrent endgrent using fptr? */ #if (defined(GETGRENT_R_HAS_FPTR) || defined(GETGRGID_R_HAS_FPTR) || defined(GETGRNAM_R_HAS_FPTR) || defined(SETGRENT_R_HAS_FPTR) || defined(ENDGRENT_R_HAS_FPTR)) # define USE_GRENT_FPTR #else # undef USE_GRENT_FPTR #endif /* The getpwent getpwnam getpwuid setpwent endpwent using fptr? */ #if defined(HAS_GETPWENT_R) && (GETPWENT_R_PROTO == REENTRANT_PROTO_I_SBIH) # define GETPWENT_R_HAS_FPTR #else # undef GETPWENT_R_HAS_FPTR #endif #if defined(HAS_SETPWENT_R) && (SETPWENT_R_PROTO == REENTRANT_PROTO_I_H || SETPWENT_R_PROTO == REENTRANT_PROTO_V_H) # define SETPWENT_R_HAS_FPTR #else # undef SETPWENT_R_HAS_FPTR #endif #if defined(HAS_ENDPWENT_R) && (ENDPWENT_R_PROTO == REENTRANT_PROTO_I_H || ENDPWENT_R_PROTO == REENTRANT_PROTO_V_H) # define ENDPWENT_R_HAS_FPTR #else # undef ENDPWENT_R_HAS_FPTR #endif /* Any of the getpwent getpwnam getpwuid setpwent endpwent using fptr? */ #if (defined(GETPWENT_R_HAS_FPTR) || defined(GETPWNAM_R_HAS_FPTR) || defined(GETPWUID_R_HAS_FPTR) || defined(SETPWENT_R_HAS_FPTR) || defined(ENDPWENT_R_HAS_FPTR)) # define USE_PWENT_FPTR #else # undef USE_PWENT_FPTR #endif /* The getpwent getpwgid getpwnam using buffer? */ #if defined(HAS_GETPWENT_R) && (GETPWENT_R_PROTO == REENTRANT_PROTO_I_SBWR || GETPWENT_R_PROTO == REENTRANT_PROTO_I_SBIR || GETPWENT_R_PROTO == REENTRANT_PROTO_S_SBW || GETPWENT_R_PROTO == REENTRANT_PROTO_S_SBI || GETPWENT_R_PROTO == REENTRANT_PROTO_I_SBI || GETPWENT_R_PROTO == REENTRANT_PROTO_I_SBIH) # define GETPWENT_R_HAS_BUFFER #else # undef GETPWENT_R_HAS_BUFFER #endif #if defined(HAS_GETPWNAM_R) && (GETPWNAM_R_PROTO == REENTRANT_PROTO_I_CSBWR || GETPWNAM_R_PROTO == REENTRANT_PROTO_I_CSBIR || GETPWNAM_R_PROTO == REENTRANT_PROTO_S_CSBI || GETPWNAM_R_PROTO == REENTRANT_PROTO_I_CSBI) # define GETPWNAM_R_HAS_BUFFER #else # undef GETPWNAM_R_HAS_BUFFER #endif /* Any of the getpwent getpwgid getpwnam using buffer? */ #if (defined(GETPWENT_R_HAS_BUFFER) || defined(GETPWGID_R_HAS_BUFFER) || defined(GETPWNAM_R_HAS_BUFFER)) # define USE_PWENT_BUFFER #else # undef USE_PWENT_BUFFER #endif /* The gethostent gethostbyaddr gethostbyname using ptr? */ #if defined(HAS_GETHOSTENT_R) && (GETHOSTENT_R_PROTO == REENTRANT_PROTO_I_SBWRE) # define GETHOSTENT_R_HAS_PTR #else # undef GETHOSTENT_R_HAS_PTR #endif #if defined(HAS_GETHOSTBYADDR_R) && (GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_I_CWISBWRE || GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_I_TsISBWRE) # define GETHOSTBYADDR_R_HAS_PTR #else # undef GETHOSTBYADDR_R_HAS_PTR #endif #if defined(HAS_GETHOSTBYNAME_R) && (GETHOSTBYNAME_R_PROTO == REENTRANT_PROTO_I_CSBWRE) # define GETHOSTBYNAME_R_HAS_PTR #else # undef GETHOSTBYNAME_R_HAS_PTR #endif /* Any of the gethostent gethostbyaddr gethostbyname using ptr? */ #if (defined(GETHOSTENT_R_HAS_PTR) || defined(GETHOSTBYADDR_R_HAS_PTR) || defined(GETHOSTBYNAME_R_HAS_PTR)) # define USE_HOSTENT_PTR #else # undef USE_HOSTENT_PTR #endif /* The getnetent getnetbyaddr getnetbyname using ptr? */ #if defined(HAS_GETNETENT_R) && (GETNETENT_R_PROTO == REENTRANT_PROTO_I_SBWRE) # define GETNETENT_R_HAS_PTR #else # undef GETNETENT_R_HAS_PTR #endif #if defined(HAS_GETNETBYADDR_R) && (GETNETBYADDR_R_PROTO == REENTRANT_PROTO_I_UISBWRE || GETNETBYADDR_R_PROTO == REENTRANT_PROTO_I_uISBWRE) # define GETNETBYADDR_R_HAS_PTR #else # undef GETNETBYADDR_R_HAS_PTR #endif #if defined(HAS_GETNETBYNAME_R) && (GETNETBYNAME_R_PROTO == REENTRANT_PROTO_I_CSBWRE) # define GETNETBYNAME_R_HAS_PTR #else # undef GETNETBYNAME_R_HAS_PTR #endif /* Any of the getnetent getnetbyaddr getnetbyname using ptr? */ #if (defined(GETNETENT_R_HAS_PTR) || defined(GETNETBYADDR_R_HAS_PTR) || defined(GETNETBYNAME_R_HAS_PTR)) # define USE_NETENT_PTR #else # undef USE_NETENT_PTR #endif /* The getprotoent getprotobyname getprotobynumber using ptr? */ #if defined(HAS_GETPROTOENT_R) && (GETPROTOENT_R_PROTO == REENTRANT_PROTO_I_SBWR) # define GETPROTOENT_R_HAS_PTR #else # undef GETPROTOENT_R_HAS_PTR #endif #if defined(HAS_GETPROTOBYNAME_R) && (GETPROTOBYNAME_R_PROTO == REENTRANT_PROTO_I_CSBWR) # define GETPROTOBYNAME_R_HAS_PTR #else # undef GETPROTOBYNAME_R_HAS_PTR #endif #if defined(HAS_GETPROTOBYNUMBER_R) && (GETPROTOBYNUMBER_R_PROTO == REENTRANT_PROTO_I_ISBWR) # define GETPROTOBYNUMBER_R_HAS_PTR #else # undef GETPROTOBYNUMBER_R_HAS_PTR #endif /* Any of the getprotoent getprotobyname getprotobynumber using ptr? */ #if (defined(GETPROTOENT_R_HAS_PTR) || defined(GETPROTOBYNAME_R_HAS_PTR) || defined(GETPROTOBYNUMBER_R_HAS_PTR)) # define USE_PROTOENT_PTR #else # undef USE_PROTOENT_PTR #endif /* The getservent getservbyname getservbyport using ptr? */ #if defined(HAS_GETSERVENT_R) && (GETSERVENT_R_PROTO == REENTRANT_PROTO_I_SBWR) # define GETSERVENT_R_HAS_PTR #else # undef GETSERVENT_R_HAS_PTR #endif #if defined(HAS_GETSERVBYNAME_R) && (GETSERVBYNAME_R_PROTO == REENTRANT_PROTO_I_CCSBWR) # define GETSERVBYNAME_R_HAS_PTR #else # undef GETSERVBYNAME_R_HAS_PTR #endif #if defined(HAS_GETSERVBYPORT_R) && (GETSERVBYPORT_R_PROTO == REENTRANT_PROTO_I_ICSBWR) # define GETSERVBYPORT_R_HAS_PTR #else # undef GETSERVBYPORT_R_HAS_PTR #endif /* Any of the getservent getservbyname getservbyport using ptr? */ #if (defined(GETSERVENT_R_HAS_PTR) || defined(GETSERVBYNAME_R_HAS_PTR) || defined(GETSERVBYPORT_R_HAS_PTR)) # define USE_SERVENT_PTR #else # undef USE_SERVENT_PTR #endif /* The gethostent gethostbyaddr gethostbyname using buffer? */ #if defined(HAS_GETHOSTENT_R) && (GETHOSTENT_R_PROTO == REENTRANT_PROTO_I_SBWRE || GETHOSTENT_R_PROTO == REENTRANT_PROTO_I_SBIE || GETHOSTENT_R_PROTO == REENTRANT_PROTO_S_SBIE || GETHOSTENT_R_PROTO == REENTRANT_PROTO_S_SBI || GETHOSTENT_R_PROTO == REENTRANT_PROTO_I_SBI) # define GETHOSTENT_R_HAS_BUFFER #else # undef GETHOSTENT_R_HAS_BUFFER #endif #if defined(HAS_GETHOSTBYADDR_R) && (GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_I_CWISBWRE || GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_CWISBWIE || GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_CWISBIE || GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_TWISBIE || GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_CIISBIE || GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_CSBIE || GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_TSBIE || GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_I_TsISBWRE) # define GETHOSTBYADDR_R_HAS_BUFFER #else # undef GETHOSTBYADDR_R_HAS_BUFFER #endif #if defined(HAS_GETHOSTBYNAME_R) && (GETHOSTBYNAME_R_PROTO == REENTRANT_PROTO_I_CSBWRE || GETHOSTBYNAME_R_PROTO == REENTRANT_PROTO_S_CSBIE) # define GETHOSTBYNAME_R_HAS_BUFFER #else # undef GETHOSTBYNAME_R_HAS_BUFFER #endif /* Any of the gethostent gethostbyaddr gethostbyname using buffer? */ #if (defined(GETHOSTENT_R_HAS_BUFFER) || defined(GETHOSTBYADDR_R_HAS_BUFFER) || defined(GETHOSTBYNAME_R_HAS_BUFFER)) # define USE_HOSTENT_BUFFER #else # undef USE_HOSTENT_BUFFER #endif /* The getnetent getnetbyaddr getnetbyname using buffer? */ #if defined(HAS_GETNETENT_R) && (GETNETENT_R_PROTO == REENTRANT_PROTO_I_SBWRE || GETNETENT_R_PROTO == REENTRANT_PROTO_I_SBIE || GETNETENT_R_PROTO == REENTRANT_PROTO_S_SBIE || GETNETENT_R_PROTO == REENTRANT_PROTO_S_SBI || GETNETENT_R_PROTO == REENTRANT_PROTO_I_SBI) # define GETNETENT_R_HAS_BUFFER #else # undef GETNETENT_R_HAS_BUFFER #endif #if defined(HAS_GETNETBYADDR_R) && (GETNETBYADDR_R_PROTO == REENTRANT_PROTO_I_UISBWRE || GETNETBYADDR_R_PROTO == REENTRANT_PROTO_I_LISBI || GETNETBYADDR_R_PROTO == REENTRANT_PROTO_S_TISBI || GETNETBYADDR_R_PROTO == REENTRANT_PROTO_S_LISBI || GETNETBYADDR_R_PROTO == REENTRANT_PROTO_I_uISBWRE) # define GETNETBYADDR_R_HAS_BUFFER #else # undef GETNETBYADDR_R_HAS_BUFFER #endif #if defined(HAS_GETNETBYNAME_R) && (GETNETBYNAME_R_PROTO == REENTRANT_PROTO_I_CSBWRE || GETNETBYNAME_R_PROTO == REENTRANT_PROTO_I_CSBI || GETNETBYNAME_R_PROTO == REENTRANT_PROTO_S_CSBI) # define GETNETBYNAME_R_HAS_BUFFER #else # undef GETNETBYNAME_R_HAS_BUFFER #endif /* Any of the getnetent getnetbyaddr getnetbyname using buffer? */ #if (defined(GETNETENT_R_HAS_BUFFER) || defined(GETNETBYADDR_R_HAS_BUFFER) || defined(GETNETBYNAME_R_HAS_BUFFER)) # define USE_NETENT_BUFFER #else # undef USE_NETENT_BUFFER #endif /* The getprotoent getprotobyname getprotobynumber using buffer? */ #if defined(HAS_GETPROTOENT_R) && (GETPROTOENT_R_PROTO == REENTRANT_PROTO_I_SBWR || GETPROTOENT_R_PROTO == REENTRANT_PROTO_I_SBI || GETPROTOENT_R_PROTO == REENTRANT_PROTO_S_SBI) # define GETPROTOENT_R_HAS_BUFFER #else # undef GETPROTOENT_R_HAS_BUFFER #endif #if defined(HAS_GETPROTOBYNAME_R) && (GETPROTOBYNAME_R_PROTO == REENTRANT_PROTO_I_CSBWR || GETPROTOBYNAME_R_PROTO == REENTRANT_PROTO_S_CSBI) # define GETPROTOBYNAME_R_HAS_BUFFER #else # undef GETPROTOBYNAME_R_HAS_BUFFER #endif #if defined(HAS_GETPROTOBYNUMBER_R) && (GETPROTOBYNUMBER_R_PROTO == REENTRANT_PROTO_I_ISBWR || GETPROTOBYNUMBER_R_PROTO == REENTRANT_PROTO_S_ISBI) # define GETPROTOBYNUMBER_R_HAS_BUFFER #else # undef GETPROTOBYNUMBER_R_HAS_BUFFER #endif /* Any of the getprotoent getprotobyname getprotobynumber using buffer? */ #if (defined(GETPROTOENT_R_HAS_BUFFER) || defined(GETPROTOBYNAME_R_HAS_BUFFER) || defined(GETPROTOBYNUMBER_R_HAS_BUFFER)) # define USE_PROTOENT_BUFFER #else # undef USE_PROTOENT_BUFFER #endif /* The getservent getservbyname getservbyport using buffer? */ #if defined(HAS_GETSERVENT_R) && (GETSERVENT_R_PROTO == REENTRANT_PROTO_I_SBWR || GETSERVENT_R_PROTO == REENTRANT_PROTO_I_SBI || GETSERVENT_R_PROTO == REENTRANT_PROTO_S_SBI) # define GETSERVENT_R_HAS_BUFFER #else # undef GETSERVENT_R_HAS_BUFFER #endif #if defined(HAS_GETSERVBYNAME_R) && (GETSERVBYNAME_R_PROTO == REENTRANT_PROTO_I_CCSBWR || GETSERVBYNAME_R_PROTO == REENTRANT_PROTO_S_CCSBI) # define GETSERVBYNAME_R_HAS_BUFFER #else # undef GETSERVBYNAME_R_HAS_BUFFER #endif #if defined(HAS_GETSERVBYPORT_R) && (GETSERVBYPORT_R_PROTO == REENTRANT_PROTO_I_ICSBWR || GETSERVBYPORT_R_PROTO == REENTRANT_PROTO_S_ICSBI) # define GETSERVBYPORT_R_HAS_BUFFER #else # undef GETSERVBYPORT_R_HAS_BUFFER #endif /* Any of the getservent getservbyname getservbyport using buffer? */ #if (defined(GETSERVENT_R_HAS_BUFFER) || defined(GETSERVBYNAME_R_HAS_BUFFER) || defined(GETSERVBYPORT_R_HAS_BUFFER)) # define USE_SERVENT_BUFFER #else # undef USE_SERVENT_BUFFER #endif /* The gethostent gethostbyaddr gethostbyname using errno? */ #if defined(HAS_GETHOSTENT_R) && (GETHOSTENT_R_PROTO == REENTRANT_PROTO_I_SBWRE || GETHOSTENT_R_PROTO == REENTRANT_PROTO_I_SBIE || GETHOSTENT_R_PROTO == REENTRANT_PROTO_S_SBIE) # define GETHOSTENT_R_HAS_ERRNO #else # undef GETHOSTENT_R_HAS_ERRNO #endif #if defined(HAS_GETHOSTBYADDR_R) && (GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_I_CWISBWRE || GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_CWISBWIE || GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_CWISBIE || GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_TWISBIE || GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_CIISBIE || GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_CSBIE || GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_TSBIE || GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_I_TsISBWRE) # define GETHOSTBYADDR_R_HAS_ERRNO #else # undef GETHOSTBYADDR_R_HAS_ERRNO #endif #if defined(HAS_GETHOSTBYNAME_R) && (GETHOSTBYNAME_R_PROTO == REENTRANT_PROTO_I_CSBWRE || GETHOSTBYNAME_R_PROTO == REENTRANT_PROTO_S_CSBIE) # define GETHOSTBYNAME_R_HAS_ERRNO #else # undef GETHOSTBYNAME_R_HAS_ERRNO #endif /* Any of the gethostent gethostbyaddr gethostbyname using errno? */ #if (defined(GETHOSTENT_R_HAS_ERRNO) || defined(GETHOSTBYADDR_R_HAS_ERRNO) || defined(GETHOSTBYNAME_R_HAS_ERRNO)) # define USE_HOSTENT_ERRNO #else # undef USE_HOSTENT_ERRNO #endif /* The getnetent getnetbyaddr getnetbyname using errno? */ #if defined(HAS_GETNETENT_R) && (GETNETENT_R_PROTO == REENTRANT_PROTO_I_SBWRE || GETNETENT_R_PROTO == REENTRANT_PROTO_I_SBIE || GETNETENT_R_PROTO == REENTRANT_PROTO_S_SBIE) # define GETNETENT_R_HAS_ERRNO #else # undef GETNETENT_R_HAS_ERRNO #endif #if defined(HAS_GETNETBYADDR_R) && (GETNETBYADDR_R_PROTO == REENTRANT_PROTO_I_UISBWRE || GETNETBYADDR_R_PROTO == REENTRANT_PROTO_I_uISBWRE) # define GETNETBYADDR_R_HAS_ERRNO #else # undef GETNETBYADDR_R_HAS_ERRNO #endif #if defined(HAS_GETNETBYNAME_R) && (GETNETBYNAME_R_PROTO == REENTRANT_PROTO_I_CSBWRE) # define GETNETBYNAME_R_HAS_ERRNO #else # undef GETNETBYNAME_R_HAS_ERRNO #endif /* Any of the getnetent getnetbyaddr getnetbyname using errno? */ #if (defined(GETNETENT_R_HAS_ERRNO) || defined(GETNETBYADDR_R_HAS_ERRNO) || defined(GETNETBYNAME_R_HAS_ERRNO)) # define USE_NETENT_ERRNO #else # undef USE_NETENT_ERRNO #endif typedef struct { #ifdef HAS_ASCTIME_R char* _asctime_buffer; size_t _asctime_size; #endif /* HAS_ASCTIME_R */ #ifdef HAS_CRYPT_R #if CRYPT_R_PROTO == REENTRANT_PROTO_B_CCD CRYPTD* _crypt_data; #else struct crypt_data *_crypt_struct_buffer; #endif #endif /* HAS_CRYPT_R */ #ifdef HAS_CTIME_R char* _ctime_buffer; size_t _ctime_size; #endif /* HAS_CTIME_R */ #ifdef HAS_DRAND48_R struct drand48_data _drand48_struct; double _drand48_double; #endif /* HAS_DRAND48_R */ #ifdef HAS_GETGRNAM_R struct group _grent_struct; char* _grent_buffer; size_t _grent_size; # ifdef USE_GRENT_PTR struct group* _grent_ptr; # endif # ifdef USE_GRENT_FPTR FILE* _grent_fptr; # endif #endif /* HAS_GETGRNAM_R */ #ifdef HAS_GETHOSTBYNAME_R struct hostent _hostent_struct; # if GETHOSTBYNAME_R_PROTO == REENTRANT_PROTO_I_CSD struct hostent_data _hostent_data; # else char* _hostent_buffer; size_t _hostent_size; # endif # ifdef USE_HOSTENT_PTR struct hostent* _hostent_ptr; # endif # ifdef USE_HOSTENT_ERRNO int _hostent_errno; # endif #endif /* HAS_GETHOSTBYNAME_R */ #ifdef HAS_GETLOGIN_R char* _getlogin_buffer; size_t _getlogin_size; #endif /* HAS_GETLOGIN_R */ #ifdef HAS_GETNETBYNAME_R struct netent _netent_struct; # if GETNETBYNAME_R_PROTO == REENTRANT_PROTO_I_CSD struct netent_data _netent_data; # else char* _netent_buffer; size_t _netent_size; # endif # ifdef USE_NETENT_PTR struct netent* _netent_ptr; # endif # ifdef USE_NETENT_ERRNO int _netent_errno; # endif #endif /* HAS_GETNETBYNAME_R */ #ifdef HAS_GETPROTOBYNAME_R struct protoent _protoent_struct; # if GETPROTOBYNAME_R_PROTO == REENTRANT_PROTO_I_CSD struct protoent_data _protoent_data; # else char* _protoent_buffer; size_t _protoent_size; # endif # ifdef USE_PROTOENT_PTR struct protoent* _protoent_ptr; # endif # ifdef USE_PROTOENT_ERRNO int _protoent_errno; # endif #endif /* HAS_GETPROTOBYNAME_R */ #ifdef HAS_GETPWNAM_R struct passwd _pwent_struct; char* _pwent_buffer; size_t _pwent_size; # ifdef USE_PWENT_PTR struct passwd* _pwent_ptr; # endif # ifdef USE_PWENT_FPTR FILE* _pwent_fptr; # endif #endif /* HAS_GETPWNAM_R */ #ifdef HAS_GETSERVBYNAME_R struct servent _servent_struct; # if GETSERVBYNAME_R_PROTO == REENTRANT_PROTO_I_CCSD struct servent_data _servent_data; # else char* _servent_buffer; size_t _servent_size; # endif # ifdef USE_SERVENT_PTR struct servent* _servent_ptr; # endif # ifdef USE_SERVENT_ERRNO int _servent_errno; # endif #endif /* HAS_GETSERVBYNAME_R */ #ifdef HAS_GETSPNAM_R struct spwd _spent_struct; char* _spent_buffer; size_t _spent_size; # ifdef USE_SPENT_PTR struct spwd* _spent_ptr; # endif # ifdef USE_SPENT_FPTR FILE* _spent_fptr; # endif #endif /* HAS_GETSPNAM_R */ #ifdef HAS_RANDOM_R struct random_data _random_struct; # if RANDOM_R_PROTO == REENTRANT_PROTO_I_iS int _random_retval; # endif # if RANDOM_R_PROTO == REENTRANT_PROTO_I_lS long _random_retval; # endif # if RANDOM_R_PROTO == REENTRANT_PROTO_I_St int32_t _random_retval; # endif #endif /* HAS_RANDOM_R */ #ifdef HAS_READDIR_R struct dirent* _readdir_struct; size_t _readdir_size; # if READDIR_R_PROTO == REENTRANT_PROTO_I_TSR struct dirent* _readdir_ptr; # endif #endif /* HAS_READDIR_R */ #ifdef HAS_READDIR64_R struct dirent64* _readdir64_struct; size_t _readdir64_size; # if READDIR64_R_PROTO == REENTRANT_PROTO_I_TSR struct dirent64* _readdir64_ptr; # endif #endif /* HAS_READDIR64_R */ #ifdef HAS_SETLOCALE_R char* _setlocale_buffer; size_t _setlocale_size; #endif /* HAS_SETLOCALE_R */ #ifdef HAS_SRANDOM_R struct random_data _srandom_struct; #endif /* HAS_SRANDOM_R */ #ifdef HAS_STRERROR_R char* _strerror_buffer; size_t _strerror_size; #endif /* HAS_STRERROR_R */ #ifdef HAS_TTYNAME_R char* _ttyname_buffer; size_t _ttyname_size; #endif /* HAS_TTYNAME_R */ int dummy; /* cannot have empty structs */ } REENTR; /* The wrappers. */ #ifdef HAS_ASCTIME_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef asctime # if !defined(asctime) && ASCTIME_R_PROTO == REENTRANT_PROTO_B_SB # define asctime(a) asctime_r(a, PL_reentrant_buffer->_asctime_buffer) # endif # if !defined(asctime) && ASCTIME_R_PROTO == REENTRANT_PROTO_B_SBI # define asctime(a) asctime_r(a, PL_reentrant_buffer->_asctime_buffer, PL_reentrant_buffer->_asctime_size) # endif # if !defined(asctime) && ASCTIME_R_PROTO == REENTRANT_PROTO_I_SB # define asctime(a) (asctime_r(a, PL_reentrant_buffer->_asctime_buffer) == 0 ? PL_reentrant_buffer->_asctime_buffer : 0) # endif # if !defined(asctime) && ASCTIME_R_PROTO == REENTRANT_PROTO_I_SBI # define asctime(a) (asctime_r(a, PL_reentrant_buffer->_asctime_buffer, PL_reentrant_buffer->_asctime_size) == 0 ? PL_reentrant_buffer->_asctime_buffer : 0) # endif # endif #endif /* HAS_ASCTIME_R */ #ifdef HAS_CRYPT_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef crypt # if !defined(crypt) && CRYPT_R_PROTO == REENTRANT_PROTO_B_CCS # define crypt(a, b) crypt_r(a, b, PL_reentrant_buffer->_crypt_struct_buffer) # endif # if !defined(crypt) && CRYPT_R_PROTO == REENTRANT_PROTO_B_CCD # define crypt(a, b) crypt_r(a, b, &PL_reentrant_buffer->_crypt_data) # endif # endif #endif /* HAS_CRYPT_R */ #ifdef HAS_CTERMID_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef ctermid # if !defined(ctermid) && CTERMID_R_PROTO == REENTRANT_PROTO_B_B # define ctermid(a) ctermid_r(a) # endif # endif #endif /* HAS_CTERMID_R */ #ifdef HAS_CTIME_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef ctime # if !defined(ctime) && CTIME_R_PROTO == REENTRANT_PROTO_B_SB # define ctime(a) ctime_r(a, PL_reentrant_buffer->_ctime_buffer) # endif # if !defined(ctime) && CTIME_R_PROTO == REENTRANT_PROTO_B_SBI # define ctime(a) ctime_r(a, PL_reentrant_buffer->_ctime_buffer, PL_reentrant_buffer->_ctime_size) # endif # if !defined(ctime) && CTIME_R_PROTO == REENTRANT_PROTO_I_SB # define ctime(a) (ctime_r(a, PL_reentrant_buffer->_ctime_buffer) == 0 ? PL_reentrant_buffer->_ctime_buffer : 0) # endif # if !defined(ctime) && CTIME_R_PROTO == REENTRANT_PROTO_I_SBI # define ctime(a) (ctime_r(a, PL_reentrant_buffer->_ctime_buffer, PL_reentrant_buffer->_ctime_size) == 0 ? PL_reentrant_buffer->_ctime_buffer : 0) # endif # endif #endif /* HAS_CTIME_R */ #ifdef HAS_DRAND48_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef drand48 # if !defined(drand48) && DRAND48_R_PROTO == REENTRANT_PROTO_I_ST # define drand48() (drand48_r(&PL_reentrant_buffer->_drand48_struct, &PL_reentrant_buffer->_drand48_double) == 0 ? PL_reentrant_buffer->_drand48_double : 0) # endif # endif #endif /* HAS_DRAND48_R */ #ifdef HAS_ENDGRENT_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef endgrent # if !defined(endgrent) && ENDGRENT_R_PROTO == REENTRANT_PROTO_I_H # define endgrent() (endgrent_r(&PL_reentrant_buffer->_grent_fptr) == 0 ? 1 : 0) # endif # if !defined(endgrent) && ENDGRENT_R_PROTO == REENTRANT_PROTO_V_H # define endgrent() endgrent_r(&PL_reentrant_buffer->_grent_fptr) # endif # endif #endif /* HAS_ENDGRENT_R */ #ifdef HAS_ENDHOSTENT_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef endhostent # if !defined(endhostent) && ENDHOSTENT_R_PROTO == REENTRANT_PROTO_I_D # define endhostent() (endhostent_r(&PL_reentrant_buffer->_hostent_data) == 0 ? 1 : 0) # endif # if !defined(endhostent) && ENDHOSTENT_R_PROTO == REENTRANT_PROTO_V_D # define endhostent() endhostent_r(&PL_reentrant_buffer->_hostent_data) # endif # endif #endif /* HAS_ENDHOSTENT_R */ #ifdef HAS_ENDNETENT_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef endnetent # if !defined(endnetent) && ENDNETENT_R_PROTO == REENTRANT_PROTO_I_D # define endnetent() (endnetent_r(&PL_reentrant_buffer->_netent_data) == 0 ? 1 : 0) # endif # if !defined(endnetent) && ENDNETENT_R_PROTO == REENTRANT_PROTO_V_D # define endnetent() endnetent_r(&PL_reentrant_buffer->_netent_data) # endif # endif #endif /* HAS_ENDNETENT_R */ #ifdef HAS_ENDPROTOENT_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef endprotoent # if !defined(endprotoent) && ENDPROTOENT_R_PROTO == REENTRANT_PROTO_I_D # define endprotoent() (endprotoent_r(&PL_reentrant_buffer->_protoent_data) == 0 ? 1 : 0) # endif # if !defined(endprotoent) && ENDPROTOENT_R_PROTO == REENTRANT_PROTO_V_D # define endprotoent() endprotoent_r(&PL_reentrant_buffer->_protoent_data) # endif # endif #endif /* HAS_ENDPROTOENT_R */ #ifdef HAS_ENDPWENT_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef endpwent # if !defined(endpwent) && ENDPWENT_R_PROTO == REENTRANT_PROTO_I_H # define endpwent() (endpwent_r(&PL_reentrant_buffer->_pwent_fptr) == 0 ? 1 : 0) # endif # if !defined(endpwent) && ENDPWENT_R_PROTO == REENTRANT_PROTO_V_H # define endpwent() endpwent_r(&PL_reentrant_buffer->_pwent_fptr) # endif # endif #endif /* HAS_ENDPWENT_R */ #ifdef HAS_ENDSERVENT_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef endservent # if !defined(endservent) && ENDSERVENT_R_PROTO == REENTRANT_PROTO_I_D # define endservent() (endservent_r(&PL_reentrant_buffer->_servent_data) == 0 ? 1 : 0) # endif # if !defined(endservent) && ENDSERVENT_R_PROTO == REENTRANT_PROTO_V_D # define endservent() endservent_r(&PL_reentrant_buffer->_servent_data) # endif # endif #endif /* HAS_ENDSERVENT_R */ #ifdef HAS_GETGRENT_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef getgrent # if !defined(getgrent) && GETGRENT_R_PROTO == REENTRANT_PROTO_I_SBWR # define getgrent() ((PL_reentrant_retint = getgrent_r(&PL_reentrant_buffer->_grent_struct, PL_reentrant_buffer->_grent_buffer, PL_reentrant_buffer->_grent_size, &PL_reentrant_buffer->_grent_ptr)) == 0 ? PL_reentrant_buffer->_grent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct group *) Perl_reentrant_retry("getgrent") : 0)) # endif # if !defined(getgrent) && GETGRENT_R_PROTO == REENTRANT_PROTO_I_SBIR # define getgrent() ((PL_reentrant_retint = getgrent_r(&PL_reentrant_buffer->_grent_struct, PL_reentrant_buffer->_grent_buffer, PL_reentrant_buffer->_grent_size, &PL_reentrant_buffer->_grent_ptr)) == 0 ? PL_reentrant_buffer->_grent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct group *) Perl_reentrant_retry("getgrent") : 0)) # endif # if !defined(getgrent) && GETGRENT_R_PROTO == REENTRANT_PROTO_S_SBW # define getgrent() (getgrent_r(&PL_reentrant_buffer->_grent_struct, PL_reentrant_buffer->_grent_buffer, PL_reentrant_buffer->_grent_size) ? &PL_reentrant_buffer->_grent_struct : ((errno == ERANGE) ? (struct group *) Perl_reentrant_retry("getgrent") : 0)) # endif # if !defined(getgrent) && GETGRENT_R_PROTO == REENTRANT_PROTO_S_SBI # define getgrent() (getgrent_r(&PL_reentrant_buffer->_grent_struct, PL_reentrant_buffer->_grent_buffer, PL_reentrant_buffer->_grent_size) ? &PL_reentrant_buffer->_grent_struct : ((errno == ERANGE) ? (struct group *) Perl_reentrant_retry("getgrent") : 0)) # endif # if !defined(getgrent) && GETGRENT_R_PROTO == REENTRANT_PROTO_I_SBI # define getgrent() ((PL_reentrant_retint = getgrent_r(&PL_reentrant_buffer->_grent_struct, PL_reentrant_buffer->_grent_buffer, PL_reentrant_buffer->_grent_size)) == 0 ? &PL_reentrant_buffer->_grent_struct : ((PL_reentrant_retint == ERANGE) ? (struct group *) Perl_reentrant_retry("getgrent") : 0)) # endif # if !defined(getgrent) && GETGRENT_R_PROTO == REENTRANT_PROTO_I_SBIH # define getgrent() ((PL_reentrant_retint = getgrent_r(&PL_reentrant_buffer->_grent_struct, PL_reentrant_buffer->_grent_buffer, PL_reentrant_buffer->_grent_size, &PL_reentrant_buffer->_grent_fptr)) == 0 ? &PL_reentrant_buffer->_grent_struct : ((PL_reentrant_retint == ERANGE) ? (struct group *) Perl_reentrant_retry("getgrent") : 0)) # endif # endif #endif /* HAS_GETGRENT_R */ #ifdef HAS_GETGRGID_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef getgrgid # if !defined(getgrgid) && GETGRGID_R_PROTO == REENTRANT_PROTO_I_TSBWR # define getgrgid(a) ((PL_reentrant_retint = getgrgid_r(a, &PL_reentrant_buffer->_grent_struct, PL_reentrant_buffer->_grent_buffer, PL_reentrant_buffer->_grent_size, &PL_reentrant_buffer->_grent_ptr)) == 0 ? PL_reentrant_buffer->_grent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct group *) Perl_reentrant_retry("getgrgid", a) : 0)) # endif # if !defined(getgrgid) && GETGRGID_R_PROTO == REENTRANT_PROTO_I_TSBIR # define getgrgid(a) ((PL_reentrant_retint = getgrgid_r(a, &PL_reentrant_buffer->_grent_struct, PL_reentrant_buffer->_grent_buffer, PL_reentrant_buffer->_grent_size, &PL_reentrant_buffer->_grent_ptr)) == 0 ? PL_reentrant_buffer->_grent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct group *) Perl_reentrant_retry("getgrgid", a) : 0)) # endif # if !defined(getgrgid) && GETGRGID_R_PROTO == REENTRANT_PROTO_I_TSBI # define getgrgid(a) ((PL_reentrant_retint = getgrgid_r(a, &PL_reentrant_buffer->_grent_struct, PL_reentrant_buffer->_grent_buffer, PL_reentrant_buffer->_grent_size)) == 0 ? &PL_reentrant_buffer->_grent_struct : ((PL_reentrant_retint == ERANGE) ? (struct group *) Perl_reentrant_retry("getgrgid", a) : 0)) # endif # if !defined(getgrgid) && GETGRGID_R_PROTO == REENTRANT_PROTO_S_TSBI # define getgrgid(a) (getgrgid_r(a, &PL_reentrant_buffer->_grent_struct, PL_reentrant_buffer->_grent_buffer, PL_reentrant_buffer->_grent_size) ? &PL_reentrant_buffer->_grent_struct : ((errno == ERANGE) ? (struct group *) Perl_reentrant_retry("getgrgid", a) : 0)) # endif # endif #endif /* HAS_GETGRGID_R */ #ifdef HAS_GETGRNAM_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef getgrnam # if !defined(getgrnam) && GETGRNAM_R_PROTO == REENTRANT_PROTO_I_CSBWR # define getgrnam(a) ((PL_reentrant_retint = getgrnam_r(a, &PL_reentrant_buffer->_grent_struct, PL_reentrant_buffer->_grent_buffer, PL_reentrant_buffer->_grent_size, &PL_reentrant_buffer->_grent_ptr)) == 0 ? PL_reentrant_buffer->_grent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct group *) Perl_reentrant_retry("getgrnam", a) : 0)) # endif # if !defined(getgrnam) && GETGRNAM_R_PROTO == REENTRANT_PROTO_I_CSBIR # define getgrnam(a) ((PL_reentrant_retint = getgrnam_r(a, &PL_reentrant_buffer->_grent_struct, PL_reentrant_buffer->_grent_buffer, PL_reentrant_buffer->_grent_size, &PL_reentrant_buffer->_grent_ptr)) == 0 ? PL_reentrant_buffer->_grent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct group *) Perl_reentrant_retry("getgrnam", a) : 0)) # endif # if !defined(getgrnam) && GETGRNAM_R_PROTO == REENTRANT_PROTO_S_CBI # define getgrnam(a) (getgrnam_r(a, PL_reentrant_buffer->_grent_buffer, PL_reentrant_buffer->_grent_size) ? PL_reentrant_buffer->_grent_buffer : ((errno == ERANGE) ? (struct group *) Perl_reentrant_retry("getgrnam", a) : 0)) # endif # if !defined(getgrnam) && GETGRNAM_R_PROTO == REENTRANT_PROTO_I_CSBI # define getgrnam(a) ((PL_reentrant_retint = getgrnam_r(a, &PL_reentrant_buffer->_grent_struct, PL_reentrant_buffer->_grent_buffer, PL_reentrant_buffer->_grent_size)) == 0 ? &PL_reentrant_buffer->_grent_struct : ((PL_reentrant_retint == ERANGE) ? (struct group *) Perl_reentrant_retry("getgrnam", a) : 0)) # endif # if !defined(getgrnam) && GETGRNAM_R_PROTO == REENTRANT_PROTO_S_CSBI # define getgrnam(a) (getgrnam_r(a, &PL_reentrant_buffer->_grent_struct, PL_reentrant_buffer->_grent_buffer, PL_reentrant_buffer->_grent_size) ? &PL_reentrant_buffer->_grent_struct : ((errno == ERANGE) ? (struct group *) Perl_reentrant_retry("getgrnam", a) : 0)) # endif # endif #endif /* HAS_GETGRNAM_R */ #ifdef HAS_GETHOSTBYADDR_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef gethostbyaddr # if !defined(gethostbyaddr) && GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_I_CWISBWRE # define gethostbyaddr(a, b, c) ((PL_reentrant_retint = gethostbyaddr_r(a, b, c, &PL_reentrant_buffer->_hostent_struct, PL_reentrant_buffer->_hostent_buffer, PL_reentrant_buffer->_hostent_size, &PL_reentrant_buffer->_hostent_ptr, &PL_reentrant_buffer->_hostent_errno)) == 0 ? PL_reentrant_buffer->_hostent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostbyaddr", a, b, c) : 0)) # endif # if !defined(gethostbyaddr) && GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_CWISBWIE # define gethostbyaddr(a, b, c) (gethostbyaddr_r(a, b, c, &PL_reentrant_buffer->_hostent_struct, PL_reentrant_buffer->_hostent_buffer, PL_reentrant_buffer->_hostent_size, PL_reentrant_buffer->_hostent_size, &PL_reentrant_buffer->_hostent_errno) ? &PL_reentrant_buffer->_hostent_struct : ((errno == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostbyaddr", a, b, c) : 0)) # endif # if !defined(gethostbyaddr) && GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_CWISBIE # define gethostbyaddr(a, b, c) (gethostbyaddr_r(a, b, c, &PL_reentrant_buffer->_hostent_struct, PL_reentrant_buffer->_hostent_buffer, PL_reentrant_buffer->_hostent_size, &PL_reentrant_buffer->_hostent_errno) ? &PL_reentrant_buffer->_hostent_struct : ((errno == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostbyaddr", a, b, c) : 0)) # endif # if !defined(gethostbyaddr) && GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_TWISBIE # define gethostbyaddr(a, b, c) (gethostbyaddr_r(a, b, c, &PL_reentrant_buffer->_hostent_struct, PL_reentrant_buffer->_hostent_buffer, PL_reentrant_buffer->_hostent_size, &PL_reentrant_buffer->_hostent_errno) ? &PL_reentrant_buffer->_hostent_struct : ((errno == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostbyaddr", a, b, c) : 0)) # endif # if !defined(gethostbyaddr) && GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_CIISBIE # define gethostbyaddr(a, b, c) (gethostbyaddr_r(a, b, c, &PL_reentrant_buffer->_hostent_struct, PL_reentrant_buffer->_hostent_buffer, PL_reentrant_buffer->_hostent_size, &PL_reentrant_buffer->_hostent_errno) ? &PL_reentrant_buffer->_hostent_struct : ((errno == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostbyaddr", a, b, c) : 0)) # endif # if !defined(gethostbyaddr) && GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_CSBIE # define gethostbyaddr(a, b, c) (gethostbyaddr_r(a, b, c, PL_reentrant_buffer->_hostent_size, &PL_reentrant_buffer->_hostent_errno) ? 1 : ((errno == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostbyaddr", a, b, c) : 0)) # endif # if !defined(gethostbyaddr) && GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_S_TSBIE # define gethostbyaddr(a, b, c) (gethostbyaddr_r(a, b, c, PL_reentrant_buffer->_hostent_size, &PL_reentrant_buffer->_hostent_errno) ? 1 : ((errno == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostbyaddr", a, b, c) : 0)) # endif # if !defined(gethostbyaddr) && GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_I_CWISD # define gethostbyaddr(a, b, c) ((PL_reentrant_retint = gethostbyaddr_r(a, b, c, &PL_reentrant_buffer->_hostent_struct, &PL_reentrant_buffer->_hostent_data)) == 0 ? &PL_reentrant_buffer->_hostent_struct : ((PL_reentrant_retint == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostbyaddr", a, b, c) : 0)) # endif # if !defined(gethostbyaddr) && GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_I_CIISD # define gethostbyaddr(a, b, c) ((PL_reentrant_retint = gethostbyaddr_r(a, b, c, &PL_reentrant_buffer->_hostent_struct, &PL_reentrant_buffer->_hostent_data)) == 0 ? &PL_reentrant_buffer->_hostent_struct : ((PL_reentrant_retint == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostbyaddr", a, b, c) : 0)) # endif # if !defined(gethostbyaddr) && GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_I_CII # define gethostbyaddr(a, b, c) ((PL_reentrant_retint = gethostbyaddr_r(a, b, c)) == 0 ? 1 : ((PL_reentrant_retint == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostbyaddr", a, b, c) : 0)) # endif # if !defined(gethostbyaddr) && GETHOSTBYADDR_R_PROTO == REENTRANT_PROTO_I_TsISBWRE # define gethostbyaddr(a, b, c) ((PL_reentrant_retint = gethostbyaddr_r(a, b, c, &PL_reentrant_buffer->_hostent_struct, PL_reentrant_buffer->_hostent_buffer, PL_reentrant_buffer->_hostent_size, &PL_reentrant_buffer->_hostent_ptr, &PL_reentrant_buffer->_hostent_errno)) == 0 ? PL_reentrant_buffer->_hostent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostbyaddr", a, b, c) : 0)) # endif # endif #endif /* HAS_GETHOSTBYADDR_R */ #ifdef HAS_GETHOSTBYNAME_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef gethostbyname # if !defined(gethostbyname) && GETHOSTBYNAME_R_PROTO == REENTRANT_PROTO_I_CSBWRE # define gethostbyname(a) ((PL_reentrant_retint = gethostbyname_r(a, &PL_reentrant_buffer->_hostent_struct, PL_reentrant_buffer->_hostent_buffer, PL_reentrant_buffer->_hostent_size, &PL_reentrant_buffer->_hostent_ptr, &PL_reentrant_buffer->_hostent_errno)) == 0 ? PL_reentrant_buffer->_hostent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostbyname", a) : 0)) # endif # if !defined(gethostbyname) && GETHOSTBYNAME_R_PROTO == REENTRANT_PROTO_S_CSBIE # define gethostbyname(a) (gethostbyname_r(a, &PL_reentrant_buffer->_hostent_struct, PL_reentrant_buffer->_hostent_buffer, PL_reentrant_buffer->_hostent_size, &PL_reentrant_buffer->_hostent_errno) ? &PL_reentrant_buffer->_hostent_struct : ((errno == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostbyname", a) : 0)) # endif # if !defined(gethostbyname) && GETHOSTBYNAME_R_PROTO == REENTRANT_PROTO_I_CSD # define gethostbyname(a) ((PL_reentrant_retint = gethostbyname_r(a, &PL_reentrant_buffer->_hostent_struct, &PL_reentrant_buffer->_hostent_data)) == 0 ? &PL_reentrant_buffer->_hostent_struct : ((PL_reentrant_retint == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostbyname", a) : 0)) # endif # endif #endif /* HAS_GETHOSTBYNAME_R */ #ifdef HAS_GETHOSTENT_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef gethostent # if !defined(gethostent) && GETHOSTENT_R_PROTO == REENTRANT_PROTO_I_SBWRE # define gethostent() ((PL_reentrant_retint = gethostent_r(&PL_reentrant_buffer->_hostent_struct, PL_reentrant_buffer->_hostent_buffer, PL_reentrant_buffer->_hostent_size, &PL_reentrant_buffer->_hostent_ptr, &PL_reentrant_buffer->_hostent_errno)) == 0 ? PL_reentrant_buffer->_hostent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostent") : 0)) # endif # if !defined(gethostent) && GETHOSTENT_R_PROTO == REENTRANT_PROTO_I_SBIE # define gethostent() ((PL_reentrant_retint = gethostent_r(&PL_reentrant_buffer->_hostent_struct, PL_reentrant_buffer->_hostent_buffer, PL_reentrant_buffer->_hostent_size, &PL_reentrant_buffer->_hostent_errno)) == 0 ? &PL_reentrant_buffer->_hostent_struct : ((PL_reentrant_retint == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostent") : 0)) # endif # if !defined(gethostent) && GETHOSTENT_R_PROTO == REENTRANT_PROTO_S_SBIE # define gethostent() (gethostent_r(&PL_reentrant_buffer->_hostent_struct, PL_reentrant_buffer->_hostent_buffer, PL_reentrant_buffer->_hostent_size, &PL_reentrant_buffer->_hostent_errno) ? &PL_reentrant_buffer->_hostent_struct : ((errno == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostent") : 0)) # endif # if !defined(gethostent) && GETHOSTENT_R_PROTO == REENTRANT_PROTO_S_SBI # define gethostent() (gethostent_r(&PL_reentrant_buffer->_hostent_struct, PL_reentrant_buffer->_hostent_buffer, PL_reentrant_buffer->_hostent_size) ? &PL_reentrant_buffer->_hostent_struct : ((errno == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostent") : 0)) # endif # if !defined(gethostent) && GETHOSTENT_R_PROTO == REENTRANT_PROTO_I_SBI # define gethostent() ((PL_reentrant_retint = gethostent_r(&PL_reentrant_buffer->_hostent_struct, PL_reentrant_buffer->_hostent_buffer, PL_reentrant_buffer->_hostent_size)) == 0 ? &PL_reentrant_buffer->_hostent_struct : ((PL_reentrant_retint == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostent") : 0)) # endif # if !defined(gethostent) && GETHOSTENT_R_PROTO == REENTRANT_PROTO_I_SD # define gethostent() ((PL_reentrant_retint = gethostent_r(&PL_reentrant_buffer->_hostent_struct, &PL_reentrant_buffer->_hostent_data)) == 0 ? &PL_reentrant_buffer->_hostent_struct : ((PL_reentrant_retint == ERANGE) ? (struct hostent *) Perl_reentrant_retry("gethostent") : 0)) # endif # endif #endif /* HAS_GETHOSTENT_R */ #ifdef HAS_GETLOGIN_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef getlogin # if !defined(getlogin) && GETLOGIN_R_PROTO == REENTRANT_PROTO_I_BW # define getlogin() ((PL_reentrant_retint = getlogin_r(PL_reentrant_buffer->_getlogin_buffer, PL_reentrant_buffer->_getlogin_size)) == 0 ? PL_reentrant_buffer->_getlogin_buffer : ((PL_reentrant_retint == ERANGE) ? (char *) Perl_reentrant_retry("getlogin") : 0)) # endif # if !defined(getlogin) && GETLOGIN_R_PROTO == REENTRANT_PROTO_I_BI # define getlogin() ((PL_reentrant_retint = getlogin_r(PL_reentrant_buffer->_getlogin_buffer, PL_reentrant_buffer->_getlogin_size)) == 0 ? PL_reentrant_buffer->_getlogin_buffer : ((PL_reentrant_retint == ERANGE) ? (char *) Perl_reentrant_retry("getlogin") : 0)) # endif # if !defined(getlogin) && GETLOGIN_R_PROTO == REENTRANT_PROTO_B_BW # define getlogin() getlogin_r(PL_reentrant_buffer->_getlogin_buffer, PL_reentrant_buffer->_getlogin_size) # endif # if !defined(getlogin) && GETLOGIN_R_PROTO == REENTRANT_PROTO_B_BI # define getlogin() getlogin_r(PL_reentrant_buffer->_getlogin_buffer, PL_reentrant_buffer->_getlogin_size) # endif # endif #endif /* HAS_GETLOGIN_R */ #ifdef HAS_GETNETBYADDR_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef getnetbyaddr # if !defined(getnetbyaddr) && GETNETBYADDR_R_PROTO == REENTRANT_PROTO_I_UISBWRE # define getnetbyaddr(a, b) ((PL_reentrant_retint = getnetbyaddr_r(a, b, &PL_reentrant_buffer->_netent_struct, PL_reentrant_buffer->_netent_buffer, PL_reentrant_buffer->_netent_size, &PL_reentrant_buffer->_netent_ptr, &PL_reentrant_buffer->_netent_errno)) == 0 ? PL_reentrant_buffer->_netent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetbyaddr", a, b) : 0)) # endif # if !defined(getnetbyaddr) && GETNETBYADDR_R_PROTO == REENTRANT_PROTO_I_LISBI # define getnetbyaddr(a, b) ((PL_reentrant_retint = getnetbyaddr_r(a, b, &PL_reentrant_buffer->_netent_struct, PL_reentrant_buffer->_netent_buffer, PL_reentrant_buffer->_netent_size)) == 0 ? &PL_reentrant_buffer->_netent_struct : ((PL_reentrant_retint == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetbyaddr", a, b) : 0)) # endif # if !defined(getnetbyaddr) && GETNETBYADDR_R_PROTO == REENTRANT_PROTO_S_TISBI # define getnetbyaddr(a, b) (getnetbyaddr_r(a, b, &PL_reentrant_buffer->_netent_struct, PL_reentrant_buffer->_netent_buffer, PL_reentrant_buffer->_netent_size) ? &PL_reentrant_buffer->_netent_struct : ((errno == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetbyaddr", a, b) : 0)) # endif # if !defined(getnetbyaddr) && GETNETBYADDR_R_PROTO == REENTRANT_PROTO_S_LISBI # define getnetbyaddr(a, b) (getnetbyaddr_r(a, b, &PL_reentrant_buffer->_netent_struct, PL_reentrant_buffer->_netent_buffer, PL_reentrant_buffer->_netent_size) ? &PL_reentrant_buffer->_netent_struct : ((errno == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetbyaddr", a, b) : 0)) # endif # if !defined(getnetbyaddr) && GETNETBYADDR_R_PROTO == REENTRANT_PROTO_I_TISD # define getnetbyaddr(a, b) ((PL_reentrant_retint = getnetbyaddr_r(a, b, &PL_reentrant_buffer->_netent_struct, &PL_reentrant_buffer->_netent_data)) == 0 ? &PL_reentrant_buffer->_netent_struct : ((PL_reentrant_retint == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetbyaddr", a, b) : 0)) # endif # if !defined(getnetbyaddr) && GETNETBYADDR_R_PROTO == REENTRANT_PROTO_I_LISD # define getnetbyaddr(a, b) ((PL_reentrant_retint = getnetbyaddr_r(a, b, &PL_reentrant_buffer->_netent_struct, &PL_reentrant_buffer->_netent_data)) == 0 ? &PL_reentrant_buffer->_netent_struct : ((PL_reentrant_retint == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetbyaddr", a, b) : 0)) # endif # if !defined(getnetbyaddr) && GETNETBYADDR_R_PROTO == REENTRANT_PROTO_I_IISD # define getnetbyaddr(a, b) ((PL_reentrant_retint = getnetbyaddr_r(a, b, &PL_reentrant_buffer->_netent_struct, &PL_reentrant_buffer->_netent_data)) == 0 ? &PL_reentrant_buffer->_netent_struct : ((PL_reentrant_retint == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetbyaddr", a, b) : 0)) # endif # if !defined(getnetbyaddr) && GETNETBYADDR_R_PROTO == REENTRANT_PROTO_I_uISBWRE # define getnetbyaddr(a, b) ((PL_reentrant_retint = getnetbyaddr_r(a, b, &PL_reentrant_buffer->_netent_struct, PL_reentrant_buffer->_netent_buffer, PL_reentrant_buffer->_netent_size, &PL_reentrant_buffer->_netent_ptr, &PL_reentrant_buffer->_netent_errno)) == 0 ? PL_reentrant_buffer->_netent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetbyaddr", a, b) : 0)) # endif # endif #endif /* HAS_GETNETBYADDR_R */ #ifdef HAS_GETNETBYNAME_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef getnetbyname # if !defined(getnetbyname) && GETNETBYNAME_R_PROTO == REENTRANT_PROTO_I_CSBWRE # define getnetbyname(a) ((PL_reentrant_retint = getnetbyname_r(a, &PL_reentrant_buffer->_netent_struct, PL_reentrant_buffer->_netent_buffer, PL_reentrant_buffer->_netent_size, &PL_reentrant_buffer->_netent_ptr, &PL_reentrant_buffer->_netent_errno)) == 0 ? PL_reentrant_buffer->_netent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetbyname", a) : 0)) # endif # if !defined(getnetbyname) && GETNETBYNAME_R_PROTO == REENTRANT_PROTO_I_CSBI # define getnetbyname(a) ((PL_reentrant_retint = getnetbyname_r(a, &PL_reentrant_buffer->_netent_struct, PL_reentrant_buffer->_netent_buffer, PL_reentrant_buffer->_netent_size)) == 0 ? &PL_reentrant_buffer->_netent_struct : ((PL_reentrant_retint == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetbyname", a) : 0)) # endif # if !defined(getnetbyname) && GETNETBYNAME_R_PROTO == REENTRANT_PROTO_S_CSBI # define getnetbyname(a) (getnetbyname_r(a, &PL_reentrant_buffer->_netent_struct, PL_reentrant_buffer->_netent_buffer, PL_reentrant_buffer->_netent_size) ? &PL_reentrant_buffer->_netent_struct : ((errno == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetbyname", a) : 0)) # endif # if !defined(getnetbyname) && GETNETBYNAME_R_PROTO == REENTRANT_PROTO_I_CSD # define getnetbyname(a) ((PL_reentrant_retint = getnetbyname_r(a, &PL_reentrant_buffer->_netent_struct, &PL_reentrant_buffer->_netent_data)) == 0 ? &PL_reentrant_buffer->_netent_struct : ((PL_reentrant_retint == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetbyname", a) : 0)) # endif # endif #endif /* HAS_GETNETBYNAME_R */ #ifdef HAS_GETNETENT_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef getnetent # if !defined(getnetent) && GETNETENT_R_PROTO == REENTRANT_PROTO_I_SBWRE # define getnetent() ((PL_reentrant_retint = getnetent_r(&PL_reentrant_buffer->_netent_struct, PL_reentrant_buffer->_netent_buffer, PL_reentrant_buffer->_netent_size, &PL_reentrant_buffer->_netent_ptr, &PL_reentrant_buffer->_netent_errno)) == 0 ? PL_reentrant_buffer->_netent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetent") : 0)) # endif # if !defined(getnetent) && GETNETENT_R_PROTO == REENTRANT_PROTO_I_SBIE # define getnetent() ((PL_reentrant_retint = getnetent_r(&PL_reentrant_buffer->_netent_struct, PL_reentrant_buffer->_netent_buffer, PL_reentrant_buffer->_netent_size, &PL_reentrant_buffer->_netent_errno)) == 0 ? &PL_reentrant_buffer->_netent_struct : ((PL_reentrant_retint == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetent") : 0)) # endif # if !defined(getnetent) && GETNETENT_R_PROTO == REENTRANT_PROTO_S_SBIE # define getnetent() (getnetent_r(&PL_reentrant_buffer->_netent_struct, PL_reentrant_buffer->_netent_buffer, PL_reentrant_buffer->_netent_size, &PL_reentrant_buffer->_netent_errno) ? &PL_reentrant_buffer->_netent_struct : ((errno == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetent") : 0)) # endif # if !defined(getnetent) && GETNETENT_R_PROTO == REENTRANT_PROTO_S_SBI # define getnetent() (getnetent_r(&PL_reentrant_buffer->_netent_struct, PL_reentrant_buffer->_netent_buffer, PL_reentrant_buffer->_netent_size) ? &PL_reentrant_buffer->_netent_struct : ((errno == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetent") : 0)) # endif # if !defined(getnetent) && GETNETENT_R_PROTO == REENTRANT_PROTO_I_SBI # define getnetent() ((PL_reentrant_retint = getnetent_r(&PL_reentrant_buffer->_netent_struct, PL_reentrant_buffer->_netent_buffer, PL_reentrant_buffer->_netent_size)) == 0 ? &PL_reentrant_buffer->_netent_struct : ((PL_reentrant_retint == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetent") : 0)) # endif # if !defined(getnetent) && GETNETENT_R_PROTO == REENTRANT_PROTO_I_SD # define getnetent() ((PL_reentrant_retint = getnetent_r(&PL_reentrant_buffer->_netent_struct, &PL_reentrant_buffer->_netent_data)) == 0 ? &PL_reentrant_buffer->_netent_struct : ((PL_reentrant_retint == ERANGE) ? (struct netent *) Perl_reentrant_retry("getnetent") : 0)) # endif # endif #endif /* HAS_GETNETENT_R */ #ifdef HAS_GETPROTOBYNAME_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef getprotobyname # if !defined(getprotobyname) && GETPROTOBYNAME_R_PROTO == REENTRANT_PROTO_I_CSBWR # define getprotobyname(a) ((PL_reentrant_retint = getprotobyname_r(a, &PL_reentrant_buffer->_protoent_struct, PL_reentrant_buffer->_protoent_buffer, PL_reentrant_buffer->_protoent_size, &PL_reentrant_buffer->_protoent_ptr)) == 0 ? PL_reentrant_buffer->_protoent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct protoent *) Perl_reentrant_retry("getprotobyname", a) : 0)) # endif # if !defined(getprotobyname) && GETPROTOBYNAME_R_PROTO == REENTRANT_PROTO_S_CSBI # define getprotobyname(a) (getprotobyname_r(a, &PL_reentrant_buffer->_protoent_struct, PL_reentrant_buffer->_protoent_buffer, PL_reentrant_buffer->_protoent_size) ? &PL_reentrant_buffer->_protoent_struct : ((errno == ERANGE) ? (struct protoent *) Perl_reentrant_retry("getprotobyname", a) : 0)) # endif # if !defined(getprotobyname) && GETPROTOBYNAME_R_PROTO == REENTRANT_PROTO_I_CSD # define getprotobyname(a) (REENTR_MEMZERO(&PL_reentrant_buffer->_protoent_data, sizeof(PL_reentrant_buffer->_protoent_data)),(PL_reentrant_retint = getprotobyname_r(a, &PL_reentrant_buffer->_protoent_struct, &PL_reentrant_buffer->_protoent_data)) == 0 ? &PL_reentrant_buffer->_protoent_struct : ((PL_reentrant_retint == ERANGE) ? (struct protoent *) Perl_reentrant_retry("getprotobyname", a) : 0)) # endif # endif #endif /* HAS_GETPROTOBYNAME_R */ #ifdef HAS_GETPROTOBYNUMBER_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef getprotobynumber # if !defined(getprotobynumber) && GETPROTOBYNUMBER_R_PROTO == REENTRANT_PROTO_I_ISBWR # define getprotobynumber(a) ((PL_reentrant_retint = getprotobynumber_r(a, &PL_reentrant_buffer->_protoent_struct, PL_reentrant_buffer->_protoent_buffer, PL_reentrant_buffer->_protoent_size, &PL_reentrant_buffer->_protoent_ptr)) == 0 ? PL_reentrant_buffer->_protoent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct protoent *) Perl_reentrant_retry("getprotobynumber", a) : 0)) # endif # if !defined(getprotobynumber) && GETPROTOBYNUMBER_R_PROTO == REENTRANT_PROTO_S_ISBI # define getprotobynumber(a) (getprotobynumber_r(a, &PL_reentrant_buffer->_protoent_struct, PL_reentrant_buffer->_protoent_buffer, PL_reentrant_buffer->_protoent_size) ? &PL_reentrant_buffer->_protoent_struct : ((errno == ERANGE) ? (struct protoent *) Perl_reentrant_retry("getprotobynumber", a) : 0)) # endif # if !defined(getprotobynumber) && GETPROTOBYNUMBER_R_PROTO == REENTRANT_PROTO_I_ISD # define getprotobynumber(a) (REENTR_MEMZERO(&PL_reentrant_buffer->_protoent_data, sizeof(PL_reentrant_buffer->_protoent_data)),(PL_reentrant_retint = getprotobynumber_r(a, &PL_reentrant_buffer->_protoent_struct, &PL_reentrant_buffer->_protoent_data)) == 0 ? &PL_reentrant_buffer->_protoent_struct : ((PL_reentrant_retint == ERANGE) ? (struct protoent *) Perl_reentrant_retry("getprotobynumber", a) : 0)) # endif # endif #endif /* HAS_GETPROTOBYNUMBER_R */ #ifdef HAS_GETPROTOENT_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef getprotoent # if !defined(getprotoent) && GETPROTOENT_R_PROTO == REENTRANT_PROTO_I_SBWR # define getprotoent() ((PL_reentrant_retint = getprotoent_r(&PL_reentrant_buffer->_protoent_struct, PL_reentrant_buffer->_protoent_buffer, PL_reentrant_buffer->_protoent_size, &PL_reentrant_buffer->_protoent_ptr)) == 0 ? PL_reentrant_buffer->_protoent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct protoent *) Perl_reentrant_retry("getprotoent") : 0)) # endif # if !defined(getprotoent) && GETPROTOENT_R_PROTO == REENTRANT_PROTO_I_SBI # define getprotoent() ((PL_reentrant_retint = getprotoent_r(&PL_reentrant_buffer->_protoent_struct, PL_reentrant_buffer->_protoent_buffer, PL_reentrant_buffer->_protoent_size)) == 0 ? &PL_reentrant_buffer->_protoent_struct : ((PL_reentrant_retint == ERANGE) ? (struct protoent *) Perl_reentrant_retry("getprotoent") : 0)) # endif # if !defined(getprotoent) && GETPROTOENT_R_PROTO == REENTRANT_PROTO_S_SBI # define getprotoent() (getprotoent_r(&PL_reentrant_buffer->_protoent_struct, PL_reentrant_buffer->_protoent_buffer, PL_reentrant_buffer->_protoent_size) ? &PL_reentrant_buffer->_protoent_struct : ((errno == ERANGE) ? (struct protoent *) Perl_reentrant_retry("getprotoent") : 0)) # endif # if !defined(getprotoent) && GETPROTOENT_R_PROTO == REENTRANT_PROTO_I_SD # define getprotoent() (REENTR_MEMZERO(&PL_reentrant_buffer->_protoent_data, sizeof(PL_reentrant_buffer->_protoent_data)),(PL_reentrant_retint = getprotoent_r(&PL_reentrant_buffer->_protoent_struct, &PL_reentrant_buffer->_protoent_data)) == 0 ? &PL_reentrant_buffer->_protoent_struct : ((PL_reentrant_retint == ERANGE) ? (struct protoent *) Perl_reentrant_retry("getprotoent") : 0)) # endif # endif #endif /* HAS_GETPROTOENT_R */ #ifdef HAS_GETPWENT_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef getpwent # if !defined(getpwent) && GETPWENT_R_PROTO == REENTRANT_PROTO_I_SBWR # define getpwent() ((PL_reentrant_retint = getpwent_r(&PL_reentrant_buffer->_pwent_struct, PL_reentrant_buffer->_pwent_buffer, PL_reentrant_buffer->_pwent_size, &PL_reentrant_buffer->_pwent_ptr)) == 0 ? PL_reentrant_buffer->_pwent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct passwd *) Perl_reentrant_retry("getpwent") : 0)) # endif # if !defined(getpwent) && GETPWENT_R_PROTO == REENTRANT_PROTO_I_SBIR # define getpwent() ((PL_reentrant_retint = getpwent_r(&PL_reentrant_buffer->_pwent_struct, PL_reentrant_buffer->_pwent_buffer, PL_reentrant_buffer->_pwent_size, &PL_reentrant_buffer->_pwent_ptr)) == 0 ? PL_reentrant_buffer->_pwent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct passwd *) Perl_reentrant_retry("getpwent") : 0)) # endif # if !defined(getpwent) && GETPWENT_R_PROTO == REENTRANT_PROTO_S_SBW # define getpwent() (getpwent_r(&PL_reentrant_buffer->_pwent_struct, PL_reentrant_buffer->_pwent_buffer, PL_reentrant_buffer->_pwent_size) ? &PL_reentrant_buffer->_pwent_struct : ((errno == ERANGE) ? (struct passwd *) Perl_reentrant_retry("getpwent") : 0)) # endif # if !defined(getpwent) && GETPWENT_R_PROTO == REENTRANT_PROTO_S_SBI # define getpwent() (getpwent_r(&PL_reentrant_buffer->_pwent_struct, PL_reentrant_buffer->_pwent_buffer, PL_reentrant_buffer->_pwent_size) ? &PL_reentrant_buffer->_pwent_struct : ((errno == ERANGE) ? (struct passwd *) Perl_reentrant_retry("getpwent") : 0)) # endif # if !defined(getpwent) && GETPWENT_R_PROTO == REENTRANT_PROTO_I_SBI # define getpwent() ((PL_reentrant_retint = getpwent_r(&PL_reentrant_buffer->_pwent_struct, PL_reentrant_buffer->_pwent_buffer, PL_reentrant_buffer->_pwent_size)) == 0 ? &PL_reentrant_buffer->_pwent_struct : ((PL_reentrant_retint == ERANGE) ? (struct passwd *) Perl_reentrant_retry("getpwent") : 0)) # endif # if !defined(getpwent) && GETPWENT_R_PROTO == REENTRANT_PROTO_I_SBIH # define getpwent() ((PL_reentrant_retint = getpwent_r(&PL_reentrant_buffer->_pwent_struct, PL_reentrant_buffer->_pwent_buffer, PL_reentrant_buffer->_pwent_size, &PL_reentrant_buffer->_pwent_fptr)) == 0 ? &PL_reentrant_buffer->_pwent_struct : ((PL_reentrant_retint == ERANGE) ? (struct passwd *) Perl_reentrant_retry("getpwent") : 0)) # endif # endif #endif /* HAS_GETPWENT_R */ #ifdef HAS_GETPWNAM_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef getpwnam # if !defined(getpwnam) && GETPWNAM_R_PROTO == REENTRANT_PROTO_I_CSBWR # define getpwnam(a) ((PL_reentrant_retint = getpwnam_r(a, &PL_reentrant_buffer->_pwent_struct, PL_reentrant_buffer->_pwent_buffer, PL_reentrant_buffer->_pwent_size, &PL_reentrant_buffer->_pwent_ptr)) == 0 ? PL_reentrant_buffer->_pwent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct passwd *) Perl_reentrant_retry("getpwnam", a) : 0)) # endif # if !defined(getpwnam) && GETPWNAM_R_PROTO == REENTRANT_PROTO_I_CSBIR # define getpwnam(a) ((PL_reentrant_retint = getpwnam_r(a, &PL_reentrant_buffer->_pwent_struct, PL_reentrant_buffer->_pwent_buffer, PL_reentrant_buffer->_pwent_size, &PL_reentrant_buffer->_pwent_ptr)) == 0 ? PL_reentrant_buffer->_pwent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct passwd *) Perl_reentrant_retry("getpwnam", a) : 0)) # endif # if !defined(getpwnam) && GETPWNAM_R_PROTO == REENTRANT_PROTO_S_CSBI # define getpwnam(a) (getpwnam_r(a, &PL_reentrant_buffer->_pwent_struct, PL_reentrant_buffer->_pwent_buffer, PL_reentrant_buffer->_pwent_size) ? &PL_reentrant_buffer->_pwent_struct : ((errno == ERANGE) ? (struct passwd *) Perl_reentrant_retry("getpwnam", a) : 0)) # endif # if !defined(getpwnam) && GETPWNAM_R_PROTO == REENTRANT_PROTO_I_CSBI # define getpwnam(a) ((PL_reentrant_retint = getpwnam_r(a, &PL_reentrant_buffer->_pwent_struct, PL_reentrant_buffer->_pwent_buffer, PL_reentrant_buffer->_pwent_size)) == 0 ? &PL_reentrant_buffer->_pwent_struct : ((PL_reentrant_retint == ERANGE) ? (struct passwd *) Perl_reentrant_retry("getpwnam", a) : 0)) # endif # endif #endif /* HAS_GETPWNAM_R */ #ifdef HAS_GETPWUID_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef getpwuid # if !defined(getpwuid) && GETPWUID_R_PROTO == REENTRANT_PROTO_I_TSBWR # define getpwuid(a) ((PL_reentrant_retint = getpwuid_r(a, &PL_reentrant_buffer->_pwent_struct, PL_reentrant_buffer->_pwent_buffer, PL_reentrant_buffer->_pwent_size, &PL_reentrant_buffer->_pwent_ptr)) == 0 ? PL_reentrant_buffer->_pwent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct passwd *) Perl_reentrant_retry("getpwuid", a) : 0)) # endif # if !defined(getpwuid) && GETPWUID_R_PROTO == REENTRANT_PROTO_I_TSBIR # define getpwuid(a) ((PL_reentrant_retint = getpwuid_r(a, &PL_reentrant_buffer->_pwent_struct, PL_reentrant_buffer->_pwent_buffer, PL_reentrant_buffer->_pwent_size, &PL_reentrant_buffer->_pwent_ptr)) == 0 ? PL_reentrant_buffer->_pwent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct passwd *) Perl_reentrant_retry("getpwuid", a) : 0)) # endif # if !defined(getpwuid) && GETPWUID_R_PROTO == REENTRANT_PROTO_I_TSBI # define getpwuid(a) ((PL_reentrant_retint = getpwuid_r(a, &PL_reentrant_buffer->_pwent_struct, PL_reentrant_buffer->_pwent_buffer, PL_reentrant_buffer->_pwent_size)) == 0 ? &PL_reentrant_buffer->_pwent_struct : ((PL_reentrant_retint == ERANGE) ? (struct passwd *) Perl_reentrant_retry("getpwuid", a) : 0)) # endif # if !defined(getpwuid) && GETPWUID_R_PROTO == REENTRANT_PROTO_S_TSBI # define getpwuid(a) (getpwuid_r(a, &PL_reentrant_buffer->_pwent_struct, PL_reentrant_buffer->_pwent_buffer, PL_reentrant_buffer->_pwent_size) ? &PL_reentrant_buffer->_pwent_struct : ((errno == ERANGE) ? (struct passwd *) Perl_reentrant_retry("getpwuid", a) : 0)) # endif # endif #endif /* HAS_GETPWUID_R */ #ifdef HAS_GETSERVBYNAME_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef getservbyname # if !defined(getservbyname) && GETSERVBYNAME_R_PROTO == REENTRANT_PROTO_I_CCSBWR # define getservbyname(a, b) ((PL_reentrant_retint = getservbyname_r(a, b, &PL_reentrant_buffer->_servent_struct, PL_reentrant_buffer->_servent_buffer, PL_reentrant_buffer->_servent_size, &PL_reentrant_buffer->_servent_ptr)) == 0 ? PL_reentrant_buffer->_servent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct servent *) Perl_reentrant_retry("getservbyname", a, b) : 0)) # endif # if !defined(getservbyname) && GETSERVBYNAME_R_PROTO == REENTRANT_PROTO_S_CCSBI # define getservbyname(a, b) (getservbyname_r(a, b, &PL_reentrant_buffer->_servent_struct, PL_reentrant_buffer->_servent_buffer, PL_reentrant_buffer->_servent_size) ? &PL_reentrant_buffer->_servent_struct : ((errno == ERANGE) ? (struct servent *) Perl_reentrant_retry("getservbyname", a, b) : 0)) # endif # if !defined(getservbyname) && GETSERVBYNAME_R_PROTO == REENTRANT_PROTO_I_CCSD # define getservbyname(a, b) (REENTR_MEMZERO(&PL_reentrant_buffer->_servent_data, sizeof(PL_reentrant_buffer->_servent_data)),(PL_reentrant_retint = getservbyname_r(a, b, &PL_reentrant_buffer->_servent_struct, &PL_reentrant_buffer->_servent_data)) == 0 ? &PL_reentrant_buffer->_servent_struct : ((PL_reentrant_retint == ERANGE) ? (struct servent *) Perl_reentrant_retry("getservbyname", a, b) : 0)) # endif # endif #endif /* HAS_GETSERVBYNAME_R */ #ifdef HAS_GETSERVBYPORT_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef getservbyport # if !defined(getservbyport) && GETSERVBYPORT_R_PROTO == REENTRANT_PROTO_I_ICSBWR # define getservbyport(a, b) ((PL_reentrant_retint = getservbyport_r(a, b, &PL_reentrant_buffer->_servent_struct, PL_reentrant_buffer->_servent_buffer, PL_reentrant_buffer->_servent_size, &PL_reentrant_buffer->_servent_ptr)) == 0 ? PL_reentrant_buffer->_servent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct servent *) Perl_reentrant_retry("getservbyport", a, b) : 0)) # endif # if !defined(getservbyport) && GETSERVBYPORT_R_PROTO == REENTRANT_PROTO_S_ICSBI # define getservbyport(a, b) (getservbyport_r(a, b, &PL_reentrant_buffer->_servent_struct, PL_reentrant_buffer->_servent_buffer, PL_reentrant_buffer->_servent_size) ? &PL_reentrant_buffer->_servent_struct : ((errno == ERANGE) ? (struct servent *) Perl_reentrant_retry("getservbyport", a, b) : 0)) # endif # if !defined(getservbyport) && GETSERVBYPORT_R_PROTO == REENTRANT_PROTO_I_ICSD # define getservbyport(a, b) (REENTR_MEMZERO(&PL_reentrant_buffer->_servent_data, sizeof(PL_reentrant_buffer->_servent_data)),(PL_reentrant_retint = getservbyport_r(a, b, &PL_reentrant_buffer->_servent_struct, &PL_reentrant_buffer->_servent_data)) == 0 ? &PL_reentrant_buffer->_servent_struct : ((PL_reentrant_retint == ERANGE) ? (struct servent *) Perl_reentrant_retry("getservbyport", a, b) : 0)) # endif # endif #endif /* HAS_GETSERVBYPORT_R */ #ifdef HAS_GETSERVENT_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef getservent # if !defined(getservent) && GETSERVENT_R_PROTO == REENTRANT_PROTO_I_SBWR # define getservent() ((PL_reentrant_retint = getservent_r(&PL_reentrant_buffer->_servent_struct, PL_reentrant_buffer->_servent_buffer, PL_reentrant_buffer->_servent_size, &PL_reentrant_buffer->_servent_ptr)) == 0 ? PL_reentrant_buffer->_servent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct servent *) Perl_reentrant_retry("getservent") : 0)) # endif # if !defined(getservent) && GETSERVENT_R_PROTO == REENTRANT_PROTO_I_SBI # define getservent() ((PL_reentrant_retint = getservent_r(&PL_reentrant_buffer->_servent_struct, PL_reentrant_buffer->_servent_buffer, PL_reentrant_buffer->_servent_size)) == 0 ? &PL_reentrant_buffer->_servent_struct : ((PL_reentrant_retint == ERANGE) ? (struct servent *) Perl_reentrant_retry("getservent") : 0)) # endif # if !defined(getservent) && GETSERVENT_R_PROTO == REENTRANT_PROTO_S_SBI # define getservent() (getservent_r(&PL_reentrant_buffer->_servent_struct, PL_reentrant_buffer->_servent_buffer, PL_reentrant_buffer->_servent_size) ? &PL_reentrant_buffer->_servent_struct : ((errno == ERANGE) ? (struct servent *) Perl_reentrant_retry("getservent") : 0)) # endif # if !defined(getservent) && GETSERVENT_R_PROTO == REENTRANT_PROTO_I_SD # define getservent() (REENTR_MEMZERO(&PL_reentrant_buffer->_servent_data, sizeof(PL_reentrant_buffer->_servent_data)),(PL_reentrant_retint = getservent_r(&PL_reentrant_buffer->_servent_struct, &PL_reentrant_buffer->_servent_data)) == 0 ? &PL_reentrant_buffer->_servent_struct : ((PL_reentrant_retint == ERANGE) ? (struct servent *) Perl_reentrant_retry("getservent") : 0)) # endif # endif #endif /* HAS_GETSERVENT_R */ #ifdef HAS_GETSPNAM_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef getspnam # if !defined(getspnam) && GETSPNAM_R_PROTO == REENTRANT_PROTO_I_CSBWR # define getspnam(a) ((PL_reentrant_retint = getspnam_r(a, &PL_reentrant_buffer->_spent_struct, PL_reentrant_buffer->_spent_buffer, PL_reentrant_buffer->_spent_size, &PL_reentrant_buffer->_spent_ptr)) == 0 ? PL_reentrant_buffer->_spent_ptr : ((PL_reentrant_retint == ERANGE) ? (struct spwd *) Perl_reentrant_retry("getspnam", a) : 0)) # endif # if !defined(getspnam) && GETSPNAM_R_PROTO == REENTRANT_PROTO_S_CSBI # define getspnam(a) (getspnam_r(a, &PL_reentrant_buffer->_spent_struct, PL_reentrant_buffer->_spent_buffer, PL_reentrant_buffer->_spent_size) ? &PL_reentrant_buffer->_spent_struct : ((errno == ERANGE) ? (struct spwd *) Perl_reentrant_retry("getspnam", a) : 0)) # endif # endif #endif /* HAS_GETSPNAM_R */ #ifdef HAS_RANDOM_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef random # if !defined(random) && RANDOM_R_PROTO == REENTRANT_PROTO_I_iS # define random() (random_r(&PL_reentrant_buffer->_random_retval, &PL_reentrant_buffer->_random_struct) == 0 ? PL_reentrant_buffer->_random_retval : 0) # endif # if !defined(random) && RANDOM_R_PROTO == REENTRANT_PROTO_I_lS # define random() (random_r(&PL_reentrant_buffer->_random_retval, &PL_reentrant_buffer->_random_struct) == 0 ? PL_reentrant_buffer->_random_retval : 0) # endif # if !defined(random) && RANDOM_R_PROTO == REENTRANT_PROTO_I_St # define random() (random_r(&PL_reentrant_buffer->_random_struct, &PL_reentrant_buffer->_random_retval) == 0 ? PL_reentrant_buffer->_random_retval : 0) # endif # endif #endif /* HAS_RANDOM_R */ #ifdef HAS_READDIR_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef readdir # if !defined(readdir) && READDIR_R_PROTO == REENTRANT_PROTO_I_TSR # define readdir(a) (readdir_r(a, PL_reentrant_buffer->_readdir_struct, &PL_reentrant_buffer->_readdir_ptr) == 0 ? PL_reentrant_buffer->_readdir_ptr : 0) # endif # if !defined(readdir) && READDIR_R_PROTO == REENTRANT_PROTO_I_TS # define readdir(a) (readdir_r(a, PL_reentrant_buffer->_readdir_struct) == 0 ? PL_reentrant_buffer->_readdir_struct : 0) # endif # endif #endif /* HAS_READDIR_R */ #ifdef HAS_READDIR64_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef readdir64 # if !defined(readdir64) && READDIR64_R_PROTO == REENTRANT_PROTO_I_TSR # define readdir64(a) (readdir64_r(a, PL_reentrant_buffer->_readdir64_struct, &PL_reentrant_buffer->_readdir64_ptr) == 0 ? PL_reentrant_buffer->_readdir64_ptr : 0) # endif # if !defined(readdir64) && READDIR64_R_PROTO == REENTRANT_PROTO_I_TS # define readdir64(a) (readdir64_r(a, PL_reentrant_buffer->_readdir64_struct) == 0 ? PL_reentrant_buffer->_readdir64_struct : 0) # endif # endif #endif /* HAS_READDIR64_R */ #ifdef HAS_SETGRENT_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef setgrent # if !defined(setgrent) && SETGRENT_R_PROTO == REENTRANT_PROTO_I_H # define setgrent() (setgrent_r(&PL_reentrant_buffer->_grent_fptr) == 0 ? 1 : 0) # endif # if !defined(setgrent) && SETGRENT_R_PROTO == REENTRANT_PROTO_V_H # define setgrent() setgrent_r(&PL_reentrant_buffer->_grent_fptr) # endif # endif #endif /* HAS_SETGRENT_R */ #ifdef HAS_SETHOSTENT_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef sethostent # if !defined(sethostent) && SETHOSTENT_R_PROTO == REENTRANT_PROTO_I_ID # define sethostent(a) (sethostent_r(a, &PL_reentrant_buffer->_hostent_data) == 0 ? 1 : 0) # endif # if !defined(sethostent) && SETHOSTENT_R_PROTO == REENTRANT_PROTO_V_ID # define sethostent(a) sethostent_r(a, &PL_reentrant_buffer->_hostent_data) # endif # endif #endif /* HAS_SETHOSTENT_R */ #ifdef HAS_SETLOCALE_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef setlocale # if !defined(setlocale) && SETLOCALE_R_PROTO == REENTRANT_PROTO_I_ICBI # define setlocale(a, b) (setlocale_r(a, b, PL_reentrant_buffer->_setlocale_buffer, PL_reentrant_buffer->_setlocale_size) == 0 ? PL_reentrant_buffer->_setlocale_buffer : 0) # endif # endif #endif /* HAS_SETLOCALE_R */ #ifdef HAS_SETNETENT_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef setnetent # if !defined(setnetent) && SETNETENT_R_PROTO == REENTRANT_PROTO_I_ID # define setnetent(a) (setnetent_r(a, &PL_reentrant_buffer->_netent_data) == 0 ? 1 : 0) # endif # if !defined(setnetent) && SETNETENT_R_PROTO == REENTRANT_PROTO_V_ID # define setnetent(a) setnetent_r(a, &PL_reentrant_buffer->_netent_data) # endif # endif #endif /* HAS_SETNETENT_R */ #ifdef HAS_SETPROTOENT_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef setprotoent # if !defined(setprotoent) && SETPROTOENT_R_PROTO == REENTRANT_PROTO_I_ID # define setprotoent(a) (setprotoent_r(a, &PL_reentrant_buffer->_protoent_data) == 0 ? 1 : 0) # endif # if !defined(setprotoent) && SETPROTOENT_R_PROTO == REENTRANT_PROTO_V_ID # define setprotoent(a) setprotoent_r(a, &PL_reentrant_buffer->_protoent_data) # endif # endif #endif /* HAS_SETPROTOENT_R */ #ifdef HAS_SETPWENT_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef setpwent # if !defined(setpwent) && SETPWENT_R_PROTO == REENTRANT_PROTO_I_H # define setpwent() (setpwent_r(&PL_reentrant_buffer->_pwent_fptr) == 0 ? 1 : 0) # endif # if !defined(setpwent) && SETPWENT_R_PROTO == REENTRANT_PROTO_V_H # define setpwent() setpwent_r(&PL_reentrant_buffer->_pwent_fptr) # endif # endif #endif /* HAS_SETPWENT_R */ #ifdef HAS_SETSERVENT_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef setservent # if !defined(setservent) && SETSERVENT_R_PROTO == REENTRANT_PROTO_I_ID # define setservent(a) (setservent_r(a, &PL_reentrant_buffer->_servent_data) == 0 ? 1 : 0) # endif # if !defined(setservent) && SETSERVENT_R_PROTO == REENTRANT_PROTO_V_ID # define setservent(a) setservent_r(a, &PL_reentrant_buffer->_servent_data) # endif # endif #endif /* HAS_SETSERVENT_R */ #ifdef HAS_SRAND48_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef srand48 # if !defined(srand48) && SRAND48_R_PROTO == REENTRANT_PROTO_I_LS # define srand48(a) (srand48_r(a, &PL_reentrant_buffer->_drand48_struct) == 0 ? &PL_reentrant_buffer->_drand48_struct : 0) # endif # endif #endif /* HAS_SRAND48_R */ #ifdef HAS_SRANDOM_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef srandom # if !defined(srandom) && SRANDOM_R_PROTO == REENTRANT_PROTO_I_TS # define srandom(a) (srandom_r(a, &PL_reentrant_buffer->_srandom_struct) == 0 ? &PL_reentrant_buffer->_srandom_struct : 0) # endif # endif #endif /* HAS_SRANDOM_R */ #ifdef HAS_STRERROR_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef strerror # if !defined(strerror) && STRERROR_R_PROTO == REENTRANT_PROTO_I_IBW # define strerror(a) (strerror_r(a, PL_reentrant_buffer->_strerror_buffer, PL_reentrant_buffer->_strerror_size) == 0 ? PL_reentrant_buffer->_strerror_buffer : 0) # endif # if !defined(strerror) && STRERROR_R_PROTO == REENTRANT_PROTO_I_IBI # define strerror(a) (strerror_r(a, PL_reentrant_buffer->_strerror_buffer, PL_reentrant_buffer->_strerror_size) == 0 ? PL_reentrant_buffer->_strerror_buffer : 0) # endif # if !defined(strerror) && STRERROR_R_PROTO == REENTRANT_PROTO_B_IBW # define strerror(a) strerror_r(a, PL_reentrant_buffer->_strerror_buffer, PL_reentrant_buffer->_strerror_size) # endif # endif #endif /* HAS_STRERROR_R */ #ifdef HAS_TMPNAM_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef tmpnam # if !defined(tmpnam) && TMPNAM_R_PROTO == REENTRANT_PROTO_B_B # define tmpnam(a) tmpnam_r(a) # endif # endif #endif /* HAS_TMPNAM_R */ #ifdef HAS_TTYNAME_R # if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1) # undef ttyname # if !defined(ttyname) && TTYNAME_R_PROTO == REENTRANT_PROTO_I_IBW # define ttyname(a) (ttyname_r(a, PL_reentrant_buffer->_ttyname_buffer, PL_reentrant_buffer->_ttyname_size) == 0 ? PL_reentrant_buffer->_ttyname_buffer : 0) # endif # if !defined(ttyname) && TTYNAME_R_PROTO == REENTRANT_PROTO_I_IBI # define ttyname(a) (ttyname_r(a, PL_reentrant_buffer->_ttyname_buffer, PL_reentrant_buffer->_ttyname_size) == 0 ? PL_reentrant_buffer->_ttyname_buffer : 0) # endif # if !defined(ttyname) && TTYNAME_R_PROTO == REENTRANT_PROTO_B_IBI # define ttyname(a) ttyname_r(a, PL_reentrant_buffer->_ttyname_buffer, PL_reentrant_buffer->_ttyname_size) # endif # endif #endif /* HAS_TTYNAME_R */ #endif /* USE_REENTRANT_API */ #endif /* ex: set ro: */ perl-5.12.0-RC0/README.amiga0000444000175000017500000001556711325125741014101 0ustar jessejesseIf you read this file _as_is_, just ignore the funny characters you see. It is written in the POD format (see perlpod manpage) which is specially designed to be readable as is. =head1 NAME perlamiga - Perl under Amiga OS =head1 NOTE B if you want to help fixing this problem.> =head1 SYNOPSIS One can read this document in the following formats: man perlamiga multiview perlamiga.guide to list some (not all may be available simultaneously), or it may be read I: either as F, or F. A recent version of perl for the Amiga can be found at the Geek Gadgets section of the Aminet: http://www.aminet.net/~aminet/dev/gg =cut Contents perlamiga - Perl under Amiga OS NAME SYNOPSIS DESCRIPTION - Prerequisites - Starting Perl programs under AmigaOS - Shortcomings of Perl under AmigaOS INSTALLATION Accessing documentation - Manpages - HTML - GNU info files - LaTeX docs BUILD - Build Prerequisites - Getting the perl source - Application of the patches - Making - Testing - Installing the built perl AUTHOR SEE ALSO =head1 DESCRIPTION =head2 Prerequisites for Compiling Perl on AmigaOS =over 6 =item B You need the Unix emulation for AmigaOS, whose most important part is B. For a minimum setup, get the latest versions of the following packages from the Aminet archives ( http://www.aminet.net/~aminet/ ): ixemul-bin ixemul-env-bin pdksh-bin Note also that this is a minimum setup; you might want to add other packages of B (the I). =item B You need at the very least AmigaOS version 2.0. Recommended is version 3.1. =back =head2 Starting Perl programs under AmigaOS Start your Perl program F with arguments C the same way as on any other platform, by perl foo arg1 arg2 arg3 If you want to specify perl options C<-my_opts> to the perl itself (as opposed to your program), use perl -my_opts foo arg1 arg2 arg3 Alternately, you can try to get a replacement for the system's B command that honors the #!/usr/bin/perl syntax in scripts and set the s-Bit of your scripts. Then you can invoke your scripts like under UNIX with foo arg1 arg2 arg3 (Note that having *nixish full path to perl F is not necessary, F would be enough, but having full path would make it easier to use your script under *nix.) =head2 Shortcomings of Perl under AmigaOS Perl under AmigaOS lacks some features of perl under UNIX because of deficiencies in the UNIX-emulation, most notably: =over 6 =item * fork() =item * some features of the UNIX filesystem regarding link count and file dates =item * inplace operation (the -i switch) without backup file =item * umask() works, but the correct permissions are only set when the file is finally close()d =back =head1 INSTALLATION Change to the installation directory (most probably ADE:), and extract the binary distribution: lha -mraxe x perl-$VERSION-bin.lha or tar xvzpf perl-$VERSION-bin.tgz (Of course you need lha or tar and gunzip for this.) For installation of the Unix emulation, read the appropriate docs. =head1 Accessing documentation =head2 Manpages for Perl on AmigaOS If you have C installed on your system, and you installed perl manpages, use something like this: man perlfunc man less man ExtUtils.MakeMaker to access documentation for different components of Perl. Start with man perl Note: You have to modify your man.conf file to search for manpages in the /ade/lib/perl5/man/man3 directory, or the man pages for the perl library will not be found. Note that dot (F<.>) is used as a package separator for documentation for packages, and as usual, sometimes you need to give the section - C<3> above - to avoid shadowing by the I. =head2 Perl HTML Documentation on AmigaOS If you have some WWW browser available, you can build B docs. Cd to directory with F<.pod> files, and do like this cd /ade/lib/perl5/pod pod2html After this you can direct your browser the file F in this directory, and go ahead with reading docs. Alternatively you may be able to get these docs prebuilt from C. =head2 Perl GNU Info Files on AmigaOS Users of C would appreciate it very much, especially with C mode loaded. You need to get latest C from C, or, alternately, prebuilt info pages. =head2 Perl LaTeX Documentation on AmigaOS Can be constructed using C. =head1 BUILDING PERL ON AMIGAOS Here we discuss how to build Perl under AmigaOS. =head2 Build Prerequisites for Perl on AmigaOS You need to have the latest B (Unix emulation for Amiga) from Aminet. =head2 Getting the Perl Source for AmigaOS You can either get the latest perl-for-amiga source from Ninemoons and extract it with: tar xvzpf perl-$VERSION-src.tgz or get the official source from CPAN: http://www.cpan.org/src/5.0 Extract it like this tar xvzpf perl-$VERSION.tar.gz You will see a message about errors while extracting F. This is normal and expected. (There is a conflict with a similarly-named file F, but it causes no harm.) =head2 Making Perl on AmigaOS Remember to use a hefty wad of stack (I use 2000000) sh configure.gnu --prefix=/gg Now type make depend Now! make =head2 Testing Perl on AmigaOS Now run make test Some tests will be skipped because they need the fork() function: F, F, F, F, F, F, F =head2 Installing the built Perl on AmigaOS Run make install =head1 PERL 5.8.0 BROKEN IN AMIGAOS As told above, Perl 5.6.1 was still good in AmigaOS, as was 5.7.2. After Perl 5.7.2 (change #11423, see the Changes file, and the file pod/perlhack.pod for how to get the individual changes) Perl dropped its internal support for vfork(), and that was very probably the step that broke AmigaOS (since the ixemul library has only vfork). The build finally fails when the ext/DynaLoader is being built, and PERL ends up as "0" in the produced Makefile, trying to run "0" does not quite work. Also, executing miniperl in backticks seems to generate nothing: very probably related to the (v)fork problems. B =head1 AUTHORS Norbert Pueschel, pueschel@imsdd.meb.uni-bonn.de Jan-Erik Karlsson, trg@privat.utfors.se =head1 SEE ALSO perl(1). =cut perl-5.12.0-RC0/pp_sys.c0000444000175000017500000040161611333417500013613 0ustar jessejesse/* pp_sys.c * * Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, * 2004, 2005, 2006, 2007, 2008 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * But only a short way ahead its floor and the walls on either side were * cloven by a great fissure, out of which the red glare came, now leaping * up, now dying down into darkness; and all the while far below there was * a rumour and a trouble as of great engines throbbing and labouring. * * [p.945 of _The Lord of the Rings_, VI/iii: "Mount Doom"] */ /* This file contains system pp ("push/pop") functions that * execute the opcodes that make up a perl program. A typical pp function * expects to find its arguments on the stack, and usually pushes its * results onto the stack, hence the 'pp' terminology. Each OP structure * contains a pointer to the relevant pp_foo() function. * * By 'system', we mean ops which interact with the OS, such as pp_open(). */ #include "EXTERN.h" #define PERL_IN_PP_SYS_C #include "perl.h" #include "time64.h" #include "time64.c" #ifdef I_SHADOW /* Shadow password support for solaris - pdo@cs.umd.edu * Not just Solaris: at least HP-UX, IRIX, Linux. * The API is from SysV. * * There are at least two more shadow interfaces, * see the comments in pp_gpwent(). * * --jhi */ # ifdef __hpux__ /* There is a MAXINT coming from <- <- * and another MAXINT from "perl.h" <- . */ # undef MAXINT # endif # include #endif #ifdef I_SYS_WAIT # include #endif #ifdef I_SYS_RESOURCE # include #endif #ifdef NETWARE NETDB_DEFINE_CONTEXT #endif #ifdef HAS_SELECT # ifdef I_SYS_SELECT # include # endif #endif /* XXX Configure test needed. h_errno might not be a simple 'int', especially for multi-threaded applications, see "extern int errno in perl.h". Creating such a test requires taking into account the differences between compiling multithreaded and singlethreaded ($ccflags et al). HOST_NOT_FOUND is typically defined in . */ #if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__) extern int h_errno; #endif #ifdef HAS_PASSWD # ifdef I_PWD # include # else # if !defined(VMS) struct passwd *getpwnam (char *); struct passwd *getpwuid (Uid_t); # endif # endif # ifdef HAS_GETPWENT #ifndef getpwent struct passwd *getpwent (void); #elif defined (VMS) && defined (my_getpwent) struct passwd *Perl_my_getpwent (pTHX); #endif # endif #endif #ifdef HAS_GROUP # ifdef I_GRP # include # else struct group *getgrnam (char *); struct group *getgrgid (Gid_t); # endif # ifdef HAS_GETGRENT #ifndef getgrent struct group *getgrent (void); #endif # endif #endif #ifdef I_UTIME # if defined(_MSC_VER) || defined(__MINGW32__) # include # else # include # endif #endif #ifdef HAS_CHSIZE # ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */ # undef my_chsize # endif # define my_chsize PerlLIO_chsize #else # ifdef HAS_TRUNCATE # define my_chsize PerlLIO_chsize # else I32 my_chsize(int fd, Off_t length); # endif #endif #ifdef HAS_FLOCK # define FLOCK flock #else /* no flock() */ /* fcntl.h might not have been included, even if it exists, because the current Configure only sets I_FCNTL if it's needed to pick up the *_OK constants. Make sure it has been included before testing the fcntl() locking constants. */ # if defined(HAS_FCNTL) && !defined(I_FCNTL) # include # endif # if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK) # define FLOCK fcntl_emulate_flock # define FCNTL_EMULATE_FLOCK # else /* no flock() or fcntl(F_SETLK,...) */ # ifdef HAS_LOCKF # define FLOCK lockf_emulate_flock # define LOCKF_EMULATE_FLOCK # endif /* lockf */ # endif /* no flock() or fcntl(F_SETLK,...) */ # ifdef FLOCK static int FLOCK (int, int); /* * These are the flock() constants. Since this sytems doesn't have * flock(), the values of the constants are probably not available. */ # ifndef LOCK_SH # define LOCK_SH 1 # endif # ifndef LOCK_EX # define LOCK_EX 2 # endif # ifndef LOCK_NB # define LOCK_NB 4 # endif # ifndef LOCK_UN # define LOCK_UN 8 # endif # endif /* emulating flock() */ #endif /* no flock() */ #define ZBTLEN 10 static const char zero_but_true[ZBTLEN + 1] = "0 but true"; #if defined(I_SYS_ACCESS) && !defined(R_OK) # include #endif #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC) # define FD_CLOEXEC 1 /* NeXT needs this */ #endif #include "reentr.h" #ifdef __Lynx__ /* Missing protos on LynxOS */ void sethostent(int); void endhostent(void); void setnetent(int); void endnetent(void); void setprotoent(int); void endprotoent(void); void setservent(int); void endservent(void); #endif #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */ /* F_OK unused: if stat() cannot find it... */ #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK) /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */ # define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK)) #endif #if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS) # ifdef I_SYS_SECURITY # include # endif # ifdef ACC_SELF /* HP SecureWare */ # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF)) # else /* SCO */ # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f))) # endif #endif #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF) /* AIX */ # define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF)) #endif #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \ && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \ || defined(HAS_SETREGID) || defined(HAS_SETRESGID)) /* The Hard Way. */ STATIC int S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) { const Uid_t ruid = getuid(); const Uid_t euid = geteuid(); const Gid_t rgid = getgid(); const Gid_t egid = getegid(); int res; #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID) Perl_croak(aTHX_ "switching effective uid is not implemented"); #else #ifdef HAS_SETREUID if (setreuid(euid, ruid)) #else #ifdef HAS_SETRESUID if (setresuid(euid, ruid, (Uid_t)-1)) #endif #endif Perl_croak(aTHX_ "entering effective uid failed"); #endif #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID) Perl_croak(aTHX_ "switching effective gid is not implemented"); #else #ifdef HAS_SETREGID if (setregid(egid, rgid)) #else #ifdef HAS_SETRESGID if (setresgid(egid, rgid, (Gid_t)-1)) #endif #endif Perl_croak(aTHX_ "entering effective gid failed"); #endif res = access(path, mode); #ifdef HAS_SETREUID if (setreuid(ruid, euid)) #else #ifdef HAS_SETRESUID if (setresuid(ruid, euid, (Uid_t)-1)) #endif #endif Perl_croak(aTHX_ "leaving effective uid failed"); #ifdef HAS_SETREGID if (setregid(rgid, egid)) #else #ifdef HAS_SETRESGID if (setresgid(rgid, egid, (Gid_t)-1)) #endif #endif Perl_croak(aTHX_ "leaving effective gid failed"); return res; } # define PERL_EFF_ACCESS(p,f) (S_emulate_eaccess(aTHX_ (p), (f))) #endif PP(pp_backtick) { dVAR; dSP; dTARGET; PerlIO *fp; const char * const tmps = POPpconstx; const I32 gimme = GIMME_V; const char *mode = "r"; TAINT_PROPER("``"); if (PL_op->op_private & OPpOPEN_IN_RAW) mode = "rb"; else if (PL_op->op_private & OPpOPEN_IN_CRLF) 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; sv_setpvs(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!" */ } else { STATUS_NATIVE_CHILD_SET(-1); if (gimme == G_SCALAR) RETPUSHUNDEF; } RETURN; } PP(pp_glob) { dVAR; OP *result; tryAMAGICunTARGET(iter, -1); /* Note that we only ever get here if File::Glob fails to load * without at the same time croaking, for some reason, or if * perl was built with PERL_EXTERNAL_GLOB */ ENTER_with_name("glob"); #ifndef VMS if (PL_tainting) { /* * 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 */ SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */ PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--); SAVESPTR(PL_rs); /* This is not permanent, either. */ PL_rs = newSVpvs_flags("\000", SVs_TEMP); #ifndef DOSISH #ifndef CSH *SvPVX(PL_rs) = '\n'; #endif /* !CSH */ #endif /* !DOSISH */ result = do_readline(); LEAVE_with_name("glob"); return result; } PP(pp_rcatline) { dVAR; PL_last_in_gv = cGVOP_gv; return do_readline(); } PP(pp_warn) { dVAR; dSP; dMARK; SV *tmpsv; const char *tmps; STRLEN len; if (SP - MARK > 1) { dTARGET; do_join(TARG, &PL_sv_no, MARK, SP); tmpsv = TARG; SP = MARK + 1; } else if (SP == MARK) { tmpsv = &PL_sv_no; EXTEND(SP, 1); SP = MARK + 1; } else { tmpsv = TOPs; } tmps = SvPV_const(tmpsv, len); if ((!tmps || !len) && PL_errgv) { SV * const error = ERRSV; SvUPGRADE(error, SVt_PV); if (SvPOK(error) && SvCUR(error)) sv_catpvs(error, "\t...caught"); tmpsv = error; tmps = SvPV_const(tmpsv, len); } if (!tmps || !len) tmpsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP); Perl_warn(aTHX_ "%"SVf, SVfARG(tmpsv)); RETSETYES; } PP(pp_die) { dVAR; dSP; dMARK; const char *tmps; SV *tmpsv; STRLEN len; bool multiarg = 0; #ifdef VMS VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH); #endif if (SP - MARK != 1) { dTARGET; do_join(TARG, &PL_sv_no, MARK, SP); tmpsv = TARG; tmps = SvPV_const(tmpsv, len); multiarg = 1; SP = MARK + 1; } else { tmpsv = TOPs; tmps = SvROK(tmpsv) ? (const char *)NULL : SvPV_const(tmpsv, len); } if (!tmps || !len) { SV * const error = ERRSV; SvUPGRADE(error, SVt_PV); if (multiarg ? SvROK(error) : SvROK(tmpsv)) { if (!multiarg) SvSetSV(error,tmpsv); else if (sv_isobject(error)) { HV * const stash = SvSTASH(SvRV(error)); 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(error); PUSHs(file); PUSHs(line); PUTBACK; call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR|G_EVAL|G_KEEPERR); sv_setsv(error,*PL_stack_sp--); } } DIE(aTHX_ NULL); } else { if (SvPOK(error) && SvCUR(error)) sv_catpvs(error, "\t...propagated"); tmpsv = error; if (SvOK(tmpsv)) tmps = SvPV_const(tmpsv, len); else tmps = NULL; } } if (!tmps || !len) tmpsv = newSVpvs_flags("Died", SVs_TEMP); DIE(aTHX_ "%"SVf, SVfARG(tmpsv)); RETURN; } /* I/O. */ PP(pp_open) { dVAR; dSP; dMARK; dORIGMARK; dTARGET; SV *sv; IO *io; const char *tmps; STRLEN len; bool ok; GV * const gv = MUTABLE_GV(*++MARK); if (!isGV(gv)) DIE(aTHX_ PL_no_usym, "filehandle"); if ((io = GvIOp(gv))) { MAGIC *mg; IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT; if (IoDIRP(io)) Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED), "Opening dirhandle %s also as a file", GvENAME(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 */ *MARK-- = SvTIED_obj(MUTABLE_SV(io), mg); PUSHMARK(MARK); PUTBACK; ENTER_with_name("call_OPEN"); call_method("OPEN", G_SCALAR); LEAVE_with_name("call_OPEN"); SPAGAIN; RETURN; } } if (MARK < SP) { sv = *++MARK; } else { sv = GvSVn(gv); } tmps = SvPV_const(sv, len); ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK)); SP = ORIGMARK; if (ok) PUSHi( (I32)PL_forkprocess ); else if (PL_forkprocess == 0) /* we are a new child */ PUSHi(0); else RETPUSHUNDEF; RETURN; } PP(pp_close) { dVAR; dSP; GV * const gv = (MAXARG == 0) ? PL_defoutgv : MUTABLE_GV(POPs); if (gv) { IO * const io = GvIO(gv); if (io) { MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { PUSHMARK(SP); XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg)); PUTBACK; ENTER_with_name("call_CLOSE"); call_method("CLOSE", G_SCALAR); LEAVE_with_name("call_CLOSE"); SPAGAIN; RETURN; } } } EXTEND(SP, 1); PUSHs(boolSV(do_close(gv, TRUE))); RETURN; } PP(pp_pipe_op) { #ifdef HAS_PIPE dVAR; dSP; register IO *rstio; register IO *wstio; int fd[2]; GV * const wgv = MUTABLE_GV(POPs); GV * const rgv = MUTABLE_GV(POPs); if (!rgv || !wgv) goto badexit; if (!isGV_with_GP(rgv) || !isGV_with_GP(wgv)) DIE(aTHX_ PL_no_usym, "filehandle"); rstio = GvIOn(rgv); wstio = GvIOn(wgv); if (IoIFP(rstio)) do_close(rgv, FALSE); if (IoIFP(wstio)) do_close(wgv, FALSE); if (PerlProc_pipe(fd) < 0) goto badexit; IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE); IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE); IoOFP(rstio) = IoIFP(rstio); IoIFP(wstio) = IoOFP(wstio); IoTYPE(rstio) = IoTYPE_RDONLY; 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 defined(HAS_FCNTL) && defined(F_SETFD) fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */ fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */ #endif RETPUSHYES; badexit: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_func, "pipe"); return NORMAL; #endif } PP(pp_fileno) { dVAR; dSP; dTARGET; GV *gv; IO *io; PerlIO *fp; MAGIC *mg; if (MAXARG < 1) RETPUSHUNDEF; gv = MUTABLE_GV(POPs); if (gv && (io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) { PUSHMARK(SP); XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg)); PUTBACK; ENTER_with_name("call_FILENO"); call_method("FILENO", G_SCALAR); LEAVE_with_name("call_FILENO"); SPAGAIN; RETURN; } if (!gv || !(io = GvIO(gv)) || !(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. if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); */ RETPUSHUNDEF; } PUSHi(PerlIO_fileno(fp)); RETURN; } PP(pp_umask) { dVAR; dSP; #ifdef HAS_UMASK dTARGET; Mode_t anum; if (MAXARG < 1) { 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); TAINT_PROPER("umask"); XPUSHi(anum); #else /* Only DIE if trying to restrict permissions on "user" (self). * Otherwise it's harmless and more useful to just return undef * since 'group' and 'other' concepts probably don't exist here. */ if (MAXARG >= 1 && (POPi & 0700)) DIE(aTHX_ "umask not implemented"); XPUSHs(&PL_sv_undef); #endif RETURN; } PP(pp_binmode) { dVAR; dSP; GV *gv; IO *io; PerlIO *fp; SV *discp = NULL; if (MAXARG < 1) RETPUSHUNDEF; if (MAXARG > 1) { discp = POPs; } gv = MUTABLE_GV(POPs); if (gv && (io = GvIO(gv))) { MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { PUSHMARK(SP); XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg)); if (discp) XPUSHs(discp); PUTBACK; ENTER_with_name("call_BINMODE"); call_method("BINMODE", G_SCALAR); LEAVE_with_name("call_BINMODE"); SPAGAIN; RETURN; } } EXTEND(SP, 1); if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) { if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); 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; } } } PP(pp_tie) { dVAR; dSP; dMARK; HV* stash; GV *gv = NULL; SV *sv; const I32 markoff = MARK - PL_stack_base; const char *methname; int how = PERL_MAGIC_tied; U32 items; SV *varsv = *++MARK; switch(SvTYPE(varsv)) { case SVt_PVHV: methname = "TIEHASH"; HvEITER_set(MUTABLE_HV(varsv), 0); break; case SVt_PVAV: methname = "TIEARRAY"; break; case SVt_PVGV: if (isGV_with_GP(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; } /* FALL THROUGH */ 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); } else { /* Not clear why we don't call call_method here too. * perhaps to get different error message ? */ STRLEN len; const char *name = SvPV_nomg_const(*MARK, len); stash = gv_stashpvn(name, len, 0); if (!stash || !(gv = gv_fetchmethod(stash, methname))) { DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"", methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no)); } 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); } LEAVE_with_name("call_TIE"); SP = PL_stack_base + markoff; PUSHs(sv); RETURN; } PP(pp_untie) { dVAR; dSP; MAGIC *mg; SV *sv = POPs; const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar; if (isGV_with_GP(sv) && !(sv = MUTABLE_SV(GvIOp(sv)))) RETPUSHYES; if ((mg = SvTIED_mg(sv, how))) { SV * const obj = SvRV(SvTIED_obj(sv, mg)); if (obj) { GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE); CV *cv; if (gv && isGV(gv) && (cv = GvCV(gv))) { PUSHMARK(SP); XPUSHs(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 ) ; } } } sv_unmagic(sv, how) ; RETPUSHYES; } PP(pp_tied) { dVAR; dSP; const MAGIC *mg; SV *sv = POPs; const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar; if (isGV_with_GP(sv) && !(sv = MUTABLE_SV(GvIOp(sv)))) RETPUSHUNDEF; if ((mg = SvTIED_mg(sv, how))) { SV *osv = SvTIED_obj(sv, mg); if (osv == mg->mg_obj) osv = sv_mortalcopy(osv); PUSHs(osv); RETURN; } RETPUSHUNDEF; } PP(pp_dbmopen) { dVAR; dSP; dPOPPOPssrl; HV* stash; GV *gv = NULL; HV * const hv = MUTABLE_HV(POPs); 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"); } ENTER; PUSHMARK(SP); EXTEND(SP, 5); PUSHs(sv); PUSHs(left); if (SvIV(right)) mPUSHu(O_RDWR|O_CREAT); else mPUSHu(O_RDWR); PUSHs(right); PUTBACK; call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR); 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; } if (sv_isobject(TOPs)) { sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied); sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0); } LEAVE; RETURN; } PP(pp_sselect) { #ifdef HAS_SELECT dVAR; dSP; dTARGET; register I32 i; register I32 j; register char *s; register SV *sv; NV value; I32 maxlen = 0; I32 nfound; struct timeval timebuf; struct timeval *tbuf = &timebuf; I32 growsize; char *fd_sets[4]; #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 I32 masksize; I32 offset; I32 k; # if BYTEORDER & 0xf0000 # define ORDERBYTE (0x88888888 - BYTEORDER) # else # define ORDERBYTE (0x4444 - BYTEORDER) # endif #endif SP -= 4; for (i = 1; i <= 3; i++) { SV * const sv = SP[i]; if (!SvOK(sv)) continue; if (SvREADONLY(sv)) { if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0)) DIE(aTHX_ "%s", PL_no_modify); } if (!SvPOK(sv)) { Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask"); SvPV_force_nolen(sv); /* force string conversion */ } j = SvCUR(sv); if (maxlen < j) maxlen = j; } /* little endians can use vecs directly */ #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 # ifdef NFDBITS # ifndef NBBY # define NBBY 8 # endif masksize = NFDBITS / NBBY; # else masksize = sizeof(long); /* documented int, everyone seems to use long */ # endif Zero(&fd_sets[0], 4, char*); #endif # if SELECT_MIN_BITS == 1 growsize = sizeof(fd_set); # else # if defined(__GLIBC__) && defined(__FD_SETSIZE) # undef SELECT_MIN_BITS # define SELECT_MIN_BITS __FD_SETSIZE # endif /* If SELECT_MIN_BITS is greater than one we most probably will want * to align the sizes with SELECT_MIN_BITS/8 because for example * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates * on (sets/tests/clears bits) is 32 bits. */ growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8))); # endif sv = SP[4]; if (SvOK(sv)) { value = SvNV(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; for (i = 1; i <= 3; i++) { sv = SP[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]; } #else fd_sets[i] = SvPVX(sv); #endif } #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST /* 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. */ #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); #endif for (i = 1; i <= 3; i++) { if (fd_sets[i]) { sv = SP[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]); #endif SvSETMAGIC(sv); } } PUSHi(nfound); if (GIMME == G_ARRAY && tbuf) { value = (NV)(timebuf.tv_sec) + (NV)(timebuf.tv_usec) / 1000000.0; mPUSHn(value); } RETURN; #else DIE(aTHX_ "select not implemented"); return NORMAL; #endif } /* =for apidoc setdefout Sets PL_defoutgv, the default file handle for output, to the passed in typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference count of the passed in typeglob is increased by one, and the reference count of the typeglob that PL_defoutgv points to is decreased by one. =cut */ void Perl_setdefout(pTHX_ GV *gv) { dVAR; SvREFCNT_inc_simple_void(gv); SvREFCNT_dec(PL_defoutgv); PL_defoutgv = gv; } PP(pp_select) { dVAR; dSP; dTARGET; HV *hv; GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL; GV * egv = GvEGV(PL_defoutgv); if (!egv) egv = PL_defoutgv; hv = GvSTASH(egv); if (! hv) XPUSHs(&PL_sv_undef); else { GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE); if (gvp && *gvp == egv) { gv_efullname4(TARG, PL_defoutgv, NULL, TRUE); XPUSHTARG; } else { mXPUSHs(newRV(MUTABLE_SV(egv))); } } if (newdefout) { if (!GvIO(newdefout)) gv_IOadd(newdefout); setdefout(newdefout); } RETURN; } PP(pp_getc) { dVAR; dSP; dTARGET; IO *io = NULL; GV * const gv = (MAXARG==0) ? PL_stdingv : MUTABLE_GV(POPs); if (gv && (io = GvIO(gv))) { MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { const I32 gimme = GIMME_V; PUSHMARK(SP); XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg)); PUTBACK; ENTER; call_method("GETC", gimme); LEAVE; SPAGAIN; if (gimme == G_SCALAR) SvSetMagicSV_nosteal(TARG, TOPs); RETURN; } } if (!gv || do_eof(gv)) { /* make sure we have fp with something */ if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY)) && ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); 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); } PUSHTARG; RETURN; } STATIC OP * S_doform(pTHX_ CV *cv, GV *gv, OP *retop) { dVAR; register PERL_CONTEXT *cx; const I32 gimme = GIMME_V; PERL_ARGS_ASSERT_DOFORM; ENTER; SAVETMPS; PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp); PUSHFORMAT(cx, retop); SAVECOMPPAD(); PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1); setdefout(gv); /* locally select filehandle so $% et al work */ return CvSTART(cv); } PP(pp_enterwrite) { dVAR; dSP; register GV *gv; register IO *io; GV *fgv; CV *cv = NULL; SV *tmpsv = NULL; if (MAXARG == 0) gv = PL_defoutgv; else { gv = MUTABLE_GV(POPs); if (!gv) gv = PL_defoutgv; } EXTEND(SP, 1); io = GvIO(gv); if (!io) { RETPUSHNO; } if (IoFMT_GV(io)) fgv = IoFMT_GV(io); else fgv = gv; if (!fgv) goto not_a_format_reference; cv = GvFORM(fgv); if (!cv) { const char *name; tmpsv = sv_newmortal(); gv_efullname4(tmpsv, fgv, NULL, FALSE); name = SvPV_nolen_const(tmpsv); if (name && *name) DIE(aTHX_ "Undefined format \"%s\" called", name); not_a_format_reference: DIE(aTHX_ "Not a format reference"); } if (CvCLONE(cv)) cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv)))); IoFLAGS(io) &= ~IOf_DIDTOP; return doform(cv,gv,PL_op->op_next); } PP(pp_leavewrite) { dVAR; dSP; GV * const gv = cxstack[cxstack_ix].blk_format.gv; register IO * const io = GvIOp(gv); PerlIO *ofp; PerlIO *fp; SV **newsp; I32 gimme; register PERL_CONTEXT *cx; if (!io || !(ofp = IoOFP(io))) goto forget_top; DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n", (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget))); if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) && 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_ "%s_TOP", GvNAME(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); if (lines <= 0) /* Yow, header didn't even fit!!! */ goto forget_top; while (lines-- > 0) { s = strchr(s, '\n'); 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(PL_formfeed, ofp); IoLINES_LEFT(io) = IoPAGE_LEN(io); IoPAGE(io)++; PL_formtarget = PL_toptarget; IoFLAGS(io) |= IOf_DIDTOP; fgv = IoTOP_GV(io); if (!fgv) DIE(aTHX_ "bad top format reference"); cv = GvFORM(fgv); if (!cv) { SV * const sv = sv_newmortal(); const char *name; gv_efullname4(sv, fgv, NULL, FALSE); name = SvPV_nolen_const(sv); if (name && *name) DIE(aTHX_ "Undefined top format \"%s\" called", name); else DIE(aTHX_ "Undefined top format called"); } if (cv && CvCLONE(cv)) cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv)))); return doform(cv, gv, PL_op); } forget_top: POPBLOCK(cx,PL_curpm); POPFORMAT(cx); LEAVE; fp = IoOFP(io); if (!fp) { if (ckWARN2(WARN_CLOSED,WARN_IO)) { if (IoIFP(io)) report_evil_fh(gv, io, OP_phoney_INPUT_ONLY); else if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); } 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); } } /* bad_ofp: */ PL_formtarget = PL_bodytarget; PUTBACK; PERL_UNUSED_VAR(newsp); PERL_UNUSED_VAR(gimme); return cx->blk_sub.retop; } PP(pp_prtf) { dVAR; dSP; dMARK; dORIGMARK; IO *io; PerlIO *fp; SV *sv; GV * const gv = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv; if (gv && (io = GvIO(gv))) { 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; } PUSHMARK(MARK - 1); *MARK = SvTIED_obj(MUTABLE_SV(io), mg); PUTBACK; ENTER; call_method("PRINTF", G_SCALAR); LEAVE; SPAGAIN; MARK = ORIGMARK + 1; *MARK = *SP; SP = MARK; RETURN; } } sv = newSV(0); if (!(io = GvIO(gv))) { if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); SETERRNO(EBADF,RMS_IFI); goto just_say_no; } else if (!(fp = IoOFP(io))) { if (ckWARN2(WARN_CLOSED,WARN_IO)) { if (IoIFP(io)) report_evil_fh(gv, io, OP_phoney_INPUT_ONLY); else if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); } SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI); goto just_say_no; } else { if (SvTAINTED(MARK[1])) TAINT_PROPER("printf"); 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; } SvREFCNT_dec(sv); SP = ORIGMARK; PUSHs(&PL_sv_yes); RETURN; just_say_no: SvREFCNT_dec(sv); SP = ORIGMARK; PUSHs(&PL_sv_undef); RETURN; } PP(pp_sysopen) { dVAR; dSP; const int perm = (MAXARG > 3) ? POPi : 0666; const int mode = POPi; SV * const sv = POPs; GV * const gv = MUTABLE_GV(POPs); STRLEN len; /* Need TIEHANDLE method ? */ const char * const tmps = SvPV_const(sv, len); /* FIXME? do_open should do const */ if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) { IoLINES(GvIOp(gv)) = 0; PUSHs(&PL_sv_yes); } else { PUSHs(&PL_sv_undef); } RETURN; } PP(pp_sysread) { dVAR; dSP; dMARK; dORIGMARK; dTARGET; int offset; IO *io; char *buffer; SSize_t length; SSize_t count; Sock_size_t bufsize; SV *bufsv; STRLEN blen; int fp_utf8; int buffer_utf8; SV *read_target; Size_t got = 0; Size_t wanted; bool charstart = FALSE; STRLEN charskip = 0; STRLEN skip = 0; GV * const gv = MUTABLE_GV(*++MARK); if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) && gv && (io = GvIO(gv)) ) { const MAGIC * mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { SV *sv; PUSHMARK(MARK-1); *MARK = SvTIED_obj(MUTABLE_SV(io), mg); ENTER; call_method("READ", G_SCALAR); LEAVE; SPAGAIN; sv = POPs; SP = ORIGMARK; PUSHs(sv); RETURN; } } if (!gv) goto say_undef; bufsv = *++MARK; if (! SvOK(bufsv)) sv_setpvs(bufsv, ""); length = SvIVx(*++MARK); SETERRNO(0,0); if (MARK < SP) offset = SvIVx(*++MARK); else offset = 0; io = GvIO(gv); if (!io || !IoIFP(io)) { if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); SETERRNO(EBADF,RMS_IFI); goto say_undef; } if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) { 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 = !IN_BYTES && SvUTF8(bufsv); } if (length < 0) DIE(aTHX_ "Negative length"); wanted = length; charstart = TRUE; charskip = 0; skip = 0; #ifdef HAS_SOCKET if (PL_op->op_type == OP_RECV) { char namebuf[MAXPATHLEN]; #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__) bufsize = sizeof (struct sockaddr_in); #else 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(PerlIO_fileno(IoIFP(io)), buffer, length, offset, (struct sockaddr *)namebuf, &bufsize); if (count < 0) RETPUSHUNDEF; #ifdef EPOC /* Bogus return without padding */ bufsize = sizeof (struct sockaddr_in); #endif 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; sv_setpvn(TARG, namebuf, bufsize); PUSHs(TARG); RETURN; } #else if (PL_op->op_type == OP_RECV) DIE(aTHX_ PL_no_sock_func, "recv"); #endif if (DO_UTF8(bufsv)) { /* offset adjust in characters not bytes */ blen = sv_len_utf8(bufsv); } if (offset < 0) { if (-offset > (int)blen) DIE(aTHX_ "Offset outside string"); offset += blen; } if (DO_UTF8(bufsv)) { /* convert offset-as-chars to offset-as-bytes */ if (offset >= (int)blen) offset += SvCUR(bufsv) - blen; else offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer; } more_bytes: bufsize = SvCUR(bufsv); /* Allocating length + offset + 1 isn't perfect in the case of reading bytes from a byte file handle into a UTF8 buffer, but it won't harm us unduly. (should be 2 * length + offset + 1, or possibly something longer if PL_encoding is true) */ buffer = SvGROW(bufsv, (STRLEN)(length+offset+1)); if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */ Zero(buffer+bufsize, offset-bufsize, char); } buffer = buffer + offset; if (!buffer_utf8) { read_target = bufsv; } else { /* 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); 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) { count = PerlSock_recv(PerlIO_fileno(IoIFP(io)), buffer, length, 0); } else #endif { count = PerlLIO_read(PerlIO_fileno(IoIFP(io)), buffer, length); } } else #ifdef HAS_SOCKET__bad_code_maybe if (IoTYPE(io) == IoTYPE_SOCKET) { char namebuf[MAXPATHLEN]; #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS) bufsize = sizeof (struct sockaddr_in); #else bufsize = sizeof namebuf; #endif count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0, (struct sockaddr *)namebuf, &bufsize); } else #endif { 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) && ckWARN(WARN_IO)) report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY); 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; } } /* 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); } 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); } SvSETMAGIC(bufsv); /* This should not be marked tainted if the fp is marked clean */ if (!(IoFLAGS(io) & IOf_UNTAINT)) SvTAINTED_on(bufsv); SP = ORIGMARK; PUSHi(count); RETURN; say_undef: SP = ORIGMARK; RETPUSHUNDEF; } PP(pp_send) { dVAR; dSP; dMARK; dORIGMARK; dTARGET; IO *io; SV *bufsv; const char *buffer; SSize_t retval; STRLEN blen; STRLEN orig_blen_bytes; const int op_type = PL_op->op_type; bool doing_utf8; U8 *tmpbuf = NULL; GV *const gv = MUTABLE_GV(*++MARK); if (PL_op->op_type == OP_SYSWRITE && gv && (io = GvIO(gv))) { MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { SV *sv; if (MARK == SP - 1) { sv = *SP; mXPUSHi(sv_len(sv)); PUTBACK; } PUSHMARK(ORIGMARK); *(ORIGMARK+1) = SvTIED_obj(MUTABLE_SV(io), mg); ENTER; call_method("WRITE", G_SCALAR); LEAVE; SPAGAIN; sv = POPs; SP = ORIGMARK; PUSHs(sv); RETURN; } } if (!gv) goto say_undef; bufsv = *++MARK; SETERRNO(0,0); io = GvIO(gv); if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) { retval = -1; if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) { if (io && IoIFP(io)) report_evil_fh(gv, io, OP_phoney_INPUT_ONLY); else report_evil_fh(gv, io, PL_op->op_type); } SETERRNO(EBADF,RMS_IFI); goto say_undef; } /* Do this first to trigger any overloading. */ buffer = SvPV_const(bufsv, blen); orig_blen_bytes = blen; doing_utf8 = DO_UTF8(bufsv); if (PerlIO_isutf8(IoIFP(io))) { if (!SvUTF8(bufsv)) { /* We don't modify the original scalar. */ tmpbuf = bytes_to_utf8((const U8*) buffer, &blen); buffer = (char *) tmpbuf; doing_utf8 = TRUE; } } 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)); } } if (op_type == OP_SYSWRITE) { Size_t length = 0; /* This length is in characters. */ STRLEN blen_chars; IV offset; if (doing_utf8) { if (tmpbuf) { /* The SV is bytes, and we've had to upgrade it. */ blen_chars = orig_blen_bytes; } else { /* The SV really is UTF-8. */ if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) { /* Don't call sv_len_utf8 again because it will call magic or overloading a second time, and we might get back a different result. */ blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen); } else { /* It's safe, and it may well be cached. */ blen_chars = sv_len_utf8(bufsv); } } } else { blen_chars = blen; } if (MARK >= SP) { length = blen_chars; } else { #if Size_t_size > IVSIZE 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_chars) { Safefree(tmpbuf); DIE(aTHX_ "Offset outside string"); } offset += blen_chars; } else if (offset > (IV)blen_chars) { Safefree(tmpbuf); DIE(aTHX_ "Offset outside string"); } } else offset = 0; if (length > blen_chars - offset) length = blen_chars - offset; if (doing_utf8) { /* Here we convert length from characters to bytes. */ if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) { /* Either we had to convert the SV, or the SV is magical, or the SV has overloading, in which case we can't or mustn't or mustn't call it again. */ buffer = (const char*)utf8_hop((const U8 *)buffer, offset); length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer; } else { /* It's a real UTF-8 SV, and it's not going to change under us. Take advantage of any cache. */ I32 start = offset; I32 len_I32 = length; /* Convert the start and end character positions to bytes. Remember that the second argument to sv_pos_u2b is relative to the first. */ sv_pos_u2b(bufsv, &start, &len_I32); buffer += start; length = len_I32; } } else { buffer = buffer+offset; } #ifdef PERL_SOCK_SYSWRITE_IS_SEND if (IoTYPE(io) == IoTYPE_SOCKET) { retval = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, length, 0); } else #endif { /* See the note at doio.c:do_print about filesize limits. --jhi */ retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)), buffer, length); } } #ifdef HAS_SOCKET else { const int flags = SvIVx(*++MARK); if (SP > MARK) { STRLEN mlen; char * const sockbuf = SvPVx(*++MARK, mlen); retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, flags, (struct sockaddr *)sockbuf, mlen); } else { retval = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags); } } #else else DIE(aTHX_ PL_no_sock_func, "send"); #endif if (retval < 0) goto say_undef; SP = ORIGMARK; if (doing_utf8) retval = utf8_length((U8*)buffer, (U8*)buffer + retval); Safefree(tmpbuf); #if Size_t_size > IVSIZE PUSHn(retval); #else PUSHi(retval); #endif RETURN; say_undef: Safefree(tmpbuf); SP = ORIGMARK; RETPUSHUNDEF; } PP(pp_eof) { dVAR; dSP; GV *gv; IO *io; MAGIC *mg; if (MAXARG) gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */ else if (PL_op->op_flags & OPf_SPECIAL) gv = PL_last_in_gv = GvEGV(PL_argvgv); /* eof() - ARGV magic */ else gv = PL_last_in_gv; /* eof */ if (!gv) RETPUSHNO; if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) { PUSHMARK(SP); XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg)); /* * in Perl 5.12 and later, the additional paramter is a bitmask: * 0 = eof * 1 = eof(FH) * 2 = eof() <- ARGV magic */ if (MAXARG) mPUSHi(1); /* 1 = eof(FH) - simple, explicit FH */ else if (PL_op->op_flags & OPf_SPECIAL) mPUSHi(2); /* 2 = eof() - ARGV magic */ else mPUSHi(0); /* 0 = eof - simple, implicit FH */ PUTBACK; ENTER; call_method("EOF", G_SCALAR); LEAVE; SPAGAIN; RETURN; } if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */ if (io && !IoIFP(io)) { if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) { IoLINES(io) = 0; IoFLAGS(io) &= ~IOf_START; do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL); if (GvSV(gv)) sv_setpvs(GvSV(gv), "-"); else GvSV(gv) = newSVpvs("-"); SvSETMAGIC(GvSV(gv)); } else if (!nextargv(gv)) RETPUSHYES; } } PUSHs(boolSV(do_eof(gv))); RETURN; } PP(pp_tell) { dVAR; dSP; dTARGET; GV *gv; IO *io; if (MAXARG != 0) PL_last_in_gv = MUTABLE_GV(POPs); gv = PL_last_in_gv; if (gv && (io = GvIO(gv))) { MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { PUSHMARK(SP); XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg)); PUTBACK; ENTER; call_method("TELL", G_SCALAR); LEAVE; SPAGAIN; RETURN; } } else if (!gv) { if (!errno) SETERRNO(EBADF,RMS_IFI); PUSHi(-1); RETURN; } #if LSEEKSIZE > IVSIZE PUSHn( do_tell(gv) ); #else PUSHi( do_tell(gv) ); #endif RETURN; } PP(pp_sysseek) { dVAR; dSP; const int whence = POPi; #if LSEEKSIZE > IVSIZE const Off_t offset = (Off_t)SvNVx(POPs); #else const Off_t offset = (Off_t)SvIVx(POPs); #endif GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs); IO *io; if (gv && (io = GvIO(gv))) { MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { PUSHMARK(SP); XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg)); #if LSEEKSIZE > IVSIZE mXPUSHn((NV) offset); #else mXPUSHi(offset); #endif mXPUSHi(whence); PUTBACK; ENTER; call_method("SEEK", G_SCALAR); LEAVE; SPAGAIN; RETURN; } } if (PL_op->op_type == OP_SEEK) PUSHs(boolSV(do_seek(gv, offset, whence))); else { const Off_t sought = do_sysseek(gv, offset, whence); if (sought < 0) PUSHs(&PL_sv_undef); else { SV* const sv = sought ? #if LSEEKSIZE > IVSIZE newSVnv((NV)sought) #else newSViv(sought) #endif : newSVpvn(zero_but_true, ZBTLEN); mPUSHs(sv); } } RETURN; } PP(pp_truncate) { dVAR; dSP; /* There seems to be no consensus on the length type of truncate() * and ftruncate(), both off_t and size_t have supporters. In * general one would think that when using large files, off_t is * at least as wide as size_t, so using an off_t should be okay. */ /* XXX Configure probe for the length type of *truncate() needed XXX */ Off_t len; #if Off_t_size > IVSIZE len = (Off_t)POPn; #else len = (Off_t)POPi; #endif /* Checking for length < 0 is problematic as the type might or * might not be signed: if it is not, clever compilers will moan. */ /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */ SETERRNO(0,0); { int result = 1; GV *tmpgv; IO *io; if (PL_op->op_flags & OPf_SPECIAL) { tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO); do_ftruncate_gv: if (!GvIO(tmpgv)) result = 0; else { PerlIO *fp; io = GvIOp(tmpgv); do_ftruncate_io: TAINT_PROPER("truncate"); if (!(fp = IoIFP(io))) { result = 0; } else { PerlIO_flush(fp); #ifdef HAS_TRUNCATE if (ftruncate(PerlIO_fileno(fp), len) < 0) #else if (my_chsize(PerlIO_fileno(fp), len) < 0) #endif result = 0; } } } else { SV * const sv = POPs; const char *name; if (isGV_with_GP(sv)) { tmpgv = MUTABLE_GV(sv); /* *main::FRED for example */ goto do_ftruncate_gv; } else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) { tmpgv = MUTABLE_GV(SvRV(sv)); /* \*main::FRED for example */ goto do_ftruncate_gv; } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */ goto do_ftruncate_io; } name = SvPV_nolen_const(sv); TAINT_PROPER("truncate"); #ifdef HAS_TRUNCATE if (truncate(name, len) < 0) result = 0; #else { const int tmpfd = PerlLIO_open(name, O_RDWR); 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; } } PP(pp_ioctl) { dVAR; dSP; dTARGET; SV * const argsv = POPs; const unsigned int func = POPu; const int optype = PL_op->op_type; GV * const gv = MUTABLE_GV(POPs); IO * const io = gv ? GvIOn(gv) : NULL; char *s; IV retval; if (!io || !argsv || !IoIFP(io)) { if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); 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); } s[SvCUR(argsv)] = 17; /* a little sanity check here */ } else { retval = SvIV(argsv); s = INT2PTR(char*,retval); /* ouch */ } TAINT_PROPER(PL_op_desc[optype]); if (optype == OP_IOCTL) #ifdef HAS_IOCTL retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s); #else DIE(aTHX_ "ioctl is not implemented"); #endif else #ifndef HAS_FCNTL DIE(aTHX_ "fcntl is not implemented"); #else #if defined(OS2) && defined(__EMX__) retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s); #else retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s); #endif #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 (retval == -1) RETPUSHUNDEF; if (retval != 0) { PUSHi(retval); } else { PUSHp(zero_but_true, ZBTLEN); } #endif RETURN; } PP(pp_flock) { #ifdef FLOCK dVAR; dSP; dTARGET; I32 value; IO *io = NULL; PerlIO *fp; const int argtype = POPi; GV * const gv = (MAXARG == 0) ? PL_last_in_gv : MUTABLE_GV(POPs); if (gv && (io = GvIO(gv))) fp = IoIFP(io); else { fp = NULL; io = NULL; } /* 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); } else { if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); value = 0; SETERRNO(EBADF,RMS_IFI); } PUSHi(value); RETURN; #else DIE(aTHX_ PL_no_func, "flock()"); return NORMAL; #endif } /* Sockets. */ PP(pp_socket) { #ifdef HAS_SOCKET dVAR; dSP; const int protocol = POPi; const int type = POPi; const int domain = POPi; GV * const gv = MUTABLE_GV(POPs); register IO * const io = gv ? GvIOn(gv) : NULL; int fd; if (!gv || !io) { if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); if (io && IoIFP(io)) do_close(gv, FALSE); SETERRNO(EBADF,LIB_INVARG); RETPUSHUNDEF; } if (IoIFP(io)) do_close(gv, FALSE); TAINT_PROPER("socket"); fd = PerlSock_socket(domain, type, protocol); if (fd < 0) 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 defined(HAS_FCNTL) && defined(F_SETFD) fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */ #endif #ifdef EPOC setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */ #endif RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "socket"); return NORMAL; #endif } PP(pp_sockpair) { #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET)) dVAR; dSP; const int protocol = POPi; const int type = POPi; const int domain = POPi; GV * const gv2 = MUTABLE_GV(POPs); GV * const gv1 = MUTABLE_GV(POPs); register IO * const io1 = gv1 ? GvIOn(gv1) : NULL; register IO * const io2 = gv2 ? GvIOn(gv2) : NULL; int fd[2]; if (!gv1 || !gv2 || !io1 || !io2) { if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) { if (!gv1 || !io1) report_evil_fh(gv1, io1, PL_op->op_type); if (!gv2 || !io2) report_evil_fh(gv1, io2, PL_op->op_type); } if (io1 && IoIFP(io1)) do_close(gv1, FALSE); if (io2 && IoIFP(io2)) do_close(gv2, FALSE); RETPUSHUNDEF; } if (IoIFP(io1)) do_close(gv1, FALSE); if (IoIFP(io2)) do_close(gv2, FALSE); TAINT_PROPER("socketpair"); if (PerlSock_socketpair(domain, type, protocol, fd) < 0) 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; IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE); 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 defined(HAS_FCNTL) && defined(F_SETFD) fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */ fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */ #endif RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "socketpair"); return NORMAL; #endif } PP(pp_bind) { #ifdef HAS_SOCKET dVAR; dSP; SV * const addrsv = POPs; /* OK, so on what platform does bind modify addr? */ const char *addr; GV * const gv = MUTABLE_GV(POPs); register IO * const io = GvIOn(gv); STRLEN len; if (!io || !IoIFP(io)) goto nuts; addr = SvPV_const(addrsv, len); TAINT_PROPER("bind"); if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0) RETPUSHYES; else RETPUSHUNDEF; nuts: if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); SETERRNO(EBADF,SS_IVCHAN); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "bind"); return NORMAL; #endif } PP(pp_connect) { #ifdef HAS_SOCKET dVAR; dSP; SV * const addrsv = POPs; GV * const gv = MUTABLE_GV(POPs); register IO * const io = GvIOn(gv); const char *addr; STRLEN len; if (!io || !IoIFP(io)) goto nuts; addr = SvPV_const(addrsv, len); TAINT_PROPER("connect"); if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0) RETPUSHYES; else RETPUSHUNDEF; nuts: if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); SETERRNO(EBADF,SS_IVCHAN); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "connect"); return NORMAL; #endif } PP(pp_listen) { #ifdef HAS_SOCKET dVAR; dSP; const int backlog = POPi; GV * const gv = MUTABLE_GV(POPs); register IO * const io = gv ? GvIOn(gv) : NULL; if (!gv || !io || !IoIFP(io)) goto nuts; if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0) RETPUSHYES; else RETPUSHUNDEF; nuts: if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); SETERRNO(EBADF,SS_IVCHAN); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "listen"); return NORMAL; #endif } PP(pp_accept) { #ifdef HAS_SOCKET dVAR; dSP; dTARGET; register IO *nstio; register IO *gstio; char namebuf[MAXPATHLEN]; #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__) Sock_size_t len = sizeof (struct sockaddr_in); #else Sock_size_t len = sizeof namebuf; #endif GV * const ggv = MUTABLE_GV(POPs); GV * const ngv = MUTABLE_GV(POPs); int fd; if (!ngv) goto badexit; if (!ggv) goto nuts; gstio = GvIO(ggv); if (!gstio || !IoIFP(gstio)) goto nuts; nstio = GvIOn(ngv); fd = PerlSock_accept(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; } #endif if (fd < 0) goto badexit; if (IoIFP(nstio)) 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 defined(HAS_FCNTL) && defined(F_SETFD) fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */ #endif #ifdef EPOC len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */ setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */ #endif #ifdef __SCO_VERSION__ len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */ #endif PUSHp(namebuf, len); RETURN; nuts: if (ckWARN(WARN_CLOSED)) report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type); SETERRNO(EBADF,SS_IVCHAN); badexit: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "accept"); return NORMAL; #endif } PP(pp_shutdown) { #ifdef HAS_SOCKET dVAR; dSP; dTARGET; const int how = POPi; GV * const gv = MUTABLE_GV(POPs); register IO * const io = GvIOn(gv); if (!io || !IoIFP(io)) goto nuts; PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 ); RETURN; nuts: if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); SETERRNO(EBADF,SS_IVCHAN); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "shutdown"); return NORMAL; #endif } PP(pp_ssockopt) { #ifdef HAS_SOCKET dVAR; dSP; const int optype = PL_op->op_type; SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs; const unsigned int optname = (unsigned int) POPi; const unsigned int lvl = (unsigned int) POPi; GV * const gv = MUTABLE_GV(POPs); register IO * const io = GvIOn(gv); int fd; Sock_size_t len; if (!io || !IoIFP(io)) goto nuts; fd = PerlIO_fileno(IoIFP(io)); 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; SvCUR_set(sv, len); *SvEND(sv) ='\0'; PUSHs(sv); break; case OP_SSOCKOPT: { #if defined(__SYMBIAN32__) # define SETSOCKOPT_OPTION_VALUE_T void * #else # define SETSOCKOPT_OPTION_VALUE_T const char * #endif /* XXX TODO: We need to have a proper type (a Configure probe, * etc.) for what the C headers think of the third argument of * setsockopt(), the option_value read-only buffer: is it * a "char *", or a "void *", const or not. Some compilers * don't take kindly to e.g. assuming that "char *" implicitly * promotes to a "void *", or to explicitly promoting/demoting * consts to non/vice versa. The "const void *" is the SUS * definition, but that does not fly everywhere for the above * reasons. */ SETSOCKOPT_OPTION_VALUE_T buf; int aint; if (SvPOKp(sv)) { STRLEN l; buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l); len = l; } else { aint = (int)SvIV(sv); buf = (SETSOCKOPT_OPTION_VALUE_T) &aint; len = sizeof(int); } if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0) goto nuts2; PUSHs(&PL_sv_yes); } break; } RETURN; nuts: if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, optype); SETERRNO(EBADF,SS_IVCHAN); nuts2: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); return NORMAL; #endif } PP(pp_getpeername) { #ifdef HAS_SOCKET dVAR; dSP; const int optype = PL_op->op_type; GV * const gv = MUTABLE_GV(POPs); register IO * const io = GvIOn(gv); Sock_size_t len; SV *sv; int fd; if (!io || !IoIFP(io)) goto nuts; sv = sv_2mortal(newSV(257)); (void)SvPOK_only(sv); len = 256; SvCUR_set(sv, len); *SvEND(sv) ='\0'; fd = PerlIO_fileno(IoIFP(io)); switch (optype) { case OP_GETSOCKNAME: 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 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; } #ifdef BOGUS_GETNAME_RETURN /* Interactive Unix, getpeername() and getsockname() does not return valid namelen */ if (len == BOGUS_GETNAME_RETURN) len = sizeof(struct sockaddr); #endif SvCUR_set(sv, len); *SvEND(sv) ='\0'; PUSHs(sv); RETURN; nuts: if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, optype); SETERRNO(EBADF,SS_IVCHAN); nuts2: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); return NORMAL; #endif } /* Stat calls. */ PP(pp_stat) { dVAR; dSP; GV *gv = NULL; IO *io; I32 gimme; I32 max = 13; if (PL_op->op_flags & OPf_REF) { gv = cGVOP_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", gv ? GvENAME(gv) : ""); } else if (PL_laststype != OP_LSTAT) Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat"); } do_fstat: if (gv != PL_defgv) { PL_laststype = OP_STAT; PL_statgv = gv; sv_setpvs(PL_statname, ""); if(gv) { io = GvIO(gv); do_fstat_have_io: if (io) { if (IoIFP(io)) { PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache); } else if (IoDIRP(io)) { PL_laststatval = PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache); } else { PL_laststatval = -1; } } } } if (PL_laststatval < 0) { if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, GvIO(gv), PL_op->op_type); max = 0; } } else { SV* const sv = POPs; if (isGV_with_GP(sv)) { gv = MUTABLE_GV(sv); goto do_fstat; } else if(SvROK(sv) && isGV_with_GP(SvRV(sv))) { gv = MUTABLE_GV(SvRV(sv)); if (PL_op->op_type == OP_LSTAT) goto do_fstat_warning_check; goto do_fstat; } else 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; } sv_setpv(PL_statname, SvPV_nolen_const(sv)); PL_statgv = NULL; PL_laststype = PL_op->op_type; if (PL_op->op_type == OP_LSTAT) PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache); else PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache); if (PL_laststatval < 0) { if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n')) Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat"); max = 0; } } gimme = GIMME_V; if (gimme != G_ARRAY) { if (gimme != G_VOID) XPUSHs(boolSV(max)); RETURN; } if (max) { EXTEND(SP, max); EXTEND_MORTAL(max); mPUSHi(PL_statcache.st_dev); mPUSHi(PL_statcache.st_ino); mPUSHu(PL_statcache.st_mode); mPUSHu(PL_statcache.st_nlink); #if Uid_t_size > IVSIZE mPUSHn(PL_statcache.st_uid); #else # if Uid_t_sign <= 0 mPUSHi(PL_statcache.st_uid); # else mPUSHu(PL_statcache.st_uid); # endif #endif #if Gid_t_size > IVSIZE mPUSHn(PL_statcache.st_gid); #else # if Gid_t_sign <= 0 mPUSHi(PL_statcache.st_gid); # else mPUSHu(PL_statcache.st_gid); # endif #endif #ifdef USE_STAT_RDEV mPUSHi(PL_statcache.st_rdev); #else PUSHs(newSVpvs_flags("", SVs_TEMP)); #endif #if Off_t_size > IVSIZE mPUSHn(PL_statcache.st_size); #else mPUSHi(PL_statcache.st_size); #endif #ifdef BIG_TIME 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); #endif #ifdef USE_STAT_BLOCKS mPUSHu(PL_statcache.st_blksize); mPUSHu(PL_statcache.st_blocks); #else PUSHs(newSVpvs_flags("", SVs_TEMP)); PUSHs(newSVpvs_flags("", SVs_TEMP)); #endif } RETURN; } /* This macro is used by the stacked filetest operators : * if the previous filetest failed, short-circuit and pass its value. * Else, discard it from the stack and continue. --rgs */ #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \ if (!SvTRUE(TOPs)) { RETURN; } \ else { (void)POPs; PUTBACK; } \ } PP(pp_ftrread) { dVAR; I32 result; /* Not const, because things tweak this below. Not bool, because there's no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */ #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS) I32 use_access = PL_op->op_private & OPpFT_ACCESS; /* Giving some sort of initial value silences compilers. */ # ifdef R_OK int access_mode = R_OK; # else int access_mode = 0; # endif #else /* access_mode is never used, but leaving use_access in makes the conditional compiling below much clearer. */ I32 use_access = 0; #endif int stat_mode = S_IRUSR; bool effective = FALSE; char opchar = '?'; dSP; switch (PL_op->op_type) { case OP_FTRREAD: opchar = 'R'; break; case OP_FTRWRITE: opchar = 'W'; break; case OP_FTREXEC: opchar = 'X'; break; case OP_FTEREAD: opchar = 'r'; break; case OP_FTEWRITE: opchar = 'w'; break; case OP_FTEEXEC: opchar = 'x'; break; } tryAMAGICftest(opchar); STACKED_FTEST_CHECK; switch (PL_op->op_type) { case OP_FTRREAD: #if !(defined(HAS_ACCESS) && defined(R_OK)) use_access = 0; #endif break; case OP_FTRWRITE: #if defined(HAS_ACCESS) && defined(W_OK) access_mode = W_OK; #else use_access = 0; #endif stat_mode = S_IWUSR; break; case OP_FTREXEC: #if defined(HAS_ACCESS) && defined(X_OK) access_mode = X_OK; #else use_access = 0; #endif stat_mode = S_IXUSR; break; case OP_FTEWRITE: #ifdef PERL_EFF_ACCESS access_mode = W_OK; #endif stat_mode = S_IWUSR; /* fall through */ case OP_FTEREAD: #ifndef PERL_EFF_ACCESS use_access = 0; #endif effective = TRUE; break; case OP_FTEEXEC: #ifdef PERL_EFF_ACCESS access_mode = X_OK; #else use_access = 0; #endif stat_mode = S_IXUSR; effective = TRUE; break; } if (use_access) { #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS) const char *name = POPpx; if (effective) { # ifdef PERL_EFF_ACCESS result = PERL_EFF_ACCESS(name, access_mode); # else DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s", OP_NAME(PL_op)); # endif } else { # ifdef HAS_ACCESS result = access(name, access_mode); # else DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op)); # endif } if (result == 0) RETPUSHYES; if (result < 0) RETPUSHUNDEF; RETPUSHNO; #endif } result = my_stat(); SPAGAIN; if (result < 0) RETPUSHUNDEF; if (cando(stat_mode, effective, &PL_statcache)) RETPUSHYES; RETPUSHNO; } PP(pp_ftis) { dVAR; I32 result; const int op_type = PL_op->op_type; char opchar = '?'; dSP; switch (op_type) { case OP_FTIS: opchar = 'e'; break; case OP_FTSIZE: opchar = 's'; break; case OP_FTMTIME: opchar = 'M'; break; case OP_FTCTIME: opchar = 'C'; break; case OP_FTATIME: opchar = 'A'; break; } tryAMAGICftest(opchar); STACKED_FTEST_CHECK; result = my_stat(); SPAGAIN; if (result < 0) RETPUSHUNDEF; if (op_type == OP_FTIS) RETPUSHYES; { /* 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 PUSHn(PL_statcache.st_size); #else PUSHi(PL_statcache.st_size); #endif break; case OP_FTMTIME: PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 ); break; case OP_FTATIME: PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 ); break; case OP_FTCTIME: PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 ); break; } } RETURN; } PP(pp_ftrowned) { dVAR; I32 result; char opchar = '?'; dSP; switch (PL_op->op_type) { case OP_FTROWNED: opchar = 'O'; break; case OP_FTEOWNED: opchar = 'o'; break; case OP_FTZERO: opchar = 'z'; break; case OP_FTSOCK: opchar = 'S'; break; case OP_FTCHR: opchar = 'c'; break; case OP_FTBLK: opchar = 'b'; break; case OP_FTFILE: opchar = 'f'; break; case OP_FTDIR: opchar = 'd'; break; case OP_FTPIPE: opchar = 'p'; break; case OP_FTSUID: opchar = 'u'; break; case OP_FTSGID: opchar = 'g'; break; case OP_FTSVTX: opchar = 'k'; break; } tryAMAGICftest(opchar); /* I believe that all these three are likely to be defined on most every system these days. */ #ifndef S_ISUID if(PL_op->op_type == OP_FTSUID) RETPUSHNO; #endif #ifndef S_ISGID if(PL_op->op_type == OP_FTSGID) RETPUSHNO; #endif #ifndef S_ISVTX if(PL_op->op_type == OP_FTSVTX) RETPUSHNO; #endif STACKED_FTEST_CHECK; result = my_stat(); SPAGAIN; if (result < 0) RETPUSHUNDEF; switch (PL_op->op_type) { case OP_FTROWNED: if (PL_statcache.st_uid == PL_uid) RETPUSHYES; break; case OP_FTEOWNED: if (PL_statcache.st_uid == PL_euid) RETPUSHYES; break; case OP_FTZERO: if (PL_statcache.st_size == 0) RETPUSHYES; break; case OP_FTSOCK: if (S_ISSOCK(PL_statcache.st_mode)) RETPUSHYES; break; case OP_FTCHR: if (S_ISCHR(PL_statcache.st_mode)) RETPUSHYES; break; case OP_FTBLK: if (S_ISBLK(PL_statcache.st_mode)) RETPUSHYES; break; case OP_FTFILE: if (S_ISREG(PL_statcache.st_mode)) RETPUSHYES; break; case OP_FTDIR: if (S_ISDIR(PL_statcache.st_mode)) RETPUSHYES; break; case OP_FTPIPE: if (S_ISFIFO(PL_statcache.st_mode)) RETPUSHYES; break; #ifdef S_ISUID case OP_FTSUID: if (PL_statcache.st_mode & S_ISUID) RETPUSHYES; break; #endif #ifdef S_ISGID case OP_FTSGID: if (PL_statcache.st_mode & S_ISGID) RETPUSHYES; break; #endif #ifdef S_ISVTX case OP_FTSVTX: if (PL_statcache.st_mode & S_ISVTX) RETPUSHYES; break; #endif } RETPUSHNO; } PP(pp_ftlink) { dVAR; dSP; I32 result; tryAMAGICftest('l'); result = my_lstat(); SPAGAIN; if (result < 0) RETPUSHUNDEF; if (S_ISLNK(PL_statcache.st_mode)) RETPUSHYES; RETPUSHNO; } PP(pp_fttty) { dVAR; dSP; int fd; GV *gv; SV *tmpsv = NULL; tryAMAGICftest('t'); STACKED_FTEST_CHECK; if (PL_op->op_flags & OPf_REF) gv = cGVOP_gv; else if (isGV(TOPs)) gv = MUTABLE_GV(POPs); else if (SvROK(TOPs) && isGV(SvRV(TOPs))) gv = MUTABLE_GV(SvRV(POPs)); else gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO); if (GvIO(gv) && IoIFP(GvIOp(gv))) fd = PerlIO_fileno(IoIFP(GvIOp(gv))); else if (tmpsv && SvOK(tmpsv)) { const char *tmps = SvPV_nolen_const(tmpsv); if (isDIGIT(*tmps)) fd = atoi(tmps); else RETPUSHUNDEF; } else RETPUSHUNDEF; if (PerlLIO_isatty(fd)) RETPUSHYES; RETPUSHNO; } #if defined(atarist) /* this will work with atariST. Configure will make guesses for other systems. */ # define FILE_base(f) ((f)->_base) # define FILE_ptr(f) ((f)->_ptr) # define FILE_cnt(f) ((f)->_cnt) # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base)) #endif PP(pp_fttext) { dVAR; dSP; I32 i; I32 len; I32 odd = 0; STDCHAR tbuf[512]; register STDCHAR *s; register IO *io; register SV *sv; GV *gv; PerlIO *fp; tryAMAGICftest(PL_op->op_type == OP_FTTEXT ? 'T' : 'B'); STACKED_FTEST_CHECK; if (PL_op->op_flags & OPf_REF) gv = cGVOP_gv; else if (isGV(TOPs)) gv = MUTABLE_GV(POPs); else if (SvROK(TOPs) && isGV(SvRV(TOPs))) gv = MUTABLE_GV(SvRV(POPs)); else gv = NULL; if (gv) { EXTEND(SP, 1); if (gv == PL_defgv) { if (PL_statgv) io = GvIO(PL_statgv); else { sv = PL_statname; goto really_filename; } } else { PL_statgv = gv; PL_laststatval = -1; sv_setpvs(PL_statname, ""); io = GvIO(PL_statgv); } if (io && IoIFP(io)) { if (! PerlIO_has_base(IoIFP(io))) DIE(aTHX_ "-T and -B not implemented on filehandles"); PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache); if (PL_laststatval < 0) RETPUSHUNDEF; if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */ if (PL_op->op_type == OP_FTTEXT) RETPUSHNO; else RETPUSHYES; } 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) /* null file is anything */ RETPUSHYES; 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 { if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) { gv = cGVOP_gv; report_evil_fh(gv, GvIO(gv), PL_op->op_type); } SETERRNO(EBADF,RMS_IFI); RETPUSHUNDEF; } } else { sv = POPs; really_filename: PL_statgv = NULL; PL_laststype = OP_STAT; sv_setpv(PL_statname, SvPV_nolen_const(sv)); if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) { if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n')) Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open"); RETPUSHUNDEF; } PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache); if (PL_laststatval < 0) { (void)PerlIO_close(fp); RETPUSHUNDEF; } 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) RETPUSHNO; /* special case NFS directories */ RETPUSHYES; /* null file is anything */ } s = tbuf; } /* now scan s to look for textiness */ /* XXX ASCII dependent code */ #if defined(DOSISH) || defined(USEMYBINMODE) /* ignore trailing ^Z on short files */ if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26) --len; #endif for (i = 0; i < len; i++, s++) { if (!*s) { /* null never allowed in text */ odd += len; break; } #ifdef EBCDIC else if (!(isPRINT(*s) || isSPACE(*s))) odd++; #else else if (*s & 128) { #ifdef USE_LOCALE if (IN_LOCALE_RUNTIME && isALPHA_LC(*s)) continue; #endif /* utf8 characters don't count as odd */ if (UTF8_IS_START(*s)) { int ulen = UTF8SKIP(s); if (ulen < len - i) { int j; for (j = 1; j < ulen; j++) { if (!UTF8_IS_CONTINUATION(s[j])) goto not_utf8; } --ulen; /* loop does extra increment */ s += ulen; i += ulen; continue; } } not_utf8: odd++; } else if (*s < 32 && *s != '\n' && *s != '\r' && *s != '\b' && *s != '\t' && *s != '\f' && *s != 27) odd++; #endif } if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */ RETPUSHNO; else RETPUSHYES; } /* File calls. */ PP(pp_chdir) { dVAR; dSP; dTARGET; const char *tmps = NULL; GV *gv = NULL; if( MAXARG == 1 ) { SV * const sv = POPs; if (PL_op->op_flags & OPf_SPECIAL) { gv = gv_fetchsv(sv, 0, SVt_PVIO); } else if (isGV_with_GP(sv)) { gv = MUTABLE_GV(sv); } else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) { gv = MUTABLE_GV(SvRV(sv)); } else { tmps = SvPV_nolen_const(sv); } } if( !gv && (!tmps || !*tmps) ) { HV * const table = GvHVn(PL_envgv); SV **svp; if ( (svp = hv_fetchs(table, "HOME", FALSE)) || (svp = hv_fetchs(table, "LOGDIR", FALSE)) #ifdef VMS || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE)) #endif ) { if( MAXARG == 1 ) deprecate("chdir('') or chdir(undef) as chdir()"); tmps = SvPV_nolen_const(*svp); } else { PUSHi(0); TAINT_PROPER("chdir"); RETURN; } } 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)) { PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0); } else { if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); SETERRNO(EBADF, RMS_IFI); PUSHi(0); } } else { if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); SETERRNO(EBADF,RMS_IFI); PUSHi(0); } #else DIE(aTHX_ PL_no_func, "fchdir"); #endif } else PUSHi( PerlDir_chdir(tmps) >= 0 ); #ifdef VMS /* Clear the DEFAULT element of ENV so we'll get the new value * in the future. */ hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD); #endif RETURN; } PP(pp_chown) { dVAR; dSP; dMARK; dTARGET; const I32 value = (I32)apply(PL_op->op_type, MARK, SP); SP = MARK; XPUSHi(value); RETURN; } PP(pp_chroot) { #ifdef HAS_CHROOT dVAR; dSP; dTARGET; char * const tmps = POPpx; TAINT_PROPER("chroot"); PUSHi( chroot(tmps) >= 0 ); RETURN; #else DIE(aTHX_ PL_no_func, "chroot"); return NORMAL; #endif } PP(pp_rename) { dVAR; dSP; dTARGET; int anum; const char * const tmps2 = POPpconstx; const char * const tmps = SvPV_nolen_const(TOPs); TAINT_PROPER("rename"); #ifdef HAS_RENAME anum = PerlLIO_rename(tmps, tmps2); #else if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) { if (same_dirent(tmps2, tmps)) /* can always rename to same name */ anum = 1; else { if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode)) (void)UNLINK(tmps2); if (!(anum = link(tmps, tmps2))) anum = UNLINK(tmps); } } #endif SETi( anum >= 0 ); RETURN; } #if defined(HAS_LINK) || defined(HAS_SYMLINK) PP(pp_link) { dVAR; dSP; dTARGET; const int op_type = PL_op->op_type; int result; # ifndef HAS_LINK if (op_type == OP_LINK) DIE(aTHX_ PL_no_func, "link"); # endif # ifndef HAS_SYMLINK if (op_type == OP_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 = # if defined(HAS_LINK) # if defined(HAS_SYMLINK) /* Both present - need to choose which. */ (op_type == OP_LINK) ? PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2); # else /* Only have link, so calls to pp_symlink will have DIE()d above. */ PerlLIO_link(tmps, tmps2); # endif # else # if defined(HAS_SYMLINK) /* Only have symlink, so calls to pp_link will have DIE()d above. */ symlink(tmps, tmps2); # endif # endif } SETi( result >= 0 ); RETURN; } #else PP(pp_link) { /* Have neither. */ DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); return NORMAL; } #endif PP(pp_readlink) { dVAR; dSP; #ifdef HAS_SYMLINK dTARGET; const char *tmps; char buf[MAXPATHLEN]; int len; #ifndef INCOMPLETE_TAINTS TAINT; #endif tmps = POPpconstx; len = readlink(tmps, buf, sizeof(buf) - 1); EXTEND(SP, 1); if (len < 0) RETPUSHUNDEF; PUSHp(buf, len); RETURN; #else EXTEND(SP, 1); RETSETUNDEF; /* just pretend it's a normal file */ #endif } #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR) STATIC int S_dooneliner(pTHX_ const char *cmd, const char *filename) { char * const save_filename = filename; char *cmdline; char *s; PerlIO *myfp; int anum = 1; Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10; PERL_ARGS_ASSERT_DOONELINER; Newx(cmdline, size, char); my_strlcpy(cmdline, cmd, size); my_strlcat(cmdline, " ", size); for (s = cmdline + strlen(cmdline); *filename; ) { *s++ = '\\'; *s++ = *filename++; } if (s - cmdline < size) 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; #ifdef HAS_SYS_ERRLIST e <= sys_nerr #endif ; e++) { /* you don't see this */ const char * const errmsg = #ifdef HAS_SYS_ERRLIST sys_errlist[e] #else strerror(e) #endif ; 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 */ anum = (PerlLIO_stat(save_filename, &PL_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; } #endif /* This macro removes trailing slashes from a directory name. * Different operating and file systems take differently to * trailing slashes. According to POSIX 1003.1 1996 Edition * any number of trailing slashes should be allowed. * Thusly we snip them away so that even non-conforming * systems are happy. * We should probably do this "filtering" for all * the functions that expect (potentially) directory names: * -d, chdir(), chmod(), chown(), chroot(), fcntl()?, * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */ #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; \ } PP(pp_mkdir) { dVAR; dSP; dTARGET; STRLEN len; const char *tmps; bool copy = FALSE; const int mode = (MAXARG > 1) ? POPi : 0777; TRIMSLASHES(tmps,len,copy); TAINT_PROPER("mkdir"); #ifdef HAS_MKDIR SETi( PerlDir_mkdir(tmps, mode) >= 0 ); #else { int oldumask; SETi( dooneliner("mkdir", tmps) ); oldumask = PerlLIO_umask(0); PerlLIO_umask(oldumask); PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777); } #endif if (copy) Safefree(tmps); RETURN; } PP(pp_rmdir) { dVAR; dSP; dTARGET; STRLEN len; const char *tmps; bool copy = FALSE; TRIMSLASHES(tmps,len,copy); TAINT_PROPER("rmdir"); #ifdef HAS_RMDIR SETi( PerlDir_rmdir(tmps) >= 0 ); #else SETi( dooneliner("rmdir", tmps) ); #endif if (copy) Safefree(tmps); RETURN; } /* Directory calls. */ PP(pp_open_dir) { #if defined(Direntry_t) && defined(HAS_READDIR) dVAR; dSP; const char * const dirname = POPpconstx; GV * const gv = MUTABLE_GV(POPs); register IO * const io = GvIOn(gv); if (!io) goto nope; if ((IoIFP(io) || IoOFP(io))) Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED), "Opening filehandle %s also as a directory", GvENAME(gv)); if (IoDIRP(io)) PerlDir_close(IoDIRP(io)); if (!(IoDIRP(io) = PerlDir_open(dirname))) goto nope; RETPUSHYES; nope: if (!errno) SETERRNO(EBADF,RMS_DIR); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "opendir"); return NORMAL; #endif } PP(pp_readdir) { #if !defined(Direntry_t) || !defined(HAS_READDIR) DIE(aTHX_ PL_no_dir_func, "readdir"); return NORMAL; #else #if !defined(I_DIRENT) && !defined(VMS) Direntry_t *readdir (DIR *); #endif dVAR; dSP; SV *sv; const I32 gimme = GIMME; GV * const gv = MUTABLE_GV(POPs); register const Direntry_t *dp; register IO * const io = GvIOn(gv); if (!io || !IoDIRP(io)) { Perl_ck_warner(aTHX_ packWARN(WARN_IO), "readdir() attempted on invalid dirhandle %s", GvENAME(gv)); goto nope; } do { dp = (Direntry_t *)PerlDir_read(IoDIRP(io)); if (!dp) break; #ifdef DIRNAMLEN sv = newSVpvn(dp->d_name, dp->d_namlen); #else sv = newSVpv(dp->d_name, 0); #endif #ifndef INCOMPLETE_TAINTS if (!(IoFLAGS(io) & IOf_UNTAINT)) SvTAINTED_on(sv); #endif mXPUSHs(sv); } while (gimme == G_ARRAY); if (!dp && gimme != G_ARRAY) goto nope; RETURN; nope: if (!errno) SETERRNO(EBADF,RMS_ISI); if (GIMME == G_ARRAY) RETURN; else RETPUSHUNDEF; #endif } PP(pp_telldir) { #if defined(HAS_TELLDIR) || defined(telldir) dVAR; dSP; dTARGET; /* XXX does _anyone_ need this? --AD 2/20/1998 */ /* XXX netbsd still seemed to. XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style. --JHI 1999-Feb-02 */ # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO) long telldir (DIR *); # endif GV * const gv = MUTABLE_GV(POPs); register IO * const io = GvIOn(gv); if (!io || !IoDIRP(io)) { Perl_ck_warner(aTHX_ packWARN(WARN_IO), "telldir() attempted on invalid dirhandle %s", GvENAME(gv)); goto nope; } PUSHi( PerlDir_tell(IoDIRP(io)) ); RETURN; nope: if (!errno) SETERRNO(EBADF,RMS_ISI); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "telldir"); return NORMAL; #endif } PP(pp_seekdir) { #if defined(HAS_SEEKDIR) || defined(seekdir) dVAR; dSP; const long along = POPl; GV * const gv = MUTABLE_GV(POPs); register IO * const io = GvIOn(gv); if (!io || !IoDIRP(io)) { Perl_ck_warner(aTHX_ packWARN(WARN_IO), "seekdir() attempted on invalid dirhandle %s", GvENAME(gv)); goto nope; } (void)PerlDir_seek(IoDIRP(io), along); RETPUSHYES; nope: if (!errno) SETERRNO(EBADF,RMS_ISI); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "seekdir"); return NORMAL; #endif } PP(pp_rewinddir) { #if defined(HAS_REWINDDIR) || defined(rewinddir) dVAR; dSP; GV * const gv = MUTABLE_GV(POPs); register IO * const io = GvIOn(gv); if (!io || !IoDIRP(io)) { Perl_ck_warner(aTHX_ packWARN(WARN_IO), "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv)); goto nope; } (void)PerlDir_rewind(IoDIRP(io)); RETPUSHYES; nope: if (!errno) SETERRNO(EBADF,RMS_ISI); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "rewinddir"); return NORMAL; #endif } PP(pp_closedir) { #if defined(Direntry_t) && defined(HAS_READDIR) dVAR; dSP; GV * const gv = MUTABLE_GV(POPs); register IO * const io = GvIOn(gv); if (!io || !IoDIRP(io)) { Perl_ck_warner(aTHX_ packWARN(WARN_IO), "closedir() attempted on invalid dirhandle %s", GvENAME(gv)); goto nope; } #ifdef VOID_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; } #endif IoDIRP(io) = 0; RETPUSHYES; nope: if (!errno) SETERRNO(EBADF,RMS_IFI); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "closedir"); return NORMAL; #endif } /* Process control. */ PP(pp_fork) { #ifdef HAS_FORK dVAR; dSP; dTARGET; Pid_t childpid; EXTEND(SP, 1); PERL_FLUSHALL_FOR_CHILD; childpid = PerlProc_fork(); if (childpid < 0) RETSETUNDEF; if (!childpid) { GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV); if (tmpgv) { SvREADONLY_off(GvSV(tmpgv)); sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid()); SvREADONLY_on(GvSV(tmpgv)); } #ifdef THREADS_HAVE_PIDS PL_ppid = (IV)getppid(); #endif #ifdef PERL_USES_PL_PIDSTATUS hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */ #endif } PUSHi(childpid); RETURN; #else # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) dSP; dTARGET; Pid_t childpid; EXTEND(SP, 1); PERL_FLUSHALL_FOR_CHILD; childpid = PerlProc_fork(); if (childpid == -1) RETSETUNDEF; PUSHi(childpid); RETURN; # else DIE(aTHX_ PL_no_func, "fork"); return NORMAL; # endif #endif } PP(pp_wait) { #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__) dVAR; dSP; dTARGET; Pid_t childpid; int argflags; if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) childpid = wait4pid(-1, &argflags, 0); else { while ((childpid = wait4pid(-1, &argflags, 0)) == -1 && 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) */ STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1); # else STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1); # endif XPUSHi(childpid); RETURN; #else DIE(aTHX_ PL_no_func, "wait"); return NORMAL; #endif } PP(pp_waitpid) { #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__) dVAR; dSP; dTARGET; const int optype = POPi; const Pid_t pid = TOPi; Pid_t result; int argflags; if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) result = wait4pid(pid, &argflags, optype); else { while ((result = wait4pid(pid, &argflags, optype)) == -1 && 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) */ STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1); # else STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1); # endif SETi(result); RETURN; #else DIE(aTHX_ PL_no_func, "waitpid"); return NORMAL; #endif } PP(pp_system) { dVAR; dSP; dMARK; dORIGMARK; dTARGET; #if defined(__LIBCATAMOUNT__) PL_statusvalue = -1; SP = ORIGMARK; XPUSHi(-1); #else I32 value; int result; if (PL_tainting) { TAINT_ENV(); while (++MARK <= SP) { (void)SvPV_nolen_const(*MARK); /* stringify for taint check */ if (PL_tainted) break; } MARK = ORIGMARK; TAINT_PROPER("system"); } PERL_FLUSHALL_FOR_CHILD; #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO) { Pid_t childpid; int pp[2]; I32 did_pipes = 0; if (PerlProc_pipe(pp) >= 0) did_pipes = 1; 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]); } RETURN; } sleep(5); } if (childpid > 0) { Sigsave_t ihand,qhand; /* place to save signals during system() */ int status; if (did_pipes) PerlLIO_close(pp[1]); #ifndef PERL_MICRO rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand); rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand); #endif do { result = wait4pid(childpid, &status, 0); } while (result == -1 && errno == EINTR); #ifndef PERL_MICRO (void)rsignal_restore(SIGINT, &ihand); (void)rsignal_restore(SIGQUIT, &qhand); #endif STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status); do_execfree(); /* free any memory child malloced on fork */ SP = ORIGMARK; if (did_pipes) { int errkid; unsigned n = 0; SSize_t n1; while (n < sizeof(int)) { 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"); errno = errkid; /* Propagate errno from kid */ STATUS_NATIVE_CHILD_SET(-1); } } XPUSHi(STATUS_CURRENT); RETURN; } if (did_pipes) { PerlLIO_close(pp[0]); #if defined(HAS_FCNTL) && defined(F_SETFD) fcntl(pp[1], F_SETFD, FD_CLOEXEC); #endif } 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); } 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; # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS) value = (I32)do_aspawn(really, MARK, SP); # else value = (I32)do_aspawn(really, (void **)MARK, (void **)SP); # endif } else if (SP - MARK != 1) { # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS) value = (I32)do_aspawn(NULL, MARK, SP); # else value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP); # endif } else { value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP))); } if (PL_statusvalue == -1) /* hint that value must be returned as is */ result = 1; STATUS_NATIVE_CHILD_SET(value); do_execfree(); SP = ORIGMARK; XPUSHi(result ? value : STATUS_CURRENT); #endif /* !FORK or VMS or OS/2 */ #endif RETURN; } PP(pp_exec) { dVAR; dSP; dMARK; dORIGMARK; dTARGET; I32 value; if (PL_tainting) { TAINT_ENV(); while (++MARK <= SP) { (void)SvPV_nolen_const(*MARK); /* stringify for taint check */ if (PL_tainted) 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); } else if (SP - MARK != 1) #ifdef VMS value = (I32)vms_do_aexec(NULL, MARK, SP); #else # ifdef __OPEN_VM { (void ) do_aspawn(NULL, MARK, SP); value = 0; } # else value = (I32)do_aexec(NULL, MARK, SP); # endif #endif else { #ifdef VMS value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP))); #else # ifdef __OPEN_VM (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP))); value = 0; # else value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP))); # endif #endif } SP = ORIGMARK; XPUSHi(value); RETURN; } PP(pp_getppid) { #ifdef HAS_GETPPID dVAR; dSP; dTARGET; # ifdef THREADS_HAVE_PIDS if (PL_ppid != 1 && getppid() == 1) /* maybe the parent process has died. Refresh ppid cache */ PL_ppid = 1; XPUSHi( PL_ppid ); # else XPUSHi( getppid() ); # endif RETURN; #else DIE(aTHX_ PL_no_func, "getppid"); return NORMAL; #endif } PP(pp_getpgrp) { #ifdef HAS_GETPGRP dVAR; dSP; dTARGET; Pid_t pgrp; const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs); #ifdef BSD_GETPGRP pgrp = (I32)BSD_GETPGRP(pid); #else if (pid != 0 && pid != PerlProc_getpid()) DIE(aTHX_ "POSIX getpgrp can't take an argument"); pgrp = getpgrp(); #endif XPUSHi(pgrp); RETURN; #else DIE(aTHX_ PL_no_func, "getpgrp()"); return NORMAL; #endif } PP(pp_setpgrp) { #ifdef HAS_SETPGRP dVAR; dSP; dTARGET; Pid_t pgrp; Pid_t pid; if (MAXARG < 2) { pgrp = 0; pid = 0; XPUSHi(-1); } else { pgrp = POPi; pid = TOPi; } TAINT_PROPER("setpgrp"); #ifdef BSD_SETPGRP SETi( BSD_SETPGRP(pid, pgrp) >= 0 ); #else if ((pgrp != 0 && pgrp != PerlProc_getpid()) || (pid != 0 && pid != PerlProc_getpid())) { DIE(aTHX_ "setpgrp can't take arguments"); } SETi( setpgrp() >= 0 ); #endif /* USE_BSDPGRP */ RETURN; #else DIE(aTHX_ PL_no_func, "setpgrp()"); return NORMAL; #endif } PP(pp_getpriority) { #ifdef HAS_GETPRIORITY dVAR; dSP; dTARGET; const int who = POPi; const int which = TOPi; SETi( getpriority(which, who) ); RETURN; #else DIE(aTHX_ PL_no_func, "getpriority()"); return NORMAL; #endif } PP(pp_setpriority) { #ifdef HAS_SETPRIORITY dVAR; dSP; dTARGET; const int niceval = POPi; const int who = POPi; const int which = TOPi; TAINT_PROPER("setpriority"); SETi( setpriority(which, who, niceval) >= 0 ); RETURN; #else DIE(aTHX_ PL_no_func, "setpriority()"); return NORMAL; #endif } /* Time calls. */ PP(pp_time) { dVAR; dSP; dTARGET; #ifdef BIG_TIME XPUSHn( time(NULL) ); #else XPUSHi( time(NULL) ); #endif RETURN; } PP(pp_tms) { #ifdef HAS_TIMES dVAR; dSP; EXTEND(SP, 4); #ifndef VMS (void)PerlProc_times(&PL_timesbuf); #else (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */ /* struct tms, though same data */ /* is returned. */ #endif mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick); if (GIMME == G_ARRAY) { mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick); mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick); mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick); } RETURN; #else # ifdef PERL_MICRO dSP; mPUSHn(0.0); EXTEND(SP, 4); if (GIMME == G_ARRAY) { mPUSHn(0.0); mPUSHn(0.0); mPUSHn(0.0); } RETURN; # else DIE(aTHX_ "times not implemented"); return NORMAL; # endif #endif /* HAS_TIMES */ } /* The 32 bit int year limits the times we can represent to these boundaries with a few days wiggle room to account for time zone offsets */ /* Sat Jan 3 00:00:00 -2147481748 */ #define TIME_LOWER_BOUND -67768100567755200.0 /* Sun Dec 29 12:00:00 2147483647 */ #define TIME_UPPER_BOUND 67767976233316800.0 PP(pp_gmtime) { dVAR; dSP; Time64_T when; struct TM tmbuf; 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"}; static const char * const monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"}; if (MAXARG < 1) { time_t now; (void)time(&now); when = (Time64_T)now; } else { double input = Perl_floor(POPn); when = (Time64_T)input; if (when != input) { Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), "%s(%.0f) too large", opname, input); } } if ( TIME_LOWER_BOUND > when ) { Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), "%s(%.0f) too small", opname, when); err = NULL; } else if( when > TIME_UPPER_BOUND ) { Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), "%s(%.0f) too large", opname, when); err = NULL; } else { if (PL_op->op_type == OP_LOCALTIME) err = S_localtime64_r(&when, &tmbuf); else err = S_gmtime64_r(&when, &tmbuf); } if (err == NULL) { /* XXX %lld broken for quads */ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), "%s(%.0f) failed", opname, (double)when); } if (GIMME != G_ARRAY) { /* scalar context */ SV *tsv; /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */ double year = (double)tmbuf.tm_year + 1900; EXTEND(SP, 1); EXTEND_MORTAL(1); if (err == NULL) RETPUSHUNDEF; tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f", dayname[tmbuf.tm_wday], monname[tmbuf.tm_mon], tmbuf.tm_mday, tmbuf.tm_hour, tmbuf.tm_min, tmbuf.tm_sec, year); mPUSHs(tsv); } else { /* list context */ 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); } RETURN; } PP(pp_alarm) { #ifdef HAS_ALARM dVAR; dSP; dTARGET; int anum; anum = POPi; anum = alarm((unsigned int)anum); EXTEND(SP, 1); if (anum < 0) RETPUSHUNDEF; PUSHi(anum); RETURN; #else DIE(aTHX_ PL_no_func, "alarm"); return NORMAL; #endif } PP(pp_sleep) { dVAR; dSP; dTARGET; I32 duration; Time_t lasttime; Time_t when; (void)time(&lasttime); if (MAXARG < 1) PerlProc_pause(); else { duration = POPi; PerlProc_sleep((unsigned int)duration); } (void)time(&when); XPUSHi(when - lasttime); RETURN; } /* Shared memory. */ /* Merged with some message passing. */ PP(pp_shmwrite) { #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) dVAR; dSP; dMARK; dTARGET; const int op_type = PL_op->op_type; I32 value; switch (op_type) { case OP_MSGSND: value = (I32)(do_msgsnd(MARK, SP) >= 0); break; case OP_MSGRCV: value = (I32)(do_msgrcv(MARK, SP) >= 0); break; case OP_SEMOP: value = (I32)(do_semop(MARK, SP) >= 0); break; default: value = (I32)(do_shmio(op_type, MARK, SP) >= 0); break; } SP = MARK; PUSHi(value); RETURN; #else return pp_semget(); #endif } /* Semaphores. */ PP(pp_semget) { #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) dVAR; dSP; dMARK; dTARGET; const int anum = do_ipcget(PL_op->op_type, MARK, SP); SP = MARK; if (anum == -1) RETPUSHUNDEF; PUSHi(anum); RETURN; #else DIE(aTHX_ "System V IPC is not implemented on this machine"); return NORMAL; #endif } PP(pp_semctl) { #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) dVAR; dSP; dMARK; dTARGET; const int anum = do_ipcctl(PL_op->op_type, MARK, SP); SP = MARK; if (anum == -1) RETSETUNDEF; if (anum != 0) { PUSHi(anum); } else { PUSHp(zero_but_true, ZBTLEN); } RETURN; #else return pp_semget(); #endif } /* I can't const this further without getting warnings about the types of various arrays passed in from structures. */ static SV * S_space_join_names_mortal(pTHX_ char *const *array) { SV *target; PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL; if (array && *array) { target = newSVpvs_flags("", SVs_TEMP); while (1) { sv_catpv(target, *array); if (!*++array) break; sv_catpvs(target, " "); } } else { target = sv_mortalcopy(&PL_sv_no); } return target; } /* Get system info. */ PP(pp_ghostent) { #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT) dVAR; dSP; I32 which = PL_op->op_type; register char **elem; register SV *sv; #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */ struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int); struct hostent *gethostbyname(Netdb_name_t); struct hostent *gethostent(void); #endif struct hostent *hent = NULL; unsigned long len; EXTEND(SP, 10); if (which == OP_GHBYNAME) { #ifdef HAS_GETHOSTBYNAME const char* const name = POPpbytex; hent = PerlSock_gethostbyname(name); #else 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); hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype); #else DIE(aTHX_ PL_no_sock_func, "gethostbyaddr"); #endif } else #ifdef HAS_GETHOSTENT hent = PerlSock_gethostent(); #else DIE(aTHX_ PL_no_sock_func, "gethostent"); #endif #ifdef HOST_NOT_FOUND if (!hent) { #ifdef USE_REENTRANT_API # ifdef USE_GETHOSTENT_ERRNO h_errno = PL_reentrant_buffer->_gethostent_errno; # endif #endif STATUS_UNIX_SET(h_errno); } #endif if (GIMME != 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; } 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); #ifdef h_addr 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)); #endif /* h_addr */ } RETURN; #else DIE(aTHX_ PL_no_sock_func, "gethostent"); return NORMAL; #endif } PP(pp_gnetent) { #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT) dVAR; dSP; I32 which = PL_op->op_type; register SV *sv; #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */ struct netent *getnetbyaddr(Netdb_net_t, int); struct netent *getnetbyname(Netdb_name_t); struct netent *getnetent(void); #endif struct netent *nent; if (which == OP_GNBYNAME){ #ifdef HAS_GETNETBYNAME 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); #else DIE(aTHX_ PL_no_sock_func, "getnetbyaddr"); #endif } else #ifdef HAS_GETNETENT nent = PerlSock_getnetent(); #else DIE(aTHX_ PL_no_sock_func, "getnetent"); #endif #ifdef HOST_NOT_FOUND if (!nent) { #ifdef USE_REENTRANT_API # ifdef USE_GETNETENT_ERRNO h_errno = PL_reentrant_buffer->_getnetent_errno; # endif #endif STATUS_UNIX_SET(h_errno); } #endif EXTEND(SP, 4); if (GIMME != 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; } if (nent) { mPUSHs(newSVpv(nent->n_name, 0)); PUSHs(space_join_names_mortal(nent->n_aliases)); mPUSHi(nent->n_addrtype); mPUSHi(nent->n_net); } RETURN; #else DIE(aTHX_ PL_no_sock_func, "getnetent"); return NORMAL; #endif } PP(pp_gprotoent) { #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT) dVAR; dSP; I32 which = PL_op->op_type; register SV *sv; #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */ struct protoent *getprotobyname(Netdb_name_t); struct protoent *getprotobynumber(int); struct protoent *getprotoent(void); #endif struct protoent *pent; if (which == OP_GPBYNAME) { #ifdef HAS_GETPROTOBYNAME const char* const name = POPpbytex; pent = PerlSock_getprotobyname(name); #else DIE(aTHX_ PL_no_sock_func, "getprotobyname"); #endif } else if (which == OP_GPBYNUMBER) { #ifdef HAS_GETPROTOBYNUMBER const int number = POPi; pent = PerlSock_getprotobynumber(number); #else DIE(aTHX_ PL_no_sock_func, "getprotobynumber"); #endif } else #ifdef HAS_GETPROTOENT pent = PerlSock_getprotoent(); #else DIE(aTHX_ PL_no_sock_func, "getprotoent"); #endif EXTEND(SP, 3); if (GIMME != 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; } if (pent) { mPUSHs(newSVpv(pent->p_name, 0)); PUSHs(space_join_names_mortal(pent->p_aliases)); mPUSHi(pent->p_proto); } RETURN; #else DIE(aTHX_ PL_no_sock_func, "getprotoent"); return NORMAL; #endif } PP(pp_gservent) { #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT) dVAR; dSP; I32 which = PL_op->op_type; register SV *sv; #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */ struct servent *getservbyname(Netdb_name_t, Netdb_name_t); struct servent *getservbyport(int, Netdb_name_t); struct servent *getservent(void); #endif struct servent *sent; 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); #else 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; #ifdef HAS_HTONS port = PerlSock_htons(port); #endif sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto); #else DIE(aTHX_ PL_no_sock_func, "getservbyport"); #endif } else #ifdef HAS_GETSERVENT sent = PerlSock_getservent(); #else DIE(aTHX_ PL_no_sock_func, "getservent"); #endif EXTEND(SP, 4); if (GIMME != G_ARRAY) { PUSHs(sv = sv_newmortal()); if (sent) { if (which == OP_GSBYNAME) { #ifdef HAS_NTOHS sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port)); #else sv_setiv(sv, (IV)(sent->s_port)); #endif } else sv_setpv(sv, sent->s_name); } RETURN; } if (sent) { mPUSHs(newSVpv(sent->s_name, 0)); PUSHs(space_join_names_mortal(sent->s_aliases)); #ifdef HAS_NTOHS mPUSHi(PerlSock_ntohs(sent->s_port)); #else mPUSHi(sent->s_port); #endif mPUSHs(newSVpv(sent->s_proto, 0)); } RETURN; #else DIE(aTHX_ PL_no_sock_func, "getservent"); return NORMAL; #endif } PP(pp_shostent) { #ifdef HAS_SETHOSTENT dVAR; dSP; PerlSock_sethostent(TOPi); RETSETYES; #else DIE(aTHX_ PL_no_sock_func, "sethostent"); return NORMAL; #endif } PP(pp_snetent) { #ifdef HAS_SETNETENT dVAR; dSP; (void)PerlSock_setnetent(TOPi); RETSETYES; #else DIE(aTHX_ PL_no_sock_func, "setnetent"); return NORMAL; #endif } PP(pp_sprotoent) { #ifdef HAS_SETPROTOENT dVAR; dSP; (void)PerlSock_setprotoent(TOPi); RETSETYES; #else DIE(aTHX_ PL_no_sock_func, "setprotoent"); return NORMAL; #endif } PP(pp_sservent) { #ifdef HAS_SETSERVENT dVAR; dSP; (void)PerlSock_setservent(TOPi); RETSETYES; #else DIE(aTHX_ PL_no_sock_func, "setservent"); return NORMAL; #endif } PP(pp_ehostent) { #ifdef HAS_ENDHOSTENT dVAR; dSP; PerlSock_endhostent(); EXTEND(SP,1); RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "endhostent"); return NORMAL; #endif } PP(pp_enetent) { #ifdef HAS_ENDNETENT dVAR; dSP; PerlSock_endnetent(); EXTEND(SP,1); RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "endnetent"); return NORMAL; #endif } PP(pp_eprotoent) { #ifdef HAS_ENDPROTOENT dVAR; dSP; PerlSock_endprotoent(); EXTEND(SP,1); RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "endprotoent"); return NORMAL; #endif } PP(pp_eservent) { #ifdef HAS_ENDSERVENT dVAR; dSP; PerlSock_endservent(); EXTEND(SP,1); RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "endservent"); return NORMAL; #endif } PP(pp_gpwent) { #ifdef HAS_PASSWD dVAR; dSP; I32 which = PL_op->op_type; register SV *sv; struct passwd *pwent = NULL; /* * We currently support only the SysV getsp* shadow password interface. * The interface is declared in and often one needs to link * with -lsecurity or some such. * This interface is used at least by Solaris, HP-UX, IRIX, and Linux. * (and SCO?) * * AIX getpwnam() is clever enough to return the encrypted password * only if the caller (euid?) is root. * * There are at least three other shadow password APIs. Many platforms * seem to contain more than one interface for accessing the shadow * password databases, possibly for compatibility reasons. * The getsp*() is by far he simplest one, the other two interfaces * are much more complicated, but also very similar to each other. * * * * * struct pr_passwd *getprpw*(); * The password is in * char getprpw*(...).ufld.fd_encrypt[] * Mention HAS_GETPRPWNAM here so that Configure probes for it. * * * * * struct es_passwd *getespw*(); * The password is in * char *(getespw*(...).ufld.fd_encrypt) * Mention HAS_GETESPWNAM here so that Configure probes for it. * * (AIX) * struct userpw *getuserpw(); * The password is in * char *(getuserpw(...)).spw_upw_passwd * (but the de facto standard getpwnam() should work okay) * * Mention I_PROT here so that Configure probes for it. * * In HP-UX for getprpw*() the manual page claims that one should include * instead of , but that is not needed * if one includes as that includes , * and pp_sys.c already includes if there is such. * * Note that is already probed for, but currently * it is only included in special cases. * * In Digital UNIX/Tru64 if using the getespw*() (which seems to be * be preferred interface, even though also the getprpw*() interface * is available) one needs to link with -lsecurity -ldb -laud -lm. * One also needs to call set_auth_parameters() in main() before * doing anything else, whether one is using getespw*() or getprpw*(). * * Note that accessing the shadow databases can be magnitudes * slower than accessing the standard databases. * * --jhi */ # if defined(__CYGWIN__) && defined(USE_REENTRANT_API) /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r(): * the pw_comment is left uninitialized. */ PL_reentrant_buffer->_pwent_struct.pw_comment = NULL; # endif switch (which) { case OP_GPWNAM: { const char* const name = POPpbytex; pwent = getpwnam(name); } break; case OP_GPWUID: { Uid_t uid = POPi; pwent = getpwuid(uid); } break; case OP_GPWENT: # ifdef HAS_GETPWENT pwent = getpwent(); #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */ if (pwent) pwent = getpwnam(pwent->pw_name); #endif # else DIE(aTHX_ PL_no_func, "getpwent"); # endif break; } EXTEND(SP, 10); if (GIMME != G_ARRAY) { PUSHs(sv = sv_newmortal()); if (pwent) { if (which == OP_GPWNAM) # if Uid_t_sign <= 0 sv_setiv(sv, (IV)pwent->pw_uid); # else sv_setuv(sv, (UV)pwent->pw_uid); # endif 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. */ # 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 unsccessful * 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); # endif # ifndef INCOMPLETE_TAINTS /* passwd is tainted because user himself can diddle with it. * admittedly not much and in a very limited way, but nevertheless. */ SvTAINTED_on(sv); # endif # if Uid_t_sign <= 0 mPUSHi(pwent->pw_uid); # else mPUSHu(pwent->pw_uid); # endif # if Uid_t_sign <= 0 mPUSHi(pwent->pw_gid); # else mPUSHu(pwent->pw_gid); # endif /* 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); # else # ifdef PWQUOTA mPUSHi(pwent->pw_quota); # else # ifdef PWAGE 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)); # endif # endif # endif /* 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)); # else # ifdef PWCOMMENT 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)); # endif # endif # ifdef PWGECOS PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0))); # else PUSHs(sv = sv_mortalcopy(&PL_sv_no)); # endif # ifndef INCOMPLETE_TAINTS /* pw_gecos is tainted because user himself can diddle with it. */ SvTAINTED_on(sv); # endif mPUSHs(newSVpv(pwent->pw_dir, 0)); PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0))); # ifndef INCOMPLETE_TAINTS /* pw_shell is tainted because user himself can diddle with it. */ SvTAINTED_on(sv); # endif # ifdef PWEXPIRE mPUSHi(pwent->pw_expire); # endif } RETURN; #else DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); return NORMAL; #endif } PP(pp_spwent) { #if defined(HAS_PASSWD) && defined(HAS_SETPWENT) dVAR; dSP; setpwent(); RETPUSHYES; #else DIE(aTHX_ PL_no_func, "setpwent"); return NORMAL; #endif } PP(pp_epwent) { #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT) dVAR; dSP; endpwent(); RETPUSHYES; #else DIE(aTHX_ PL_no_func, "endpwent"); return NORMAL; #endif } PP(pp_ggrent) { #ifdef HAS_GROUP dVAR; dSP; const I32 which = PL_op->op_type; const struct group *grent; if (which == OP_GGRNAM) { const char* const name = POPpbytex; grent = (const struct group *)getgrnam(name); } else if (which == OP_GGRGID) { const Gid_t gid = POPi; grent = (const struct group *)getgrgid(gid); } else #ifdef HAS_GETGRENT grent = (struct group *)getgrent(); #else DIE(aTHX_ PL_no_func, "getgrent"); #endif EXTEND(SP, 4); if (GIMME != G_ARRAY) { SV * const sv = sv_newmortal(); PUSHs(sv); if (grent) { if (which == OP_GGRNAM) #if Gid_t_sign <= 0 sv_setiv(sv, (IV)grent->gr_gid); #else sv_setuv(sv, (UV)grent->gr_gid); #endif else sv_setpv(sv, grent->gr_name); } RETURN; } if (grent) { mPUSHs(newSVpv(grent->gr_name, 0)); #ifdef GRPASSWD mPUSHs(newSVpv(grent->gr_passwd, 0)); #else PUSHs(sv_mortalcopy(&PL_sv_no)); #endif #if Gid_t_sign <= 0 mPUSHi(grent->gr_gid); #else mPUSHu(grent->gr_gid); #endif #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)); #endif } RETURN; #else DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); return NORMAL; #endif } PP(pp_sgrent) { #if defined(HAS_GROUP) && defined(HAS_SETGRENT) dVAR; dSP; setgrent(); RETPUSHYES; #else DIE(aTHX_ PL_no_func, "setgrent"); return NORMAL; #endif } PP(pp_egrent) { #if defined(HAS_GROUP) && defined(HAS_ENDGRENT) dVAR; dSP; endgrent(); RETPUSHYES; #else DIE(aTHX_ PL_no_func, "endgrent"); return NORMAL; #endif } PP(pp_getlogin) { #ifdef HAS_GETLOGIN dVAR; dSP; dTARGET; char *tmps; EXTEND(SP, 1); if (!(tmps = PerlProc_getlogin())) RETPUSHUNDEF; PUSHp(tmps, strlen(tmps)); RETURN; #else DIE(aTHX_ PL_no_func, "getlogin"); return NORMAL; #endif } /* Miscellaneous. */ PP(pp_syscall) { #ifdef HAS_SYSCALL dVAR; dSP; dMARK; dORIGMARK; dTARGET; register I32 items = SP - MARK; unsigned long a[20]; register I32 i = 0; I32 retval = -1; if (PL_tainting) { 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) * or where sizeof(long) != sizeof(char*). But such machines will * 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; } switch (items) { default: DIE(aTHX_ "Too many args to syscall"); case 0: DIE(aTHX_ "Too few args to syscall"); case 1: retval = syscall(a[0]); break; case 2: retval = syscall(a[0],a[1]); break; case 3: retval = syscall(a[0],a[1],a[2]); break; case 4: 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; case 6: 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; case 8: retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]); break; #ifdef atarist case 9: retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]); break; case 10: retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]); break; case 11: retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9], a[10]); break; case 12: retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9], a[10],a[11]); break; case 13: retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9], a[10],a[11],a[12]); break; case 14: retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9], a[10],a[11],a[12],a[13]); break; #endif /* atarist */ } SP = ORIGMARK; PUSHi(retval); RETURN; #else DIE(aTHX_ PL_no_func, "syscall"); return NORMAL; #endif } #ifdef FCNTL_EMULATE_FLOCK /* XXX Emulate flock() with fcntl(). What's really needed is a good file locking module. */ static int fcntl_emulate_flock(int fd, int operation) { int res; struct flock flock; switch (operation & ~LOCK_NB) { case LOCK_SH: flock.l_type = F_RDLCK; break; case LOCK_EX: flock.l_type = F_WRLCK; break; case LOCK_UN: flock.l_type = F_UNLCK; break; default: 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; return res; } #endif /* FCNTL_EMULATE_FLOCK */ #ifdef LOCKF_EMULATE_FLOCK /* XXX Emulate flock() with lockf(). This is just to increase portability of scripts. The calls are not completely interchangeable. What's really needed is a good file locking module. */ /* The lockf() constants might have been defined in . Unfortunately, causes troubles on some mixed (BSD/POSIX) systems, such as SunOS 4.1.3. Further, the lockf() constants aren't POSIX, so they might not be visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll just stick in the SVID values and be done with it. Sigh. */ # ifndef F_ULOCK # define F_ULOCK 0 /* Unlock a previously locked region */ # endif # ifndef F_LOCK # define F_LOCK 1 /* Lock a region for exclusive use */ # endif # ifndef F_TLOCK # define F_TLOCK 2 /* Test and lock a region for exclusive use */ # endif # ifndef F_TEST # define F_TEST 3 /* Test a region for other processes locks */ # endif static int lockf_emulate_flock(int fd, int operation) { int i; Off_t pos; dSAVE_ERRNO; /* 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 */ 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; } if (pos > 0) /* need to restore position of the handle */ PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */ return (i); } #endif /* LOCKF_EMULATE_FLOCK */ /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */ perl-5.12.0-RC0/thread.h0000444000175000017500000002725311325125742013560 0ustar jessejesse/* thread.h * * Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, * by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ #if defined(USE_ITHREADS) #if defined(VMS) #include #endif #ifdef WIN32 # include #else #ifdef NETWARE # include #else # 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__); \ } \ } STMT_END # define PERL_GET_CONTEXT Perl_get_context() # define PERL_SET_CONTEXT(t) Perl_set_context((void*)t) # define PTHREAD_GETSPECIFIC_INT # ifdef DJGPP # define pthread_addr_t any_t # define NEED_PTHREAD_INIT # define PTHREAD_CREATE_JOINABLE (1) # endif # ifdef __OPEN_VM # define pthread_addr_t void * # endif # ifdef OEMVS # define pthread_addr_t void * # define pthread_create(t,a,s,d) pthread_create(t,&(a),s,d) # define pthread_keycreate pthread_key_create # endif # ifdef VMS # define pthread_attr_init(a) pthread_attr_create(a) # define PTHREAD_ATTR_SETDETACHSTATE(a,s) pthread_setdetach_np(a,s) # define PTHREAD_CREATE(t,a,s,d) pthread_create(t,a,s,d) # define pthread_key_create(k,d) pthread_keycreate(k,(pthread_destructor_t)(d)) # define pthread_mutexattr_init(a) pthread_mutexattr_create(a) # define pthread_mutexattr_settype(a,t) pthread_mutexattr_setkind_np(a,t) # endif # if defined(__hpux) && defined(__ux_version) && __ux_version <= 1020 # define pthread_attr_init(a) pthread_attr_create(a) /* XXX pthread_setdetach_np() missing in DCE threads on HP-UX 10.20 */ # define PTHREAD_ATTR_SETDETACHSTATE(a,s) (0) # define PTHREAD_CREATE(t,a,s,d) pthread_create(t,a,s,d) # define pthread_key_create(k,d) pthread_keycreate(k,(pthread_destructor_t)(d)) # define pthread_mutexattr_init(a) pthread_mutexattr_create(a) # define pthread_mutexattr_settype(a,t) pthread_mutexattr_setkind_np(a,t) # endif # if defined(DJGPP) || defined(__OPEN_VM) || defined(OEMVS) # define PTHREAD_ATTR_SETDETACHSTATE(a,s) pthread_attr_setdetachstate(a,&(s)) # define YIELD pthread_yield(NULL) # endif # endif # if !defined(__hpux) || !defined(__ux_version) || __ux_version > 1020 # define pthread_mutexattr_default NULL # define pthread_condattr_default NULL # endif #endif /* NETWARE */ #endif #ifndef PTHREAD_CREATE /* You are not supposed to pass NULL as the 2nd arg of PTHREAD_CREATE(). */ # define PTHREAD_CREATE(t,a,s,d) pthread_create(t,&(a),s,d) #endif #ifndef PTHREAD_ATTR_SETDETACHSTATE # define PTHREAD_ATTR_SETDETACHSTATE(a,s) pthread_attr_setdetachstate(a,s) #endif #ifndef PTHREAD_CREATE_JOINABLE # ifdef OLD_PTHREAD_CREATE_JOINABLE # define PTHREAD_CREATE_JOINABLE OLD_PTHREAD_CREATE_JOINABLE # else # define PTHREAD_CREATE_JOINABLE 0 /* Panic? No, guess. */ # endif #endif #ifdef DGUX # define THREAD_CREATE_NEEDS_STACK (32*1024) #endif #ifdef __VMS /* Default is 1024 on VAX, 8192 otherwise */ # ifdef __ia64 # define THREAD_CREATE_NEEDS_STACK (48*1024) # else # define THREAD_CREATE_NEEDS_STACK (32*1024) # endif #endif #ifdef I_MACH_CTHREADS /* cthreads interface */ /* #include is in perl.h #ifdef I_MACH_CTHREADS */ #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__); \ } \ } 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; \ } 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__); \ } \ } STMT_END #define COND_SIGNAL(c) condition_signal(*c) #define COND_BROADCAST(c) condition_broadcast(*c) #define COND_WAIT(c, m) condition_wait(*c, *m) #define COND_DESTROY(c) \ STMT_START { \ condition_free(*c); \ *c = 0; \ } STMT_END #define THREAD_CREATE(thr, f) (thr->self = cthread_fork(f, thr), 0) #define THREAD_POST_CREATE(thr) #define THREAD_RET_TYPE any_t #define THREAD_RET_CAST(x) ((any_t) x) #define DETACH(t) cthread_detach(t->self) #define JOIN(t, avp) (*(avp) = MUTABLE_AV(cthread_join(t->self))) #define PERL_SET_CONTEXT(t) cthread_set_data(cthread_self(), t) #define PERL_GET_CONTEXT cthread_data(cthread_self()) #define INIT_THREADS cthread_init() #define YIELD cthread_yield() #define ALLOC_THREAD_KEY NOOP #define FREE_THREAD_KEY NOOP #define SET_THREAD_SELF(thr) (thr->self = cthread_self()) #endif /* I_MACH_CTHREADS */ #ifndef YIELD # ifdef SCHED_YIELD # define YIELD SCHED_YIELD # else # ifdef HAS_SCHED_YIELD # define YIELD sched_yield() # else # ifdef HAS_PTHREAD_YIELD /* pthread_yield(NULL) platforms are expected * to have #defined YIELD for themselves. */ # define YIELD pthread_yield() # endif # endif # endif #endif #ifdef __hpux # define MUTEX_INIT_NEEDS_MUTEX_ZEROED #endif #ifndef MUTEX_INIT # ifdef MUTEX_INIT_NEEDS_MUTEX_ZEROED /* 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__); \ } 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__); \ } STMT_END # endif # define MUTEX_LOCK(m) \ STMT_START { \ int _eC_; \ if ((_eC_ = 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_ = 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__); \ } 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__); \ } 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__); \ } 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__); \ } 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__); \ } 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__); \ } STMT_END #endif /* COND_INIT */ /* DETACH(t) must only be called while holding t->mutex */ #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__); \ } \ } 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__); \ } STMT_END #endif /* JOIN */ /* Use an unchecked fetch of thread-specific data instead of a checked one. * It would fail if the key were bogus, but if the key were bogus then * Really Bad Things would be happening anyway. --dan */ #if (defined(__ALPHA) && (__VMS_VER >= 70000000)) || \ (defined(__alpha) && defined(__osf__) && !defined(__GNUC__)) /* Available only on >= 4.0 */ # define HAS_PTHREAD_UNCHECKED_GETSPECIFIC_NP /* Configure test needed */ #endif #ifdef HAS_PTHREAD_UNCHECKED_GETSPECIFIC_NP # define PTHREAD_GETSPECIFIC(key) pthread_unchecked_getspecific_np(key) #else # define PTHREAD_GETSPECIFIC(key) pthread_getspecific(key) #endif #ifndef PERL_GET_CONTEXT # define PERL_GET_CONTEXT PTHREAD_GETSPECIFIC(PL_thr_key) #endif #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__); \ } STMT_END #endif /* PERL_SET_CONTEXT */ #ifndef INIT_THREADS # ifdef NEED_PTHREAD_INIT # define INIT_THREADS pthread_init() # endif #endif #ifndef ALLOC_THREAD_KEY # define ALLOC_THREAD_KEY \ STMT_START { \ if (pthread_key_create(&PL_thr_key, 0)) { \ write(2, STR_WITH_LEN("panic: pthread_key_create failed\n")); \ exit(1); \ } \ } STMT_END #endif #ifndef FREE_THREAD_KEY # define FREE_THREAD_KEY \ STMT_START { \ 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) # else # define PTHREAD_ATFORK(prepare,parent,child) \ NOOP # endif #endif #ifndef THREAD_RET_TYPE # define THREAD_RET_TYPE void * # define THREAD_RET_CAST(p) ((void *)(p)) #endif /* THREAD_RET */ # define LOCK_DOLLARZERO_MUTEX MUTEX_LOCK(&PL_dollarzero_mutex) # define UNLOCK_DOLLARZERO_MUTEX MUTEX_UNLOCK(&PL_dollarzero_mutex) #endif /* USE_ITHREADS */ #ifndef MUTEX_LOCK # define MUTEX_LOCK(m) #endif #ifndef MUTEX_UNLOCK # define MUTEX_UNLOCK(m) #endif #ifndef MUTEX_INIT # define MUTEX_INIT(m) #endif #ifndef MUTEX_DESTROY # define MUTEX_DESTROY(m) #endif #ifndef COND_INIT # define COND_INIT(c) #endif #ifndef COND_SIGNAL # define COND_SIGNAL(c) #endif #ifndef COND_BROADCAST # define COND_BROADCAST(c) #endif #ifndef COND_WAIT # define COND_WAIT(c, m) #endif #ifndef COND_DESTROY # define COND_DESTROY(c) #endif #ifndef LOCK_DOLLARZERO_MUTEX # define LOCK_DOLLARZERO_MUTEX #endif #ifndef UNLOCK_DOLLARZERO_MUTEX # define UNLOCK_DOLLARZERO_MUTEX #endif /* THR, SET_THR, and dTHR are there for compatibility with old versions */ #ifndef THR # define THR PERL_GET_THX #endif #ifndef SET_THR # define SET_THR(t) PERL_SET_THX(t) #endif #ifndef dTHR # define dTHR dNOOP #endif #ifndef INIT_THREADS # define INIT_THREADS NOOP #endif /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */ perl-5.12.0-RC0/warnings.h0000644000175000017500000001013311325127002014117 0ustar jessejesse/* -*- buffer-read-only: t -*- !!!!!!! DO NOT EDIT THIS FILE !!!!!!! This file is built by warnings.pl Any changes made here will be lost! */ #define Off(x) ((x) / 8) #define Bit(x) (1 << ((x) % 8)) #define IsSet(a, x) ((a)[Off(x)] & Bit(x)) #define G_WARN_OFF 0 /* $^W == 0 */ #define G_WARN_ON 1 /* -w flag and $^W != 0 */ #define G_WARN_ALL_ON 2 /* -W flag */ #define G_WARN_ALL_OFF 4 /* -X flag */ #define G_WARN_ONCE 8 /* set if 'once' ever enabled */ #define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF) #define pWARN_STD NULL #define pWARN_ALL (((STRLEN*)0)+1) /* use warnings 'all' */ #define pWARN_NONE (((STRLEN*)0)+2) /* no warnings 'all' */ #define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \ (x) == pWARN_NONE) /* if PL_warnhook is set to this value, then warnings die */ #define PERL_WARNHOOK_FATAL (&PL_sv_placeholder) /* Warnings Categories added in Perl 5.008 */ #define WARN_ALL 0 #define WARN_CLOSURE 1 #define WARN_DEPRECATED 2 #define WARN_EXITING 3 #define WARN_GLOB 4 #define WARN_IO 5 #define WARN_CLOSED 6 #define WARN_EXEC 7 #define WARN_LAYER 8 #define WARN_NEWLINE 9 #define WARN_PIPE 10 #define WARN_UNOPENED 11 #define WARN_MISC 12 #define WARN_NUMERIC 13 #define WARN_ONCE 14 #define WARN_OVERFLOW 15 #define WARN_PACK 16 #define WARN_PORTABLE 17 #define WARN_RECURSION 18 #define WARN_REDEFINE 19 #define WARN_REGEXP 20 #define WARN_SEVERE 21 #define WARN_DEBUGGING 22 #define WARN_INPLACE 23 #define WARN_INTERNAL 24 #define WARN_MALLOC 25 #define WARN_SIGNAL 26 #define WARN_SUBSTR 27 #define WARN_SYNTAX 28 #define WARN_AMBIGUOUS 29 #define WARN_BAREWORD 30 #define WARN_DIGIT 31 #define WARN_PARENTHESIS 32 #define WARN_PRECEDENCE 33 #define WARN_PRINTF 34 #define WARN_PROTOTYPE 35 #define WARN_QW 36 #define WARN_RESERVED 37 #define WARN_SEMICOLON 38 #define WARN_TAINT 39 #define WARN_THREADS 40 #define WARN_UNINITIALIZED 41 #define WARN_UNPACK 42 #define WARN_UNTIE 43 #define WARN_UTF8 44 #define WARN_VOID 45 /* Warnings Categories added in Perl 5.011 */ #define WARN_IMPRECISION 46 #define WARN_ILLEGALPROTO 47 #define WARNsize 12 #define WARN_ALLstring "\125\125\125\125\125\125\125\125\125\125\125\125" #define WARN_NONEstring "\0\0\0\0\0\0\0\0\0\0\0\0" #define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD) #define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD) #define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE)) #define isWARN_on(c,x) (IsSet((U8 *)(c + 1), 2*(x))) #define isWARNf_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)+1)) #define DUP_WARNINGS(p) \ (specialWARN(p) ? (STRLEN*)(p) \ : (STRLEN*)CopyD(p, PerlMemShared_malloc(sizeof(*p)+*p), sizeof(*p)+*p, \ char)) #define ckWARN(w) Perl_ckwarn(aTHX_ packWARN(w)) #define ckWARN2(w1,w2) Perl_ckwarn(aTHX_ packWARN2(w1,w2)) #define ckWARN3(w1,w2,w3) Perl_ckwarn(aTHX_ packWARN3(w1,w2,w3)) #define ckWARN4(w1,w2,w3,w4) Perl_ckwarn(aTHX_ packWARN4(w1,w2,w3,w4)) #define ckWARN_d(w) Perl_ckwarn_d(aTHX_ packWARN(w)) #define ckWARN2_d(w1,w2) Perl_ckwarn_d(aTHX_ packWARN2(w1,w2)) #define ckWARN3_d(w1,w2,w3) Perl_ckwarn_d(aTHX_ packWARN3(w1,w2,w3)) #define ckWARN4_d(w1,w2,w3,w4) Perl_ckwarn_d(aTHX_ packWARN4(w1,w2,w3,w4)) #define WARNshift 8 #define packWARN(a) (a ) #define packWARN2(a,b) ((a) | ((b)<<8) ) #define packWARN3(a,b,c) ((a) | ((b)<<8) | ((c)<<16) ) #define packWARN4(a,b,c,d) ((a) | ((b)<<8) | ((c)<<16) | ((d) <<24)) #define unpackWARN1(x) ((x) & 0xFF) #define unpackWARN2(x) (((x) >>8) & 0xFF) #define unpackWARN3(x) (((x) >>16) & 0xFF) #define unpackWARN4(x) (((x) >>24) & 0xFF) #define ckDEAD(x) \ ( ! specialWARN(PL_curcop->cop_warnings) && \ ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \ isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) || \ isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) || \ isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) || \ isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x)))) /* end of file warnings.h */ /* ex: set ro: */ perl-5.12.0-RC0/hv.c0000444000175000017500000024406611340037012012711 0ustar jessejesse/* hv.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * I sit beside the fire and think * of all that I have seen. * --Bilbo * * [p.278 of _The Lord of the Rings_, II/iii: "The Ring Goes South"] */ /* =head1 Hash Manipulation Functions A HV structure represents a Perl hash. It consists mainly of an array of pointers, each of which points to a linked list of HE structures. The array is indexed by the hash function of the key, so each linked list represents all the hash entries with the same hash value. Each HE contains a pointer to the actual value, plus a pointer to a HEK structure which holds the key and hash value. =cut */ #include "EXTERN.h" #define PERL_IN_HV_C #define PERL_HASH_INTERNAL_ACCESS #include "perl.h" #define HV_MAX_LENGTH_BEFORE_SPLIT 14 static const char S_strtab_error[] = "Cannot modify shared string table in hv_%s"; STATIC void S_more_he(pTHX) { dVAR; /* We could generate this at compile time via (another) auxiliary C program? */ const size_t arena_size = Perl_malloc_good_size(PERL_ARENA_SIZE); HE* he = (HE*) Perl_get_arena(aTHX_ arena_size, HE_SVSLOT); HE * const heend = &he[arena_size / sizeof(HE) - 1]; PL_body_roots[HE_SVSLOT] = he; while (he < heend) { HeNEXT(he) = (HE*)(he + 1); he++; } HeNEXT(he) = 0; } #ifdef PURIFY #define new_HE() (HE*)safemalloc(sizeof(HE)) #define del_HE(p) safefree((char*)p) #else STATIC HE* S_new_he(pTHX) { dVAR; HE* he; void ** const root = &PL_body_roots[HE_SVSLOT]; if (!*root) S_more_he(aTHX); he = (HE*) *root; assert(he); *root = HeNEXT(he); return he; } #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; \ } STMT_END #endif STATIC HEK * S_save_hek_flags(const char *str, I32 len, U32 hash, int flags) { const int flags_masked = flags & HVhek_MASK; char *k; register HEK *hek; PERL_ARGS_ASSERT_SAVE_HEK_FLAGS; Newx(k, HEK_BASESIZE + len + 2, char); hek = (HEK*)k; 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 | HVhek_UNSHARED; if (flags & HVhek_FREEKEY) Safefree(str); return hek; } /* free the pool of temporary HE/HEK pairs returned by hv_fetch_ent * for tied hashes */ void Perl_free_tied_hv_pool(pTHX) { dVAR; HE *he = PL_hv_fetch_ent_mh; while (he) { HE * const ohe = he; Safefree(HeKEY_hek(he)); he = HeNEXT(he); del_HE(ohe); } PL_hv_fetch_ent_mh = NULL; } #if defined(USE_ITHREADS) HEK * Perl_hek_dup(pTHX_ HEK *source, CLONE_PARAMS* param) { HEK *shared; PERL_ARGS_ASSERT_HEK_DUP; PERL_UNUSED_ARG(param); if (!source) return NULL; 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); } return shared; } HE * Perl_he_dup(pTHX_ const HE *e, bool shared, CLONE_PARAMS* param) { HE *ret; PERL_ARGS_ASSERT_HE_DUP; if (!e) return NULL; /* look for it in the table first */ ret = (HE*)ptr_table_fetch(PL_ptr_table, e); if (ret) return ret; /* create anew and remember what it is */ ret = new_HE(); ptr_table_store(PL_ptr_table, e, ret); 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) = SvREFCNT_inc(sv_dup(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; } else HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e), HeKFLAGS(e)); HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e), param)); return ret; } #endif /* USE_ITHREADS */ static void S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen, const char *msg) { SV * const sv = sv_newmortal(); PERL_ARGS_ASSERT_HV_NOTALLOWED; if (!(flags & HVhek_FREEKEY)) { 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); } if (flags & HVhek_UTF8) { SvUTF8_on(sv); } Perl_croak(aTHX_ msg, SVfARG(sv)); } /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot * contains an SV* */ /* =for apidoc hv_store Stores an SV in a hash. The hash key is specified as C and C is the length of the key. The C parameter is the precomputed hash value; if it is zero then Perl will compute it. The return value will be NULL if the operation failed or if the value did not need to be actually stored within the hash (as in the case of tied hashes). Otherwise it can be dereferenced to get the original C. Note that the caller is responsible for suitably incrementing the reference count of C before the call, and decrementing it if the function returned NULL. Effectively a successful hv_store takes ownership of one reference to C. This is usually what you want; a newly created SV has a reference count of one, so if all your code does is create SVs then store them in a hash, hv_store will own the only reference to the new SV, and your code doesn't need to do anything further to tidy up. hv_store is not implemented as a call to hv_store_ent, and does not create a temporary SV for the key, so if your key data is not already in SV form then use hv_store in preference to hv_store_ent. See L for more information on how to use this function on tied hashes. =for apidoc hv_store_ent Stores C in a hash. The hash key is specified as C. The C parameter is the precomputed hash value; if it is zero then Perl will compute it. The return value is the new hash entry so created. It will be NULL if the operation failed or if the value did not need to be actually stored within the hash (as in the case of tied hashes). Otherwise the contents of the return value can be accessed using the C macros described here. Note that the caller is responsible for suitably incrementing the reference count of C before the call, and decrementing it if the function returned NULL. Effectively a successful hv_store_ent takes ownership of one reference to C. This is usually what you want; a newly created SV has a reference count of one, so if all your code does is create SVs then store them in a hash, hv_store will own the only reference to the new SV, and your code doesn't need to do anything further to tidy up. Note that hv_store_ent only reads the C; unlike C it does not take ownership of it, so maintaining the correct reference count on C is entirely the caller's responsibility. hv_store is not implemented as a call to hv_store_ent, and does not create a temporary SV for the key, so if your key data is not already in SV form then use hv_store in preference to hv_store_ent. See L for more information on how to use this function on tied hashes. =for apidoc hv_exists Returns a boolean indicating whether the specified hash key exists. The C is the length of the key. =for apidoc hv_fetch Returns the SV which corresponds to the specified key in the hash. The C is the length of the key. If C is set then the fetch will be part of a store. Check that the return value is non-null before dereferencing it to an C. See L for more information on how to use this function on tied hashes. =for apidoc hv_exists_ent Returns a boolean indicating whether the specified hash key exists. C can be a valid precomputed hash value, or 0 to ask for it to be computed. =cut */ /* returns an HE * structure with the all fields set */ /* note that hent_val will be a mortal sv for MAGICAL hashes */ /* =for apidoc hv_fetch_ent Returns the hash entry which corresponds to the specified key in the hash. C must be a valid precomputed hash number for the given C, or 0 if you want the function to compute it. IF C is set then the fetch will be part of a store. Make sure the return value is non-null before accessing it. The return value when C is a tied hash is a pointer to a static location, so be sure to make a copy of the structure if you need to store it somewhere. See L for more information on how to use this function on tied hashes. =cut */ /* 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) { STRLEN klen; int flags; PERL_ARGS_ASSERT_HV_COMMON_KEY_LEN; if (klen_i32 < 0) { klen = -klen_i32; flags = HVhek_UTF8; } else { 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, register U32 hash) { dVAR; XPVHV* xhv; HE *entry; HE **oentry; SV *sv; bool is_utf8; int masked_flags; const int return_svp = action & HV_FETCH_JUST_SV; if (!hv) return NULL; if (SvTYPE(hv) == SVTYPEMASK) 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; } } } 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; } } else { is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE); } if (action & HV_DELETE) { 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); } 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; } #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; } } #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); magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem)); /* 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(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; } #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 = PL_tainted; if (keysv || is_utf8) { if (!keysv) { keysv = newSVpvn_utf8(key, klen, TRUE); } if (PL_tainting) PL_tainted = 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); 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; } #endif } } /* ISSTORE */ } /* SvMAGICAL */ if (!HvARRAY(hv)) { 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)) #endif ) { 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. */ } #endif else { /* XXX remove at some point? */ if (flags & HVhek_FREEKEY) Safefree(key); return NULL; } } if (is_utf8 & !(flags & HVhek_KEYCANONICAL)) { 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; if (key != 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 (HvREHASH(hv)) { PERL_HASH_INTERNAL(hash, key, klen); /* We don't have a pointer to the hv, so we have to replicate the flag into every HEK, so that hv_iterkeysv can see it. */ /* And yes, you do need this even though you are not "storing" because you can flip the flags below if doing an lval lookup. (And that was put in to give the semantics Andreas was expecting.) */ flags |= HVhek_REHASH; } else if (!hash) { if (keysv && (SvIsCOW_shared_hash(keysv))) { hash = SvSHARED_HASH(keysv); } else { PERL_HASH(hash, key, klen); } } masked_flags = (flags & HVhek_MASK); #ifdef DYNAMIC_ENV_FETCH if (!HvARRAY(hv)) entry = NULL; else #endif { entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; } for (; entry; entry = HeNEXT(entry)) { if (HeHASH(entry) != hash) /* strings can't be equal */ continue; if (HeKLEN(entry) != (I32)klen) continue; if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8) continue; 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 actaully 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 entry ? (void *) &HeVAL(entry) : NULL; } return entry; } #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); } } #endif if (!entry && SvREADONLY(hv) && !(action & HV_FETCH_ISEXISTS)) { 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; } if (action & HV_FETCH_LVALUE) { val = 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. */ 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; } oentry = &(HvARRAY(hv))[hash & (I32) xhv->xhv_max]; entry = new_HE(); /* 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); 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 /* gotta do the real thing */ HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags); HeVAL(entry) = val; HeNEXT(entry) = *oentry; *oentry = entry; if (val == &PL_sv_placeholder) HvPLACEHOLDERS(hv)++; if (masked_flags & HVhek_ENABLEHVKFLAGS) HvHASKFLAGS_on(hv); { const HE *counter = HeNEXT(entry); xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */ if (!counter) { /* initial entry? */ xhv->xhv_fill++; /* HvFILL(hv)++ */ } else if (xhv->xhv_keys > (IV)xhv->xhv_max) { hsplit(hv); } else if(!HvREHASH(hv)) { U32 n_links = 1; while ((counter = HeNEXT(counter))) n_links++; if (n_links > HV_MAX_LENGTH_BEFORE_SPLIT) { /* Use only the old HvKEYS(hv) > HvMAX(hv) condition to limit bucket splits on a rehashed hash, as we're not going to split it again, and if someone is lucky (evil) enough to get all the keys in one list they could exhaust our memory as we repeatedly double the number of buckets on every entry. Linear search feels a less worse thing to do. */ hsplit(hv); } } } if (return_svp) { return entry ? (void *) &HeVAL(entry) : NULL; } return (void *) entry; } STATIC void S_hv_magic_check(HV *hv, bool *needs_copy, bool *needs_store) { const MAGIC *mg = SvMAGIC(hv); PERL_ARGS_ASSERT_HV_MAGIC_CHECK; *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; } } /* =for apidoc hv_scalar Evaluates the hash in scalar context and returns the result. Handles magic when the hash is tied. =cut */ SV * Perl_hv_scalar(pTHX_ HV *hv) { SV *sv; 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); } sv = sv_newmortal(); if (HvFILL((const HV *)hv)) Perl_sv_setpvf(aTHX_ sv, "%ld/%ld", (long)HvFILL(hv), (long)HvMAX(hv) + 1); else sv_setiv(sv, 0); return sv; } /* =for apidoc hv_delete Deletes a key/value pair in the hash. The value SV is removed from the hash and returned to the caller. The C is the length of the key. The C value will normally be zero; if set to G_DISCARD then NULL will be returned. =for apidoc hv_delete_ent Deletes a key/value pair in the hash. The value SV is removed from the hash and returned to the caller. The C value will normally be zero; if set to G_DISCARD then NULL will be returned. C can be a valid precomputed hash value, or 0 to ask for it to be computed. =cut */ STATIC SV * S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, int k_flags, I32 d_flags, U32 hash) { dVAR; register XPVHV* xhv; register HE *entry; register HE **oentry; HE *const *first_entry; bool is_utf8 = (k_flags & HVhek_UTF8) ? TRUE : FALSE; int masked_flags; 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 */ } #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; } #endif } } } xhv = (XPVHV*)SvANY(hv); if (!HvARRAY(hv)) return NULL; if (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 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; } HvHASKFLAGS_on(MUTABLE_SV(hv)); } if (HvREHASH(hv)) { PERL_HASH_INTERNAL(hash, key, klen); } else if (!hash) { if (keysv && (SvIsCOW_shared_hash(keysv))) { hash = SvSHARED_HASH(keysv); } else { PERL_HASH(hash, key, klen); } } masked_flags = (k_flags & HVhek_MASK); first_entry = oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; entry = *oentry; for (; entry; oentry = &HeNEXT(entry), entry = *oentry) { SV *sv; if (HeHASH(entry) != hash) /* strings can't be equal */ continue; if (HeKLEN(entry) != (I32)klen) continue; if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8) continue; 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 (d_flags & G_DISCARD) sv = NULL; else { sv = sv_2mortal(HeVAL(entry)); HeVAL(entry) = &PL_sv_placeholder; } /* * 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)) { SvREFCNT_dec(HeVAL(entry)); HeVAL(entry) = &PL_sv_placeholder; /* 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(!*first_entry) { xhv->xhv_fill--; /* HvFILL(hv)-- */ } if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */) HvLAZYDEL_on(hv); else hv_free_ent(hv, entry); xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */ if (xhv->xhv_keys == 0) HvHASKFLAGS_off(hv); } return sv; } if (SvREADONLY(hv)) { hv_notallowed(k_flags, key, klen, "Attempt to delete disallowed key '%"SVf"' from" " a restricted hash"); } if (k_flags & HVhek_FREEKEY) Safefree(key); return NULL; } STATIC void S_hsplit(pTHX_ HV *hv) { dVAR; register XPVHV* const xhv = (XPVHV*)SvANY(hv); const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */ register I32 newsize = oldsize * 2; register I32 i; char *a = (char*) HvARRAY(hv); register HE **aep; register HE **oentry; int longest_chain = 0; int was_shared; PERL_ARGS_ASSERT_HSPLIT; /*PerlIO_printf(PerlIO_stderr(), "hsplit called for %p which had %d\n", (void*)hv, (int) oldsize);*/ if (HvPLACEHOLDERS_get(hv) && !SvREADONLY(hv)) { /* Can make this clear any placeholders first for non-restricted hashes, even though Storable rebuilds restricted hashes by putting in all the placeholders (first) before turning on the readonly flag, because Storable always pre-splits the hash. */ hv_clear_placeholders(hv); } PL_nomemok = TRUE; #if defined(STRANGE_MALLOC) || defined(MYMALLOC) Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize) + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char); if (!a) { PL_nomemok = FALSE; return; } if (SvOOK(hv)) { Move(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux); } #else Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize) + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char); if (!a) { PL_nomemok = FALSE; return; } Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char); if (SvOOK(hv)) { Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux); } if (oldsize >= 64) { offer_nice_chunk(HvARRAY(hv), PERL_HV_ARRAY_ALLOC_BYTES(oldsize) + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0)); } else Safefree(HvARRAY(hv)); #endif PL_nomemok = FALSE; Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/ xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */ HvARRAY(hv) = (HE**) a; aep = (HE**)a; for (i=0; ixhv_fill++; /* HvFILL(hv)++ */ *bep = entry; right_length++; continue; } else { oentry = &HeNEXT(entry); left_length++; } } if (!*aep) /* everything moved */ xhv->xhv_fill--; /* HvFILL(hv)-- */ /* I think we don't actually need to keep track of the longest length, merely flag if anything is too long. But for the moment while developing this code I'll track it. */ if (left_length > longest_chain) longest_chain = left_length; if (right_length > longest_chain) longest_chain = right_length; } /* Pick your policy for "hashing isn't working" here: */ if (longest_chain <= HV_MAX_LENGTH_BEFORE_SPLIT /* split worked? */ || HvREHASH(hv)) { return; } if (hv == PL_strtab) { /* Urg. Someone is doing something nasty to the string table. Can't win. */ return; } /* Awooga. Awooga. Pathological data. */ /*PerlIO_printf(PerlIO_stderr(), "%p %d of %d with %d/%d buckets\n", (void*)hv, longest_chain, HvTOTALKEYS(hv), HvFILL(hv), 1+HvMAX(hv));*/ ++newsize; Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize) + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char); if (SvOOK(hv)) { Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux); } was_shared = HvSHAREKEYS(hv); xhv->xhv_fill = 0; HvSHAREKEYS_off(hv); HvREHASH_on(hv); aep = HvARRAY(hv); for (i=0; ixhv_max); if (!*bep) xhv->xhv_fill++; /* HvFILL(hv)++ */ HeNEXT(entry) = *bep; *bep = entry; entry = next; } } Safefree (HvARRAY(hv)); HvARRAY(hv) = (HE **)a; } void Perl_hv_ksplit(pTHX_ HV *hv, IV newmax) { dVAR; register XPVHV* xhv = (XPVHV*)SvANY(hv); const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */ register I32 newsize; register I32 i; register char *a; register HE **aep; register HE *entry; register HE **oentry; PERL_ARGS_ASSERT_HV_KSPLIT; newsize = (I32) newmax; /* possible truncation here */ if (newsize != newmax || newmax <= oldsize) return; while ((newsize & (1 + ~newsize)) != newsize) { newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */ } if (newsize < newmax) newsize *= 2; if (newsize < newmax) return; /* overflow detection */ a = (char *) HvARRAY(hv); if (a) { PL_nomemok = TRUE; #if defined(STRANGE_MALLOC) || defined(MYMALLOC) Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize) + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char); if (!a) { PL_nomemok = FALSE; return; } if (SvOOK(hv)) { Copy(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux); } #else Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize) + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char); if (!a) { PL_nomemok = FALSE; return; } Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char); if (SvOOK(hv)) { Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux); } if (oldsize >= 64) { offer_nice_chunk(HvARRAY(hv), PERL_HV_ARRAY_ALLOC_BYTES(oldsize) + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0)); } else Safefree(HvARRAY(hv)); #endif PL_nomemok = FALSE; Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/ } else { Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char); } xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */ HvARRAY(hv) = (HE **) a; if (!xhv->xhv_fill /* !HvFILL(hv) */) /* skip rest if no entries */ return; aep = (HE**)a; for (i=0; ixhv_fill++; /* HvFILL(hv)++ */ aep[j] = entry; continue; } else oentry = &HeNEXT(entry); } if (!*aep) /* everything moved */ xhv->xhv_fill--; /* HvFILL(hv)-- */ } } HV * Perl_newHVhv(pTHX_ HV *ohv) { dVAR; HV * const hv = newHV(); STRLEN hv_max, hv_fill; if (!ohv || (hv_fill = HvFILL(ohv)) == 0) 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) = 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; HvFILL(hv) = hv_fill; 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); /* Can we use fewer buckets? (hv_max is always 2^n-1) */ while (hv_max && hv_max + 1 >= hv_fill * 2) hv_max = hv_max / 2; HvMAX(hv) = hv_max; hv_iterinit(ohv); while ((entry = hv_iternext_flags(ohv, 0))) { SV *const val = HeVAL(entry); (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry), SvIMMORTAL(val) ? val : newSVsv(val), HeHASH(entry), HeKFLAGS(entry)); } HvRITER_set(ohv, riter); HvEITER_set(ohv, eiter); } return hv; } /* A rather specialised version of newHVhv for copying %^H, ensuring all the magic stays on it. */ HV * Perl_hv_copy_hints_hv(pTHX_ HV *const ohv) { HV * const hv = newHV(); STRLEN hv_fill; if (ohv && (hv_fill = HvFILL(ohv))) { STRLEN hv_max = HvMAX(ohv); HE *entry; const I32 riter = HvRITER_get(ohv); HE * const eiter = HvEITER_get(ohv); while (hv_max && hv_max + 1 >= hv_fill * 2) hv_max = hv_max / 2; HvMAX(hv) = hv_max; hv_iterinit(ohv); while ((entry = hv_iternext_flags(ohv, 0))) { SV *const sv = newSVsv(HeVAL(entry)); SV *heksv = newSVhek(HeKEY_hek(entry)); sv_magic(sv, NULL, PERL_MAGIC_hintselem, (char *)heksv, HEf_SVKEY); SvREFCNT_dec(heksv); (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry), sv, HeHASH(entry), HeKFLAGS(entry)); } HvRITER_set(ohv, riter); HvEITER_set(ohv, eiter); } hv_magic(hv, NULL, PERL_MAGIC_hints); return hv; } void Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry) { dVAR; SV *val; PERL_ARGS_ASSERT_HV_FREE_ENT; if (!entry) return; val = HeVAL(entry); if (HvNAME(hv) && anonymise_cv(HvNAME_HEK(hv), val) && GvCVu(val)) mro_method_changed_in(hv); SvREFCNT_dec(val); if (HeKLEN(entry) == HEf_SVKEY) { SvREFCNT_dec(HeKEY_sv(entry)); Safefree(HeKEY_hek(entry)); } else if (HvSHAREKEYS(hv)) unshare_hek(HeKEY_hek(entry)); else Safefree(HeKEY_hek(entry)); del_HE(entry); } static I32 S_anonymise_cv(pTHX_ HEK *stash, SV *val) { CV *cv; PERL_ARGS_ASSERT_ANONYMISE_CV; if (val && isGV(val) && isGV_with_GP(val) && (cv = GvCV(val))) { if ((SV *)CvGV(cv) == val) { GV *anongv; if (stash) { SV *gvname = newSVhek(stash); sv_catpvs(gvname, "::__ANON__"); anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV); SvREFCNT_dec(gvname); } else { anongv = gv_fetchpvs("__ANON__::__ANON__", GV_ADDMULTI, SVt_PVCV); } CvGV(cv) = anongv; CvANON_on(cv); return 1; } } return 0; } void Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry) { dVAR; PERL_ARGS_ASSERT_HV_DELAYFREE_ENT; if (!entry) 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))); } hv_free_ent(hv, entry); } /* =for apidoc hv_clear Clears a hash, making it empty. =cut */ void Perl_hv_clear(pTHX_ HV *hv) { dVAR; register XPVHV* xhv; if (!hv) return; DEBUG_A(Perl_hv_assert(aTHX_ hv)); xhv = (XPVHV*)SvANY(hv); 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) && SvREADONLY(HeVAL(entry))) { SV* const keysv = hv_iterkeysv(entry); Perl_croak(aTHX_ "Attempt to delete readonly key '%"SVf"' from a restricted hash", (void*)keysv); } SvREFCNT_dec(HeVAL(entry)); HeVAL(entry) = &PL_sv_placeholder; HvPLACEHOLDERS(hv)++; } } } goto reset; } hfreeentries(hv); HvPLACEHOLDERS_set(hv, 0); if (HvARRAY(hv)) Zero(HvARRAY(hv), xhv->xhv_max+1 /* HvMAX(hv)+1 */, HE*); if (SvRMAGICAL(hv)) mg_clear(MUTABLE_SV(hv)); HvHASKFLAGS_off(hv); HvREHASH_off(hv); reset: if (SvOOK(hv)) { if(HvNAME_get(hv)) mro_isa_changed_in(hv); HvEITER_set(hv, NULL); } } /* =for apidoc hv_clear_placeholders Clears any placeholders from a hash. If a restricted hash has any of its keys marked as readonly and the key is subsequently deleted, the key is not actually deleted but is marked by assigning it a value of &PL_sv_placeholder. This tags it so it will be ignored by future operations such as iterating over the hash, but will still allow the hash to have a value reassigned to the key at some future point. This function clears any such placeholder keys from the hash. See Hash::Util::lock_keys() for an example of its use. =cut */ void Perl_hv_clear_placeholders(pTHX_ HV *hv) { dVAR; const U32 items = (U32)HvPLACEHOLDERS_get(hv); PERL_ARGS_ASSERT_HV_CLEAR_PLACEHOLDERS; if (items) clear_placeholders(hv, items); } static void S_clear_placeholders(pTHX_ HV *hv, U32 items) { dVAR; I32 i; PERL_ARGS_ASSERT_CLEAR_PLACEHOLDERS; if (items == 0) return; i = HvMAX(hv); do { /* Loop down the linked list heads */ bool first = TRUE; HE **oentry = &(HvARRAY(hv))[i]; HE *entry; while ((entry = *oentry)) { if (HeVAL(entry) == &PL_sv_placeholder) { *oentry = HeNEXT(entry); if (first && !*oentry) HvFILL(hv)--; /* This linked list is now empty. */ if (entry == HvEITER_get(hv)) HvLAZYDEL_on(hv); else hv_free_ent(hv, entry); if (--items == 0) { /* Finished. */ HvTOTALKEYS(hv) -= (IV)HvPLACEHOLDERS_get(hv); if (HvKEYS(hv) == 0) HvHASKFLAGS_off(hv); HvPLACEHOLDERS_set(hv, 0); return; } } else { oentry = &HeNEXT(entry); first = FALSE; } } } while (--i >= 0); /* You can't get here, hence assertion should always fail. */ assert (items == 0); assert (0); } STATIC void S_hfreeentries(pTHX_ HV *hv) { /* This is the array that we're going to restore */ HE **const orig_array = HvARRAY(hv); HEK *name; int attempts = 100; PERL_ARGS_ASSERT_HFREEENTRIES; if (!orig_array) return; if (HvNAME(hv) && orig_array != NULL) { /* symbol table: make all the contained subs ANON */ STRLEN i; XPVHV *xhv = (XPVHV*)SvANY(hv); for (i = 0; i <= xhv->xhv_max; i++) { HE *entry = (HvARRAY(hv))[i]; for (; entry; entry = HeNEXT(entry)) { SV *val = HeVAL(entry); /* we need to put the subs in the __ANON__ symtable, as * this one is being cleared. */ anonymise_cv(NULL, val); } } } if (SvOOK(hv)) { /* If the hash is actually a symbol table with a name, look after the name. */ struct xpvhv_aux *iter = HvAUX(hv); name = iter->xhv_name; iter->xhv_name = NULL; } else { name = NULL; } /* orig_array remains unchanged throughout the loop. If after freeing all the entries it turns out that one of the little blighters has triggered an action that has caused HvARRAY to be re-allocated, then we set array to the new HvARRAY, and try again. */ while (1) { /* This is the one we're going to try to empty. First time round it's the original array. (Hopefully there will only be 1 time round) */ HE ** const array = HvARRAY(hv); I32 i = HvMAX(hv); /* Because we have taken xhv_name out, the only allocated pointer in the aux structure that might exist is the backreference array. */ if (SvOOK(hv)) { HE *entry; struct mro_meta *meta; struct xpvhv_aux *iter = HvAUX(hv); /* If there are weak references to this HV, we need to avoid freeing them up here. In particular we need to keep the AV visible as what we're deleting might well have weak references back to this HV, so the for loop below may well trigger the removal of backreferences from this array. */ if (iter->xhv_backreferences) { /* So donate them to regular backref magic to keep them safe. The sv_magic will increase the reference count of the AV, so we need to drop it first. */ SvREFCNT_dec(iter->xhv_backreferences); if (AvFILLp(iter->xhv_backreferences) == -1) { /* Turns out that the array is empty. Just free it. */ SvREFCNT_dec(iter->xhv_backreferences); } else { sv_magic(MUTABLE_SV(hv), MUTABLE_SV(iter->xhv_backreferences), PERL_MAGIC_backref, NULL, 0); } iter->xhv_backreferences = NULL; } entry = iter->xhv_eiter; /* HvEITER(hv) */ if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */ HvLAZYDEL_off(hv); hv_free_ent(hv, entry); } iter->xhv_riter = -1; /* HvRITER(hv) = -1 */ iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */ if((meta = iter->xhv_mro_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; } 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; } if(meta->mro_nextmethod) SvREFCNT_dec(meta->mro_nextmethod); SvREFCNT_dec(meta->isa); Safefree(meta); iter->xhv_mro_meta = NULL; } /* There are now no allocated pointers in the aux structure. */ SvFLAGS(hv) &= ~SVf_OOK; /* Goodbye, aux structure. */ /* What aux structure? */ } /* make everyone else think the array is empty, so that the destructors * called for freed entries can't recusively mess with us */ HvARRAY(hv) = NULL; HvFILL(hv) = 0; ((XPVHV*) SvANY(hv))->xhv_keys = 0; do { /* Loop down the linked list heads */ HE *entry = array[i]; while (entry) { register HE * const oentry = entry; entry = HeNEXT(entry); hv_free_ent(hv, oentry); } } while (--i >= 0); /* As there are no allocated pointers in the aux structure, it's now safe to free the array we just cleaned up, if it's not the one we're going to put back. */ if (array != orig_array) { Safefree(array); } if (!HvARRAY(hv)) { /* Good. No-one added anything this time round. */ break; } if (SvOOK(hv)) { /* Someone attempted to iterate or set the hash name while we had the array set to 0. We'll catch backferences on the next time round the while loop. */ assert(HvARRAY(hv)); if (HvAUX(hv)->xhv_name) { unshare_hek_or_pvn(HvAUX(hv)->xhv_name, 0, 0, 0); } } if (--attempts == 0) { Perl_die(aTHX_ "panic: hfreeentries failed to free hash - something is repeatedly re-creating entries"); } } HvARRAY(hv) = orig_array; /* If the hash was actually a symbol table, put the name back. */ if (name) { /* We have restored the original array. If name is non-NULL, then the original array had an aux structure at the end. So this is valid: */ SvFLAGS(hv) |= SVf_OOK; HvAUX(hv)->xhv_name = name; } } /* =for apidoc hv_undef Undefines the hash. =cut */ void Perl_hv_undef(pTHX_ HV *hv) { dVAR; register XPVHV* xhv; const char *name; if (!hv) return; DEBUG_A(Perl_hv_assert(aTHX_ hv)); xhv = (XPVHV*)SvANY(hv); if ((name = HvNAME_get(hv)) && !PL_dirty) mro_isa_changed_in(hv); hfreeentries(hv); if (name) { if (PL_stashcache) (void)hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD); hv_name_set(hv, NULL, 0, 0); } SvFLAGS(hv) &= ~SVf_OOK; Safefree(HvARRAY(hv)); xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */ HvARRAY(hv) = 0; HvPLACEHOLDERS_set(hv, 0); if (SvRMAGICAL(hv)) mg_clear(MUTABLE_SV(hv)); } static struct xpvhv_aux* S_hv_auxinit(HV *hv) { struct xpvhv_aux *iter; char *array; PERL_ARGS_ASSERT_HV_AUXINIT; if (!HvARRAY(hv)) { Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1) + sizeof(struct xpvhv_aux), char); } else { array = (char *) HvARRAY(hv); Renew(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1) + sizeof(struct xpvhv_aux), char); } HvARRAY(hv) = (HE**) array; /* SvOOK_on(hv) attacks the IV flags. */ SvFLAGS(hv) |= SVf_OOK; iter = HvAUX(hv); iter->xhv_riter = -1; /* HvRITER(hv) = -1 */ iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */ iter->xhv_name = 0; iter->xhv_backreferences = 0; iter->xhv_mro_meta = NULL; return iter; } /* =for apidoc hv_iterinit Prepares a starting point to traverse a hash table. Returns the number of keys in the hash (i.e. the same as C). The return value is currently only meaningful for hashes without tie magic. NOTE: Before version 5.004_65, C used to return the number of hash buckets that happen to be in use. If you still need that esoteric value, you can get it through the macro C. =cut */ I32 Perl_hv_iterinit(pTHX_ HV *hv) { PERL_ARGS_ASSERT_HV_ITERINIT; /* FIXME: Are we not NULL, or do we croak? Place bets now! */ if (!hv) Perl_croak(aTHX_ "Bad hash"); if (SvOOK(hv)) { struct xpvhv_aux * const 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->xhv_riter = -1; /* HvRITER(hv) = -1 */ iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */ } else { hv_auxinit(hv); } /* used to be xhv->xhv_fill before 5.004_65 */ return HvTOTALKEYS(hv); } I32 * Perl_hv_riter_p(pTHX_ HV *hv) { struct xpvhv_aux *iter; PERL_ARGS_ASSERT_HV_RITER_P; if (!hv) Perl_croak(aTHX_ "Bad hash"); iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv); return &(iter->xhv_riter); } HE ** Perl_hv_eiter_p(pTHX_ HV *hv) { struct xpvhv_aux *iter; PERL_ARGS_ASSERT_HV_EITER_P; if (!hv) Perl_croak(aTHX_ "Bad hash"); iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv); return &(iter->xhv_eiter); } void Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) { struct xpvhv_aux *iter; PERL_ARGS_ASSERT_HV_RITER_SET; if (!hv) Perl_croak(aTHX_ "Bad hash"); if (SvOOK(hv)) { iter = HvAUX(hv); } else { if (riter == -1) return; iter = hv_auxinit(hv); } iter->xhv_riter = riter; } void Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) { struct xpvhv_aux *iter; PERL_ARGS_ASSERT_HV_EITER_SET; if (!hv) Perl_croak(aTHX_ "Bad hash"); if (SvOOK(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; iter = hv_auxinit(hv); } iter->xhv_eiter = eiter; } void Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags) { dVAR; struct xpvhv_aux *iter; U32 hash; PERL_ARGS_ASSERT_HV_NAME_SET; PERL_UNUSED_ARG(flags); if (len > I32_MAX) Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len); if (SvOOK(hv)) { iter = HvAUX(hv); if (iter->xhv_name) { unshare_hek_or_pvn(iter->xhv_name, 0, 0, 0); } } else { if (name == 0) return; iter = hv_auxinit(hv); } PERL_HASH(hash, name, len); iter->xhv_name = name ? share_hek(name, len, hash) : NULL; } AV ** Perl_hv_backreferences_p(pTHX_ HV *hv) { struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv); PERL_ARGS_ASSERT_HV_BACKREFERENCES_P; PERL_UNUSED_CONTEXT; return &(iter->xhv_backreferences); } void Perl_hv_kill_backrefs(pTHX_ HV *hv) { AV *av; PERL_ARGS_ASSERT_HV_KILL_BACKREFS; if (!SvOOK(hv)) return; av = HvAUX(hv)->xhv_backreferences; if (av) { HvAUX(hv)->xhv_backreferences = 0; Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av); SvREFCNT_dec(av); } } /* hv_iternext is implemented as a macro in hv.h =for apidoc hv_iternext Returns entries from a hash iterator. See C. You may call C or C on the hash entry that the iterator currently points to, without losing your place or invalidating your iterator. Note that in this case the current entry is deleted from the hash with your iterator holding the last reference to it. Your iterator is flagged to free the entry on the next call to C, so you must not discard your iterator immediately else the entry will leak - call C to trigger the resource deallocation. =for apidoc hv_iternext_flags Returns entries from a hash iterator. See C and C. The C value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is set the placeholders keys (for restricted hashes) will be returned in addition to normal keys. By default placeholders are automatically skipped over. Currently a placeholder is implemented with a value that is C<&Perl_sv_placeholder>. Note that the implementation of placeholders and restricted hashes may change, and the implementation currently is insufficiently abstracted for any change to be tidy. =cut */ HE * Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) { dVAR; register XPVHV* xhv; register HE *entry; HE *oldentry; MAGIC* mg; struct xpvhv_aux *iter; PERL_ARGS_ASSERT_HV_ITERNEXT_FLAGS; if (!hv) Perl_croak(aTHX_ "Bad hash"); xhv = (XPVHV*)SvANY(hv); if (!SvOOK(hv)) { /* Too many things (well, pp_each at least) merrily assume that you can call iv_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) ) ) { SV * const key = sv_newmortal(); if (entry) { sv_setsv(key, HeSVKEY_force(entry)); SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */ } else { char *k; HEK *hek; /* one HE per MAGICAL hash */ iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */ Zero(entry, 1, HE); Newxz(k, HEK_BASESIZE + sizeof(const SV *), char); hek = (HEK*)k; HeKEY_hek(entry) = hek; HeKLEN(entry) = HEf_SVKEY; } magic_nextpack(MUTABLE_SV(hv),mg,key); if (SvOK(key)) { /* force key to stay around until next time */ HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key)); return entry; /* beware, hent_val is not set */ } SvREFCNT_dec(HeVAL(entry)); Safefree(HeKEY_hek(entry)); del_HE(entry); iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */ 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(); #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) */ #endif } #endif /* hv_iterint now ensures this. */ assert (HvARRAY(hv)); /* At start of hash, entry is NULL. */ if (entry) { entry = HeNEXT(entry); if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) { /* * Skip past any placeholders -- don't want to include them in * any iteration. */ while (entry && HeVAL(entry) == &PL_sv_placeholder) { entry = HeNEXT(entry); } } } /* 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 */ break; } entry = (HvARRAY(hv))[iter->xhv_riter]; 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 (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */ HvLAZYDEL_off(hv); hv_free_ent(hv, oldentry); } /*if (HvREHASH(hv) && entry && !HeKREHASH(entry)) PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", (void*)hv, (void*)entry);*/ iter->xhv_eiter = entry; /* HvEITER(hv) = entry */ return entry; } /* =for apidoc hv_iterkey Returns the key from the current position of the hash iterator. See C. =cut */ char * Perl_hv_iterkey(pTHX_ register 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; } else { *retlen = HeKLEN(entry); return HeKEY(entry); } } /* unlike hv_iterval(), this always returns a mortal copy of the key */ /* =for apidoc hv_iterkeysv Returns the key as an C from the current position of the hash iterator. The return value will always be a mortal copy of the key. Also see C. =cut */ SV * Perl_hv_iterkeysv(pTHX_ register HE *entry) { PERL_ARGS_ASSERT_HV_ITERKEYSV; return sv_2mortal(newSVhek(HeKEY_hek(entry))); } /* =for apidoc hv_iterval Returns the value from the current position of the hash iterator. See C. =cut */ SV * Perl_hv_iterval(pTHX_ HV *hv, register 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; } } return HeVAL(entry); } /* =for apidoc hv_iternextsv Performs an C, C, and C in one operation. =cut */ SV * Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen) { HE * const he = hv_iternext_flags(hv, 0); PERL_ARGS_ASSERT_HV_ITERNEXTSV; if (!he) return NULL; *key = hv_iterkey(he, retlen); return hv_iterval(hv, he); } /* Now a macro in hv.h =for apidoc hv_magic Adds magic to a hash. See C. =cut */ /* possibly free a shared string if no one has access to it * len and hash must both be valid for str. */ void Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash) { unshare_hek_or_pvn (NULL, str, len, hash); } void Perl_unshare_hek(pTHX_ HEK *hek) { assert(hek); unshare_hek_or_pvn(hek, NULL, 0, 0); } /* possibly free a shared string if no one has access to it hek if non-NULL takes priority over the other 3, else str, len and hash are used. If so, len and hash must both be valid for str. */ STATIC void S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash) { dVAR; register XPVHV* xhv; HE *entry; register HE **oentry; HE **first; bool is_utf8 = FALSE; int k_flags = 0; const char * const save = str; 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)); /* 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; } hash = HEK_HASH(hek); } else if (len < 0) { STRLEN tmplen = -len; is_utf8 = TRUE; /* See the note in hv_fetch(). --jhi */ str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8); len = tmplen; if (is_utf8) k_flags = HVhek_UTF8; if (str != save) k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY; } /* 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); } */ xhv = (XPVHV*)SvANY(PL_strtab); /* assert(xhv_array != 0) */ first = oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)]; if (he) { const HE *const he_he = &(he->shared_he_he); for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) { if (entry == he_he) break; } } else { const int flags_masked = k_flags & HVhek_MASK; for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) { if (HeHASH(entry) != hash) /* strings can't be equal */ continue; if (HeKLEN(entry) != len) continue; if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */ continue; if (HeKFLAGS(entry) != flags_masked) continue; break; } } if (entry) { if (--entry->he_valu.hent_refcount == 0) { *oentry = HeNEXT(entry); if (!*first) { /* There are now no entries in our slot. */ xhv->xhv_fill--; /* HvFILL(hv)-- */ } Safefree(entry); xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */ } } if (!entry) Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Attempt to free non-existent 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); } /* get a (constant) string ptr from the global string table * string will get added if it is not already there. * len and hash must both be valid for str. */ HEK * Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash) { bool is_utf8 = FALSE; int flags = 0; const char * const save = str; PERL_ARGS_ASSERT_SHARE_HEK; if (len < 0) { STRLEN tmplen = -len; is_utf8 = TRUE; /* See the note in hv_fetch(). --jhi */ str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8); len = tmplen; /* If we were able to downgrade here, then than means that we were passed in a key which only had chars 0-255, but was utf8 encoded. */ if (is_utf8) flags = HVhek_UTF8; /* If we found we were able to downgrade the string to bytes, then we should flag that it needs upgrading on keys or each. Also flag that we need share_hek_flags to free the string. */ if (str != save) flags |= HVhek_WASUTF8 | HVhek_FREEKEY; } return share_hek_flags (str, len, hash, flags); } STATIC HEK * S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags) { dVAR; register HE *entry; const int flags_masked = flags & HVhek_MASK; const U32 hindex = hash & (I32) HvMAX(PL_strtab); register XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab); PERL_ARGS_ASSERT_SHARE_HEK_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); 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) != 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 HEK directly from the HE. */ 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? */ xhv->xhv_fill++; /* HvFILL(hv)++ */ } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) { hsplit(PL_strtab); } } ++entry->he_valu.hent_refcount; if (flags & HVhek_FREEKEY) Safefree(str); return HeKEY_hek(entry); } I32 * Perl_hv_placeholders_p(pTHX_ HV *hv) { dVAR; MAGIC *mg = mg_find((const SV *)hv, PERL_MAGIC_rhash); PERL_ARGS_ASSERT_HV_PLACEHOLDERS_P; if (!mg) { mg = sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, 0); if (!mg) { Perl_die(aTHX_ "panic: hv_placeholders_p"); } } return &(mg->mg_len); } I32 Perl_hv_placeholders_get(pTHX_ const HV *hv) { dVAR; MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash); PERL_ARGS_ASSERT_HV_PLACEHOLDERS_GET; return mg ? mg->mg_len : 0; } void Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph) { dVAR; MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash); PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET; if (mg) { 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"); } /* else we don't need to add magic to record 0 placeholders. */ } STATIC SV * S_refcounted_he_value(pTHX_ const struct refcounted_he *he) { dVAR; SV *value; PERL_ARGS_ASSERT_REFCOUNTED_HE_VALUE; switch(he->refcounted_he_data[0] & HVrhek_typemask) { case HVrhek_undef: value = newSV(0); break; case HVrhek_delete: value = &PL_sv_placeholder; break; case HVrhek_IV: 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; 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; default: Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %x", he->refcounted_he_data[0]); } return value; } /* =for apidoc refcounted_he_chain_2hv Generates and returns a C by walking up the tree starting at the passed in C. =cut */ HV * Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain) { dVAR; HV *hv = newHV(); U32 placeholders = 0; /* 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 hash with only 8 entries in its array. */ const U32 max = HvMAX(hv); if (!HvARRAY(hv)) { char *array; Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char); HvARRAY(hv) = (HE**)array; } while (chain) { #ifdef USE_ITHREADS U32 hash = chain->refcounted_he_hash; #else 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. */ #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; #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; #endif } } 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))); #else 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; /* Link it into the chain. */ HeNEXT(entry) = *oentry; if (!HeNEXT(entry)) { /* initial entry. */ HvFILL(hv)++; } *oentry = entry; HvTOTALKEYS(hv)++; next_please: chain = chain->refcounted_he_next; } if (placeholders) { clear_placeholders(hv, placeholders); HvTOTALKEYS(hv) -= placeholders; } /* We could check in the loop to see if we encounter any keys with key flags, but it's probably not worth it, as this per-hash flag is only really meant as an optimisation for things like Storable. */ HvHASKFLAGS_on(hv); DEBUG_A(Perl_hv_assert(aTHX_ hv)); return hv; } SV * Perl_refcounted_he_fetch(pTHX_ const struct refcounted_he *chain, SV *keysv, const char *key, STRLEN klen, int flags, U32 hash) { dVAR; /* Just to be awkward, if you're using this interface the UTF-8-or-not-ness of your key has to exactly match that which is stored. */ SV *value = &PL_sv_placeholder; if (chain) { /* No point in doing any of this if there's nothing to find. */ bool is_utf8; if (keysv) { if (flags & HVhek_FREEKEY) Safefree(key); key = SvPV_const(keysv, klen); flags = 0; is_utf8 = (SvUTF8(keysv) != 0); } else { is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE); } if (!hash) { if (keysv && (SvIsCOW_shared_hash(keysv))) { hash = SvSHARED_HASH(keysv); } else { PERL_HASH(hash, key, klen); } } for (; chain; chain = chain->refcounted_he_next) { #ifdef USE_ITHREADS if (hash != chain->refcounted_he_hash) continue; if (klen != chain->refcounted_he_keylen) continue; if (memNE(REF_HE_KEY(chain),key,klen)) continue; if (!!is_utf8 != !!(chain->refcounted_he_data[0] & HVhek_UTF8)) continue; #else if (hash != HEK_HASH(chain->refcounted_he_hek)) continue; if (klen != (STRLEN)HEK_LEN(chain->refcounted_he_hek)) continue; if (memNE(HEK_KEY(chain->refcounted_he_hek),key,klen)) continue; if (!!is_utf8 != !!HEK_UTF8(chain->refcounted_he_hek)) continue; #endif value = sv_2mortal(refcounted_he_value(chain)); break; } } if (flags & HVhek_FREEKEY) Safefree(key); return value; } /* =for apidoc refcounted_he_new Creates a new C. As S is copied, and value is stored in a compact form, all references remain the property of the caller. The C is returned with a reference count of 1. =cut */ struct refcounted_he * Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent, SV *const key, SV *const value) { dVAR; STRLEN key_len; const char *key_p = SvPV_const(key, key_len); STRLEN value_len = 0; const char *value_p = NULL; char value_type; char flags; bool is_utf8 = SvUTF8(key) ? TRUE : FALSE; if (SvPOK(value)) { value_type = HVrhek_PV; } else if (SvIOK(value)) { value_type = SvUOK((const SV *)value) ? HVrhek_UV : HVrhek_IV; } else if (value == &PL_sv_placeholder) { value_type = HVrhek_delete; } else if (!SvOK(value)) { value_type = HVrhek_undef; } else { value_type = HVrhek_PV; } if (value_type == HVrhek_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; } flags = value_type; if (is_utf8) { /* Hash keys are always stored normalised to (yes) ISO-8859-1. As we're going to be building hash keys from this value in future, normalise it now. */ key_p = (char*)bytes_from_utf8((const U8*)key_p, &key_len, &is_utf8); flags |= is_utf8 ? HVhek_UTF8 : HVhek_WASUTF8; } return refcounted_he_new_common(parent, key_p, key_len, flags, value_type, ((value_type == HVrhek_PV || value_type == HVrhek_PV_UTF8) ? (void *)value_p : (void *)value), value_len); } static struct refcounted_he * S_refcounted_he_new_common(pTHX_ struct refcounted_he *const parent, const char *const key_p, const STRLEN key_len, const char flags, char value_type, const void *value, const STRLEN value_len) { dVAR; struct refcounted_he *he; U32 hash; const bool is_pv = value_type == HVrhek_PV || value_type == HVrhek_PV_UTF8; STRLEN key_offset = is_pv ? value_len + 2 : 1; PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_COMMON; #ifdef USE_ITHREADS he = (struct refcounted_he*) PerlMemShared_malloc(sizeof(struct refcounted_he) - 1 + key_len + key_offset); #else he = (struct refcounted_he*) PerlMemShared_malloc(sizeof(struct refcounted_he) - 1 + key_offset); #endif he->refcounted_he_next = parent; if (is_pv) { Copy((char *)value, 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((const SV *)value); } else if (value_type == HVrhek_UV) { he->refcounted_he_val.refcounted_he_u_uv = SvUVX((const SV *)value); } PERL_HASH(hash, key_p, key_len); #ifdef USE_ITHREADS he->refcounted_he_hash = hash; he->refcounted_he_keylen = key_len; Copy(key_p, he->refcounted_he_data + key_offset, key_len, char); #else he->refcounted_he_hek = share_hek_flags(key_p, key_len, hash, flags); #endif if (flags & HVhek_WASUTF8) { /* If it was downgraded from UTF-8, then the pointer returned from bytes_from_utf8 is an allocated pointer that we must free. */ Safefree(key_p); } he->refcounted_he_data[0] = flags; he->refcounted_he_refcnt = 1; return he; } /* =for apidoc refcounted_he_free Decrements the reference count of the passed in C by one. If the reference count reaches zero the structure's memory is freed, and C iterates onto the parent node. =cut */ void Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) { dVAR; 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; } #ifndef USE_ITHREADS unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0); #endif copy = he; he = he->refcounted_he_next; PerlMemShared_free(copy); } } const char * Perl_fetch_cop_label(pTHX_ struct refcounted_he *const chain, STRLEN *len, U32 *flags) { if (!chain) return NULL; #ifdef USE_ITHREADS if (chain->refcounted_he_keylen != 1) return NULL; if (*REF_HE_KEY(chain) != ':') return NULL; #else if ((STRLEN)HEK_LEN(chain->refcounted_he_hek) != 1) return NULL; if (*HEK_KEY(chain->refcounted_he_hek) != ':') 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; if (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; } return chain->refcounted_he_data + 1; } /* As newSTATEOP currently gets passed plain char* labels, we will only provide that interface. Once it works out how to pass in length and UTF-8 ness, this function will need superseding. */ struct refcounted_he * Perl_store_cop_label(pTHX_ struct refcounted_he *const chain, const char *label) { PERL_ARGS_ASSERT_STORE_COP_LABEL; return refcounted_he_new_common(chain, ":", 1, HVrhek_PV, HVrhek_PV, label, strlen(label)); } /* =for apidoc hv_assert Check that a hash is in an internally consistent state. =cut */ #ifdef DEBUGGING void Perl_hv_assert(pTHX_ HV *hv) { dVAR; HE* entry; int withflags = 0; int placeholders = 0; int real = 0; int bad = 0; const I32 riter = HvRITER_get(hv); HE *eiter = HvEITER_get(hv); PERL_ARGS_ASSERT_HV_ASSERT; (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++; } 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; } } 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; } if (bad) { sv_dump(MUTABLE_SV(hv)); } HvRITER_set(hv, riter); /* Restore hash iterator state */ HvEITER_set(hv, eiter); } #endif /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */ perl-5.12.0-RC0/keywords.h0000644000175000017500000001443411325125741014156 0ustar jessejesse/* -*- buffer-read-only: t -*- * * keywords.h * * Copyright (C) 1994, 1995, 1996, 1997, 1999, 2000, 2001, 2002, 2005, * 2006, 2007, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * * !!!!!!! DO NOT EDIT THIS FILE !!!!!!! * This file is built by keywords.pl from its data. Any changes made here * will be lost! */ #define KEY_NULL 0 #define KEY___FILE__ 1 #define KEY___LINE__ 2 #define KEY___PACKAGE__ 3 #define KEY___DATA__ 4 #define KEY___END__ 5 #define KEY_AUTOLOAD 6 #define KEY_BEGIN 7 #define KEY_UNITCHECK 8 #define KEY_CORE 9 #define KEY_DESTROY 10 #define KEY_END 11 #define KEY_INIT 12 #define KEY_CHECK 13 #define KEY_abs 14 #define KEY_accept 15 #define KEY_alarm 16 #define KEY_and 17 #define KEY_atan2 18 #define KEY_bind 19 #define KEY_binmode 20 #define KEY_bless 21 #define KEY_break 22 #define KEY_caller 23 #define KEY_chdir 24 #define KEY_chmod 25 #define KEY_chomp 26 #define KEY_chop 27 #define KEY_chown 28 #define KEY_chr 29 #define KEY_chroot 30 #define KEY_close 31 #define KEY_closedir 32 #define KEY_cmp 33 #define KEY_connect 34 #define KEY_continue 35 #define KEY_cos 36 #define KEY_crypt 37 #define KEY_dbmclose 38 #define KEY_dbmopen 39 #define KEY_default 40 #define KEY_defined 41 #define KEY_delete 42 #define KEY_die 43 #define KEY_do 44 #define KEY_dump 45 #define KEY_each 46 #define KEY_else 47 #define KEY_elsif 48 #define KEY_endgrent 49 #define KEY_endhostent 50 #define KEY_endnetent 51 #define KEY_endprotoent 52 #define KEY_endpwent 53 #define KEY_endservent 54 #define KEY_eof 55 #define KEY_eq 56 #define KEY_eval 57 #define KEY_exec 58 #define KEY_exists 59 #define KEY_exit 60 #define KEY_exp 61 #define KEY_fcntl 62 #define KEY_fileno 63 #define KEY_flock 64 #define KEY_for 65 #define KEY_foreach 66 #define KEY_fork 67 #define KEY_format 68 #define KEY_formline 69 #define KEY_ge 70 #define KEY_getc 71 #define KEY_getgrent 72 #define KEY_getgrgid 73 #define KEY_getgrnam 74 #define KEY_gethostbyaddr 75 #define KEY_gethostbyname 76 #define KEY_gethostent 77 #define KEY_getlogin 78 #define KEY_getnetbyaddr 79 #define KEY_getnetbyname 80 #define KEY_getnetent 81 #define KEY_getpeername 82 #define KEY_getpgrp 83 #define KEY_getppid 84 #define KEY_getpriority 85 #define KEY_getprotobyname 86 #define KEY_getprotobynumber 87 #define KEY_getprotoent 88 #define KEY_getpwent 89 #define KEY_getpwnam 90 #define KEY_getpwuid 91 #define KEY_getservbyname 92 #define KEY_getservbyport 93 #define KEY_getservent 94 #define KEY_getsockname 95 #define KEY_getsockopt 96 #define KEY_given 97 #define KEY_glob 98 #define KEY_gmtime 99 #define KEY_goto 100 #define KEY_grep 101 #define KEY_gt 102 #define KEY_hex 103 #define KEY_if 104 #define KEY_index 105 #define KEY_int 106 #define KEY_ioctl 107 #define KEY_join 108 #define KEY_keys 109 #define KEY_kill 110 #define KEY_last 111 #define KEY_lc 112 #define KEY_lcfirst 113 #define KEY_le 114 #define KEY_length 115 #define KEY_link 116 #define KEY_listen 117 #define KEY_local 118 #define KEY_localtime 119 #define KEY_lock 120 #define KEY_log 121 #define KEY_lstat 122 #define KEY_lt 123 #define KEY_m 124 #define KEY_map 125 #define KEY_mkdir 126 #define KEY_msgctl 127 #define KEY_msgget 128 #define KEY_msgrcv 129 #define KEY_msgsnd 130 #define KEY_my 131 #define KEY_ne 132 #define KEY_next 133 #define KEY_no 134 #define KEY_not 135 #define KEY_oct 136 #define KEY_open 137 #define KEY_opendir 138 #define KEY_or 139 #define KEY_ord 140 #define KEY_our 141 #define KEY_pack 142 #define KEY_package 143 #define KEY_pipe 144 #define KEY_pop 145 #define KEY_pos 146 #define KEY_print 147 #define KEY_printf 148 #define KEY_prototype 149 #define KEY_push 150 #define KEY_q 151 #define KEY_qq 152 #define KEY_qr 153 #define KEY_quotemeta 154 #define KEY_qw 155 #define KEY_qx 156 #define KEY_rand 157 #define KEY_read 158 #define KEY_readdir 159 #define KEY_readline 160 #define KEY_readlink 161 #define KEY_readpipe 162 #define KEY_recv 163 #define KEY_redo 164 #define KEY_ref 165 #define KEY_rename 166 #define KEY_require 167 #define KEY_reset 168 #define KEY_return 169 #define KEY_reverse 170 #define KEY_rewinddir 171 #define KEY_rindex 172 #define KEY_rmdir 173 #define KEY_s 174 #define KEY_say 175 #define KEY_scalar 176 #define KEY_seek 177 #define KEY_seekdir 178 #define KEY_select 179 #define KEY_semctl 180 #define KEY_semget 181 #define KEY_semop 182 #define KEY_send 183 #define KEY_setgrent 184 #define KEY_sethostent 185 #define KEY_setnetent 186 #define KEY_setpgrp 187 #define KEY_setpriority 188 #define KEY_setprotoent 189 #define KEY_setpwent 190 #define KEY_setservent 191 #define KEY_setsockopt 192 #define KEY_shift 193 #define KEY_shmctl 194 #define KEY_shmget 195 #define KEY_shmread 196 #define KEY_shmwrite 197 #define KEY_shutdown 198 #define KEY_sin 199 #define KEY_sleep 200 #define KEY_socket 201 #define KEY_socketpair 202 #define KEY_sort 203 #define KEY_splice 204 #define KEY_split 205 #define KEY_sprintf 206 #define KEY_sqrt 207 #define KEY_srand 208 #define KEY_stat 209 #define KEY_state 210 #define KEY_study 211 #define KEY_sub 212 #define KEY_substr 213 #define KEY_symlink 214 #define KEY_syscall 215 #define KEY_sysopen 216 #define KEY_sysread 217 #define KEY_sysseek 218 #define KEY_system 219 #define KEY_syswrite 220 #define KEY_tell 221 #define KEY_telldir 222 #define KEY_tie 223 #define KEY_tied 224 #define KEY_time 225 #define KEY_times 226 #define KEY_tr 227 #define KEY_truncate 228 #define KEY_uc 229 #define KEY_ucfirst 230 #define KEY_umask 231 #define KEY_undef 232 #define KEY_unless 233 #define KEY_unlink 234 #define KEY_unpack 235 #define KEY_unshift 236 #define KEY_untie 237 #define KEY_until 238 #define KEY_use 239 #define KEY_utime 240 #define KEY_values 241 #define KEY_vec 242 #define KEY_wait 243 #define KEY_waitpid 244 #define KEY_wantarray 245 #define KEY_warn 246 #define KEY_when 247 #define KEY_while 248 #define KEY_write 249 #define KEY_x 250 #define KEY_xor 251 #define KEY_y 252 /* ex: set ro: */ perl-5.12.0-RC0/unixish.h0000444000175000017500000001072111325125742013770 0ustar jessejesse/* unixish.h * * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1999, 2000, 2001, 2002, * 2003, 2006, 2007, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * The following symbols are defined if your operating system supports * functions by that name. All Unixes I know of support them, thus they * are not checked by the configuration script, but are directly defined * here. */ #ifndef PERL_MICRO /* HAS_IOCTL: * This symbol, if defined, indicates that the ioctl() routine is * available to set I/O characteristics */ #define HAS_IOCTL /**/ /* HAS_UTIME: * This symbol, if defined, indicates that the routine utime() is * available to update the access and modification times of files. */ #define HAS_UTIME /**/ /* HAS_GROUP * This symbol, if defined, indicates that the getgrnam() and * getgrgid() routines are available to get group entries. * The getgrent() has a separate definition, HAS_GETGRENT. */ #define HAS_GROUP /**/ /* HAS_PASSWD * This symbol, if defined, indicates that the getpwnam() and * getpwuid() routines are available to get password entries. * The getpwent() has a separate definition, HAS_GETPWENT. */ #define HAS_PASSWD /**/ #define HAS_KILL #define HAS_WAIT #endif /* !PERL_MICRO */ /* USEMYBINMODE * This symbol, if defined, indicates that the program should * use the routine my_binmode(FILE *fp, char iotype) to insure * that a file is in "binary" mode -- that is, that no translation * of bytes occurs on read or write operations. */ #undef USEMYBINMODE /* Stat_t: * This symbol holds the type used to declare buffers for information * returned by stat(). It's usually just struct stat. It may be necessary * to include and to get any typedef'ed * information. */ #define Stat_t struct stat /* USE_STAT_RDEV: * This symbol is defined if this system has a stat structure declaring * st_rdev */ #define USE_STAT_RDEV /**/ /* ACME_MESS: * This symbol, if defined, indicates that error messages should be * should be generated in a format that allows the use of the Acme * GUI/editor's autofind feature. */ #undef ACME_MESS /**/ /* UNLINK_ALL_VERSIONS: * This symbol, if defined, indicates that the program should arrange * to remove all versions of a file if unlink() is called. This is * probably only relevant for VMS. */ /* #define UNLINK_ALL_VERSIONS / **/ /* VMS: * This symbol, if defined, indicates that the program is running under * VMS. It is currently automatically set by cpps running under VMS, * and is included here for completeness only. */ /* #define VMS / **/ /* ALTERNATE_SHEBANG: * This symbol, if defined, contains a "magic" string which may be used * as the first line of a Perl program designed to be executed directly * by name, instead of the standard Unix #!. If ALTERNATE_SHEBANG * begins with a character other then #, then Perl will only treat * it as a command line if it finds the string "perl" in the first * word; otherwise it's treated as the first line of code in the script. * (IOW, Perl won't hand off to another interpreter via an alternate * shebang sequence that might be legal Perl code.) */ /* #define ALTERNATE_SHEBANG "#!" / **/ # include #ifndef SIGABRT # define SIGABRT SIGILL #endif #ifndef SIGILL # define SIGILL 6 /* blech */ #endif #define ABORT() kill(PerlProc_getpid(),SIGABRT); /* * fwrite1() should be a routine with the same calling sequence as fwrite(), * but which outputs all of the bytes requested as a single stream (unlike * fwrite() itself, which on some systems outputs several distinct records * if the number_of_items parameter is >1). */ #define fwrite1 fwrite #define Stat(fname,bufptr) stat((fname),(bufptr)) #define Fstat(fd,bufptr) fstat((fd),(bufptr)) #define Fflush(fp) fflush(fp) #define Mkdir(path,mode) mkdir((path),(mode)) #ifndef PERL_SYS_INIT_BODY # define PERL_SYS_INIT_BODY(c,v) \ MALLOC_CHECK_TAINT2(*c,*v) PERL_FPU_INIT; PERLIO_INIT; MALLOC_INIT #endif #ifndef PERL_SYS_TERM_BODY # define PERL_SYS_TERM_BODY() \ HINTS_REFCNT_TERM; OP_REFCNT_TERM; PERLIO_TERM; MALLOC_TERM; #endif #define BIT_BUCKET "/dev/null" #define dXSUB_SYS #ifndef NO_ENVIRON_ARRAY #define USE_ENVIRON_ARRAY #endif /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */ perl-5.12.0-RC0/README.dos0000444000175000017500000002443211325125741013577 0ustar jessejesseIf you read this file _as_is_, just ignore the funny characters you see. It is written in the POD format (see perlpod manpage) which is specially designed to be readable as is. =head1 NAME perldos - Perl under DOS, W31, W95. =head1 SYNOPSIS These are instructions for building Perl under DOS (or w??), using DJGPP v2.03 or later. Under w95 long filenames are supported. =head1 DESCRIPTION Before you start, you should glance through the README file found in the top-level directory where the Perl distribution was extracted. Make sure you read and understand the terms under which this software is being distributed. This port currently supports MakeMaker (the set of modules that is used to build extensions to perl). Therefore, you should be able to build and install most extensions found in the CPAN sites. Detailed instructions on how to build and install perl extension modules, including XS-type modules, is included. See 'BUILDING AND INSTALLING MODULES'. =head2 Prerequisites for Compiling Perl on DOS =over 4 =item DJGPP DJGPP is a port of GNU C/C++ compiler and development tools to 32-bit, protected-mode environment on Intel 32-bit CPUs running MS-DOS and compatible operating systems, by DJ Delorie and friends. For more details (FAQ), check out the home of DJGPP at: http://www.delorie.com/djgpp/ If you have questions about DJGPP, try posting to the DJGPP newsgroup: comp.os.msdos.djgpp, or use the email gateway djgpp@delorie.com. You can find the full DJGPP distribution on any of the mirrors listed here: http://www.delorie.com/djgpp/getting.html You need the following files to build perl (or add new modules): v2/djdev203.zip v2gnu/bnu2112b.zip v2gnu/gcc2953b.zip v2gnu/bsh204b.zip v2gnu/mak3791b.zip v2gnu/fil40b.zip v2gnu/sed3028b.zip v2gnu/txt20b.zip v2gnu/dif272b.zip v2gnu/grep24b.zip v2gnu/shl20jb.zip v2gnu/gwk306b.zip v2misc/csdpmi5b.zip or possibly any newer version. =item Pthreads Thread support is not tested in this version of the djgpp perl. =back =head2 Shortcomings of Perl under DOS Perl under DOS lacks some features of perl under UNIX because of deficiencies in the UNIX-emulation, most notably: =over 4 =item * fork() and pipe() =item * some features of the UNIX filesystem regarding link count and file dates =item * in-place operation is a little bit broken with short filenames =item * sockets =back =head2 Building Perl on DOS =over 4 =item * Unpack the source package F with djtarx. If you want to use long file names under w95 and also to get Perl to pass all its tests, don't forget to use set LFN=y set FNCASE=y before unpacking the archive. =item * Create a "symlink" or copy your bash.exe to sh.exe in your C<($DJDIR)/bin> directory. ln -s bash.exe sh.exe [If you have the recommended version of bash for DJGPP, this is already done for you.] And make the C environment variable point to this F: set SHELL=c:/djgpp/bin/sh.exe (use full path name!) You can do this in F too. Add this line BEFORE any section definition: +SHELL=%DJDIR%/bin/sh.exe =item * If you have F and F in your path, then rename F to F, and F to F. Copy or link F to F if you don't have F. Copy or link F to F if you don't have F. [If you have the recommended versions of djdev, shell utilities and gawk, all these are already done for you, and you will not need to do anything.] =item * Chdir to the djgpp subdirectory of perl toplevel and type the following commands: set FNCASE=y configure.bat This will do some preprocessing then run the Configure script for you. The Configure script is interactive, but in most cases you just need to press ENTER. The "set" command ensures that DJGPP preserves the letter case of file names when reading directories. If you already issued this set command when unpacking the archive, and you are in the same DOS session as when you unpacked the archive, you don't have to issue the set command again. This command is necessary *before* you start to (re)configure or (re)build perl in order to ensure both that perl builds correctly and that building XS-type modules can succeed. See the DJGPP info entry for "_preserve_fncase" for more information: info libc alphabetical _preserve_fncase If the script says that your package is incomplete, and asks whether to continue, just answer with Y (this can only happen if you don't use long filenames or forget to issue "set FNCASE=y" first). When Configure asks about the extensions, I suggest IO and Fcntl, and if you want database handling then SDBM_File or GDBM_File (you need to install gdbm for this one). If you want to use the POSIX extension (this is the default), make sure that the stack size of your F is at least 512kbyte (you can check this with: C). You can use the Configure script in non-interactive mode too. When I built my F, I used something like this: configure.bat -des You can find more info about Configure's command line switches in the F file. When the script ends, and you want to change some values in the generated F file, then run sh Configure -S after you made your modifications. IMPORTANT: if you use this C<-S> switch, be sure to delete the CONFIG environment variable before running the script: set CONFIG= =item * Now you can compile Perl. Type: make =back =head2 Testing Perl on DOS Type: make test If you're lucky you should see "All tests successful". But there can be a few failed subtests (less than 5 hopefully) depending on some external conditions (e.g. some subtests fail under linux/dosemu or plain dos with short filenames only). =head2 Installation of Perl on DOS Type: make install This will copy the newly compiled perl and libraries into your DJGPP directory structure. Perl.exe and the utilities go into C<($DJDIR)/bin>, and the library goes under C<($DJDIR)/lib/perl5>. The pod documentation goes under C<($DJDIR)/lib/perl5/pod>. =head1 BUILDING AND INSTALLING MODULES ON DOS =head2 Building Prerequisites for Perl on DOS For building and installing non-XS modules, all you need is a working perl under DJGPP. Non-XS modules do not require re-linking the perl binary, and so are simpler to build and install. XS-type modules do require re-linking the perl binary, because part of an XS module is written in "C", and has to be linked together with the perl binary to be executed. This is required because perl under DJGPP is built with the "static link" option, due to the lack of "dynamic linking" in the DJGPP environment. Because XS modules require re-linking of the perl binary, you need both the perl binary distribution and the perl source distribution to build an XS extension module. In addition, you will have to have built your perl binary from the source distribution so that all of the components of the perl binary are available for the required link step. =head2 Unpacking CPAN Modules on DOS First, download the module package from CPAN (e.g., the "Comma Separated Value" text package, Text-CSV-0.01.tar.gz). Then expand the contents of the package into some location on your disk. Most CPAN modules are built with an internal directory structure, so it is usually safe to expand it in the root of your DJGPP installation. Some people prefer to locate source trees under /usr/src (i.e., C<($DJDIR)/usr/src>), but you may put it wherever seems most logical to you, *EXCEPT* under the same directory as your perl source code. There are special rules that apply to modules which live in the perl source tree that do not apply to most of the modules in CPAN. Unlike other DJGPP packages, which are normal "zip" files, most CPAN module packages are "gzipped tarballs". Recent versions of WinZip will safely unpack and expand them, *UNLESS* they have zero-length files. It is a known WinZip bug (as of v7.0) that it will not extract zero-length files. From the command line, you can use the djtar utility provided with DJGPP to unpack and expand these files. For example: C:\djgpp>djtarx -v Text-CSV-0.01.tar.gz This will create the new directory C<($DJDIR)/Text-CSV-0.01>, filling it with the source for this module. =head2 Building Non-XS Modules on DOS To build a non-XS module, you can use the standard module-building instructions distributed with perl modules. perl Makefile.PL make make test make install This is sufficient because non-XS modules install only ".pm" files and (sometimes) pod and/or man documentation. No re-linking of the perl binary is needed to build, install or use non-XS modules. =head2 Building XS Modules on DOS To build an XS module, you must use the standard module-building instructions distributed with perl modules *PLUS* three extra instructions specific to the DJGPP "static link" build environment. set FNCASE=y perl Makefile.PL make make perl make test make -f Makefile.aperl inst_perl MAP_TARGET=perl.exe make install The first extra instruction sets DJGPP's FNCASE environment variable so that the new perl binary which you must build for an XS-type module will build correctly. The second extra instruction re-builds the perl binary in your module directory before you run "make test", so that you are testing with the new module code you built with "make". The third extra instruction installs the perl binary from your module directory into the standard DJGPP binary directory, C<($DJDIR)/bin>, replacing your previous perl binary. Note that the MAP_TARGET value *must* have the ".exe" extension or you will not create a "perl.exe" to replace the one in C<($DJDIR)/bin>. When you are done, the XS-module install process will have added information to your "perllocal" information telling that the perl binary has been replaced, and what module was installed. You can view this information at any time by using the command: perl -S perldoc perllocal =head1 AUTHOR Laszlo Molnar, F [Installing/building perl] Peter J. Farley III F [Building/installing modules] =head1 SEE ALSO perl(1). =cut perl-5.12.0-RC0/INTERN.h0000444000175000017500000000274611143650473013312 0ustar jessejesse/* INTERN.h * * Copyright (C) 1991, 1992, 1993, 1995, 1996, 1998, 2000, 2001, * by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * EXT designates a global var which is defined in perl.h * dEXT designates a global var which is defined in another * file, so we can't count on finding it in perl.h * (this practice should be avoided). */ #undef EXT #undef dEXT #undef EXTCONST #undef dEXTCONST #if defined(VMS) && !defined(__GNUC__) /* Suppress portability warnings from DECC for VMS-specific extensions */ # ifdef __DECC # pragma message disable (GLOBALEXT,NOSHAREEXT,READONLYEXT) # endif # define EXT globaldef {"$GLOBAL_RW_VARS"} noshare # define dEXT globaldef {"$GLOBAL_RW_VARS"} noshare # define EXTCONST globaldef {"$GLOBAL_RO_VARS"} readonly # define dEXTCONST globaldef {"$GLOBAL_RO_VARS"} readonly #else # if (defined(WIN32) && defined(__MINGW32__)) || defined(__SYMBIAN32__) # define EXT __declspec(dllexport) # define dEXT # define EXTCONST __declspec(dllexport) const # define dEXTCONST const # else # ifdef __cplusplus # define EXT # define dEXT # define EXTCONST extern const # define dEXTCONST const # else # define EXT # define dEXT # define EXTCONST const # define dEXTCONST const # endif # endif #endif #undef INIT #define INIT(x) = x #define DOINIT perl-5.12.0-RC0/installperl0000555000175000017500000007027111325127001014403 0ustar jessejesse#!./perl -w BEGIN { require 5.004; chdir '..' if !-d 'lib' and -d '../lib'; @INC = 'lib'; $ENV{PERL5LIB} = 'lib'; # This needs to be at BEGIN time, before any use of Config require './install_lib.pl'; } use strict; use vars qw($Is_VMS $Is_W32 $Is_OS2 $Is_Cygwin $Is_Darwin $Is_NetWare %opts $packlist); my ($dostrip, $versiononly, $force, $otherperls, $archname, $nwinstall, $nopods); # Not sure how easy it would be to refactor to remove the need for local $depth # below use vars qw /$depth/; BEGIN { if ($Is_VMS) { eval 'use VMS::Filespec;' } } my $scr_ext = ($Is_VMS ? '.Com' : $Is_W32 ? '.bat' : ''); use File::Find; use File::Compare; use File::Copy (); use File::Path (); use ExtUtils::Packlist; use Cwd; if ($Is_NetWare) { $Is_W32 = 0; $scr_ext = '.pl'; } # override the ones in the rest of the script sub mkpath { File::Path::mkpath(@_) unless $opts{notify}; } my $mainperldir = "/usr/bin"; my $exe_ext = $Config{exe_ext}; # Allow "make install PERLNAME=something_besides_perl": my $perl = defined($ENV{PERLNAME}) ? $ENV{PERLNAME} : 'perl'; # This is the base used for versioned names, like "perl5.6.0". # It's separate because a common use of $PERLNAME is to install # perl as "perl5", if that's used as base for versioned files you # get "perl55.6.0". my $perl_verbase = defined($ENV{PERLNAME_VERBASE}) ? $ENV{PERLNAME_VERBASE} : $perl; my $dbg = ''; my $ndbg = ''; if ( $Is_VMS ) { if ( defined $Config{usevmsdebug} ) { if ( $Config{usevmsdebug} eq 'define' ) { $dbg = 'dbg'; $ndbg = 'ndbg'; } } } $otherperls = 1; # This little hack simplifies making the code after the comment "Fetch some # frequently-used items from %Config" warning free. With $opts{destdir} always # defined, it's also possible to make the s/\Q$opts{destdir}\E unconditional. $opts{destdir} = ''; # Consider refactoring this to use Getopt::Long once Getopt::Long's planned # feature is implemented, to distinguish + and - options. while (@ARGV) { $opts{notify} = 1 if $ARGV[0] eq '-n'; $dostrip = 1 if $ARGV[0] eq '-s'; $versiononly = 1 if $ARGV[0] eq '-v'; $versiononly = 0 if $ARGV[0] eq '+v'; $opts{silent} = 1 if $ARGV[0] eq '-S'; $otherperls = 0 if $ARGV[0] eq '-o'; $force = 1 if $ARGV[0] eq '-f'; $opts{verbose} = 1 if $ARGV[0] eq '-V' || $ARGV [0] eq '-n'; $archname = 1 if $ARGV[0] eq '-A'; $nwinstall = 1 if $ARGV[0] eq '-netware'; $nopods = 1 if $ARGV[0] eq '-p'; $opts{destdir} = $1 if $ARGV[0] =~ /^-?-destdir=(.*)$/; if ($ARGV[0] eq '-?' or $ARGV[0] =~ /^-?-h/) { print <<"EOT"; Usage $0: [switches] -n Don't actually run any commands; just print them. -s Run strip on installed binaries. -v Only install perl as a binary with the version number in the name. (Override whatever config.sh says) +v Install perl as "perl" and as a binary with the version number in the name. (Override whatever config.sh says) -S Silent mode. -f Force installation (don't check if same version is there) -o Skip checking for other copies of perl in your PATH. -V Verbose mode. -A Also install perl with the architecture's name in the perl binary's name. -p Don't install the pod files. [This will break use diagnostics;] -netware Install correctly on a Netware server. -destdir Prefix installation directories by this string. EOT exit; } shift; } $versiononly = 1 if $Config{versiononly} && !defined $versiononly; my (@scripts, @tolink); open SCRIPTS, "utils.lst" or die "Can't open utils.lst: $!"; while () { next if /^#/; s/\s*#\s*pod\s*=.*//; # install script regardless of pod location next if /a2p/; # a2p is binary, to be installed separately chomp; if (/(\S*)\s*#\s*link\s*=\s*(\S*)/) { push @scripts, $1; push @tolink, [$1, $2]; } else { push @scripts, $_; } } close SCRIPTS; if ($scr_ext) { @scripts = map { "$_$scr_ext" } @scripts; } my @pods = $nopods ? () : (, 'x2p/a2p.pod'); # Specify here any .pm files that are actually architecture-dependent. # (Those included with XS extensions under ext/ are automatically # added later.) # Now that the default privlib has the full perl version number included, # we no longer have to play the trick of sticking version-specific .pm # files under the archlib directory. my %archpms = ( Config => 1, lib => 1, Cwd => 1, ); if ($^O eq 'dos') { push(@scripts,'djgpp/fixpmain'); $archpms{config} = $archpms{filehand} = 1; } if ((-e "testcompile") && (defined($ENV{'COMPILE'}))) { push(@scripts, map("$_.exe", @scripts)); } # Exclude nonxs extensions that are not architecture dependent my @nonxs = grep(!/^Errno$/, split(' ', $Config{'nonxs_ext'})); my @ext_dirs = qw(cpan dist ext); foreach my $ext_dir (@ext_dirs) { find(sub { if (($File::Find::name =~ m{^$ext_dir\b(.*)/([^/]+)\.pm$}) && ! grep { (my $dir = $_) =~ s/\//-/g; $File::Find::name =~ /^$ext_dir\/$dir\// } @nonxs) { my($path, $modname) = ($1,$2); # Change hypenated name like Filter-Util-Call to nested # directory name Filter/Util/Call $path =~ s{-}{/}g; # strip to optional "/lib", or remove trailing component $path =~ s{.*/lib\b}{} or $path =~ s{/[^/]*$}{}; # strip any leading / $path =~ s{^/}{}; # reconstitute canonical module name $modname = "$path/$modname" if length $path; # remember it $archpms{$modname} = 1; } }, $ext_dir); } # print "[$_]\n" for sort keys %archpms; my $ver = $Config{version}; my $release = substr($],0,3); # Not used currently. my $patchlevel = substr($],3,2); die "Patchlevel of perl ($patchlevel)", "and patchlevel of config.sh ($Config{'PERL_VERSION'}) don't match\n" if $patchlevel != $Config{'PERL_VERSION'}; # Fetch some frequently-used items from %Config my $installbin = "$opts{destdir}$Config{installbin}"; my $installscript = "$opts{destdir}$Config{installscript}"; my $installprivlib = "$opts{destdir}$Config{installprivlib}"; my $installarchlib = "$opts{destdir}$Config{installarchlib}"; my $installsitelib = "$opts{destdir}$Config{installsitelib}"; my $installsitearch = "$opts{destdir}$Config{installsitearch}"; my $installman1dir = "$opts{destdir}$Config{installman1dir}"; my $man1ext = $Config{man1ext}; my $libperl = $Config{libperl}; # Shared library and dynamic loading suffixes. my $so = $Config{so}; my $dlext = $Config{dlext}; my $dlsrc = $Config{dlsrc}; if ($^O eq 'os390') { my $pwd; chomp($pwd=`pwd`); my $archlibexp = $Config{archlibexp}; my $usedl = $Config{usedl}; if ($usedl eq 'define') { `./$^X -pibak -e 's{$pwd\/libperl.x}{$archlibexp/CORE/libperl.x}' lib/Config.pm`; } } if ($nwinstall) { # This is required only if we are installing on a NetWare server $installscript = $Config{installnwscripts}; $installprivlib = $Config{installnwlib}; $installarchlib = $Config{installnwlib}; $installsitelib = $Config{installnwlib}; } my $binexp = $Config{binexp}; if ($Is_VMS) { # Hang in there until File::Spec hits the big time foreach ( \$installbin, \$installscript, \$installprivlib, \$installarchlib, \$installsitelib, \$installsitearch, \$installman1dir ) { $$_ = unixify($$_); $$_ =~ s:/$::; } } # Do some quick sanity checks. $installbin || die "No installbin directory in config.sh\n"; -d $installbin || mkpath($installbin, $opts{verbose}, 0777); -d $installbin || $opts{notify} || die "$installbin is not a directory\n"; -w $installbin || $opts{notify} || die "$installbin is not writable by you\n" unless $installbin =~ m#^/afs/# || $opts{notify}; if (!$Is_NetWare) { if (!$Is_VMS) { -x 'perl' . $exe_ext || die "perl isn't executable!\n"; } else { -x $ndbg . 'perl' . $exe_ext || die "${ndbg}perl$exe_ext isn't executable!\n"; if ($dbg) { -x $dbg . 'perl' . $exe_ext || die "${dbg}perl$exe_ext isn't executable!\n"; } } -f 't/rantests' || $Is_W32 || warn "WARNING: You've never run 'make test' or", " some tests failed! (Installing anyway.)\n"; } #if (!$Is_NetWare) # This will be used to store the packlist $packlist = ExtUtils::Packlist->new("$installarchlib/.packlist"); if (($Is_W32 and ! $Is_NetWare) or $Is_Cygwin) { my $perldll; if ($Is_Cygwin) { $perldll = $libperl; } else { $perldll = 'perl5'.$Config{patchlevel}.'.'.$dlext; } if ($dlsrc ne "dl_none.xs") { -f $perldll || die "No perl DLL built\n"; } # Install the DLL safe_unlink("$installbin/$perldll"); copy("$perldll", "$installbin/$perldll"); chmod(0755, "$installbin/$perldll"); $packlist->{"$installbin/$perldll"} = { type => 'file' }; } # if (($Is_W32 and ! $Is_NetWare) or $Is_Cygwin) # First we install the version-numbered executables. if ($Is_VMS) { safe_unlink("$installbin/perl_setup.com"); copy("perl_setup.com", "$installbin/perl_setup.com"); chmod(0755, "$installbin/perl_setup.com"); safe_unlink("$installbin/$dbg$perl$exe_ext"); copy("$dbg$perl$exe_ext", "$installbin/$dbg$perl$exe_ext"); chmod(0755, "$installbin/$dbg$perl$exe_ext"); safe_unlink("$installbin/$dbg${perl}shr$exe_ext"); copy("$dbg${perl}shr$exe_ext", "$installbin/$dbg${perl}shr$exe_ext"); chmod(0755, "$installbin/$dbg${perl}shr$exe_ext"); if ($ndbg) { safe_unlink("$installbin/$ndbg$perl$exe_ext"); copy("$ndbg$perl$exe_ext", "$installbin/$ndbg$perl$exe_ext"); chmod(0755, "$installbin/$ndbg$perl$exe_ext"); safe_unlink("$installbin/${dbg}a2p$exe_ext"); copy("x2p/${dbg}a2p$exe_ext", "$installbin/${dbg}a2p$exe_ext"); chmod(0755, "$installbin/${dbg}a2p$exe_ext"); } } elsif ($^O eq 'mpeix') { # MPE lacks hard links and requires that executables with special # capabilities reside in the MPE namespace. safe_unlink("$installbin/perl$ver$exe_ext", $Config{perlpath}); # Install the primary executable into the MPE namespace as perlpath. copy("perl$exe_ext", $Config{perlpath}); chmod(0755, $Config{perlpath}); # Create a backup copy with the version number. link($Config{perlpath}, "$installbin/perl$ver$exe_ext"); } elsif ($^O ne 'dos') { if (!$Is_NetWare) { safe_unlink("$installbin/$perl_verbase$ver$exe_ext"); copy("perl$exe_ext", "$installbin/$perl_verbase$ver$exe_ext"); strip("$installbin/$perl_verbase$ver$exe_ext"); chmod(0755, "$installbin/$perl_verbase$ver$exe_ext"); } else { # If installing onto a NetWare server if ($nwinstall) { # Copy perl.nlm, echo.nlm, type.nlm, a2p.nlm & cgi2perl.nlm mkpath($Config{installnwsystem}, 1, 0777); copy("netware\\".$ENV{'MAKE_TYPE'}."\\perl.nlm", $Config{installnwsystem}); copy("netware\\testnlm\\echo\\echo.nlm", $Config{installnwsystem}); copy("netware\\testnlm\\type\\type.nlm", $Config{installnwsystem}); copy("x2p\\a2p.nlm", $Config{installnwsystem}); chmod(0755, "$Config{installnwsystem}\\perl.nlm"); mkpath($Config{installnwlcgi}, 1, 0777); copy("lib\\auto\\cgi2perl\\cgi2perl.nlm", $Config{installnwlcgi}); } } #if (!$Is_NetWare) } else { safe_unlink("$installbin/$perl.exe"); copy("perl.exe", "$installbin/$perl.exe"); } # Install library files. my ($do_installarchlib, $do_installprivlib) = (0, 0); my $vershort = ($Is_Cygwin and !$Config{usedevel}) ? substr($ver,0,-2) : $ver; mkpath($installprivlib, $opts{verbose}, 0777); mkpath($installarchlib, $opts{verbose}, 0777); mkpath($installsitelib, $opts{verbose}, 0777) if ($installsitelib); mkpath($installsitearch, $opts{verbose}, 0777) if ($installsitearch); if (chdir "lib") { $do_installarchlib = ! samepath($installarchlib, '.'); $do_installprivlib = ! samepath($installprivlib, '.'); $do_installprivlib = 0 if $versiononly && !($installprivlib =~ m/\Q$vershort/); if ($do_installarchlib || $do_installprivlib) { find(\&installlib, '.'); } chdir ".." || die "Can't cd back to source directory: $!\n"; } else { warn "Can't cd to lib to install lib files: $!\n"; } # Install header files and libraries. mkpath("$installarchlib/CORE", $opts{verbose}, 0777); my @corefiles; if ($Is_VMS) { # We did core file selection during build my $coredir = "lib/$Config{archname}/$ver/CORE"; $coredir =~ tr/./_/; map { s|^$coredir/||i; } @corefiles = <$coredir/*.*>; } elsif ($Is_Cygwin) { # On Cygwin symlink it to CORE to make Makefile happy @corefiles = <*.h libperl*.* perl*$Config{lib_ext}>; my $coredll = "$installarchlib/CORE/$libperl"; safe_unlink($coredll); ( $Config{'d_link'} eq 'define' && eval { CORE::link("$installbin/$libperl", $coredll); $packlist->{$coredll} = { from => "$installbin/$libperl", type => 'link' }; } ) || eval { symlink("$installbin/$libperl", $coredll); $packlist->{$coredll} = { from => "$installbin/$libperl", type => 'link' }; } || ( copy("$installbin/$libperl", $coredll) && push(@corefiles, $coredll) ) } else { # [als] hard-coded 'libperl' name... not good! @corefiles = <*.h libperl*.* perl*$Config{lib_ext}>; # AIX needs perl.exp installed as well. push(@corefiles,'perl.exp') if $^O eq 'aix'; if ($^O eq 'mpeix') { # MPE needs mpeixish.h installed as well. mkpath("$installarchlib/CORE/mpeix", $opts{verbose}, 0777); push(@corefiles,'mpeix/mpeixish.h'); } # If they have built sperl.o... push(@corefiles,'sperl.o') if -f 'sperl.o'; } foreach my $file (@corefiles) { # HP-UX (at least) needs to maintain execute permissions # on dynamically-loadable libraries. So we do it for all. if (copy_if_diff($file,"$installarchlib/CORE/$file")) { if ($file =~ /\.(\Q$so\E|\Q$dlext\E)$/) { strip("-S", "$installarchlib/CORE/$file") if $^O =~ /^(rhapsody|darwin)$/; chmod(0555, "$installarchlib/CORE/$file"); } else { chmod(0444, "$installarchlib/CORE/$file"); } } } # Install main perl executables # Make links to ordinary names if installbin directory isn't current directory. if (! $versiononly && ! samepath($installbin, '.') && ($^O ne 'dos') && ! $Is_VMS && ! $Is_NetWare) { safe_unlink("$installbin/$perl$exe_ext", "$installbin/suid$perl$exe_ext"); if ($^O eq 'mpeix') { # MPE doesn't support hard links, so use a symlink. # We don't want another cloned copy. symlink($Config{perlpath}, "$installbin/perl$exe_ext"); } elsif ($^O eq 'vos') { # VOS doesn't support hard links, so use a symlink. symlink("$installbin/$perl_verbase$ver$exe_ext", "$installbin/$perl$exe_ext"); } else { link("$installbin/$perl_verbase$ver$exe_ext", "$installbin/$perl$exe_ext"); } } # For development purposes it can be very useful to have multiple perls # build for different "architectures" (eg threading or not) simultaneously. if ($archname && ! samepath($installbin, '.') && ($^O ne 'dos') && ! $Is_VMS) { my $archperl = "$perl_verbase$ver-$Config{archname}$exe_ext"; safe_unlink("$installbin/$archperl"); if ($^O eq 'mpeix') { # MPE doesn't support hard links, so use a symlink. # We don't want another cloned copy. symlink($Config{perlpath}, "$installbin/$archperl"); } elsif ($^O eq 'vos') { # VOS doesn't support hard links, so use a symlink. symlink("$installbin/$perl_verbase$ver$exe_ext", "$installbin/$archperl"); } else { link("$installbin/$perl_verbase$ver$exe_ext", "$installbin/$archperl"); } } # Offer to install perl in a "standard" location my $mainperl_is_instperl = 0; if ($Config{installusrbinperl} && $Config{installusrbinperl} eq 'define' && !$versiononly && !$opts{notify} && !$Is_W32 && !$Is_NetWare && !$Is_VMS && -t STDIN && -t STDERR && -w $mainperldir && ! samepath($mainperldir, $installbin)) { my($usrbinperl) = "$mainperldir/$perl$exe_ext"; my($instperl) = "$installbin/$perl$exe_ext"; my($expinstperl) = "$binexp/$perl$exe_ext"; # First make sure $usrbinperl is not already the same as the perl we # just installed. if (-x $usrbinperl) { # Try to be clever about mainperl being a symbolic link # to binexp/perl if binexp and installbin are different. $mainperl_is_instperl = samepath($usrbinperl, $instperl) || samepath($usrbinperl, $expinstperl) || (($binexp ne $installbin) && (-l $usrbinperl) && ((readlink $usrbinperl) eq $expinstperl)); } if (! $mainperl_is_instperl) { unlink($usrbinperl); ( $Config{'d_link'} eq 'define' && eval { CORE::link $instperl, $usrbinperl } ) || eval { symlink $expinstperl, $usrbinperl } || copy($instperl, $usrbinperl); $mainperl_is_instperl = 1; } } # Make links to ordinary names if installbin directory isn't current directory. if (!$Is_NetWare && $dbg eq '') { if (! samepath($installbin, 'x2p')) { my $base = 'a2p'; $base .= $ver if $versiononly; safe_unlink("$installbin/$base$exe_ext"); copy("x2p/a2p$exe_ext", "$installbin/$base$exe_ext"); strip("$installbin/$base$exe_ext"); chmod(0755, "$installbin/$base$exe_ext"); } } # cppstdin is just a script, but it is architecture-dependent, so # it can't safely be shared. Place it in $installbin. # Note that Configure doesn't build cppstin if it isn't needed, so # we skip this if cppstdin doesn't exist. if (! $versiononly && (-f 'cppstdin') && (! samepath($installbin, '.'))) { safe_unlink("$installbin/cppstdin"); copy("cppstdin", "$installbin/cppstdin"); chmod(0755, "$installbin/cppstdin"); } sub script_alias { my ($installscript, $orig, $alias, $scr_ext) = @_; safe_unlink("$installscript/$alias$scr_ext"); if ($^O eq 'dos' or $Is_VMS or $^O eq 'transit') { copy("$installscript/$orig$scr_ext", "$installscript/$alias$scr_ext"); } elsif ($^O eq 'vos') { symlink("$installscript/$orig$scr_ext", "$installscript/$alias$scr_ext"); } else { link("$installscript/$orig$scr_ext", "$installscript/$alias$scr_ext"); } } # Install scripts. mkpath($installscript, $opts{verbose}, 0777); if ($versiononly) { for (@scripts) { (my $base = $_) =~ s#.*/##; $base .= $ver; copy($_, "$installscript/$base"); chmod(0755, "$installscript/$base"); } for (@tolink) { my ($from, $to) = map { "$_$ver" } @$_; (my $frbase = $from) =~ s#.*/##; (my $tobase = $to) =~ s#.*/##; script_alias($installscript, $frbase, $tobase, $scr_ext); } } else { for (@scripts) { (my $base = $_) =~ s#.*/##; copy($_, "$installscript/$base"); chmod(0755, "$installscript/$base"); } for (@tolink) { my ($from, $to) = @$_; (my $frbase = $from) =~ s#.*/##; (my $tobase = $to) =~ s#.*/##; script_alias($installscript, $frbase, $tobase, $scr_ext); } } # Install pod pages. Where? I guess in $installprivlib/pod # ($installprivlib/pods for cygwin). my $pod = ($Is_Cygwin || $Is_Darwin || $Is_VMS || $Is_W32) ? 'pods' : 'pod'; if ( !$versiononly || ($installprivlib =~ m/\Q$vershort/)) { mkpath("${installprivlib}/$pod", $opts{verbose}, 0777); for (@pods) { # $_ is a name like pod/perl.pod (my $base = $_) =~ s#.*/##; copy_if_diff($_, "${installprivlib}/$pod/${base}"); } } # Check to make sure there aren't other perls around in installer's # path. This is probably UNIX-specific. Check all absolute directories # in the path except for where public executables are supposed to live. # Also skip $mainperl if the user opted to have it be a link to the # installed perl. if (!$versiononly && $otherperls) { my ($path, @path); my $dirsep = ($Is_OS2 || $Is_W32 || $Is_NetWare) ? ';' : ':' ; ($path = $ENV{"PATH"}) =~ s:\\:/:g ; @path = split(/$dirsep/, $path); if ($Is_VMS) { my $i = 0; while (exists $ENV{'DCL$PATH' . $i}) { my $dir = unixpath($ENV{'DCL$PATH' . $i}); $dir =~ s-/$--; push(@path,$dir); } } my @otherperls; my %otherperls; for (@path) { next unless m,^/,; # Use &samepath here because some systems have other dirs linked # to $mainperldir (like SunOS) next unless -d; next if samepath($_, $binexp); next if samepath($_, cwd()); next if ($mainperl_is_instperl && samepath($_, $mainperldir)); my $otherperl = "$_/$perl$exe_ext"; next if $otherperls{$otherperl}++; push(@otherperls, $otherperl) if (-x $otherperl && ! -d $otherperl); } if (@otherperls) { warn "\nWarning: $perl appears in your path in the following " . "locations beyond where\nwe just installed it:\n"; for (@otherperls) { warn " ", $_, "\n"; } warn "\n"; } } $packlist->write() unless $opts{notify}; print " Installation complete\n" if $opts{verbose}; exit 0; ############################################################################### # If these are needed elsewhere, move them into install_lib.pl rather than # copying them. sub yn { my($prompt) = @_; my($answer); my($default) = $prompt =~ m/\[([yn])\]\s*$/i; print STDERR $prompt; chop($answer = ); $answer = $default if $answer =~ m/^\s*$/; ($answer =~ m/^[yY]/); } sub safe_unlink { return if $opts{notify} or $Is_VMS; my @names = @_; foreach my $name (@names) { next unless -e $name; chmod 0777, $name if ($Is_OS2 || $Is_W32 || $Is_NetWare); print " unlink $name\n" if $opts{verbose}; next if CORE::unlink($name); warn "Couldn't unlink $name: $!\n"; if ($! =~ /busy/i) { print " mv $name $name.old\n" if $opts{verbose}; safe_rename($name, "$name.old") or warn "Couldn't rename $name: $!\n"; } } } sub safe_rename { my($from,$to) = @_; if (-f $to and not unlink($to)) { my($i); for ($i = 1; $i < 50; $i++) { last if rename($to, "$to.$i"); } warn("Cannot rename to `$to.$i': $!"), return 0 if $i >= 50; # Give up! } link($from,$to) || return 0; unlink($from); } sub copy { my($from,$to) = @_; my $xto = $to; $xto =~ s/^\Q$opts{destdir}\E//; print $opts{verbose} ? " cp $from $xto\n" : " $xto\n" unless $opts{silent}; print " creating new version of $xto\n" if $Is_VMS and -e $to and !$opts{silent}; unless ($opts{notify} or File::Copy::copy($from, $to)) { # Might have been that F::C::c can't overwrite the target warn "Couldn't copy $from to $to: $!\n" unless -f $to and (chmod(0666, $to), unlink $to) and File::Copy::copy($from, $to); } $packlist->{$xto} = { type => 'file' }; } sub installlib { my $dir = $File::Find::dir; $dir =~ s#^\.(?![^/])/?##; local($depth) = $dir ? "lib/$dir" : "lib"; my $name = $_; # Ignore version control directories. if ($name =~ /^(?:CVS|RCS|SCCS|\.svn)\z/ and -d $name) { $File::Find::prune = 1; return; } # ignore patch backups, RCS files, emacs backup & temp files and the # .exists files, .PL files, and test files. return if $name =~ m{\.orig$|\.rej$|~$|^#.+#$|,v$|^\.exists|\.PL$|\.plc$|\.t$|^test\.pl$|^dbm_filter_util\.pl$|^filter-util\.pl$|^uupacktool\.pl$|^\.gitignore$} || $dir =~ m{/t(?:/|$)}; # ignore the cpan script in lib/CPAN/bin, the instmodsh and xsubpp # scripts in lib/ExtUtils, the prove script in lib/Test/Harness, # the corelist script from lib/Module/CoreList/bin and ptar* in # lib/Archive/Tar/bin, the config_data script in lib/Module/Build/scripts # (they're installed later with other utils) return if $name =~ /^(?:cpan|instmodsh|prove|corelist|ptar|cpan2dist|cpanp|cpanp-run-perl|ptardiff|config_data)\z/; # ignore the Makefiles return if $name =~ /^makefile$/i; # ignore the test extensions return if $dir =~ m{\bXS/(?:APItest|Typemap)\b}; return if $name =~ m{\b(?:APItest|Typemap)\.pm$}; # ignore the demo files return if $dir =~ /\b(?:demos?|eg)\b/; # ignore READMEs, MANIFESTs, INSTALL docs, META.ymls and change logs. # Changes.e2x and README.e2x are needed by enc2xs. return if $name =~ m{^(?:README(?:\.\w+)?)$} && $name ne 'README.e2x'; return if $name =~ m{^(?:MANIFEST|META\.yml)$}; return if $name =~ m{^(?:INSTALL|TODO|BUGS|CREDITS)$}i; return if $name =~ m{^change(?:s|log)(?:\.libnet)?$}i; return if $name =~ m{^(?:SIGNATURE|PAUSE200\d\.pub)$}; # CPAN files return if $name =~ m{^(?:NOTES|PATCHING)$}; # ExtUtils files # if using a shared perl library then ignore: # - static library files [of statically linked extensions]; # - import library files and export library files (only present on Win32 # anyway?) and empty bootstrap files [of dynamically linked extensions]. return if $Config{useshrplib} eq 'true' and ($name =~ /$Config{_a}$/ or $name =~ /\.exp$/ or ($name =~ /\.bs$/ and -z $name)); $name = "$dir/$name" if $dir ne ''; return if $name eq 'ExtUtils/XSSymSet.pm' and !$Is_VMS; my $installlib = $installprivlib; if ($dir =~ /^auto\// || ($name =~ /^(.*)\.(?:pm|pod)$/ && $archpms{$1}) || ($name =~ /^(.*)\.(?:h|lib)$/i && ($Is_W32 || $Is_NetWare)) || $name=~/^Config_(heavy|git)\.pl\z/ ) { $installlib = $installarchlib; return unless $do_installarchlib; } else { return unless $do_installprivlib; } if (-f $_) { if (/\.(?:al|ix)$/ && !($dir =~ m[^auto/(.*)$])) { $installlib = $installprivlib; #We're installing *.al and *.ix files into $installprivlib, #but we have to delete old *.al and *.ix files from the 5.000 #distribution: #This might not work because $archname might have changed. unlink("$installarchlib/$name"); } my $xname = "$installlib/$name"; $xname =~ s/^\Q$opts{destdir}\E//; $packlist->{$xname} = { type => 'file' }; if ($force || compare($_, "$installlib/$name") || $opts{notify}) { unlink("$installlib/$name"); mkpath("$installlib/$dir", $opts{verbose}, 0777); # HP-UX (at least) needs to maintain execute permissions # on dynamically-loaded libraries. if ($Is_NetWare && !$nwinstall) { # Don't copy .nlp,.nlm files, doesn't make sense on Windows and also # if copied will give problems when building new extensions. # Has to be copied if we are installing on a NetWare server and hence # the check !$nwinstall if (!(/\.(?:nlp|nlm|bs)$/)) { copy_if_diff($_, "$installlib/$name") and chmod($name =~ /\.(so|$dlext)$/o ? 0555 : 0444, "$installlib/$name"); } } else { if (copy_if_diff($_, "$installlib/$name")) { if ($name =~ /\.(so|$dlext)$/o) { strip("-S", "$installlib/$name") if $^O =~ /^(rhapsody|darwin)$/; chmod(0555, "$installlib/$name"); } else { strip("-S", "$installlib/$name") if ($name =~ /\.a$/o and $^O =~ /^(rhapsody|darwin)$/); chmod(0444, "$installlib/$name"); } } } #if ($Is_NetWare) } } } # Copy $from to $to, only if $from is different than $to. # Also preserve modification times for .a libraries. # On some systems, if you do # ranlib libperl.a # cp libperl.a /usr/local/lib/perl5/archlib/CORE/libperl.a # and then try to link against the installed libperl.a, you might # get an error message to the effect that the symbol table is older # than the library. # Return true if copying occurred. sub copy_if_diff { my($from,$to)=@_; return 1 if (($^O eq 'VMS') && (-d $from)); my $xto = $to; $xto =~ s/^\Q$opts{destdir}\E//; my $perlpodbadsymlink; if ($from =~ m!^pod/perl[\w-]+\.pod$! && -l $from && ! -e $from) { # Some Linux implementations have problems traversing over # multiple symlinks (when going over NFS?) and fail to read # the symlink target. Combine this with the fact that some # of the pod files (the perl$OS.pod) are symlinks (to ../README.$OS), # and you end up with those pods not getting installed. $perlpodbadsymlink = 1; } -f $from || $perlpodbadsymlink || warn "$0: $from not found"; $packlist->{$xto} = { type => 'file' }; if ($force || compare($from, $to) || $opts{notify}) { safe_unlink($to); # In case we don't have write permissions. if ($opts{notify}) { $from = $depth . "/" . $from if $depth; } if ($perlpodbadsymlink && $from =~ m!^pod/perl(.+)\.pod$!) { $from = "README.$1"; } copy($from, $to); # Restore timestamps if it's a .a library or for OS/2. if (!$opts{notify} && ($Is_OS2 || $to =~ /\.a$/)) { my ($atime, $mtime) = (stat $from)[8,9]; utime $atime, $mtime, $to; } 1; } } sub strip { my(@args) = @_; return unless $dostrip; my @opts; while (@args && $args[0] =~ /^(-\w+)$/) { push @opts, shift @args; } foreach my $file (@args) { if (-f $file) { if ($opts{verbose}) { print " strip " . join(' ', @opts); print " " if (@opts); print "$file\n"; } system("strip", @opts, $file); } else { print "# file '$file' skipped\n" if $opts{verbose}; } } } perl-5.12.0-RC0/regcomp.h0000444000175000017500000007236211325127001013734 0ustar jessejesse/* regcomp.h * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, * 2000, 2001, 2002, 2003, 2005, 2006, 2007, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ #include "regcharclass.h" typedef OP OP_4tree; /* Will be redefined later. */ /* Convert branch sequences to more efficient trie ops? */ #define PERL_ENABLE_TRIE_OPTIMISATION 1 /* Be really agressive about optimising patterns with trie sequences? */ #define PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION 1 /* Use old style unicode mappings for perl and posix character classes * * NOTE: Enabling this essentially breaks character class matching against unicode * strings, so that POSIX char classes match when they shouldn't, and \d matches * way more than 10 characters, and sometimes a charclass and its complement either * both match or neither match. * NOTE: Disabling this will cause various backwards compatibility issues to rear * their head, and tests to fail. However it will make the charclass behaviour * consistant regardless of internal string type, and make character class inversions * consistant. The tests that fail in the regex engine are basically broken tests. * * Personally I think 5.12 should disable this for sure. Its a bit more debatable for * 5.10, so for now im leaving it enabled. * XXX: It is now enabled for 5.11/5.12 * * -demerphq */ #define PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS 1 /* Should the optimiser take positive assertions into account? */ #define PERL_ENABLE_POSITIVE_ASSERTION_STUDY 0 /* Not for production use: */ #define PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS 0 /* Activate offsets code - set to if 1 to enable */ #ifdef DEBUGGING #define RE_TRACK_PATTERN_OFFSETS #endif /* Unless the next line is uncommented it is illegal to combine lazy matching with possessive matching. Frankly it doesn't make much sense to allow it as X*?+ matches nothing, X+?+ matches a single char only, and X{min,max}?+ matches min times only. */ /* #define REG_ALLOW_MINMOD_SUSPEND */ /* * The "internal use only" fields in regexp.h are present to pass info from * compile to execute that permits the execute phase to run lots faster on * simple cases. They are: * * regstart sv that must begin a match; NULL if none obvious * reganch is the match anchored (at beginning-of-line only)? * regmust string (pointer into program) that match must include, or NULL * [regmust changed to SV* for bminstr()--law] * regmlen length of regmust string * [regmlen not used currently] * * Regstart and reganch permit very fast decisions on suitable starting points * for a match, cutting down the work a lot. Regmust permits fast rejection * of lines that cannot possibly match. The regmust tests are costly enough * that pregcomp() supplies a regmust only if the r.e. contains something * potentially expensive (at present, the only such thing detected is * or + * at the start of the r.e., which can involve a lot of backup). Regmlen is * supplied because the test in pregexec() needs it and pregcomp() is computing * it anyway. * [regmust is now supplied always. The tests that use regmust have a * heuristic that disables the test if it usually matches.] * * [In fact, we now use regmust in many cases to locate where the search * starts in the string, so if regback is >= 0, the regmust search is never * wasted effort. The regback variable says how many characters back from * where regmust matched is the earliest possible start of the match. * For instance, /[a-z].foo/ has a regmust of 'foo' and a regback of 2.] */ /* * Structure for regexp "program". This is essentially a linear encoding * of a nondeterministic finite-state machine (aka syntax charts or * "railroad normal form" in parsing technology). Each node is an opcode * plus a "next" pointer, possibly plus an operand. "Next" pointers of * all nodes except BRANCH implement concatenation; a "next" pointer with * a BRANCH on both ends of it is connecting two alternatives. (Here we * have one of the subtle syntax dependencies: an individual BRANCH (as * opposed to a collection of them) is never concatenated with anything * because of operator precedence.) The operand of some types of node is * a literal string; for others, it is a node leading into a sub-FSM. In * particular, the operand of a BRANCH node is the first node of the branch. * (NB this is *not* a tree structure: the tail of the branch connects * to the thing following the set of BRANCHes.) The opcodes are defined * in regnodes.h which is generated from regcomp.sym by regcomp.pl. */ /* * A node is one char of opcode followed by two chars of "next" pointer. * "Next" pointers are stored as two 8-bit pieces, high order first. The * value is a positive offset from the opcode of the node containing it. * An operand, if any, simply follows the node. (Note that much of the * code generation knows about this implicit relationship.) * * Using two bytes for the "next" pointer is vast overkill for most things, * but allows patterns to get big without disasters. * * [The "next" pointer is always aligned on an even * boundary, and reads the offset directly as a short. Also, there is no * special test to reverse the sign of BACK pointers since the offset is * stored negative.] */ /* This is the stuff that used to live in regexp.h that was truly private to the engine itself. It now lives here. */ typedef struct regexp_internal { int name_list_idx; /* Optional data index of an array of paren names */ union { U32 *offsets; /* offset annotations 20001228 MJD data about mapping the program to the string - offsets[0] is proglen when this is used */ U32 proglen; } u; regnode *regstclass; /* Optional startclass as identified or constructed by the optimiser */ struct reg_data *data; /* Additional miscellaneous data used by the program. 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 */ regnode program[1]; /* Unwarranted chumminess with compiler. */ } regexp_internal; #define RXi_SET(x,y) (x)->pprivate = (void*)(y) #define RXi_GET(x) ((regexp_internal *)((x)->pprivate)) #define RXi_GET_DECL(r,ri) regexp_internal *ri = RXi_GET(r) /* * Flags stored in regexp->intflags * These are used only internally to the regexp engine * * See regexp.h for flags used externally to the regexp engine */ #define PREGf_SKIP 0x00000001 #define PREGf_IMPLICIT 0x00000002 /* Converted .* to ^.* */ #define PREGf_NAUGHTY 0x00000004 /* how exponential is this pattern? */ #define PREGf_VERBARG_SEEN 0x00000008 #define PREGf_CUTGROUP_SEEN 0x00000010 /* this is where the old regcomp.h started */ struct regnode_string { U8 str_len; U8 type; U16 next_off; char string[1]; }; /* Argument bearing node - workhorse, arg1 is often for the data field */ struct regnode_1 { U8 flags; U8 type; U16 next_off; U32 arg1; }; /* Similar to a regnode_1 but with an extra signed argument */ struct regnode_2L { U8 flags; U8 type; U16 next_off; U32 arg1; I32 arg2; }; /* 'Two field' -- Two 16 bit unsigned args */ struct regnode_2 { U8 flags; U8 type; U16 next_off; U16 arg1; U16 arg2; }; #define ANYOF_BITMAP_SIZE 32 /* 256 b/(8 b/B) */ #define ANYOF_CLASSBITMAP_SIZE 4 /* up to 32 (8*4) named classes */ /* also used by trie */ struct regnode_charclass { U8 flags; U8 type; U16 next_off; U32 arg1; char bitmap[ANYOF_BITMAP_SIZE]; /* only compile-time */ }; struct regnode_charclass_class { /* has [[:blah:]] classes */ U8 flags; /* should have ANYOF_CLASS here */ U8 type; U16 next_off; U32 arg1; char bitmap[ANYOF_BITMAP_SIZE]; /* both compile-time */ char classflags[ANYOF_CLASSBITMAP_SIZE]; /* and run-time */ }; /* XXX fix this description. Impose a limit of REG_INFTY on various pattern matching operations to limit stack growth and to avoid "infinite" recursions. */ /* The default size for REG_INFTY is I16_MAX, which is the same as SHORT_MAX (see perl.h). Unfortunately I16 isn't necessarily 16 bits (see handy.h). On the Cray C90, sizeof(short)==4 and hence I16_MAX is ((1<<31)-1), while on the Cray T90, sizeof(short)==8 and I16_MAX is ((1<<63)-1). To limit stack growth to reasonable sizes, supply a smaller default. --Andy Dougherty 11 June 1998 */ #if SHORTSIZE > 2 # ifndef REG_INFTY # define REG_INFTY ((1<<15)-1) # endif #endif #ifndef REG_INFTY # define REG_INFTY I16_MAX #endif #define ARG_VALUE(arg) (arg) #define ARG__SET(arg,val) ((arg) = (val)) #undef ARG #undef ARG1 #undef ARG2 #define ARG(p) ARG_VALUE(ARG_LOC(p)) #define ARG1(p) ARG_VALUE(ARG1_LOC(p)) #define ARG2(p) ARG_VALUE(ARG2_LOC(p)) #define ARG2L(p) ARG_VALUE(ARG2L_LOC(p)) #define ARG_SET(p, val) ARG__SET(ARG_LOC(p), (val)) #define ARG1_SET(p, val) ARG__SET(ARG1_LOC(p), (val)) #define ARG2_SET(p, val) ARG__SET(ARG2_LOC(p), (val)) #define ARG2L_SET(p, val) ARG__SET(ARG2L_LOC(p), (val)) #undef NEXT_OFF #undef NODE_ALIGN #define NEXT_OFF(p) ((p)->next_off) #define NODE_ALIGN(node) #define NODE_ALIGN_FILL(node) ((node)->flags = 0xde) /* deadbeef */ #define SIZE_ALIGN NODE_ALIGN #undef OP #undef OPERAND #undef MASK #undef STRING #define OP(p) ((p)->type) #define OPERAND(p) (((struct regnode_string *)p)->string) #define MASK(p) ((char*)OPERAND(p)) #define STR_LEN(p) (((struct regnode_string *)p)->str_len) #define STRING(p) (((struct regnode_string *)p)->string) #define STR_SZ(l) ((l + sizeof(regnode) - 1) / sizeof(regnode)) #define NODE_SZ_STR(p) (STR_SZ(STR_LEN(p))+1) #undef NODE_ALIGN #undef ARG_LOC #undef NEXTOPER #undef PREVOPER #define NODE_ALIGN(node) #define ARG_LOC(p) (((struct regnode_1 *)p)->arg1) #define ARG1_LOC(p) (((struct regnode_2 *)p)->arg1) #define ARG2_LOC(p) (((struct regnode_2 *)p)->arg2) #define ARG2L_LOC(p) (((struct regnode_2L *)p)->arg2) #define NODE_STEP_REGNODE 1 /* sizeof(regnode)/sizeof(regnode) */ #define EXTRA_STEP_2ARGS EXTRA_SIZE(struct regnode_2) #define NODE_STEP_B 4 #define NEXTOPER(p) ((p) + NODE_STEP_REGNODE) #define PREVOPER(p) ((p) - NODE_STEP_REGNODE) #define FILL_ADVANCE_NODE(ptr, op) STMT_START { \ (ptr)->type = op; (ptr)->next_off = 0; (ptr)++; } STMT_END #define FILL_ADVANCE_NODE_ARG(ptr, op, arg) STMT_START { \ ARG_SET(ptr, arg); FILL_ADVANCE_NODE(ptr, op); (ptr) += 1; } STMT_END #define REG_MAGIC 0234 #define SIZE_ONLY (RExC_emit == &PL_regdummy) /* Flags for node->flags of ANYOF */ #define ANYOF_CLASS 0x08 /* has [[:blah:]] classes */ #define ANYOF_INVERT 0x04 #define ANYOF_FOLD 0x02 #define ANYOF_LOCALE 0x01 /* Used for regstclass only */ #define ANYOF_EOS 0x10 /* Can match an empty string too */ /* There is a character or a range past 0xff */ #define ANYOF_UNICODE 0x20 #define ANYOF_UNICODE_ALL 0x40 /* Can match any char past 0xff */ /* size of node is large (includes class pointer) */ #define ANYOF_LARGE 0x80 /* Are there any runtime flags on in this node? */ #define ANYOF_RUNTIME(s) (ANYOF_FLAGS(s) & 0x0f) #define ANYOF_FLAGS_ALL 0xff /* Character classes for node->classflags of ANYOF */ /* Should be synchronized with a table in regprop() */ /* 2n should pair with 2n+1 */ #define ANYOF_ALNUM 0 /* \w, PL_utf8_alnum, utf8::IsWord, ALNUM */ #define ANYOF_NALNUM 1 #define ANYOF_SPACE 2 /* \s */ #define ANYOF_NSPACE 3 #define ANYOF_DIGIT 4 /* \d */ #define ANYOF_NDIGIT 5 #define ANYOF_ALNUMC 6 /* [[:alnum:]] isalnum(3), utf8::IsAlnum, ALNUMC */ #define ANYOF_NALNUMC 7 #define ANYOF_ALPHA 8 #define ANYOF_NALPHA 9 #define ANYOF_ASCII 10 #define ANYOF_NASCII 11 #define ANYOF_CNTRL 12 #define ANYOF_NCNTRL 13 #define ANYOF_GRAPH 14 #define ANYOF_NGRAPH 15 #define ANYOF_LOWER 16 #define ANYOF_NLOWER 17 #define ANYOF_PRINT 18 #define ANYOF_NPRINT 19 #define ANYOF_PUNCT 20 #define ANYOF_NPUNCT 21 #define ANYOF_UPPER 22 #define ANYOF_NUPPER 23 #define ANYOF_XDIGIT 24 #define ANYOF_NXDIGIT 25 #define ANYOF_PSXSPC 26 /* POSIX space: \s plus the vertical tab */ #define ANYOF_NPSXSPC 27 #define ANYOF_BLANK 28 /* GNU extension: space and tab: non-vertical space */ #define ANYOF_NBLANK 29 #define ANYOF_MAX 32 /* pseudo classes, not stored in the class bitmap, but used as flags during compilation of char classes */ #define ANYOF_VERTWS (ANYOF_MAX+1) #define ANYOF_NVERTWS (ANYOF_MAX+2) #define ANYOF_HORIZWS (ANYOF_MAX+3) #define ANYOF_NHORIZWS (ANYOF_MAX+4) /* Backward source code compatibility. */ #define ANYOF_ALNUML ANYOF_ALNUM #define ANYOF_NALNUML ANYOF_NALNUM #define ANYOF_SPACEL ANYOF_SPACE #define ANYOF_NSPACEL ANYOF_NSPACE /* Utility macros for the bitmap and classes of ANYOF */ #define ANYOF_SIZE (sizeof(struct regnode_charclass)) #define ANYOF_CLASS_SIZE (sizeof(struct regnode_charclass_class)) #define ANYOF_FLAGS(p) ((p)->flags) #define ANYOF_BIT(c) (1 << ((c) & 7)) #define ANYOF_CLASS_BYTE(p, c) (((struct regnode_charclass_class*)(p))->classflags[((c) >> 3) & 3]) #define ANYOF_CLASS_SET(p, c) (ANYOF_CLASS_BYTE(p, c) |= ANYOF_BIT(c)) #define ANYOF_CLASS_CLEAR(p, c) (ANYOF_CLASS_BYTE(p, c) &= ~ANYOF_BIT(c)) #define ANYOF_CLASS_TEST(p, c) (ANYOF_CLASS_BYTE(p, c) & ANYOF_BIT(c)) #define ANYOF_CLASS_ZERO(ret) Zero(((struct regnode_charclass_class*)(ret))->classflags, ANYOF_CLASSBITMAP_SIZE, char) #define ANYOF_BITMAP_ZERO(ret) Zero(((struct regnode_charclass*)(ret))->bitmap, ANYOF_BITMAP_SIZE, char) #define ANYOF_BITMAP(p) (((struct regnode_charclass*)(p))->bitmap) #define ANYOF_BITMAP_BYTE(p, c) (ANYOF_BITMAP(p)[(((U8)(c)) >> 3) & 31]) #define ANYOF_BITMAP_SET(p, c) (ANYOF_BITMAP_BYTE(p, c) |= ANYOF_BIT(c)) #define ANYOF_BITMAP_CLEAR(p,c) (ANYOF_BITMAP_BYTE(p, c) &= ~ANYOF_BIT(c)) #define ANYOF_BITMAP_TEST(p, c) (ANYOF_BITMAP_BYTE(p, c) & ANYOF_BIT(c)) #define ANYOF_BITMAP_SETALL(p) \ memset (ANYOF_BITMAP(p), 255, ANYOF_BITMAP_SIZE) #define ANYOF_BITMAP_CLEARALL(p) \ Zero (ANYOF_BITMAP(p), ANYOF_BITMAP_SIZE) /* Check that all 256 bits are all set. Used in S_cl_is_anything() */ #define ANYOF_BITMAP_TESTALLSET(p) \ memEQ (ANYOF_BITMAP(p), "\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377", ANYOF_BITMAP_SIZE) #define ANYOF_SKIP ((ANYOF_SIZE - 1)/sizeof(regnode)) #define ANYOF_CLASS_SKIP ((ANYOF_CLASS_SIZE - 1)/sizeof(regnode)) #define ANYOF_CLASS_ADD_SKIP (ANYOF_CLASS_SKIP - ANYOF_SKIP) /* * Utility definitions. */ #ifndef CHARMASK # define UCHARAT(p) ((int)*(const U8*)(p)) #else # define UCHARAT(p) ((int)*(p)&CHARMASK) #endif #define EXTRA_SIZE(guy) ((sizeof(guy)-1)/sizeof(struct regnode)) #define REG_SEEN_ZERO_LEN 0x00000001 #define REG_SEEN_LOOKBEHIND 0x00000002 #define REG_SEEN_GPOS 0x00000004 #define REG_SEEN_EVAL 0x00000008 #define REG_SEEN_CANY 0x00000010 #define REG_SEEN_SANY REG_SEEN_CANY /* src bckwrd cmpt */ #define REG_SEEN_RECURSE 0x00000020 #define REG_TOP_LEVEL_BRANCHES 0x00000040 #define REG_SEEN_VERBARG 0x00000080 #define REG_SEEN_CUTGROUP 0x00000100 #define REG_SEEN_RUN_ON_COMMENT 0x00000200 START_EXTERN_C #ifdef PLUGGABLE_RE_EXTENSION #include "re_nodes.h" #else #include "regnodes.h" #endif /* The following have no fixed length. U8 so we can do strchr() on it. */ #ifndef DOINIT EXTCONST U8 PL_varies[]; #else EXTCONST U8 PL_varies[] = { BRANCH, BACK, STAR, PLUS, CURLY, CURLYX, REF, REFF, REFFL, WHILEM, CURLYM, CURLYN, BRANCHJ, IFTHEN, SUSPEND, CLUMP, NREF, NREFF, NREFFL, 0 }; #endif /* The following always have a length of 1. U8 we can do strchr() on it. */ /* (Note that length 1 means "one character" under UTF8, not "one octet".) */ #ifndef DOINIT EXTCONST U8 PL_simple[]; #else EXTCONST U8 PL_simple[] = { REG_ANY, SANY, CANY, ANYOF, ALNUM, ALNUML, NALNUM, NALNUML, SPACE, SPACEL, NSPACE, NSPACEL, DIGIT, NDIGIT, VERTWS, NVERTWS, HORIZWS, NHORIZWS, 0 }; #endif #ifndef PLUGGABLE_RE_EXTENSION #ifndef DOINIT EXTCONST regexp_engine PL_core_reg_engine; #else /* DOINIT */ EXTCONST regexp_engine PL_core_reg_engine = { Perl_re_compile, Perl_regexec_flags, Perl_re_intuit_start, Perl_re_intuit_string, Perl_regfree_internal, Perl_reg_numbered_buff_fetch, Perl_reg_numbered_buff_store, Perl_reg_numbered_buff_length, Perl_reg_named_buff, Perl_reg_named_buff_iter, Perl_reg_qr_package, #if defined(USE_ITHREADS) Perl_regdupe_internal #endif }; #endif /* DOINIT */ #endif /* PLUGGABLE_RE_EXTENSION */ END_EXTERN_C /* .what is a character array with one character for each member of .data * The character describes the function of the corresponding .data item: * f - start-class data for regstclass optimization * n - Root of op tree for (?{EVAL}) item * o - Start op for (?{EVAL}) item * p - Pad for (?{EVAL}) item * s - swash for Unicode-style character class, and the multicharacter * strings resulting from casefolding the single-character entries * in the character class * t - trie struct * u - trie struct's widecharmap (a HV, so can't share, must dup) * also used for revcharmap and words under DEBUGGING * T - aho-trie struct * S - sv for named capture lookup * 20010712 mjd@plover.com * (Remember to update re_dup() and pregfree() if you add any items.) */ struct reg_data { U32 count; U8 *what; void* data[1]; }; /* Code in S_to_utf8_substr() and S_to_byte_substr() in regexec.c accesses anchored* and float* via array indexes 0 and 1. */ #define anchored_substr substrs->data[0].substr #define anchored_utf8 substrs->data[0].utf8_substr #define anchored_offset substrs->data[0].min_offset #define anchored_end_shift substrs->data[0].end_shift #define float_substr substrs->data[1].substr #define float_utf8 substrs->data[1].utf8_substr #define float_min_offset substrs->data[1].min_offset #define float_max_offset substrs->data[1].max_offset #define float_end_shift substrs->data[1].end_shift #define check_substr substrs->data[2].substr #define check_utf8 substrs->data[2].utf8_substr #define check_offset_min substrs->data[2].min_offset #define check_offset_max substrs->data[2].max_offset #define check_end_shift substrs->data[2].end_shift #define RX_ANCHORED_SUBSTR(rx) (((struct regexp *)SvANY(rx))->anchored_substr) #define RX_ANCHORED_UTF8(rx) (((struct regexp *)SvANY(rx))->anchored_utf8) #define RX_FLOAT_SUBSTR(rx) (((struct regexp *)SvANY(rx))->float_substr) #define RX_FLOAT_UTF8(rx) (((struct regexp *)SvANY(rx))->float_utf8) /* trie related stuff */ /* a transition record for the state machine. the check field determines which state "owns" the transition. the char the transition is for is determined by offset from the owning states base field. the next field determines which state is to be transitioned to if any. */ struct _reg_trie_trans { U32 next; U32 check; }; /* a transition list element for the list based representation */ struct _reg_trie_trans_list_elem { U16 forid; U32 newstate; }; typedef struct _reg_trie_trans_list_elem reg_trie_trans_le; /* a state for compressed nodes. base is an offset into an array of reg_trie_trans array. If wordnum is nonzero the state is accepting. if base is zero then the state has no children (and will be accepting) */ struct _reg_trie_state { U16 wordnum; union { U32 base; reg_trie_trans_le* list; } trans; }; typedef struct _reg_trie_state reg_trie_state; typedef struct _reg_trie_trans reg_trie_trans; /* anything in here that needs to be freed later should be dealt with in pregfree. refcount is first in both this and _reg_ac_data to allow a space optimisation in Perl_regdupe. */ struct _reg_trie_data { U32 refcount; /* number of times this trie is referenced */ U32 lasttrans; /* last valid transition element */ U16 *charmap; /* byte to charid lookup array */ reg_trie_state *states; /* state data */ reg_trie_trans *trans; /* array of transition elements */ char *bitmap; /* stclass bitmap */ U32 *wordlen; /* array of lengths of words */ U16 *jump; /* optional 1 indexed array of offsets before tail for the node following a given word. */ U16 *nextword; /* optional 1 indexed array to support linked list of duplicate wordnums */ U16 uniquecharcount; /* unique chars in trie (width of trans table) */ U32 startstate; /* initial state - used for common prefix optimisation */ STRLEN minlen; /* minimum length of words in trie - build/opt only? */ STRLEN maxlen; /* maximum length of words in trie - build/opt only? */ U32 statecount; /* Build only - number of states in the states array (including the unused zero state) */ U32 wordcount; /* Build only */ #ifdef DEBUGGING STRLEN charcount; /* Build only */ #endif }; /* There is one (3 under DEBUGGING) pointers that logically belong in this structure, but are held outside as they need duplication on thread cloning, whereas the rest of the structure can be read only: HV *widecharmap; code points > 255 to charid #ifdef DEBUGGING AV *words; Array of words contained in trie, for dumping AV *revcharmap; Map of each charid back to its character representation #endif */ #define TRIE_WORDS_OFFSET 2 typedef struct _reg_trie_data reg_trie_data; /* refcount is first in both this and _reg_trie_data to allow a space optimisation in Perl_regdupe. */ struct _reg_ac_data { U32 refcount; U32 trie; U32 *fail; reg_trie_state *states; }; typedef struct _reg_ac_data reg_ac_data; /* ANY_BIT doesnt use the structure, so we can borrow it here. This is simpler than refactoring all of it as wed end up with three different sets... */ #define TRIE_BITMAP(p) (((reg_trie_data *)(p))->bitmap) #define TRIE_BITMAP_BYTE(p, c) (TRIE_BITMAP(p)[(((U8)(c)) >> 3) & 31]) #define TRIE_BITMAP_SET(p, c) (TRIE_BITMAP_BYTE(p, c) |= ANYOF_BIT((U8)c)) #define TRIE_BITMAP_CLEAR(p,c) (TRIE_BITMAP_BYTE(p, c) &= ~ANYOF_BIT((U8)c)) #define TRIE_BITMAP_TEST(p, c) (TRIE_BITMAP_BYTE(p, c) & ANYOF_BIT((U8)c)) #define IS_ANYOF_TRIE(op) ((op)==TRIEC || (op)==AHOCORASICKC) #define IS_TRIE_AC(op) ((op)>=AHOCORASICK) #define BITMAP_BYTE(p, c) (((U8*)p)[(((U8)(c)) >> 3) & 31]) #define BITMAP_TEST(p, c) (BITMAP_BYTE(p, c) & ANYOF_BIT((U8)c)) /* these defines assume uniquecharcount is the correct variable, and state may be evaluated twice */ #define TRIE_NODENUM(state) (((state)-1)/(trie->uniquecharcount)+1) #define SAFE_TRIE_NODENUM(state) ((state) ? (((state)-1)/(trie->uniquecharcount)+1) : (state)) #define TRIE_NODEIDX(state) ((state) ? (((state)-1)*(trie->uniquecharcount)+1) : (state)) #ifdef DEBUGGING #define TRIE_CHARCOUNT(trie) ((trie)->charcount) #else #define TRIE_CHARCOUNT(trie) (trie_charcount) #endif #define RE_TRIE_MAXBUF_INIT 65536 #define RE_TRIE_MAXBUF_NAME "\022E_TRIE_MAXBUF" #define RE_DEBUG_FLAGS "\022E_DEBUG_FLAGS" /* RE_DEBUG_FLAGS is used to control what debug output is emitted its divided into three groups of options, some of which interact. The three groups are: Compile, Execute, Extra. There is room for a further group, as currently only the low three bytes are used. Compile Options: PARSE PEEP TRIE PROGRAM OFFSETS Execute Options: INTUIT MATCH TRIE Extra Options TRIE OFFSETS If you modify any of these make sure you make corresponding changes to re.pm, especially to the documentation. */ /* Compile */ #define RE_DEBUG_COMPILE_MASK 0x0000FF #define RE_DEBUG_COMPILE_PARSE 0x000001 #define RE_DEBUG_COMPILE_OPTIMISE 0x000002 #define RE_DEBUG_COMPILE_TRIE 0x000004 #define RE_DEBUG_COMPILE_DUMP 0x000008 #define RE_DEBUG_COMPILE_FLAGS 0x000010 /* Execute */ #define RE_DEBUG_EXECUTE_MASK 0x00FF00 #define RE_DEBUG_EXECUTE_INTUIT 0x000100 #define RE_DEBUG_EXECUTE_MATCH 0x000200 #define RE_DEBUG_EXECUTE_TRIE 0x000400 /* Extra */ #define RE_DEBUG_EXTRA_MASK 0xFF0000 #define RE_DEBUG_EXTRA_TRIE 0x010000 #define RE_DEBUG_EXTRA_OFFSETS 0x020000 #define RE_DEBUG_EXTRA_OFFDEBUG 0x040000 #define RE_DEBUG_EXTRA_STATE 0x080000 #define RE_DEBUG_EXTRA_OPTIMISE 0x100000 #define RE_DEBUG_EXTRA_BUFFERS 0x400000 #define RE_DEBUG_EXTRA_GPOS 0x800000 /* combined */ #define RE_DEBUG_EXTRA_STACK 0x280000 #define RE_DEBUG_FLAG(x) (re_debug_flags & x) /* Compile */ #define DEBUG_COMPILE_r(x) DEBUG_r( \ if (re_debug_flags & RE_DEBUG_COMPILE_MASK) x ) #define DEBUG_PARSE_r(x) DEBUG_r( \ if (re_debug_flags & RE_DEBUG_COMPILE_PARSE) x ) #define DEBUG_OPTIMISE_r(x) DEBUG_r( \ if (re_debug_flags & RE_DEBUG_COMPILE_OPTIMISE) x ) #define DEBUG_PARSE_r(x) DEBUG_r( \ if (re_debug_flags & RE_DEBUG_COMPILE_PARSE) x ) #define DEBUG_DUMP_r(x) DEBUG_r( \ if (re_debug_flags & RE_DEBUG_COMPILE_DUMP) x ) #define DEBUG_TRIE_COMPILE_r(x) DEBUG_r( \ if (re_debug_flags & RE_DEBUG_COMPILE_TRIE) x ) #define DEBUG_FLAGS_r(x) DEBUG_r( \ if (re_debug_flags & RE_DEBUG_COMPILE_FLAGS) x ) /* Execute */ #define DEBUG_EXECUTE_r(x) DEBUG_r( \ if (re_debug_flags & RE_DEBUG_EXECUTE_MASK) x ) #define DEBUG_INTUIT_r(x) DEBUG_r( \ if (re_debug_flags & RE_DEBUG_EXECUTE_INTUIT) x ) #define DEBUG_MATCH_r(x) DEBUG_r( \ if (re_debug_flags & RE_DEBUG_EXECUTE_MATCH) x ) #define DEBUG_TRIE_EXECUTE_r(x) DEBUG_r( \ if (re_debug_flags & RE_DEBUG_EXECUTE_TRIE) x ) /* Extra */ #define DEBUG_EXTRA_r(x) DEBUG_r( \ if (re_debug_flags & RE_DEBUG_EXTRA_MASK) x ) #define DEBUG_OFFSETS_r(x) DEBUG_r( \ if (re_debug_flags & RE_DEBUG_EXTRA_OFFSETS) x ) #define DEBUG_STATE_r(x) DEBUG_r( \ if (re_debug_flags & RE_DEBUG_EXTRA_STATE) x ) #define DEBUG_STACK_r(x) DEBUG_r( \ if (re_debug_flags & RE_DEBUG_EXTRA_STACK) x ) #define DEBUG_BUFFERS_r(x) DEBUG_r( \ if (re_debug_flags & RE_DEBUG_EXTRA_BUFFERS) x ) #define DEBUG_OPTIMISE_MORE_r(x) DEBUG_r( \ if ((RE_DEBUG_EXTRA_OPTIMISE|RE_DEBUG_COMPILE_OPTIMISE) == \ (re_debug_flags & (RE_DEBUG_EXTRA_OPTIMISE|RE_DEBUG_COMPILE_OPTIMISE)) ) x ) #define MJD_OFFSET_DEBUG(x) DEBUG_r( \ if (re_debug_flags & RE_DEBUG_EXTRA_OFFDEBUG) \ Perl_warn_nocontext x ) #define DEBUG_TRIE_COMPILE_MORE_r(x) DEBUG_TRIE_COMPILE_r( \ if (re_debug_flags & RE_DEBUG_EXTRA_TRIE) x ) #define DEBUG_TRIE_EXECUTE_MORE_r(x) DEBUG_TRIE_EXECUTE_r( \ if (re_debug_flags & RE_DEBUG_EXTRA_TRIE) x ) #define DEBUG_TRIE_r(x) DEBUG_r( \ if (re_debug_flags & (RE_DEBUG_COMPILE_TRIE \ | RE_DEBUG_EXECUTE_TRIE )) x ) #define DEBUG_GPOS_r(x) DEBUG_r( \ if (re_debug_flags & RE_DEBUG_EXTRA_GPOS) x ) /* initialization */ /* get_sv() can return NULL during global destruction. */ #define GET_RE_DEBUG_FLAGS DEBUG_r({ \ SV * re_debug_flags_sv = NULL; \ re_debug_flags_sv = get_sv(RE_DEBUG_FLAGS, 1); \ if (re_debug_flags_sv) { \ if (!SvIOK(re_debug_flags_sv)) \ sv_setuv(re_debug_flags_sv, RE_DEBUG_COMPILE_DUMP | RE_DEBUG_EXECUTE_MASK ); \ re_debug_flags=SvIV(re_debug_flags_sv); \ }\ }) #ifdef DEBUGGING #define GET_RE_DEBUG_FLAGS_DECL IV re_debug_flags = 0; GET_RE_DEBUG_FLAGS; #define RE_PV_COLOR_DECL(rpv,rlen,isuni,dsv,pv,l,m,c1,c2) \ const char * const rpv = \ pv_pretty((dsv), (pv), (l), (m), \ PL_colors[(c1)],PL_colors[(c2)], \ PERL_PV_ESCAPE_RE |((isuni) ? PERL_PV_ESCAPE_UNI : 0) ); \ const int rlen = SvCUR(dsv) #define RE_SV_ESCAPE(rpv,isuni,dsv,sv,m) \ const char * const rpv = \ pv_pretty((dsv), (SvPV_nolen_const(sv)), (SvCUR(sv)), (m), \ PL_colors[(c1)],PL_colors[(c2)], \ PERL_PV_ESCAPE_RE |((isuni) ? PERL_PV_ESCAPE_UNI : 0) ) #define RE_PV_QUOTED_DECL(rpv,isuni,dsv,pv,l,m) \ const char * const rpv = \ pv_pretty((dsv), (pv), (l), (m), \ PL_colors[0], PL_colors[1], \ ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES | \ ((isuni) ? PERL_PV_ESCAPE_UNI : 0)) \ ) #define RE_SV_DUMPLEN(ItEm) (SvCUR(ItEm) - (SvTAIL(ItEm)!=0)) #define RE_SV_TAIL(ItEm) (SvTAIL(ItEm) ? "$" : "") #else /* if not DEBUGGING */ #define GET_RE_DEBUG_FLAGS_DECL #define RE_PV_COLOR_DECL(rpv,rlen,isuni,dsv,pv,l,m,c1,c2) #define RE_SV_ESCAPE(rpv,isuni,dsv,sv,m) #define RE_PV_QUOTED_DECL(rpv,isuni,dsv,pv,l,m) #define RE_SV_DUMPLEN(ItEm) #define RE_SV_TAIL(ItEm) #endif /* DEBUG RELATED DEFINES */ /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */ perl-5.12.0-RC0/utf8.c0000444000175000017500000017571111344764022013176 0ustar jessejesse/* utf8.c * * Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 * by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * 'What a fix!' said Sam. 'That's the one place in all the lands we've ever * heard of that we don't want to see any closer; and that's the one place * we're trying to get to! And that's just where we can't get, nohow.' * * [p.603 of _The Lord of the Rings_, IV/I: "The Taming of Sméagol"] * * 'Well do I understand your speech,' he answered in the same language; * 'yet few strangers do so. Why then do you not speak in the Common Tongue, * as is the custom in the West, if you wish to be answered?' * --Gandalf, addressing Théoden's door wardens * * [p.508 of _The Lord of the Rings_, III/vi: "The King of the Golden Hall"] * * ...the travellers perceived that the floor was paved with stones of many * hues; branching runes and strange devices intertwined beneath their feet. * * [p.512 of _The Lord of the Rings_, III/vi: "The King of the Golden Hall"] */ #include "EXTERN.h" #define PERL_IN_UTF8_C #include "perl.h" #ifndef EBCDIC /* Separate prototypes needed because in ASCII systems these * usually macros but they still are compiled as code, too. */ PERL_CALLCONV UV Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags); PERL_CALLCONV U8* Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv); #endif static const char unees[] = "Malformed UTF-8 character (unexpected end of string)"; /* =head1 Unicode Support This file contains various utility functions for manipulating UTF8-encoded strings. For the uninitiated, this is a method of representing arbitrary Unicode characters as a variable number of bytes, in such a way that characters in the ASCII range are unmodified, and a zero byte never appears within non-zero characters. =cut */ /* =for apidoc is_ascii_string Returns true if first C bytes of the given string are ASCII (i.e. none of them even raise the question of UTF-8-ness). See also is_utf8_string(), is_utf8_string_loclen(), and is_utf8_string_loc(). =cut */ bool Perl_is_ascii_string(const U8 *s, STRLEN len) { const U8* const send = s + (len ? len : strlen((const char *)s)); const U8* x = s; PERL_ARGS_ASSERT_IS_ASCII_STRING; for (; x < send; ++x) { if (!UTF8_IS_INVARIANT(*x)) break; } return x == send; } /* =for apidoc uvuni_to_utf8_flags Adds the UTF-8 representation of the Unicode codepoint C to the end of the string C; C should be have at least C free bytes available. The return value is the pointer to the byte after the end of the new character. In other words, d = uvuni_to_utf8_flags(d, uv, flags); or, in most cases, d = uvuni_to_utf8(d, uv); (which is equivalent to) d = uvuni_to_utf8_flags(d, uv, 0); is the recommended Unicode-aware way of saying *(d++) = uv; =cut */ U8 * Perl_uvuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags) { PERL_ARGS_ASSERT_UVUNI_TO_UTF8_FLAGS; if (ckWARN(WARN_UTF8)) { if (UNICODE_IS_SURROGATE(uv) && !(flags & UNICODE_ALLOW_SURROGATE)) Perl_warner(aTHX_ packWARN(WARN_UTF8), "UTF-16 surrogate 0x%04"UVxf, uv); else if ( ((uv >= 0xFDD0 && uv <= 0xFDEF && !(flags & UNICODE_ALLOW_FDD0)) || ((uv & 0xFFFE) == 0xFFFE && /* Either FFFE or FFFF. */ !(flags & UNICODE_ALLOW_FFFF))) && /* UNICODE_ALLOW_SUPER includes * FFFEs and FFFFs beyond 0x10FFFF. */ ((uv <= PERL_UNICODE_MAX) || !(flags & UNICODE_ALLOW_SUPER)) ) Perl_warner(aTHX_ packWARN(WARN_UTF8), "Unicode non-character 0x%04"UVxf" is illegal for interchange", uv); } if (UNI_IS_INVARIANT(uv)) { *d++ = (U8)UTF_TO_NATIVE(uv); return d; } #if defined(EBCDIC) else { STRLEN len = UNISKIP(uv); U8 *p = d+len-1; while (p > d) { *p-- = (U8)UTF_TO_NATIVE((uv & UTF_CONTINUATION_MASK) | UTF_CONTINUATION_MARK); uv >>= UTF_ACCUMULATION_SHIFT; } *p = (U8)UTF_TO_NATIVE((uv & UTF_START_MASK(len)) | UTF_START_MARK(len)); return d+len; } #else /* Non loop style */ if (uv < 0x800) { *d++ = (U8)(( uv >> 6) | 0xc0); *d++ = (U8)(( uv & 0x3f) | 0x80); return d; } if (uv < 0x10000) { *d++ = (U8)(( uv >> 12) | 0xe0); *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80); *d++ = (U8)(( uv & 0x3f) | 0x80); return d; } if (uv < 0x200000) { *d++ = (U8)(( uv >> 18) | 0xf0); *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80); *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80); *d++ = (U8)(( uv & 0x3f) | 0x80); return d; } if (uv < 0x4000000) { *d++ = (U8)(( uv >> 24) | 0xf8); *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80); *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80); *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80); *d++ = (U8)(( uv & 0x3f) | 0x80); return d; } if (uv < 0x80000000) { *d++ = (U8)(( uv >> 30) | 0xfc); *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80); *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80); *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80); *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80); *d++ = (U8)(( uv & 0x3f) | 0x80); return d; } #ifdef HAS_QUAD if (uv < UTF8_QUAD_MAX) #endif { *d++ = 0xfe; /* Can't match U+FEFF! */ *d++ = (U8)(((uv >> 30) & 0x3f) | 0x80); *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80); *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80); *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80); *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80); *d++ = (U8)(( uv & 0x3f) | 0x80); return d; } #ifdef HAS_QUAD { *d++ = 0xff; /* Can't match U+FFFE! */ *d++ = 0x80; /* 6 Reserved bits */ *d++ = (U8)(((uv >> 60) & 0x0f) | 0x80); /* 2 Reserved bits */ *d++ = (U8)(((uv >> 54) & 0x3f) | 0x80); *d++ = (U8)(((uv >> 48) & 0x3f) | 0x80); *d++ = (U8)(((uv >> 42) & 0x3f) | 0x80); *d++ = (U8)(((uv >> 36) & 0x3f) | 0x80); *d++ = (U8)(((uv >> 30) & 0x3f) | 0x80); *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80); *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80); *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80); *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80); *d++ = (U8)(( uv & 0x3f) | 0x80); return d; } #endif #endif /* Loop style */ } /* Tests if some arbitrary number of bytes begins in a valid UTF-8 character. Note that an INVARIANT (i.e. ASCII) character is a valid UTF-8 character. The actual number of bytes in the UTF-8 character will be returned if it is valid, otherwise 0. This is the "slow" version as opposed to the "fast" version which is the "unrolled" IS_UTF8_CHAR(). E.g. for t/uni/class.t the speed difference is a factor of 2 to 3. For lengths (UTF8SKIP(s)) of four or less you should use the IS_UTF8_CHAR(), for lengths of five or more you should use the _slow(). In practice this means that the _slow() will be used very rarely, since the maximum Unicode code point (as of Unicode 4.1) is U+10FFFF, which encodes in UTF-8 to four bytes. Only the "Perl extended UTF-8" (the infamous 'v-strings') will encode into five bytes or more. =cut */ STATIC STRLEN S_is_utf8_char_slow(const U8 *s, const STRLEN len) { U8 u = *s; STRLEN slen; UV uv, ouv; PERL_ARGS_ASSERT_IS_UTF8_CHAR_SLOW; if (UTF8_IS_INVARIANT(u)) return 1; if (!UTF8_IS_START(u)) return 0; if (len < 2 || !UTF8_IS_CONTINUATION(s[1])) return 0; slen = len - 1; s++; #ifdef EBCDIC u = NATIVE_TO_UTF(u); #endif u &= UTF_START_MASK(len); uv = u; ouv = uv; while (slen--) { if (!UTF8_IS_CONTINUATION(*s)) return 0; uv = UTF8_ACCUMULATE(uv, *s); if (uv < ouv) return 0; ouv = uv; s++; } if ((STRLEN)UNISKIP(uv) < len) return 0; return len; } /* =for apidoc is_utf8_char Tests if some arbitrary number of bytes begins in a valid UTF-8 character. Note that an INVARIANT (i.e. ASCII on non-EBCDIC machines) character is a valid UTF-8 character. The actual number of bytes in the UTF-8 character will be returned if it is valid, otherwise 0. =cut */ STRLEN Perl_is_utf8_char(const U8 *s) { const STRLEN len = UTF8SKIP(s); PERL_ARGS_ASSERT_IS_UTF8_CHAR; #ifdef IS_UTF8_CHAR if (IS_UTF8_CHAR_FAST(len)) return IS_UTF8_CHAR(s, len) ? len : 0; #endif /* #ifdef IS_UTF8_CHAR */ return is_utf8_char_slow(s, len); } /* =for apidoc is_utf8_string Returns true if first C bytes of the given string form a valid UTF-8 string, false otherwise. Note that 'a valid UTF-8 string' does not mean 'a string that contains code points above 0x7F encoded in UTF-8' because a valid ASCII string is a valid UTF-8 string. See also is_ascii_string(), is_utf8_string_loclen(), and is_utf8_string_loc(). =cut */ bool Perl_is_utf8_string(const U8 *s, STRLEN len) { const U8* const send = s + (len ? len : strlen((const char *)s)); const U8* x = s; PERL_ARGS_ASSERT_IS_UTF8_STRING; while (x < send) { STRLEN c; /* Inline the easy bits of is_utf8_char() here for speed... */ if (UTF8_IS_INVARIANT(*x)) c = 1; else if (!UTF8_IS_START(*x)) goto out; else { /* ... and call is_utf8_char() only if really needed. */ #ifdef IS_UTF8_CHAR c = UTF8SKIP(x); if (IS_UTF8_CHAR_FAST(c)) { if (!IS_UTF8_CHAR(x, c)) c = 0; } else c = is_utf8_char_slow(x, c); #else c = is_utf8_char(x); #endif /* #ifdef IS_UTF8_CHAR */ if (!c) goto out; } x += c; } out: if (x != send) return FALSE; return TRUE; } /* Implemented as a macro in utf8.h =for apidoc is_utf8_string_loc Like is_utf8_string() but stores the location of the failure (in the case of "utf8ness failure") or the location s+len (in the case of "utf8ness success") in the C. See also is_utf8_string_loclen() and is_utf8_string(). =for apidoc is_utf8_string_loclen Like is_utf8_string() but stores the location of the failure (in the case of "utf8ness failure") or the location s+len (in the case of "utf8ness success") in the C, and the number of UTF-8 encoded characters in the C. See also is_utf8_string_loc() and is_utf8_string(). =cut */ bool Perl_is_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el) { const U8* const send = s + (len ? len : strlen((const char *)s)); const U8* x = s; STRLEN c; STRLEN outlen = 0; PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN; while (x < send) { /* Inline the easy bits of is_utf8_char() here for speed... */ if (UTF8_IS_INVARIANT(*x)) c = 1; else if (!UTF8_IS_START(*x)) goto out; else { /* ... and call is_utf8_char() only if really needed. */ #ifdef IS_UTF8_CHAR c = UTF8SKIP(x); if (IS_UTF8_CHAR_FAST(c)) { if (!IS_UTF8_CHAR(x, c)) c = 0; } else c = is_utf8_char_slow(x, c); #else c = is_utf8_char(x); #endif /* #ifdef IS_UTF8_CHAR */ if (!c) goto out; } x += c; outlen++; } out: if (el) *el = outlen; if (ep) *ep = x; return (x == send); } /* =for apidoc utf8n_to_uvuni Bottom level UTF-8 decode routine. Returns the Unicode code point value of the first character in the string C which is assumed to be in UTF-8 encoding and no longer than C; C will be set to the length, in bytes, of that character. If C does not point to a well-formed UTF-8 character, the behaviour is dependent on the value of C: if it contains UTF8_CHECK_ONLY, it is assumed that the caller will raise a warning, and this function will silently just set C to C<-1> and return zero. If the C does not contain UTF8_CHECK_ONLY, warnings about malformations will be given, C will be set to the expected length of the UTF-8 character in bytes, and zero will be returned. The C can also contain various flags to allow deviations from the strict UTF-8 encoding (see F). Most code should use utf8_to_uvchr() rather than call this directly. =cut */ UV Perl_utf8n_to_uvuni(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags) { dVAR; const U8 * const s0 = s; UV uv = *s, ouv = 0; STRLEN len = 1; const bool dowarn = ckWARN_d(WARN_UTF8); const UV startbyte = *s; STRLEN expectlen = 0; U32 warning = 0; SV* sv; PERL_ARGS_ASSERT_UTF8N_TO_UVUNI; /* This list is a superset of the UTF8_ALLOW_XXX. BUT it isn't, eg SUPER missing XXX */ #define UTF8_WARN_EMPTY 1 #define UTF8_WARN_CONTINUATION 2 #define UTF8_WARN_NON_CONTINUATION 3 #define UTF8_WARN_FE_FF 4 #define UTF8_WARN_SHORT 5 #define UTF8_WARN_OVERFLOW 6 #define UTF8_WARN_SURROGATE 7 #define UTF8_WARN_LONG 8 #define UTF8_WARN_FFFF 9 /* Also FFFE. */ if (curlen == 0 && !(flags & UTF8_ALLOW_EMPTY)) { warning = UTF8_WARN_EMPTY; goto malformed; } if (UTF8_IS_INVARIANT(uv)) { if (retlen) *retlen = 1; return (UV) (NATIVE_TO_UTF(*s)); } if (UTF8_IS_CONTINUATION(uv) && !(flags & UTF8_ALLOW_CONTINUATION)) { warning = UTF8_WARN_CONTINUATION; goto malformed; } if (UTF8_IS_START(uv) && curlen > 1 && !UTF8_IS_CONTINUATION(s[1]) && !(flags & UTF8_ALLOW_NON_CONTINUATION)) { warning = UTF8_WARN_NON_CONTINUATION; goto malformed; } #ifdef EBCDIC uv = NATIVE_TO_UTF(uv); #else if ((uv == 0xfe || uv == 0xff) && !(flags & UTF8_ALLOW_FE_FF)) { warning = UTF8_WARN_FE_FF; goto malformed; } #endif if (!(uv & 0x20)) { len = 2; uv &= 0x1f; } else if (!(uv & 0x10)) { len = 3; uv &= 0x0f; } else if (!(uv & 0x08)) { len = 4; uv &= 0x07; } else if (!(uv & 0x04)) { len = 5; uv &= 0x03; } #ifdef EBCDIC else if (!(uv & 0x02)) { len = 6; uv &= 0x01; } else { len = 7; uv &= 0x01; } #else else if (!(uv & 0x02)) { len = 6; uv &= 0x01; } else if (!(uv & 0x01)) { len = 7; uv = 0; } else { len = 13; uv = 0; } /* whoa! */ #endif if (retlen) *retlen = len; expectlen = len; if ((curlen < expectlen) && !(flags & UTF8_ALLOW_SHORT)) { warning = UTF8_WARN_SHORT; goto malformed; } len--; s++; ouv = uv; while (len--) { if (!UTF8_IS_CONTINUATION(*s) && !(flags & UTF8_ALLOW_NON_CONTINUATION)) { s--; warning = UTF8_WARN_NON_CONTINUATION; goto malformed; } else uv = UTF8_ACCUMULATE(uv, *s); if (!(uv > ouv)) { /* These cannot be allowed. */ if (uv == ouv) { if (expectlen != 13 && !(flags & UTF8_ALLOW_LONG)) { warning = UTF8_WARN_LONG; goto malformed; } } else { /* uv < ouv */ /* This cannot be allowed. */ warning = UTF8_WARN_OVERFLOW; goto malformed; } } s++; ouv = uv; } if (UNICODE_IS_SURROGATE(uv) && !(flags & UTF8_ALLOW_SURROGATE)) { warning = UTF8_WARN_SURROGATE; goto malformed; } else if ((expectlen > (STRLEN)UNISKIP(uv)) && !(flags & UTF8_ALLOW_LONG)) { warning = UTF8_WARN_LONG; goto malformed; } else if (UNICODE_IS_ILLEGAL(uv) && !(flags & UTF8_ALLOW_FFFF)) { warning = UTF8_WARN_FFFF; goto malformed; } return uv; malformed: if (flags & UTF8_CHECK_ONLY) { if (retlen) *retlen = ((STRLEN) -1); return 0; } if (dowarn) { if (warning == UTF8_WARN_FFFF) { sv = newSVpvs_flags("Unicode non-character ", SVs_TEMP); Perl_sv_catpvf(aTHX_ sv, "0x%04"UVxf" is illegal for interchange", uv); } else { sv = newSVpvs_flags("Malformed UTF-8 character ", SVs_TEMP); switch (warning) { case 0: /* Intentionally empty. */ break; case UTF8_WARN_EMPTY: sv_catpvs(sv, "(empty string)"); break; case UTF8_WARN_CONTINUATION: Perl_sv_catpvf(aTHX_ sv, "(unexpected continuation byte 0x%02"UVxf", with no preceding start byte)", uv); break; case UTF8_WARN_NON_CONTINUATION: if (s == s0) Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", immediately after start byte 0x%02"UVxf")", (UV)s[1], startbyte); else { const int len = (int)(s-s0); Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", %d byte%s after start byte 0x%02"UVxf", expected %d bytes)", (UV)s[1], len, len > 1 ? "s" : "", startbyte, (int)expectlen); } break; case UTF8_WARN_FE_FF: Perl_sv_catpvf(aTHX_ sv, "(byte 0x%02"UVxf")", uv); break; case UTF8_WARN_SHORT: Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")", (int)curlen, curlen == 1 ? "" : "s", (int)expectlen, startbyte); expectlen = curlen; /* distance for caller to skip */ break; case UTF8_WARN_OVERFLOW: Perl_sv_catpvf(aTHX_ sv, "(overflow at 0x%"UVxf", byte 0x%02x, after start byte 0x%02"UVxf")", ouv, *s, startbyte); break; case UTF8_WARN_SURROGATE: Perl_sv_catpvf(aTHX_ sv, "(UTF-16 surrogate 0x%04"UVxf")", uv); break; case UTF8_WARN_LONG: Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")", (int)expectlen, expectlen == 1 ? "": "s", UNISKIP(uv), startbyte); break; default: sv_catpvs(sv, "(unknown reason)"); break; } } if (warning) { const char * const s = SvPVX_const(sv); if (PL_op) Perl_warner(aTHX_ packWARN(WARN_UTF8), "%s in %s", s, OP_DESC(PL_op)); else Perl_warner(aTHX_ packWARN(WARN_UTF8), "%s", s); } } if (retlen) *retlen = expectlen ? expectlen : len; return 0; } /* =for apidoc utf8_to_uvchr Returns the native character value of the first character in the string C which is assumed to be in UTF-8 encoding; C will be set to the length, in bytes, of that character. If C does not point to a well-formed UTF-8 character, zero is returned and retlen is set, if possible, to -1. =cut */ UV Perl_utf8_to_uvchr(pTHX_ const U8 *s, STRLEN *retlen) { PERL_ARGS_ASSERT_UTF8_TO_UVCHR; return utf8n_to_uvchr(s, UTF8_MAXBYTES, retlen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY); } /* =for apidoc utf8_to_uvuni Returns the Unicode code point of the first character in the string C which is assumed to be in UTF-8 encoding; C will be set to the length, in bytes, of that character. This function should only be used when the returned UV is considered an index into the Unicode semantic tables (e.g. swashes). If C does not point to a well-formed UTF-8 character, zero is returned and retlen is set, if possible, to -1. =cut */ UV Perl_utf8_to_uvuni(pTHX_ const U8 *s, STRLEN *retlen) { PERL_ARGS_ASSERT_UTF8_TO_UVUNI; /* Call the low level routine asking for checks */ return Perl_utf8n_to_uvuni(aTHX_ s, UTF8_MAXBYTES, retlen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY); } /* =for apidoc utf8_length Return the length of the UTF-8 char encoded string C in characters. Stops at C (inclusive). If C s> or if the scan would end up past C, croaks. =cut */ STRLEN Perl_utf8_length(pTHX_ const U8 *s, const U8 *e) { dVAR; STRLEN len = 0; PERL_ARGS_ASSERT_UTF8_LENGTH; /* Note: cannot use UTF8_IS_...() too eagerly here since e.g. * the bitops (especially ~) can create illegal UTF-8. * In other words: in Perl UTF-8 is not just for Unicode. */ if (e < s) goto warn_and_return; while (s < e) { if (!UTF8_IS_INVARIANT(*s)) s += UTF8SKIP(s); else s++; len++; } if (e != s) { 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), unees); } return len; } /* =for apidoc utf8_distance Returns the number of UTF-8 characters between the UTF-8 pointers C and C. WARNING: use only if you *know* that the pointers point inside the same UTF-8 buffer. =cut */ IV Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b) { PERL_ARGS_ASSERT_UTF8_DISTANCE; return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a); } /* =for apidoc utf8_hop Return the UTF-8 pointer C displaced by C characters, either forward or backward. WARNING: do not use the following unless you *know* C is within the UTF-8 data pointed to by C *and* that on entry C is aligned on the first byte of character or just after the last byte of a character. =cut */ U8 * Perl_utf8_hop(pTHX_ const U8 *s, I32 off) { PERL_ARGS_ASSERT_UTF8_HOP; PERL_UNUSED_CONTEXT; /* Note: cannot use UTF8_IS_...() too eagerly here since e.g * the bitops (especially ~) can create illegal UTF-8. * In other words: in Perl UTF-8 is not just for Unicode. */ if (off >= 0) { while (off--) s += UTF8SKIP(s); } else { while (off++) { s--; while (UTF8_IS_CONTINUATION(*s)) s--; } } return (U8 *)s; } /* =for apidoc utf8_to_bytes Converts a string C of length C from UTF-8 into native byte encoding. Unlike C, this over-writes the original string, and updates len to contain the new length. Returns zero on failure, setting C to -1. If you need a copy of the string, see C. =cut */ U8 * Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len) { U8 * const save = s; U8 * const send = s + *len; U8 *d; PERL_ARGS_ASSERT_UTF8_TO_BYTES; /* ensure valid UTF-8 and chars < 256 before updating string */ while (s < send) { U8 c = *s++; if (!UTF8_IS_INVARIANT(c) && (!UTF8_IS_DOWNGRADEABLE_START(c) || (s >= send) || !(c = *s++) || !UTF8_IS_CONTINUATION(c))) { *len = ((STRLEN) -1); return 0; } } d = s = save; while (s < send) { STRLEN ulen; *d++ = (U8)utf8_to_uvchr(s, &ulen); s += ulen; } *d = '\0'; *len = d - save; return save; } /* =for apidoc bytes_from_utf8 Converts a string C of length C from UTF-8 into native byte encoding. Unlike C but like C, returns a pointer to the newly-created string, and updates C to contain the new length. Returns the original string if no conversion occurs, C is unchanged. Do nothing if C points to 0. Sets C to 0 if C is converted or consisted entirely of characters that are invariant in utf8 (i.e., US-ASCII on non-EBCDIC machines). =cut */ U8 * Perl_bytes_from_utf8(pTHX_ const U8 *s, STRLEN *len, bool *is_utf8) { U8 *d; const U8 *start = s; const U8 *send; I32 count = 0; PERL_ARGS_ASSERT_BYTES_FROM_UTF8; PERL_UNUSED_CONTEXT; if (!*is_utf8) return (U8 *)start; /* ensure valid UTF-8 and chars < 256 before converting string */ for (send = s + *len; s < send;) { U8 c = *s++; if (!UTF8_IS_INVARIANT(c)) { if (UTF8_IS_DOWNGRADEABLE_START(c) && s < send && (c = *s++) && UTF8_IS_CONTINUATION(c)) count++; else return (U8 *)start; } } *is_utf8 = FALSE; Newx(d, (*len) - count + 1, U8); s = start; start = d; while (s < send) { U8 c = *s++; if (!UTF8_IS_INVARIANT(c)) { /* Then it is two-byte encoded */ c = UTF8_ACCUMULATE(NATIVE_TO_UTF(c), *s++); c = ASCII_TO_NATIVE(c); } *d++ = c; } *d = '\0'; *len = d - start; return (U8 *)start; } /* =for apidoc bytes_to_utf8 Converts a string C of length C from the native encoding into UTF-8. Returns a pointer to the newly-created string, and sets C to reflect the new length. A NUL character will be written after the end of the string. If you want to convert to UTF-8 from encodings other than the native (Latin1 or EBCDIC), see sv_recode_to_utf8(). =cut */ U8* Perl_bytes_to_utf8(pTHX_ const U8 *s, STRLEN *len) { const U8 * const send = s + (*len); U8 *d; U8 *dst; PERL_ARGS_ASSERT_BYTES_TO_UTF8; PERL_UNUSED_CONTEXT; Newx(d, (*len) * 2 + 1, U8); dst = d; while (s < send) { const UV uv = NATIVE_TO_ASCII(*s++); if (UNI_IS_INVARIANT(uv)) *d++ = (U8)UTF_TO_NATIVE(uv); else { *d++ = (U8)UTF8_EIGHT_BIT_HI(uv); *d++ = (U8)UTF8_EIGHT_BIT_LO(uv); } } *d = '\0'; *len = d-dst; return dst; } /* * Convert native (big-endian) or reversed (little-endian) UTF-16 to UTF-8. * * Destination must be pre-extended to 3/2 source. Do not use in-place. * We optimize for native, for obvious reasons. */ U8* Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen) { U8* pend; U8* dstart = d; PERL_ARGS_ASSERT_UTF16_TO_UTF8; if (bytelen & 1) 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 (uv < 0x80) { #ifdef EBCDIC *d++ = UNI_TO_NATIVE(uv); #else *d++ = (U8)uv; #endif continue; } if (uv < 0x800) { *d++ = (U8)(( uv >> 6) | 0xc0); *d++ = (U8)(( uv & 0x3f) | 0x80); continue; } if (uv >= 0xd800 && uv <= 0xdbff) { /* surrogates */ if (p >= pend) { Perl_croak(aTHX_ "Malformed UTF-16 surrogate"); } else { UV low = (p[0] << 8) + p[1]; p += 2; if (low < 0xdc00 || low > 0xdfff) Perl_croak(aTHX_ "Malformed UTF-16 surrogate"); uv = ((uv - 0xd800) << 10) + (low - 0xdc00) + 0x10000; } } else if (uv >= 0xdc00 && uv <= 0xdfff) { Perl_croak(aTHX_ "Malformed UTF-16 surrogate"); } if (uv < 0x10000) { *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; } } *newlen = d - dstart; return d; } /* Note: this one is slightly destructive of the source. */ U8* Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen) { U8* s = (U8*)p; U8* const send = s + bytelen; PERL_ARGS_ASSERT_UTF16_TO_UTF8_REVERSED; if (bytelen & 1) 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; } return utf16_to_utf8(p, d, bytelen, newlen); } /* for now these are all defined (inefficiently) in terms of the utf8 versions */ bool Perl_is_uni_alnum(pTHX_ UV c) { U8 tmpbuf[UTF8_MAXBYTES+1]; uvchr_to_utf8(tmpbuf, c); return is_utf8_alnum(tmpbuf); } bool Perl_is_uni_idfirst(pTHX_ UV c) { U8 tmpbuf[UTF8_MAXBYTES+1]; uvchr_to_utf8(tmpbuf, c); return is_utf8_idfirst(tmpbuf); } bool Perl_is_uni_alpha(pTHX_ UV c) { U8 tmpbuf[UTF8_MAXBYTES+1]; uvchr_to_utf8(tmpbuf, c); return is_utf8_alpha(tmpbuf); } bool Perl_is_uni_ascii(pTHX_ UV c) { U8 tmpbuf[UTF8_MAXBYTES+1]; uvchr_to_utf8(tmpbuf, c); return is_utf8_ascii(tmpbuf); } bool Perl_is_uni_space(pTHX_ UV c) { U8 tmpbuf[UTF8_MAXBYTES+1]; uvchr_to_utf8(tmpbuf, c); return is_utf8_space(tmpbuf); } bool Perl_is_uni_digit(pTHX_ UV c) { U8 tmpbuf[UTF8_MAXBYTES+1]; uvchr_to_utf8(tmpbuf, c); return is_utf8_digit(tmpbuf); } bool Perl_is_uni_upper(pTHX_ UV c) { U8 tmpbuf[UTF8_MAXBYTES+1]; uvchr_to_utf8(tmpbuf, c); return is_utf8_upper(tmpbuf); } bool Perl_is_uni_lower(pTHX_ UV c) { U8 tmpbuf[UTF8_MAXBYTES+1]; uvchr_to_utf8(tmpbuf, c); return is_utf8_lower(tmpbuf); } bool Perl_is_uni_cntrl(pTHX_ UV c) { U8 tmpbuf[UTF8_MAXBYTES+1]; uvchr_to_utf8(tmpbuf, c); return is_utf8_cntrl(tmpbuf); } bool Perl_is_uni_graph(pTHX_ UV c) { U8 tmpbuf[UTF8_MAXBYTES+1]; uvchr_to_utf8(tmpbuf, c); return is_utf8_graph(tmpbuf); } bool Perl_is_uni_print(pTHX_ UV c) { U8 tmpbuf[UTF8_MAXBYTES+1]; uvchr_to_utf8(tmpbuf, c); return is_utf8_print(tmpbuf); } bool Perl_is_uni_punct(pTHX_ UV c) { U8 tmpbuf[UTF8_MAXBYTES+1]; uvchr_to_utf8(tmpbuf, c); return is_utf8_punct(tmpbuf); } bool Perl_is_uni_xdigit(pTHX_ UV c) { U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; uvchr_to_utf8(tmpbuf, c); return is_utf8_xdigit(tmpbuf); } UV Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp) { PERL_ARGS_ASSERT_TO_UNI_UPPER; uvchr_to_utf8(p, c); return to_utf8_upper(p, p, lenp); } UV Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp) { PERL_ARGS_ASSERT_TO_UNI_TITLE; uvchr_to_utf8(p, c); return to_utf8_title(p, p, lenp); } UV Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp) { PERL_ARGS_ASSERT_TO_UNI_LOWER; uvchr_to_utf8(p, c); return to_utf8_lower(p, p, lenp); } UV Perl_to_uni_fold(pTHX_ UV c, U8* p, STRLEN *lenp) { PERL_ARGS_ASSERT_TO_UNI_FOLD; uvchr_to_utf8(p, c); return to_utf8_fold(p, p, lenp); } /* for now these all assume no locale info available for Unicode > 255 */ bool Perl_is_uni_alnum_lc(pTHX_ UV c) { return is_uni_alnum(c); /* XXX no locale support yet */ } bool Perl_is_uni_idfirst_lc(pTHX_ UV c) { return is_uni_idfirst(c); /* XXX no locale support yet */ } bool Perl_is_uni_alpha_lc(pTHX_ UV c) { return is_uni_alpha(c); /* XXX no locale support yet */ } bool Perl_is_uni_ascii_lc(pTHX_ UV c) { return is_uni_ascii(c); /* XXX no locale support yet */ } bool Perl_is_uni_space_lc(pTHX_ UV c) { return is_uni_space(c); /* XXX no locale support yet */ } bool Perl_is_uni_digit_lc(pTHX_ UV c) { return is_uni_digit(c); /* XXX no locale support yet */ } bool Perl_is_uni_upper_lc(pTHX_ UV c) { return is_uni_upper(c); /* XXX no locale support yet */ } bool Perl_is_uni_lower_lc(pTHX_ UV c) { return is_uni_lower(c); /* XXX no locale support yet */ } bool Perl_is_uni_cntrl_lc(pTHX_ UV c) { return is_uni_cntrl(c); /* XXX no locale support yet */ } bool Perl_is_uni_graph_lc(pTHX_ UV c) { return is_uni_graph(c); /* XXX no locale support yet */ } bool Perl_is_uni_print_lc(pTHX_ UV c) { return is_uni_print(c); /* XXX no locale support yet */ } bool Perl_is_uni_punct_lc(pTHX_ UV c) { return is_uni_punct(c); /* XXX no locale support yet */ } bool Perl_is_uni_xdigit_lc(pTHX_ UV c) { return is_uni_xdigit(c); /* XXX no locale support yet */ } U32 Perl_to_uni_upper_lc(pTHX_ U32 c) { /* XXX returns only the first character -- do not use XXX */ /* XXX no locale support yet */ STRLEN len; U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; return (U32)to_uni_upper(c, tmpbuf, &len); } U32 Perl_to_uni_title_lc(pTHX_ U32 c) { /* XXX returns only the first character XXX -- do not use XXX */ /* XXX no locale support yet */ STRLEN len; U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; return (U32)to_uni_title(c, tmpbuf, &len); } U32 Perl_to_uni_lower_lc(pTHX_ U32 c) { /* XXX returns only the first character -- do not use XXX */ /* XXX no locale support yet */ STRLEN len; U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; return (U32)to_uni_lower(c, tmpbuf, &len); } static bool S_is_utf8_common(pTHX_ const U8 *const p, SV **swash, const char *const swashname) { dVAR; PERL_ARGS_ASSERT_IS_UTF8_COMMON; if (!is_utf8_char(p)) return FALSE; if (!*swash) *swash = swash_init("utf8", swashname, &PL_sv_undef, 1, 0); return swash_fetch(*swash, p, TRUE) != 0; } bool Perl_is_utf8_alnum(pTHX_ const U8 *p) { dVAR; PERL_ARGS_ASSERT_IS_UTF8_ALNUM; /* NOTE: "IsWord", not "IsAlnum", since Alnum is a true * descendant of isalnum(3), in other words, it doesn't * contain the '_'. --jhi */ return is_utf8_common(p, &PL_utf8_alnum, "IsWord"); } bool Perl_is_utf8_idfirst(pTHX_ const U8 *p) /* The naming is historical. */ { dVAR; PERL_ARGS_ASSERT_IS_UTF8_IDFIRST; if (*p == '_') return TRUE; /* is_utf8_idstart would be more logical. */ return is_utf8_common(p, &PL_utf8_idstart, "IdStart"); } bool Perl_is_utf8_idcont(pTHX_ const U8 *p) { dVAR; PERL_ARGS_ASSERT_IS_UTF8_IDCONT; if (*p == '_') return TRUE; return is_utf8_common(p, &PL_utf8_idcont, "IdContinue"); } bool Perl_is_utf8_alpha(pTHX_ const U8 *p) { dVAR; PERL_ARGS_ASSERT_IS_UTF8_ALPHA; return is_utf8_common(p, &PL_utf8_alpha, "IsAlpha"); } bool Perl_is_utf8_ascii(pTHX_ const U8 *p) { dVAR; PERL_ARGS_ASSERT_IS_UTF8_ASCII; return is_utf8_common(p, &PL_utf8_ascii, "IsAscii"); } bool Perl_is_utf8_space(pTHX_ const U8 *p) { dVAR; PERL_ARGS_ASSERT_IS_UTF8_SPACE; return is_utf8_common(p, &PL_utf8_space, "IsSpacePerl"); } bool Perl_is_utf8_perl_space(pTHX_ const U8 *p) { dVAR; PERL_ARGS_ASSERT_IS_UTF8_PERL_SPACE; return is_utf8_common(p, &PL_utf8_perl_space, "IsPerlSpace"); } bool Perl_is_utf8_perl_word(pTHX_ const U8 *p) { dVAR; PERL_ARGS_ASSERT_IS_UTF8_PERL_WORD; return is_utf8_common(p, &PL_utf8_perl_word, "IsPerlWord"); } bool Perl_is_utf8_digit(pTHX_ const U8 *p) { dVAR; PERL_ARGS_ASSERT_IS_UTF8_DIGIT; return is_utf8_common(p, &PL_utf8_digit, "IsDigit"); } bool Perl_is_utf8_posix_digit(pTHX_ const U8 *p) { dVAR; PERL_ARGS_ASSERT_IS_UTF8_POSIX_DIGIT; return is_utf8_common(p, &PL_utf8_posix_digit, "IsPosixDigit"); } bool Perl_is_utf8_upper(pTHX_ const U8 *p) { dVAR; PERL_ARGS_ASSERT_IS_UTF8_UPPER; return is_utf8_common(p, &PL_utf8_upper, "IsUppercase"); } bool Perl_is_utf8_lower(pTHX_ const U8 *p) { dVAR; PERL_ARGS_ASSERT_IS_UTF8_LOWER; return is_utf8_common(p, &PL_utf8_lower, "IsLowercase"); } bool Perl_is_utf8_cntrl(pTHX_ const U8 *p) { dVAR; PERL_ARGS_ASSERT_IS_UTF8_CNTRL; return is_utf8_common(p, &PL_utf8_cntrl, "IsCntrl"); } bool Perl_is_utf8_graph(pTHX_ const U8 *p) { dVAR; PERL_ARGS_ASSERT_IS_UTF8_GRAPH; return is_utf8_common(p, &PL_utf8_graph, "IsGraph"); } bool Perl_is_utf8_print(pTHX_ const U8 *p) { dVAR; PERL_ARGS_ASSERT_IS_UTF8_PRINT; return is_utf8_common(p, &PL_utf8_print, "IsPrint"); } bool Perl_is_utf8_punct(pTHX_ const U8 *p) { dVAR; PERL_ARGS_ASSERT_IS_UTF8_PUNCT; return is_utf8_common(p, &PL_utf8_punct, "IsPunct"); } bool Perl_is_utf8_xdigit(pTHX_ const U8 *p) { dVAR; PERL_ARGS_ASSERT_IS_UTF8_XDIGIT; return is_utf8_common(p, &PL_utf8_xdigit, "IsXDigit"); } bool Perl_is_utf8_mark(pTHX_ const U8 *p) { dVAR; PERL_ARGS_ASSERT_IS_UTF8_MARK; return is_utf8_common(p, &PL_utf8_mark, "IsM"); } bool Perl_is_utf8_X_begin(pTHX_ const U8 *p) { dVAR; PERL_ARGS_ASSERT_IS_UTF8_X_BEGIN; return is_utf8_common(p, &PL_utf8_X_begin, "_X_Begin"); } bool Perl_is_utf8_X_extend(pTHX_ const U8 *p) { dVAR; PERL_ARGS_ASSERT_IS_UTF8_X_EXTEND; return is_utf8_common(p, &PL_utf8_X_extend, "_X_Extend"); } bool Perl_is_utf8_X_prepend(pTHX_ const U8 *p) { dVAR; PERL_ARGS_ASSERT_IS_UTF8_X_PREPEND; return is_utf8_common(p, &PL_utf8_X_prepend, "GCB=Prepend"); } bool Perl_is_utf8_X_non_hangul(pTHX_ const U8 *p) { dVAR; PERL_ARGS_ASSERT_IS_UTF8_X_NON_HANGUL; return is_utf8_common(p, &PL_utf8_X_non_hangul, "HST=Not_Applicable"); } bool Perl_is_utf8_X_L(pTHX_ const U8 *p) { dVAR; PERL_ARGS_ASSERT_IS_UTF8_X_L; return is_utf8_common(p, &PL_utf8_X_L, "GCB=L"); } bool Perl_is_utf8_X_LV(pTHX_ const U8 *p) { dVAR; PERL_ARGS_ASSERT_IS_UTF8_X_LV; return is_utf8_common(p, &PL_utf8_X_LV, "GCB=LV"); } bool Perl_is_utf8_X_LVT(pTHX_ const U8 *p) { dVAR; PERL_ARGS_ASSERT_IS_UTF8_X_LVT; return is_utf8_common(p, &PL_utf8_X_LVT, "GCB=LVT"); } bool Perl_is_utf8_X_T(pTHX_ const U8 *p) { dVAR; PERL_ARGS_ASSERT_IS_UTF8_X_T; return is_utf8_common(p, &PL_utf8_X_T, "GCB=T"); } bool Perl_is_utf8_X_V(pTHX_ const U8 *p) { dVAR; PERL_ARGS_ASSERT_IS_UTF8_X_V; return is_utf8_common(p, &PL_utf8_X_V, "GCB=V"); } bool Perl_is_utf8_X_LV_LVT_V(pTHX_ const U8 *p) { dVAR; PERL_ARGS_ASSERT_IS_UTF8_X_LV_LVT_V; return is_utf8_common(p, &PL_utf8_X_LV_LVT_V, "_X_LV_LVT_V"); } /* =for apidoc to_utf8_case The "p" contains the pointer to the UTF-8 string encoding the character that is being converted. The "ustrp" is a pointer to the character buffer to put the conversion result to. The "lenp" is a pointer to the length of the result. The "swashp" is a pointer to the swash to use. Both the special and normal mappings are stored lib/unicore/To/Foo.pl, and loaded by SWASHNEW, using lib/utf8_heavy.pl. The special (usually, but not always, a multicharacter mapping), is tried first. The "special" is a string like "utf8::ToSpecLower", which means the hash %utf8::ToSpecLower. The access to the hash is through Perl_to_utf8_case(). The "normal" is a string like "ToLower" which means the swash %utf8::ToLower. =cut */ UV Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp, const char *normal, const char *special) { dVAR; U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; STRLEN len = 0; const UV uv0 = utf8_to_uvchr(p, NULL); /* The NATIVE_TO_UNI() and UNI_TO_NATIVE() mappings * are necessary in EBCDIC, they are redundant no-ops * in ASCII-ish platforms, and hopefully optimized away. */ const UV uv1 = NATIVE_TO_UNI(uv0); PERL_ARGS_ASSERT_TO_UTF8_CASE; uvuni_to_utf8(tmpbuf, uv1); if (!*swashp) /* load on-demand */ *swashp = swash_init("utf8", normal, &PL_sv_undef, 4, 0); /* This is the beginnings of a skeleton of code to read the info section * that is in all the swashes in case we ever want to do that, so one can * read things whose maps aren't code points, and whose default if missing * is not to the code point itself. This was just to see if it actually * worked. Details on what the possibilities are are in perluniprops.pod HV * const hv = get_hv("utf8::SwashInfo", 0); if (hv) { SV **svp; svp = hv_fetch(hv, (const char*)normal, strlen(normal), FALSE); const char *s; HV * const this_hash = SvRV(*svp); svp = hv_fetch(this_hash, "type", strlen("type"), FALSE); s = SvPV_const(*svp, len); } }*/ /* The 0xDF is the only special casing Unicode code point below 0x100. */ if (special && (uv1 == 0xDF || uv1 > 0xFF)) { /* It might be "special" (sometimes, but not always, * a multicharacter mapping) */ HV * const hv = get_hv(special, 0); SV **svp; if (hv && (svp = hv_fetch(hv, (const char*)tmpbuf, UNISKIP(uv1), FALSE)) && (*svp)) { const char *s; s = SvPV_const(*svp, len); if (len == 1) len = uvuni_to_utf8(ustrp, NATIVE_TO_UNI(*(U8*)s)) - ustrp; else { #ifdef EBCDIC /* If we have EBCDIC we need to remap the characters * since any characters in the low 256 are Unicode * code points, not EBCDIC. */ U8 *t = (U8*)s, *tend = t + len, *d; d = tmpbuf; if (SvUTF8(*svp)) { STRLEN tlen = 0; while (t < tend) { const UV c = utf8_to_uvchr(t, &tlen); if (tlen > 0) { d = uvchr_to_utf8(d, UNI_TO_NATIVE(c)); t += tlen; } else break; } } else { while (t < tend) { d = uvchr_to_utf8(d, UNI_TO_NATIVE(*t)); t++; } } len = d - tmpbuf; Copy(tmpbuf, ustrp, len, U8); #else Copy(s, ustrp, len, U8); #endif } } } if (!len && *swashp) { const UV uv2 = swash_fetch(*swashp, tmpbuf, TRUE); if (uv2) { /* It was "normal" (a single character mapping). */ const UV uv3 = UNI_TO_NATIVE(uv2); len = uvchr_to_utf8(ustrp, uv3) - ustrp; } } if (!len) /* Neither: just copy. In other words, there was no mapping defined, which means that the code point maps to itself */ len = uvchr_to_utf8(ustrp, uv0) - ustrp; if (lenp) *lenp = len; return len ? utf8_to_uvchr(ustrp, 0) : 0; } /* =for apidoc to_utf8_upper Convert the UTF-8 encoded character at p to its uppercase version and store that in UTF-8 in ustrp and its length in bytes in lenp. Note that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the uppercase version may be longer than the original character. The first character of the uppercased version is returned (but note, as explained above, that there may be more.) =cut */ UV Perl_to_utf8_upper(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp) { dVAR; PERL_ARGS_ASSERT_TO_UTF8_UPPER; return Perl_to_utf8_case(aTHX_ p, ustrp, lenp, &PL_utf8_toupper, "ToUpper", "utf8::ToSpecUpper"); } /* =for apidoc to_utf8_title Convert the UTF-8 encoded character at p to its titlecase version and store that in UTF-8 in ustrp and its length in bytes in lenp. Note that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the titlecase version may be longer than the original character. The first character of the titlecased version is returned (but note, as explained above, that there may be more.) =cut */ UV Perl_to_utf8_title(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp) { dVAR; PERL_ARGS_ASSERT_TO_UTF8_TITLE; return Perl_to_utf8_case(aTHX_ p, ustrp, lenp, &PL_utf8_totitle, "ToTitle", "utf8::ToSpecTitle"); } /* =for apidoc to_utf8_lower Convert the UTF-8 encoded character at p to its lowercase version and store that in UTF-8 in ustrp and its length in bytes in lenp. Note that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the lowercase version may be longer than the original character. The first character of the lowercased version is returned (but note, as explained above, that there may be more.) =cut */ UV Perl_to_utf8_lower(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp) { dVAR; PERL_ARGS_ASSERT_TO_UTF8_LOWER; return Perl_to_utf8_case(aTHX_ p, ustrp, lenp, &PL_utf8_tolower, "ToLower", "utf8::ToSpecLower"); } /* =for apidoc to_utf8_fold Convert the UTF-8 encoded character at p to its foldcase version and store that in UTF-8 in ustrp and its length in bytes in lenp. Note that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the foldcase version may be longer than the original character (up to three characters). The first character of the foldcased version is returned (but note, as explained above, that there may be more.) =cut */ UV Perl_to_utf8_fold(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp) { dVAR; PERL_ARGS_ASSERT_TO_UTF8_FOLD; return Perl_to_utf8_case(aTHX_ p, ustrp, lenp, &PL_utf8_tofold, "ToFold", "utf8::ToSpecFold"); } /* Note: * A "swash" is a swatch hash. * A "swatch" is a bit vector generated by utf8.c:S_swash_get(). * C is a pointer to a package name for SWASHNEW, should be "utf8". * For other parameters, see utf8::SWASHNEW in lib/utf8_heavy.pl. */ SV* Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none) { dVAR; SV* retval; dSP; const size_t pkg_len = strlen(pkg); const size_t name_len = strlen(name); HV * const stash = gv_stashpvn(pkg, pkg_len, 0); SV* errsv_save; PERL_ARGS_ASSERT_SWASH_INIT; PUSHSTACKi(PERLSI_MAGIC); ENTER; SAVEHINTS(); save_re_context(); if (!gv_fetchmeth(stash, "SWASHNEW", 8, -1)) { /* demand load utf8 */ ENTER; errsv_save = newSVsv(ERRSV); /* It is assumed that callers of this routine are not passing in any user derived data. */ /* Need to do this after save_re_context() as it will set PL_tainted to 1 while saving $1 etc (see the code after getrx: in Perl_magic_get). Even line to create errsv_save can turn on PL_tainted. */ SAVEBOOL(PL_tainted); PL_tainted = 0; Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn(pkg,pkg_len), NULL); if (!SvTRUE(ERRSV)) sv_setsv(ERRSV, errsv_save); SvREFCNT_dec(errsv_save); LEAVE; } SPAGAIN; PUSHMARK(SP); EXTEND(SP,5); mPUSHp(pkg, pkg_len); mPUSHp(name, name_len); PUSHs(listsv); mPUSHi(minbits); mPUSHi(none); PUTBACK; errsv_save = newSVsv(ERRSV); if (call_method("SWASHNEW", G_SCALAR)) retval = newSVsv(*PL_stack_sp--); else retval = &PL_sv_undef; if (!SvTRUE(ERRSV)) sv_setsv(ERRSV, errsv_save); SvREFCNT_dec(errsv_save); LEAVE; POPSTACK; if (IN_PERL_COMPILETIME) { CopHINTS_set(PL_curcop, PL_hints); } if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV) { if (SvPOK(retval)) Perl_croak(aTHX_ "Can't find Unicode property definition \"%"SVf"\"", SVfARG(retval)); Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref"); } return retval; } /* This API is wrong for special case conversions since we may need to * return several Unicode characters for a single Unicode character * (see lib/unicore/SpecCase.txt) The SWASHGET in lib/utf8_heavy.pl is * the lower-level routine, and it is similarly broken for returning * multiple values. --jhi */ /* Now SWASHGET is recasted into S_swash_get in this file. */ /* Note: * Returns the value of property/mapping C for the first character * of the string C. If C is true, the string C is * assumed to be in utf8. If C is false, the string C is * assumed to be in native 8-bit encoding. Caches the swatch in C. */ UV Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8) { dVAR; HV *const hv = MUTABLE_HV(SvRV(swash)); U32 klen; U32 off; STRLEN slen; STRLEN needents; const U8 *tmps = NULL; U32 bit; SV *swatch; U8 tmputf8[2]; const UV c = NATIVE_TO_ASCII(*ptr); PERL_ARGS_ASSERT_SWASH_FETCH; if (!do_utf8 && !UNI_IS_INVARIANT(c)) { tmputf8[0] = (U8)UTF8_EIGHT_BIT_HI(c); tmputf8[1] = (U8)UTF8_EIGHT_BIT_LO(c); ptr = tmputf8; } /* Given a UTF-X encoded char 0xAA..0xYY,0xZZ * then the "swatch" is a vec() for all the chars which start * with 0xAA..0xYY * So the key in the hash (klen) is length of encoded char -1 */ klen = UTF8SKIP(ptr) - 1; off = ptr[klen]; if (klen == 0) { /* If char is invariant then swatch is for all the invariant chars * In both UTF-8 and UTF-8-MOD that happens to be UTF_CONTINUATION_MARK */ needents = UTF_CONTINUATION_MARK; off = NATIVE_TO_UTF(ptr[klen]); } else { /* If char is encoded then swatch is for the prefix */ needents = (1 << UTF_ACCUMULATION_SHIFT); off = NATIVE_TO_UTF(ptr[klen]) & UTF_CONTINUATION_MASK; } /* * This single-entry cache saves about 1/3 of the utf8 overhead in test * suite. (That is, only 7-8% overall over just a hash cache. Still, * it's nothing to sniff at.) Pity we usually come through at least * two function calls to get here... * * NB: this code assumes that swatches are never modified, once generated! */ if (hv == PL_last_swash_hv && klen == PL_last_swash_klen && (!klen || memEQ((char *)ptr, (char *)PL_last_swash_key, klen)) ) { tmps = PL_last_swash_tmps; slen = PL_last_swash_slen; } else { /* Try our second-level swatch cache, kept in a hash. */ SV** svp = hv_fetch(hv, (const char*)ptr, klen, FALSE); /* If not cached, generate it via swash_get */ if (!svp || !SvPOK(*svp) || !(tmps = (const U8*)SvPV_const(*svp, slen))) { /* We use utf8n_to_uvuni() as we want an index into Unicode tables, not a native character number. */ const UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXBYTES, 0, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY); swatch = swash_get(swash, /* On EBCDIC & ~(0xA0-1) isn't a useful thing to do */ (klen) ? (code_point & ~(needents - 1)) : 0, needents); if (IN_PERL_COMPILETIME) CopHINTS_set(PL_curcop, PL_hints); svp = hv_store(hv, (const char *)ptr, klen, swatch, 0); if (!svp || !(tmps = (U8*)SvPV(*svp, slen)) || (slen << 3) < needents) Perl_croak(aTHX_ "panic: swash_fetch got improper swatch"); } PL_last_swash_hv = hv; assert(klen <= sizeof(PL_last_swash_key)); PL_last_swash_klen = (U8)klen; /* FIXME change interpvar.h? */ PL_last_swash_tmps = (U8 *) tmps; PL_last_swash_slen = slen; if (klen) Copy(ptr, PL_last_swash_key, klen, U8); } switch ((int)((slen << 3) / needents)) { case 1: bit = 1 << (off & 7); off >>= 3; return (tmps[off] & bit) != 0; case 8: return tmps[off]; case 16: off <<= 1; return (tmps[off] << 8) + tmps[off + 1] ; case 32: off <<= 2; return (tmps[off] << 24) + (tmps[off+1] << 16) + (tmps[off+2] << 8) + tmps[off + 3] ; } Perl_croak(aTHX_ "panic: swash_fetch got swatch of unexpected bit width"); NORETURN_FUNCTION_END; } /* Note: * Returns a swatch (a bit vector string) for a code point sequence * that starts from the value C and comprises the number C. * A C must be an object created by SWASHNEW (see lib/utf8_heavy.pl). * Should be used via swash_fetch, which will cache the swatch in C. */ STATIC SV* S_swash_get(pTHX_ SV* swash, UV start, UV span) { SV *swatch; U8 *l, *lend, *x, *xend, *s; STRLEN lcur, xcur, scur; HV *const hv = MUTABLE_HV(SvRV(swash)); SV** const listsvp = hv_fetchs(hv, "LIST", FALSE); SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE); SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE); SV** const nonesvp = hv_fetchs(hv, "NONE", FALSE); SV** const extssvp = hv_fetchs(hv, "EXTRAS", FALSE); const U8* const typestr = (U8*)SvPV_nolen(*typesvp); const int typeto = typestr[0] == 'T' && typestr[1] == 'o'; const STRLEN bits = SvUV(*bitssvp); const STRLEN octets = bits >> 3; /* if bits == 1, then octets == 0 */ const UV none = SvUV(*nonesvp); const UV end = start + span; PERL_ARGS_ASSERT_SWASH_GET; if (bits != 1 && bits != 8 && bits != 16 && bits != 32) { Perl_croak(aTHX_ "panic: swash_get doesn't expect bits %"UVuf, (UV)bits); } /* create and initialize $swatch */ scur = octets ? (span * octets) : (span + 7) / 8; swatch = newSV(scur); SvPOK_on(swatch); s = (U8*)SvPVX(swatch); if (octets && none) { const U8* const e = s + scur; while (s < e) { if (bits == 8) *s++ = (U8)(none & 0xff); else if (bits == 16) { *s++ = (U8)((none >> 8) & 0xff); *s++ = (U8)( none & 0xff); } else if (bits == 32) { *s++ = (U8)((none >> 24) & 0xff); *s++ = (U8)((none >> 16) & 0xff); *s++ = (U8)((none >> 8) & 0xff); *s++ = (U8)( none & 0xff); } } *s = '\0'; } else { (void)memzero((U8*)s, scur + 1); } SvCUR_set(swatch, scur); s = (U8*)SvPVX(swatch); /* read $swash->{LIST} */ l = (U8*)SvPV(*listsvp, lcur); lend = l + lcur; while (l < lend) { UV min, max, val; STRLEN numlen; I32 flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX; U8* const nl = (U8*)memchr(l, '\n', lend - l); numlen = lend - l; min = grok_hex((char *)l, &numlen, &flags, NULL); if (numlen) l += numlen; else if (nl) { l = nl + 1; /* 1 is length of "\n" */ continue; } else { l = lend; /* to LIST's end at which \n is not found */ break; } if (isBLANK(*l)) { ++l; flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX; numlen = lend - l; max = grok_hex((char *)l, &numlen, &flags, NULL); if (numlen) l += numlen; else max = min; if (octets) { if (isBLANK(*l)) { ++l; flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX; numlen = lend - l; val = grok_hex((char *)l, &numlen, &flags, NULL); if (numlen) l += numlen; else val = 0; } else { val = 0; if (typeto) { Perl_croak(aTHX_ "%s: illegal mapping '%s'", typestr, l); } } } else val = 0; /* bits == 1, then val should be ignored */ } else { max = min; if (octets) { val = 0; if (typeto) { Perl_croak(aTHX_ "%s: illegal mapping '%s'", typestr, l); } } else val = 0; /* bits == 1, then val should be ignored */ } if (nl) l = nl + 1; else l = lend; if (max < start) continue; if (octets) { UV key; if (min < start) { if (!none || val < none) { val += start - min; } min = start; } for (key = min; key <= max; key++) { STRLEN offset; if (key >= end) goto go_out_list; /* offset must be non-negative (start <= min <= key < end) */ offset = octets * (key - start); if (bits == 8) s[offset] = (U8)(val & 0xff); else if (bits == 16) { s[offset ] = (U8)((val >> 8) & 0xff); s[offset + 1] = (U8)( val & 0xff); } else if (bits == 32) { s[offset ] = (U8)((val >> 24) & 0xff); s[offset + 1] = (U8)((val >> 16) & 0xff); s[offset + 2] = (U8)((val >> 8) & 0xff); s[offset + 3] = (U8)( val & 0xff); } if (!none || val < none) ++val; } } else { /* bits == 1, then val should be ignored */ UV key; if (min < start) min = start; for (key = min; key <= max; key++) { const STRLEN offset = (STRLEN)(key - start); if (key >= end) goto go_out_list; s[offset >> 3] |= 1 << (offset & 7); } } } /* while */ go_out_list: /* read $swash->{EXTRAS} */ x = (U8*)SvPV(*extssvp, xcur); xend = x + xcur; while (x < xend) { STRLEN namelen; U8 *namestr; SV** othersvp; HV* otherhv; STRLEN otherbits; SV **otherbitssvp, *other; U8 *s, *o, *nl; STRLEN slen, olen; const U8 opc = *x++; if (opc == '\n') continue; nl = (U8*)memchr(x, '\n', xend - x); if (opc != '-' && opc != '+' && opc != '!' && opc != '&') { if (nl) { x = nl + 1; /* 1 is length of "\n" */ continue; } else { x = xend; /* to EXTRAS' end at which \n is not found */ break; } } namestr = x; if (nl) { namelen = nl - namestr; x = nl + 1; } else { namelen = xend - namestr; x = xend; } othersvp = hv_fetch(hv, (char *)namestr, namelen, FALSE); otherhv = MUTABLE_HV(SvRV(*othersvp)); otherbitssvp = hv_fetchs(otherhv, "BITS", FALSE); otherbits = (STRLEN)SvUV(*otherbitssvp); if (bits < otherbits) Perl_croak(aTHX_ "panic: swash_get found swatch size mismatch"); /* The "other" swatch must be destroyed after. */ other = swash_get(*othersvp, start, span); o = (U8*)SvPV(other, olen); if (!olen) Perl_croak(aTHX_ "panic: swash_get got improper swatch"); s = (U8*)SvPV(swatch, slen); if (bits == 1 && otherbits == 1) { if (slen != olen) Perl_croak(aTHX_ "panic: swash_get found swatch length mismatch"); switch (opc) { case '+': while (slen--) *s++ |= *o++; break; case '!': while (slen--) *s++ |= ~*o++; break; case '-': while (slen--) *s++ &= ~*o++; break; case '&': while (slen--) *s++ &= *o++; break; default: break; } } else { STRLEN otheroctets = otherbits >> 3; STRLEN offset = 0; U8* const send = s + slen; while (s < send) { UV otherval = 0; if (otherbits == 1) { otherval = (o[offset >> 3] >> (offset & 7)) & 1; ++offset; } else { STRLEN vlen = otheroctets; otherval = *o++; while (--vlen) { otherval <<= 8; otherval |= *o++; } } if (opc == '+' && otherval) NOOP; /* replace with otherval */ else if (opc == '!' && !otherval) otherval = 1; else if (opc == '-' && otherval) otherval = 0; else if (opc == '&' && !otherval) otherval = 0; else { s += octets; /* no replacement */ continue; } if (bits == 8) *s++ = (U8)( otherval & 0xff); else if (bits == 16) { *s++ = (U8)((otherval >> 8) & 0xff); *s++ = (U8)( otherval & 0xff); } else if (bits == 32) { *s++ = (U8)((otherval >> 24) & 0xff); *s++ = (U8)((otherval >> 16) & 0xff); *s++ = (U8)((otherval >> 8) & 0xff); *s++ = (U8)( otherval & 0xff); } } } sv_free(other); /* through with it! */ } /* while */ return swatch; } /* =for apidoc uvchr_to_utf8 Adds the UTF-8 representation of the Native codepoint C to the end of the string C; C should be have at least C free bytes available. The return value is the pointer to the byte after the end of the new character. In other words, d = uvchr_to_utf8(d, uv); is the recommended wide native character-aware way of saying *(d++) = uv; =cut */ /* On ASCII machines this is normally a macro but we want a real function in case XS code wants it */ U8 * Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv) { PERL_ARGS_ASSERT_UVCHR_TO_UTF8; return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0); } U8 * Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags) { PERL_ARGS_ASSERT_UVCHR_TO_UTF8_FLAGS; return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), flags); } /* =for apidoc utf8n_to_uvchr flags Returns the native character value of the first character in the string C which is assumed to be in UTF-8 encoding; C will be set to the length, in bytes, of that character. Allows length and flags to be passed to low level routine. =cut */ /* On ASCII machines this is normally a macro but we want a real function in case XS code wants it */ UV Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags) { const UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags); PERL_ARGS_ASSERT_UTF8N_TO_UVCHR; return UNI_TO_NATIVE(uv); } /* =for apidoc pv_uni_display Build to the scalar dsv a displayable version of the string spv, length len, the displayable version being at most pvlim bytes long (if longer, the rest is truncated and "..." will be appended). The flags argument can have UNI_DISPLAY_ISPRINT set to display isPRINT()able characters as themselves, UNI_DISPLAY_BACKSLASH to display the \\[nrfta\\] as the backslashed versions (like '\n') (UNI_DISPLAY_BACKSLASH is preferred over UNI_DISPLAY_ISPRINT for \\). UNI_DISPLAY_QQ (and its alias UNI_DISPLAY_REGEX) have both UNI_DISPLAY_BACKSLASH and UNI_DISPLAY_ISPRINT turned on. The pointer to the PV of the dsv is returned. =cut */ char * Perl_pv_uni_display(pTHX_ SV *dsv, const U8 *spv, STRLEN len, STRLEN pvlim, UV flags) { int truncated = 0; const char *s, *e; PERL_ARGS_ASSERT_PV_UNI_DISPLAY; sv_setpvs(dsv, ""); SvUTF8_off(dsv); for (s = (const char *)spv, e = s + len; s < e; s += UTF8SKIP(s)) { UV u; /* This serves double duty as a flag and a character to print after a \ when flags & UNI_DISPLAY_BACKSLASH is true. */ char ok = 0; if (pvlim && SvCUR(dsv) >= pvlim) { truncated++; break; } u = utf8_to_uvchr((U8*)s, 0); if (u < 256) { const unsigned char c = (unsigned char)u & 0xFF; if (flags & UNI_DISPLAY_BACKSLASH) { switch (c) { case '\n': ok = 'n'; break; case '\r': ok = 'r'; break; case '\t': ok = 't'; break; case '\f': ok = 'f'; break; case '\a': ok = 'a'; break; case '\\': ok = '\\'; break; default: break; } if (ok) { const char string = ok; sv_catpvs(dsv, "\\"); sv_catpvn(dsv, &string, 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); } if (truncated) sv_catpvs(dsv, "..."); return SvPVX(dsv); } /* =for apidoc sv_uni_display Build to the scalar dsv a displayable version of the scalar sv, the displayable version being at most pvlim bytes long (if longer, the rest is truncated and "..." will be appended). The flags argument is as in pv_uni_display(). The pointer to the PV of the dsv is returned. =cut */ char * 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*)SvPVX_const(ssv), SvCUR(ssv), pvlim, flags); } /* =for apidoc ibcmp_utf8 Return true if the strings s1 and s2 differ case-insensitively, false if not (if they are equal case-insensitively). If u1 is true, the string s1 is assumed to be in UTF-8-encoded Unicode. If u2 is true, the string s2 is assumed to be in UTF-8-encoded Unicode. If u1 or u2 are false, the respective string is assumed to be in native 8-bit encoding. If the pe1 and pe2 are non-NULL, the scanning pointers will be copied in there (they will point at the beginning of the I character). If the pointers behind pe1 or pe2 are non-NULL, they are the end pointers beyond which scanning will not continue under any circumstances. If the byte lengths l1 and l2 are non-zero, s1+l1 and s2+l2 will be used as goal end pointers that will also stop the scan, and which qualify towards defining a successful match: all the scans that define an explicit length must reach their goal pointers for a match to succeed). For case-insensitiveness, the "casefolding" of Unicode is used instead of upper/lowercasing both the characters, see http://www.unicode.org/unicode/reports/tr21/ (Case Mappings). =cut */ I32 Perl_ibcmp_utf8(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const char *s2, char **pe2, register UV l2, bool u2) { dVAR; register const U8 *p1 = (const U8*)s1; register const U8 *p2 = (const U8*)s2; register const U8 *f1 = NULL; register const U8 *f2 = NULL; register U8 *e1 = NULL; register U8 *q1 = NULL; register U8 *e2 = NULL; register U8 *q2 = NULL; STRLEN n1 = 0, n2 = 0; U8 foldbuf1[UTF8_MAXBYTES_CASE+1]; U8 foldbuf2[UTF8_MAXBYTES_CASE+1]; U8 natbuf[1+1]; STRLEN foldlen1, foldlen2; bool match; PERL_ARGS_ASSERT_IBCMP_UTF8; if (pe1) e1 = *(U8**)pe1; /* assert(e1 || l1); */ if (e1 == 0 || (l1 && l1 < (UV)(e1 - (const U8*)s1))) f1 = (const U8*)s1 + l1; if (pe2) e2 = *(U8**)pe2; /* assert(e2 || l2); */ if (e2 == 0 || (l2 && l2 < (UV)(e2 - (const U8*)s2))) f2 = (const U8*)s2 + l2; /* This shouldn't happen. However, putting an assert() there makes some * tests fail. */ /* assert((e1 == 0 && f1 == 0) || (e2 == 0 && f2 == 0) || (f1 == 0 && f2 == 0)); */ if ((e1 == 0 && f1 == 0) || (e2 == 0 && f2 == 0) || (f1 == 0 && f2 == 0)) return 1; /* mismatch; possible infinite loop or false positive */ if (!u1 || !u2) natbuf[1] = 0; /* Need to terminate the buffer. */ while ((e1 == 0 || p1 < e1) && (f1 == 0 || p1 < f1) && (e2 == 0 || p2 < e2) && (f2 == 0 || p2 < f2)) { if (n1 == 0) { if (u1) to_utf8_fold(p1, foldbuf1, &foldlen1); else { uvuni_to_utf8(natbuf, (UV) NATIVE_TO_UNI(((UV)*p1))); to_utf8_fold(natbuf, foldbuf1, &foldlen1); } q1 = foldbuf1; n1 = foldlen1; } if (n2 == 0) { if (u2) to_utf8_fold(p2, foldbuf2, &foldlen2); else { uvuni_to_utf8(natbuf, (UV) NATIVE_TO_UNI(((UV)*p2))); to_utf8_fold(natbuf, foldbuf2, &foldlen2); } q2 = foldbuf2; n2 = foldlen2; } while (n1 && n2) { if ( UTF8SKIP(q1) != UTF8SKIP(q2) || (UTF8SKIP(q1) == 1 && *q1 != *q2) || memNE((char*)q1, (char*)q2, UTF8SKIP(q1)) ) return 1; /* mismatch */ n1 -= UTF8SKIP(q1); q1 += UTF8SKIP(q1); n2 -= UTF8SKIP(q2); q2 += UTF8SKIP(q2); } if (n1 == 0) p1 += u1 ? UTF8SKIP(p1) : 1; if (n2 == 0) p2 += u2 ? UTF8SKIP(p2) : 1; } /* A match is defined by all the scans that specified * an explicit length reaching their final goals. */ match = (f1 == 0 || p1 == f1) && (f2 == 0 || p2 == f2); if (match) { if (pe1) *pe1 = (char*)p1; if (pe2) *pe2 = (char*)p2; } return match ? 0 : 1; /* 0 match, 1 mismatch */ } /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */ perl-5.12.0-RC0/README.vmesa0000444000175000017500000000756011143650473014133 0ustar jessejesse This document is written in pod format hence there are punctuation characters in odd places. Do not worry, you've apparently got the ASCII->EBCDIC translation worked out correctly. You can read more about pod in pod/perlpod.pod or the short summary in the INSTALL file. =head1 NAME README.vmesa - building and installing Perl for VM/ESA. =head1 SYNOPSIS This document will help you Configure, build, test and install Perl on VM/ESA. =head1 DESCRIPTION This is a fully ported perl for VM/ESA 2.3.0. It may work on other versions, but that's the one we've tested it on. If you've downloaded the binary distribution, it needs to be installed below /usr/local. Source code distributions have an automated "make install" step that means you do not need to extract the source code below /usr/local (though that is where it will be installed by default). You may need to worry about the networking configuration files discussed in the last bullet below. =head2 Unpacking Perl Distribution on VM/ESA To extract an ASCII tar archive on VM/ESA, try this: pax -o to=IBM-1047,from=ISO8859-1 -r < latest.tar =head2 Setup Perl and utilities on VM/ESA GNU make for VM/ESA, which may be required for the build of perl, is available from: http://vm.marist.edu/~neale/vmoe.html =head2 Configure Perl on VM/ESA Once you've unpacked the distribution, run Configure (see INSTALL for full discussion of the Configure options), and then run make, then "make test" then "make install" (this last step may require UID=0 privileges). There is a "hints" file for vmesa that specifies the correct values for most things. Some things to watch out for are: =over 4 =item * this port does support dynamic loading but it's not had much testing =item * Don't turn on the compiler optimization flag "-O". There's a bug in the compiler (APAR PQ18812) that generates some bad code the optimizer is on. =item * As VM/ESA doesn't fully support the fork() API programs relying on this call will not work. I've replaced fork()/exec() with spawn() and the standalone exec() with spawn(). This has a side effect when opening unnamed pipes in a shell script: there is no child process generated under. =item * At the moment the hints file for VM/ESA basically bypasses all of the automatic configuration process. This is because Configure relies on: 1. The header files living in the Byte File System (you could put the there if you want); 2. The C preprocessor including the #include statements in the preprocessor output (.i) file. =back =head2 Testing Anomalies of Perl on VM/ESA The "make test" step runs a Perl Verification Procedure, usually before installation. As the 5.6.1 kit was being assembled the following "failures" were known to appear on some machines during "make test" (mostly due to ASCII vs. EBCDIC conflicts), your results may differ: [the list of failures being compiled] =head2 Usage Hints for Perl on VM/ESA When using perl on VM/ESA please keep in mind that the EBCDIC and ASCII character sets are different. Perl builtin functions that may behave differently under EBCDIC are mentioned in the perlport.pod document. OpenEdition (UNIX System Services) does not (yet) support the #! means of script invocation. See: head `whence perldoc` for an example of how to use the "eval exec" trick to ask the shell to have perl run your scripts for you. =head1 AUTHORS Neale Ferguson. =head1 SEE ALSO L, L, L. =head2 Mailing list for Perl on VM/ESA If you are interested in the VM/ESA, z/OS (formerly known as OS/390) and POSIX-BC (BS2000) ports of Perl then see the perl-mvs mailing list. To subscribe, send an empty message to perl-mvs-subscribe@perl.org. See also: http://lists.perl.org/showlist.cgi?name=perl-mvs There are web archives of the mailing list at: http://www.xray.mpe.mpg.de/mailing-lists/perl-mvs/ http://archive.develooper.com/perl-mvs@perl.org/ =cut perl-5.12.0-RC0/Policy_sh.SH0000555000175000017500000001762311143650473014332 0ustar jessejessecase $PERL_CONFIG_SH in '') . ./config.sh ;; esac echo "Extracting Policy.sh (with variable substitutions)" $spitshell <Policy.sh $startsh # # This file was produced by running the Policy_sh.SH script, which # gets its values from config.sh, which is generally produced by # running Configure. # # The idea here is to distill in one place the common site-wide # "policy" answers (such as installation directories) that are # to be "sticky". If you keep the file Policy.sh around in # the same directory as you are building Perl, then Configure will # (by default) load up the Policy.sh file just before the # platform-specific hints file and rewrite it at the end. # # The sequence of events is as follows: # A: If you are NOT re-using an old config.sh: # 1. At start-up, Configure loads up the defaults from the # os-specific hints/osname_osvers.sh file and any previous # Policy.sh file. # 2. At the end, Configure runs Policy_sh.SH, which creates # Policy.sh, overwriting a previous Policy.sh if necessary. # # B: If you are re-using an old config.sh: # 1. At start-up, Configure loads up the defaults from config.sh, # ignoring any previous Policy.sh file. # 2. At the end, Configure runs Policy_sh.SH, which creates # Policy.sh, overwriting a previous Policy.sh if necessary. # # Thus the Policy.sh file gets overwritten each time # Configure is run. Any variables you add to Policy.sh will be lost # unless you copy Policy.sh somewhere else before running Configure. # # Allow Configure command-line overrides; usually these won't be # needed, but something like -Dprefix=/test/location can be quite # useful for testing out new versions. #Site-specific values: case "\$perladmin" in '') perladmin='$perladmin' ;; esac # Installation prefixes. Allow a Configure -D override. You # may wish to reinstall perl under a different prefix, perhaps # in order to test a different configuration. # For an explanation of the installation directories, see the # INSTALL file section on "Installation Directories". case "\$prefix" in '') prefix='$prefix' ;; esac # By default, the next three are the same as \$prefix. # If the user changes \$prefix, and previously \$siteprefix was the # same as \$prefix, then change \$siteprefix as well. # Use similar logic for \$vendorprefix and \$installprefix. case "\$siteprefix" in '') if test "$siteprefix" = "$prefix"; then siteprefix="\$prefix" else siteprefix='$siteprefix' fi ;; esac case "\$vendorprefix" in '') if test "$vendorprefix" = "$prefix"; then vendorprefix="\$prefix" else vendorprefix='$vendorprefix' fi ;; esac # Where installperl puts things. case "\$installprefix" in '') if test "$installprefix" = "$prefix"; then installprefix="\$prefix" else installprefix='$installprefix' fi ;; esac # Installation directives. Note that each one comes in three flavors. # For example, we have privlib, privlibexp, and installprivlib. # privlib is for private (to perl) library files. # privlibexp is the same, except any '~' the user gave to Configure # is expanded to the user's home directory. This is figured # out automatically by Configure, so you don't have to include it here. # installprivlib is for systems (such as those running AFS) that # need to distinguish between the place where things # get installed and where they finally will reside. As of 5.005_6x, # this too is handled automatically by Configure based on # $installprefix, so it isn't included here either. # # Note also that there are three broad hierarchies of installation # directories, as discussed in the INSTALL file under # "Installation Directories": # # =item Directories for the perl distribution # # =item Directories for site-specific add-on files # # =item Directories for vendor-supplied add-on files # # See Porting/Glossary for the definitions of these names, and see the # INSTALL file for further explanation and some examples. # # In each case, if your previous value was the default, leave it commented # out. That way, if you override prefix, all of these will be # automatically adjusted. # # WARNING: Be especially careful about architecture-dependent and # version-dependent names, particularly if you reuse this file for # different versions of perl. !GROK!THIS! # Set the following variables. Mention them here so metaconfig # includes the appropriate code in Configure # $bin $scriptdir $privlib $archlib # $man1dir $man3dir $html1dir $html3dir # $sitebin $sitescript $sitelib $sitearch # $siteman1dir $siteman3dir $sitehtml1dir $sitehtml3dir # $vendorbin $vendorscript $vendorlib $vendorarch # $vendorman1dir $vendorman3dir $vendorhtml1dir $vendorhtml3dir for var in \ bin scriptdir privlib archlib man1dir man3dir html1dir html3dir \ sitebin sitescript sitelib sitearch \ siteman1dir siteman3dir sitehtml1dir sitehtml3dir \ vendorbin vendorscript vendorlib vendorarch \ vendorman1dir vendorman3dir vendorhtml1dir vendorhtml3dir do case "$var" in # Directories for the core perl components bin) dflt=$prefix/bin ;; # The scriptdir test is more complex, but this is probably usually ok. scriptdir) if $test -d $prefix/script; then dflt=$prefix/script else dflt=$bin fi ;; privlib) case "$prefix" in *perl*) dflt=$prefix/lib/$version ;; *) dflt=$prefix/lib/$package/$version ;; esac ;; archlib) dflt="$privlib/$archname" ;; man1dir) dflt="$prefix/man/man1" ;; man3dir) dflt="$prefix/man/man3" ;; # Can we assume all sed's have greedy matching? man1ext) dflt=`echo $man1dir | sed -e 's!.*man!!' -e 's!^\.!!'` ;; man3ext) dflt=`echo $man3dir | sed -e 's!.*man!!' -e 's!^\.!!'` ;; # We don't know what to do with these yet. html1dir) dflt='' ;; htm31dir) dflt='' ;; # Directories for site-specific add-on files sitebin) dflt=$siteprefix/bin ;; sitescript) if $test -d $siteprefix/script; then dflt=$siteprefix/script else dflt=$sitebin fi ;; sitelib) case "$siteprefix" in *perl*) dflt=$prefix/lib/site_perl/$version ;; *) dflt=$prefix/lib/$package/site_perl/$version ;; esac ;; sitearch) dflt="$sitelib/$archname" ;; siteman1) dflt="$siteprefix/man/man1" ;; siteman3) dflt="$siteprefix/man/man3" ;; # We don't know what to do with these yet. sitehtml1) dflt='' ;; sitehtm31dir) dflt='' ;; # Directories for vendor-supplied add-on files # These are all usually empty. vendor*) if test X"$vendorprefix" = X""; then dflt='' else case "$var" in vendorbin) dflt=$vendorprefix/bin ;; vendorscript) if $test -d $vendorprefix/script; then dflt=$vendorprefix/script else dflt=$vendorbin fi ;; vendorlib) case "$vendorprefix" in *perl*) dflt=$prefix/lib/vendor_perl/$version ;; *) dflt=$prefix/lib/$package/vendor_perl/$version ;; esac ;; vendorarch) dflt="$vendorlib/$archname" ;; vendorman1) dflt="$vendorprefix/man/man1" ;; vendorman3) dflt="$vendorprefix/man/man3" ;; # We don't know what to do with these yet. vendorhtml1) dflt='' ;; vendorhtm3) dflt='' ;; esac # End of vendorprefix != '' fi ;; esac eval val="\$$var" if test X"$val" = X"$dflt"; then echo "# $var='$dflt'" else echo "# Preserving custom $var" echo "$var='$val'" fi done >> Policy.sh $spitshell <>Policy.sh # Lastly, you may add additional items here. For example, to set the # pager to your local favorite value, uncomment the following line in # the original Policy_sh.SH file and re-run sh Policy_sh.SH. # # pager='$pager' # # A full Glossary of all the config.sh variables is in the file # Porting/Glossary. !GROK!THIS! #Credits: # The original design for this Policy.sh file came from Wayne Davison, # maintainer of trn. # This version for Perl5.004_61 originally written by # Andy Dougherty . # This file may be distributed under the same terms as Perl itself. perl-5.12.0-RC0/perly.h0000444000175000017500000001172511337277446013455 0ustar jessejesse#ifdef PERL_CORE /* A Bison parser, made by GNU Bison 2.4.1. */ /* Skeleton interface for Bison's Yacc-like parsers in C Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . */ /* As a special exception, you may create a larger work that contains part or all of the Bison parser skeleton and distribute that work under terms of your choice, so long as that work isn't itself a parser generator using the skeleton or a modified version thereof as a parser skeleton. Alternatively, if you modify or redistribute the parser skeleton itself, you may (at your option) remove this special exception, which will cause the skeleton and the resulting Bison output files to be licensed under the GNU General Public License without this special exception. This special exception was added by the Free Software Foundation in version 2.2 of Bison. */ /* Tokens. */ #ifndef YYTOKENTYPE # define YYTOKENTYPE /* Put the tokens into the symbol table, so that GDB and other debuggers know about them. */ enum yytokentype { WORD = 258, METHOD = 259, FUNCMETH = 260, THING = 261, PMFUNC = 262, PRIVATEREF = 263, FUNC0SUB = 264, UNIOPSUB = 265, LSTOPSUB = 266, PLUGEXPR = 267, PLUGSTMT = 268, LABEL = 269, FORMAT = 270, SUB = 271, ANONSUB = 272, PACKAGE = 273, USE = 274, WHILE = 275, UNTIL = 276, IF = 277, UNLESS = 278, ELSE = 279, ELSIF = 280, CONTINUE = 281, FOR = 282, GIVEN = 283, WHEN = 284, DEFAULT = 285, LOOPEX = 286, DOTDOT = 287, YADAYADA = 288, FUNC0 = 289, FUNC1 = 290, FUNC = 291, UNIOP = 292, LSTOP = 293, RELOP = 294, EQOP = 295, MULOP = 296, ADDOP = 297, DOLSHARP = 298, DO = 299, HASHBRACK = 300, NOAMP = 301, LOCAL = 302, MY = 303, MYSUB = 304, REQUIRE = 305, COLONATTR = 306, PREC_LOW = 307, DOROP = 308, OROP = 309, ANDOP = 310, NOTOP = 311, ASSIGNOP = 312, DORDOR = 313, OROR = 314, ANDAND = 315, BITOROP = 316, BITANDOP = 317, SHIFTOP = 318, MATCHOP = 319, REFGEN = 320, UMINUS = 321, POWOP = 322, POSTDEC = 323, POSTINC = 324, PREDEC = 325, PREINC = 326, ARROW = 327, PEG = 328 }; #endif /* Tokens. */ #define WORD 258 #define METHOD 259 #define FUNCMETH 260 #define THING 261 #define PMFUNC 262 #define PRIVATEREF 263 #define FUNC0SUB 264 #define UNIOPSUB 265 #define LSTOPSUB 266 #define PLUGEXPR 267 #define PLUGSTMT 268 #define LABEL 269 #define FORMAT 270 #define SUB 271 #define ANONSUB 272 #define PACKAGE 273 #define USE 274 #define WHILE 275 #define UNTIL 276 #define IF 277 #define UNLESS 278 #define ELSE 279 #define ELSIF 280 #define CONTINUE 281 #define FOR 282 #define GIVEN 283 #define WHEN 284 #define DEFAULT 285 #define LOOPEX 286 #define DOTDOT 287 #define YADAYADA 288 #define FUNC0 289 #define FUNC1 290 #define FUNC 291 #define UNIOP 292 #define LSTOP 293 #define RELOP 294 #define EQOP 295 #define MULOP 296 #define ADDOP 297 #define DOLSHARP 298 #define DO 299 #define HASHBRACK 300 #define NOAMP 301 #define LOCAL 302 #define MY 303 #define MYSUB 304 #define REQUIRE 305 #define COLONATTR 306 #define PREC_LOW 307 #define DOROP 308 #define OROP 309 #define ANDOP 310 #define NOTOP 311 #define ASSIGNOP 312 #define DORDOR 313 #define OROR 314 #define ANDAND 315 #define BITOROP 316 #define BITANDOP 317 #define SHIFTOP 318 #define MATCHOP 319 #define REFGEN 320 #define UMINUS 321 #define POWOP 322 #define POSTDEC 323 #define POSTINC 324 #define PREDEC 325 #define PREINC 326 #define ARROW 327 #define PEG 328 #endif /* PERL_CORE */ #if ! defined YYSTYPE && ! defined YYSTYPE_IS_DECLARED typedef union YYSTYPE { /* Line 1676 of yacc.c */ I32 ival; /* __DEFAULT__ (marker for regen_perly.pl; must always be 1st union member) */ char *pval; OP *opval; GV *gvval; #ifdef PERL_IN_MADLY_C TOKEN* p_tkval; TOKEN* i_tkval; #else char *p_tkval; I32 i_tkval; #endif #ifdef PERL_MAD TOKEN* tkval; #endif /* Line 1676 of yacc.c */ } YYSTYPE; # define YYSTYPE_IS_TRIVIAL 1 # define yystype YYSTYPE /* obsolescent; will be withdrawn */ # define YYSTYPE_IS_DECLARED 1 #endif perl-5.12.0-RC0/win32/0000755000175000017500000000000011351321567013075 5ustar jessejesseperl-5.12.0-RC0/win32/include/0000755000175000017500000000000011351321567014520 5ustar jessejesseperl-5.12.0-RC0/win32/include/arpa/0000755000175000017500000000000011351321567015443 5ustar jessejesseperl-5.12.0-RC0/win32/include/arpa/inet.h0000444000175000017500000000006711143650501016544 0ustar jessejesse/* * this is a dummy header file for Socket.xs */ perl-5.12.0-RC0/win32/include/netdb.h0000444000175000017500000000022611143650501015753 0ustar jessejesse/* netdb.h */ /* djl */ /* Provide UNIX compatibility */ #ifndef _INC_NETDB #define _INC_NETDB #include #endif /* _INC_NETDB */ perl-5.12.0-RC0/win32/include/dirent.h0000444000175000017500000000233711143650501016151 0ustar jessejesse/* dirent.h */ /* djl * Provide UNIX compatibility */ #ifndef _INC_DIRENT #define _INC_DIRENT /* * NT versions of readdir(), etc * From the MSDOS implementation */ /* Directory entry size */ #ifdef DIRSIZ #undef DIRSIZ #endif #define DIRSIZ(rp) (sizeof(struct direct)) /* needed to compile directory stuff */ #define DIRENT direct /* 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 */ } _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 */ } DIR; #if 0 /* these have moved to win32iop.h */ DIR * win32_opendir(const char *filename); struct direct * win32_readdir(DIR *dirp); long win32_telldir(DIR *dirp); void win32_seekdir(DIR *dirp,long loc); void win32_rewinddir(DIR *dirp); int win32_closedir(DIR *dirp); #endif #endif /* _INC_DIRENT */ perl-5.12.0-RC0/win32/include/sys/0000755000175000017500000000000011351321567015336 5ustar jessejesseperl-5.12.0-RC0/win32/include/sys/socket.h0000444000175000017500000001350511325125742016777 0ustar jessejesse/* sys/socket.h */ /* djl */ /* Provide UNIX compatibility */ #ifndef _INC_SYS_SOCKET #define _INC_SYS_SOCKET #ifdef __cplusplus extern "C" { #endif #define WIN32_LEAN_AND_MEAN #ifdef __GNUC__ # define Win32_Winsock #endif #include /* Too late to include winsock2.h if winsock.h has already been loaded */ #ifndef _WINSOCKAPI_ # if defined(UNDER_CE) && UNDER_CE <= 300 /* winsock2 only for 4.00+ */ # include # else # include #endif #endif #include "win32.h" #define ENOTSOCK WSAENOTSOCK #ifdef USE_SOCKETS_AS_HANDLES #ifndef PERL_FD_SETSIZE #define PERL_FD_SETSIZE 64 #endif #define PERL_BITS_PER_BYTE 8 #define PERL_NFDBITS (sizeof(Perl_fd_mask)*PERL_BITS_PER_BYTE) typedef int Perl_fd_mask; typedef struct Perl_fd_set { Perl_fd_mask bits[(PERL_FD_SETSIZE+PERL_NFDBITS-1)/PERL_NFDBITS]; } Perl_fd_set; #define PERL_FD_CLR(n,p) \ ((p)->bits[(n)/PERL_NFDBITS] &= ~((unsigned)1 << ((n)%PERL_NFDBITS))) #define PERL_FD_SET(n,p) \ ((p)->bits[(n)/PERL_NFDBITS] |= ((unsigned)1 << ((n)%PERL_NFDBITS))) #define PERL_FD_ZERO(p) memset((char *)(p),0,sizeof(*(p))) #define PERL_FD_ISSET(n,p) \ ((p)->bits[(n)/PERL_NFDBITS] & ((unsigned)1 << ((n)%PERL_NFDBITS))) #else /* USE_SOCKETS_AS_HANDLES */ #define Perl_fd_set fd_set #define PERL_FD_SET(n,p) FD_SET(n,p) #define PERL_FD_CLR(n,p) FD_CLR(n,p) #define PERL_FD_ISSET(n,p) FD_ISSET(n,p) #define PERL_FD_ZERO(p) FD_ZERO(p) #endif /* USE_SOCKETS_AS_HANDLES */ SOCKET win32_accept (SOCKET s, struct sockaddr *addr, int *addrlen); int win32_bind (SOCKET s, const struct sockaddr *addr, int namelen); int win32_closesocket (SOCKET s); int win32_connect (SOCKET s, const struct sockaddr *name, int namelen); int win32_ioctlsocket (SOCKET s, long cmd, u_long *argp); int win32_getpeername (SOCKET s, struct sockaddr *name, int * namelen); int win32_getsockname (SOCKET s, struct sockaddr *name, int * namelen); int win32_getsockopt (SOCKET s, int level, int optname, char * optval, int *optlen); u_long win32_htonl (u_long hostlong); u_short win32_htons (u_short hostshort); unsigned long win32_inet_addr (const char * cp); char * win32_inet_ntoa (struct in_addr in); int win32_listen (SOCKET s, int backlog); u_long win32_ntohl (u_long netlong); u_short win32_ntohs (u_short netshort); 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); 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); int win32_setsockopt (SOCKET s, int level, int optname, const char * optval, int optlen); SOCKET win32_socket (int af, int type, int protocol); int win32_shutdown (SOCKET s, int how); /* Database function prototypes */ struct hostent * win32_gethostbyaddr(const char * addr, int len, int type); struct hostent * win32_gethostbyname(const char * name); int win32_gethostname (char * name, int namelen); struct servent * win32_getservbyport(int port, const char * proto); struct servent * win32_getservbyname(const char * name, const char * proto); struct protoent * win32_getprotobynumber(int proto); struct protoent * win32_getprotobyname(const char * name); struct protoent *win32_getprotoent(void); struct servent *win32_getservent(void); void win32_sethostent(int stayopen); void win32_setnetent(int stayopen); struct netent * win32_getnetent(void); struct netent * win32_getnetbyname(char *name); struct netent * win32_getnetbyaddr(long net, int type); void win32_setprotoent(int stayopen); void win32_setservent(int stayopen); void win32_endhostent(void); void win32_endnetent(void); void win32_endprotoent(void); void win32_endservent(void); #ifndef WIN32SCK_IS_STDSCK /* direct to our version */ #define htonl win32_htonl #define htons win32_htons #define ntohl win32_ntohl #define ntohs win32_ntohs #define inet_addr win32_inet_addr #define inet_ntoa win32_inet_ntoa #define socket win32_socket #define bind win32_bind #define listen win32_listen #define accept win32_accept #define connect win32_connect #define send win32_send #define sendto win32_sendto #define recv win32_recv #define recvfrom win32_recvfrom #define shutdown win32_shutdown #define closesocket win32_closesocket #define ioctlsocket win32_ioctlsocket #define setsockopt win32_setsockopt #define getsockopt win32_getsockopt #define getpeername win32_getpeername #define getsockname win32_getsockname #define gethostname win32_gethostname #define gethostbyname win32_gethostbyname #define gethostbyaddr win32_gethostbyaddr #define getprotobyname win32_getprotobyname #define getprotobynumber win32_getprotobynumber #define getservbyname win32_getservbyname #define getservbyport win32_getservbyport #define select win32_select #define endhostent win32_endhostent #define endnetent win32_endnetent #define endprotoent win32_endprotoent #define endservent win32_endservent #define getnetent win32_getnetent #define getnetbyname win32_getnetbyname #define getnetbyaddr win32_getnetbyaddr #define getprotoent win32_getprotoent #define getservent win32_getservent #define sethostent win32_sethostent #define setnetent win32_setnetent #define setprotoent win32_setprotoent #define setservent win32_setservent #ifdef USE_SOCKETS_AS_HANDLES #undef fd_set #undef FD_SET #undef FD_CLR #undef FD_ISSET #undef FD_ZERO #define fd_set Perl_fd_set #define FD_SET(n,p) PERL_FD_SET(n,p) #define FD_CLR(n,p) PERL_FD_CLR(n,p) #define FD_ISSET(n,p) PERL_FD_ISSET(n,p) #define FD_ZERO(p) PERL_FD_ZERO(p) #endif /* USE_SOCKETS_AS_HANDLES */ #endif /* WIN32SCK_IS_STDSCK */ #ifdef __cplusplus } #endif #endif /* _INC_SYS_SOCKET */ perl-5.12.0-RC0/win32/perlhost.h0000444000175000017500000015142211325127002015076 0ustar jessejesse/* perlhost.h * * (c) 1999 Microsoft Corporation. All rights reserved. * Portions (c) 1999 ActiveState Tool Corp, http://www.ActiveState.com/ * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. */ #ifndef UNDER_CE #define CHECK_HOST_INTERP #endif #ifndef ___PerlHost_H___ #define ___PerlHost_H___ #ifndef UNDER_CE #include #endif #include "iperlsys.h" #include "vmem.h" #include "vdir.h" #ifndef WC_NO_BEST_FIT_CHARS # define WC_NO_BEST_FIT_CHARS 0x00000400 #endif START_EXTERN_C extern char * g_win32_get_privlib(const char *pl, STRLEN *const len); extern char * g_win32_get_sitelib(const char *pl, STRLEN *const len); extern char * g_win32_get_vendorlib(const char *pl, STRLEN *const len); extern char * g_getlogin(void); END_EXTERN_C class CPerlHost { 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); CPerlHost(CPerlHost& host); ~CPerlHost(void); static CPerlHost* IPerlMem2Host(struct IPerlMem* piPerl); static CPerlHost* IPerlMemShared2Host(struct IPerlMem* piPerl); static CPerlHost* IPerlMemParse2Host(struct IPerlMem* piPerl); static CPerlHost* IPerlEnv2Host(struct IPerlEnv* piPerl); static CPerlHost* IPerlStdIO2Host(struct IPerlStdIO* piPerl); static CPerlHost* IPerlLIO2Host(struct IPerlLIO* piPerl); static CPerlHost* IPerlDir2Host(struct IPerlDir* piPerl); static CPerlHost* IPerlSock2Host(struct IPerlSock* piPerl); static CPerlHost* IPerlProc2Host(struct IPerlProc* piPerl); BOOL PerlCreate(void); int PerlParse(int argc, char** argv, char** env); int PerlRun(void); void PerlDestroy(void); /* IPerlMem */ /* Locks provided but should be unnecessary as this is private pool */ 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) { 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(); }; inline int IsLocked(void) { return m_pVMem->IsLocked(); }; /* IPerlMemShared */ /* Locks used to serialize access to the pool */ inline void GetLockShared(void) { m_pVMemShared->GetLock(); }; inline void FreeLockShared(void) { m_pVMemShared->FreeLock(); }; 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; }; inline void* ReallocShared(void* ptr, size_t size) { void *result; GetLockShared(); result = m_pVMemShared->Realloc(ptr, size); FreeLockShared(); return result; }; inline void FreeShared(void* ptr) { 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; }; /* IPerlMemParse */ /* Assume something else is using locks to mangaging serialize on a batch basis */ inline void GetLockParse(void) { m_pVMemParse->GetLock(); }; inline void FreeLockParse(void) { m_pVMemParse->FreeLock(); }; inline int IsLockedParse(void) { return m_pVMemParse->IsLocked(); }; inline void* MallocParse(size_t size) { return m_pVMemParse->Malloc(size); }; inline void* ReallocParse(void* ptr, size_t size) { return m_pVMemParse->Realloc(ptr, size); }; 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; }; /* IPerlEnv */ char *Getenv(const char *varname); 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; } void* CreateChildEnv(void) { return CreateLocalEnvironmentStrings(*m_pvDir); }; void FreeChildEnv(void* pStr) { FreeLocalEnvironmentStrings((char*)pStr); }; char* GetChildDir(void); void FreeChildDir(char* pStr); void Reset(void); void Clearenv(void); inline LPSTR GetIndex(DWORD &dwIndex) { if(dwIndex < m_dwEnvCount) { ++dwIndex; return m_lppEnvList[dwIndex-1]; } return NULL; }; protected: LPSTR Find(LPCSTR lpStr); void Add(LPCSTR lpStr); LPSTR CreateLocalEnvironmentStrings(VDir &vDir); void FreeLocalEnvironmentStrings(LPSTR lpStr); LPSTR* Lookup(LPCSTR lpStr); DWORD CalculateEnvironmentSpace(void); public: /* IPerlDIR */ virtual int Chdir(const char *dirname); /* IPerllProc */ void Abort(void); void Exit(int status); void _Exit(int status); int Execl(const char *cmdname, const char *arg0, const char *arg1, const char *arg2, const char *arg3); int Execv(const char *cmdname, const char *const *argv); int Execvp(const char *cmdname, const char *const *argv); inline VMem* GetMemShared(void) { m_pVMemShared->AddRef(); return m_pVMemShared; }; inline VMem* GetMemParse(void) { m_pVMemParse->AddRef(); return m_pVMemParse; }; inline VDir* GetDir(void) { return m_pvDir; }; public: struct IPerlMem m_hostperlMem; struct IPerlMem m_hostperlMemShared; struct IPerlMem m_hostperlMemParse; struct IPerlEnv m_hostperlEnv; struct IPerlStdIO m_hostperlStdIO; struct IPerlLIO m_hostperlLIO; struct IPerlDir m_hostperlDir; struct IPerlSock m_hostperlSock; struct IPerlProc m_hostperlProc; struct IPerlMem* m_pHostperlMem; struct IPerlMem* m_pHostperlMemShared; struct IPerlMem* m_pHostperlMemParse; struct IPerlEnv* m_pHostperlEnv; struct IPerlStdIO* m_pHostperlStdIO; struct IPerlLIO* m_pHostperlLIO; struct IPerlDir* m_pHostperlDir; struct IPerlSock* m_pHostperlSock; struct IPerlProc* m_pHostperlProc; inline char* MapPathA(const char *pInName) { return m_pvDir->MapPathA(pInName); }; inline WCHAR* MapPathW(const WCHAR *pInName) { return m_pvDir->MapPathW(pInName); }; protected: VDir* m_pvDir; VMem* m_pVMem; VMem* m_pVMemShared; VMem* m_pVMemParse; DWORD m_dwEnvCount; LPSTR* m_lppEnvList; BOOL m_bTopLevel; // is this a toplevel host? static long num_hosts; public: inline int LastHost(void) { return num_hosts == 1L; }; struct interpreter *host_perl; }; long CPerlHost::num_hosts = 0L; extern "C" void win32_checkTLS(struct interpreter *host_perl); #define STRUCT2RAWPTR(x, y) (CPerlHost*)(((LPBYTE)x)-offsetof(CPerlHost, y)) #ifdef CHECK_HOST_INTERP inline CPerlHost* CheckInterp(CPerlHost *host) { win32_checkTLS(host->host_perl); return host; } #define STRUCT2PTR(x, y) CheckInterp(STRUCT2RAWPTR(x, y)) #else #define STRUCT2PTR(x, y) STRUCT2RAWPTR(x, y) #endif inline CPerlHost* IPerlMem2Host(struct IPerlMem* piPerl) { return STRUCT2RAWPTR(piPerl, m_hostperlMem); } inline CPerlHost* IPerlMemShared2Host(struct IPerlMem* piPerl) { return STRUCT2RAWPTR(piPerl, m_hostperlMemShared); } inline CPerlHost* IPerlMemParse2Host(struct IPerlMem* piPerl) { return STRUCT2RAWPTR(piPerl, m_hostperlMemParse); } inline CPerlHost* IPerlEnv2Host(struct IPerlEnv* piPerl) { return STRUCT2PTR(piPerl, m_hostperlEnv); } inline CPerlHost* IPerlStdIO2Host(struct IPerlStdIO* piPerl) { return STRUCT2PTR(piPerl, m_hostperlStdIO); } inline CPerlHost* IPerlLIO2Host(struct IPerlLIO* piPerl) { return STRUCT2PTR(piPerl, m_hostperlLIO); } inline CPerlHost* IPerlDir2Host(struct IPerlDir* piPerl) { return STRUCT2PTR(piPerl, m_hostperlDir); } inline CPerlHost* IPerlSock2Host(struct IPerlSock* piPerl) { return STRUCT2PTR(piPerl, m_hostperlSock); } inline CPerlHost* IPerlProc2Host(struct IPerlProc* piPerl) { return STRUCT2PTR(piPerl, m_hostperlProc); } #undef IPERL2HOST #define IPERL2HOST(x) IPerlMem2Host(x) /* IPerlMem */ void* PerlMemMalloc(struct IPerlMem* piPerl, size_t size) { return IPERL2HOST(piPerl)->Malloc(size); } void* PerlMemRealloc(struct IPerlMem* piPerl, void* ptr, size_t size) { return IPERL2HOST(piPerl)->Realloc(ptr, size); } void PerlMemFree(struct IPerlMem* piPerl, void* ptr) { IPERL2HOST(piPerl)->Free(ptr); } void* PerlMemCalloc(struct IPerlMem* piPerl, size_t num, size_t size) { return IPERL2HOST(piPerl)->Calloc(num, size); } void PerlMemGetLock(struct IPerlMem* piPerl) { IPERL2HOST(piPerl)->GetLock(); } void PerlMemFreeLock(struct IPerlMem* piPerl) { IPERL2HOST(piPerl)->FreeLock(); } int PerlMemIsLocked(struct IPerlMem* piPerl) { return IPERL2HOST(piPerl)->IsLocked(); } struct IPerlMem perlMem = { PerlMemMalloc, PerlMemRealloc, PerlMemFree, PerlMemCalloc, PerlMemGetLock, PerlMemFreeLock, PerlMemIsLocked, }; #undef IPERL2HOST #define IPERL2HOST(x) IPerlMemShared2Host(x) /* IPerlMemShared */ void* PerlMemSharedMalloc(struct IPerlMem* piPerl, size_t size) { return IPERL2HOST(piPerl)->MallocShared(size); } void* PerlMemSharedRealloc(struct IPerlMem* piPerl, void* ptr, size_t size) { return IPERL2HOST(piPerl)->ReallocShared(ptr, size); } void PerlMemSharedFree(struct IPerlMem* piPerl, void* ptr) { IPERL2HOST(piPerl)->FreeShared(ptr); } void* PerlMemSharedCalloc(struct IPerlMem* piPerl, size_t num, size_t size) { return IPERL2HOST(piPerl)->CallocShared(num, size); } void PerlMemSharedGetLock(struct IPerlMem* piPerl) { IPERL2HOST(piPerl)->GetLockShared(); } void PerlMemSharedFreeLock(struct IPerlMem* piPerl) { IPERL2HOST(piPerl)->FreeLockShared(); } int PerlMemSharedIsLocked(struct IPerlMem* piPerl) { return IPERL2HOST(piPerl)->IsLockedShared(); } struct IPerlMem perlMemShared = { PerlMemSharedMalloc, PerlMemSharedRealloc, PerlMemSharedFree, PerlMemSharedCalloc, PerlMemSharedGetLock, PerlMemSharedFreeLock, PerlMemSharedIsLocked, }; #undef IPERL2HOST #define IPERL2HOST(x) IPerlMemParse2Host(x) /* IPerlMemParse */ void* PerlMemParseMalloc(struct IPerlMem* piPerl, size_t size) { return IPERL2HOST(piPerl)->MallocParse(size); } void* PerlMemParseRealloc(struct IPerlMem* piPerl, void* ptr, size_t size) { return IPERL2HOST(piPerl)->ReallocParse(ptr, size); } void PerlMemParseFree(struct IPerlMem* piPerl, void* ptr) { IPERL2HOST(piPerl)->FreeParse(ptr); } void* PerlMemParseCalloc(struct IPerlMem* piPerl, size_t num, size_t size) { return IPERL2HOST(piPerl)->CallocParse(num, size); } void PerlMemParseGetLock(struct IPerlMem* piPerl) { IPERL2HOST(piPerl)->GetLockParse(); } void PerlMemParseFreeLock(struct IPerlMem* piPerl) { IPERL2HOST(piPerl)->FreeLockParse(); } int PerlMemParseIsLocked(struct IPerlMem* piPerl) { return IPERL2HOST(piPerl)->IsLockedParse(); } struct IPerlMem perlMemParse = { PerlMemParseMalloc, PerlMemParseRealloc, PerlMemParseFree, PerlMemParseCalloc, PerlMemParseGetLock, PerlMemParseFreeLock, PerlMemParseIsLocked, }; #undef IPERL2HOST #define IPERL2HOST(x) IPerlEnv2Host(x) /* IPerlEnv */ char* PerlEnvGetenv(struct IPerlEnv* piPerl, const char *varname) { return IPERL2HOST(piPerl)->Getenv(varname); }; int PerlEnvPutenv(struct IPerlEnv* piPerl, const char *envstring) { return IPERL2HOST(piPerl)->Putenv(envstring); }; char* PerlEnvGetenv_len(struct IPerlEnv* piPerl, const char* varname, unsigned long* len) { return IPERL2HOST(piPerl)->Getenv(varname, len); } int PerlEnvUname(struct IPerlEnv* piPerl, struct utsname *name) { return win32_uname(name); } void PerlEnvClearenv(struct IPerlEnv* piPerl) { IPERL2HOST(piPerl)->Clearenv(); } void* PerlEnvGetChildenv(struct IPerlEnv* piPerl) { return IPERL2HOST(piPerl)->CreateChildEnv(); } void PerlEnvFreeChildenv(struct IPerlEnv* piPerl, void* childEnv) { IPERL2HOST(piPerl)->FreeChildEnv(childEnv); } char* PerlEnvGetChilddir(struct IPerlEnv* piPerl) { return IPERL2HOST(piPerl)->GetChildDir(); } void PerlEnvFreeChilddir(struct IPerlEnv* piPerl, char* childDir) { IPERL2HOST(piPerl)->FreeChildDir(childDir); } unsigned long PerlEnvOsId(struct IPerlEnv* piPerl) { return win32_os_id(); } char* PerlEnvLibPath(struct IPerlEnv* piPerl, const char *pl, STRLEN *const len) { return g_win32_get_privlib(pl, len); } char* PerlEnvSiteLibPath(struct IPerlEnv* piPerl, const char *pl, STRLEN *const len) { return g_win32_get_sitelib(pl, len); } char* PerlEnvVendorLibPath(struct IPerlEnv* piPerl, const char *pl, STRLEN *const len) { return g_win32_get_vendorlib(pl, len); } void PerlEnvGetChildIO(struct IPerlEnv* piPerl, child_IO_table* ptr) { win32_get_child_IO(ptr); } struct IPerlEnv perlEnv = { PerlEnvGetenv, PerlEnvPutenv, PerlEnvGetenv_len, PerlEnvUname, PerlEnvClearenv, PerlEnvGetChildenv, PerlEnvFreeChildenv, PerlEnvGetChilddir, PerlEnvFreeChilddir, PerlEnvOsId, PerlEnvLibPath, PerlEnvSiteLibPath, PerlEnvVendorLibPath, PerlEnvGetChildIO, }; #undef IPERL2HOST #define IPERL2HOST(x) IPerlStdIO2Host(x) /* PerlStdIO */ FILE* PerlStdIOStdin(struct IPerlStdIO* piPerl) { return win32_stdin(); } FILE* PerlStdIOStdout(struct IPerlStdIO* piPerl) { return win32_stdout(); } FILE* PerlStdIOStderr(struct IPerlStdIO* piPerl) { return win32_stderr(); } FILE* PerlStdIOOpen(struct IPerlStdIO* piPerl, const char *path, const char *mode) { return win32_fopen(path, mode); } int PerlStdIOClose(struct IPerlStdIO* piPerl, FILE* pf) { return win32_fclose((pf)); } int PerlStdIOEof(struct IPerlStdIO* piPerl, FILE* pf) { return win32_feof(pf); } int PerlStdIOError(struct IPerlStdIO* piPerl, FILE* pf) { return win32_ferror(pf); } void PerlStdIOClearerr(struct IPerlStdIO* piPerl, FILE* pf) { win32_clearerr(pf); } int PerlStdIOGetc(struct IPerlStdIO* piPerl, FILE* pf) { return win32_getc(pf); } STDCHAR* PerlStdIOGetBase(struct IPerlStdIO* piPerl, FILE* pf) { #ifdef FILE_base FILE *f = pf; return FILE_base(f); #else return NULL; #endif } int PerlStdIOGetBufsiz(struct IPerlStdIO* piPerl, FILE* pf) { #ifdef FILE_bufsiz FILE *f = pf; return FILE_bufsiz(f); #else return (-1); #endif } int PerlStdIOGetCnt(struct IPerlStdIO* piPerl, FILE* pf) { #ifdef USE_STDIO_PTR FILE *f = pf; return FILE_cnt(f); #else return (-1); #endif } STDCHAR* PerlStdIOGetPtr(struct IPerlStdIO* piPerl, FILE* pf) { #ifdef USE_STDIO_PTR FILE *f = pf; return FILE_ptr(f); #else return NULL; #endif } char* PerlStdIOGets(struct IPerlStdIO* piPerl, FILE* pf, char* s, int n) { return win32_fgets(s, n, pf); } int PerlStdIOPutc(struct IPerlStdIO* piPerl, FILE* pf, int c) { return win32_fputc(c, pf); } int PerlStdIOPuts(struct IPerlStdIO* piPerl, FILE* pf, const char *s) { return win32_fputs(s, pf); } int PerlStdIOFlush(struct IPerlStdIO* piPerl, FILE* pf) { return win32_fflush(pf); } int PerlStdIOUngetc(struct IPerlStdIO* piPerl,int c, FILE* pf) { return win32_ungetc(c, pf); } int PerlStdIOFileno(struct IPerlStdIO* piPerl, FILE* pf) { return win32_fileno(pf); } FILE* PerlStdIOFdopen(struct IPerlStdIO* piPerl, int fd, const char *mode) { return win32_fdopen(fd, mode); } FILE* PerlStdIOReopen(struct IPerlStdIO* piPerl, const char*path, const char*mode, FILE* pf) { return win32_freopen(path, mode, (FILE*)pf); } SSize_t PerlStdIORead(struct IPerlStdIO* piPerl, void *buffer, Size_t size, Size_t count, FILE* pf) { return win32_fread(buffer, size, count, pf); } SSize_t PerlStdIOWrite(struct IPerlStdIO* piPerl, const void *buffer, Size_t size, Size_t count, FILE* pf) { return win32_fwrite(buffer, size, count, pf); } void PerlStdIOSetBuf(struct IPerlStdIO* piPerl, FILE* pf, char* buffer) { win32_setbuf(pf, buffer); } int PerlStdIOSetVBuf(struct IPerlStdIO* piPerl, FILE* pf, char* buffer, int type, Size_t size) { return win32_setvbuf(pf, buffer, type, size); } void PerlStdIOSetCnt(struct IPerlStdIO* piPerl, FILE* pf, int n) { #ifdef STDIO_CNT_LVALUE FILE *f = pf; FILE_cnt(f) = n; #endif } void PerlStdIOSetPtr(struct IPerlStdIO* piPerl, FILE* pf, STDCHAR * ptr) { #ifdef STDIO_PTR_LVALUE FILE *f = pf; FILE_ptr(f) = ptr; #endif } void PerlStdIOSetlinebuf(struct IPerlStdIO* piPerl, FILE* pf) { win32_setvbuf(pf, NULL, _IOLBF, 0); } int PerlStdIOPrintf(struct IPerlStdIO* piPerl, FILE* pf, const char *format,...) { va_list(arglist); va_start(arglist, format); return win32_vfprintf(pf, format, arglist); } int PerlStdIOVprintf(struct IPerlStdIO* piPerl, FILE* pf, const char *format, va_list arglist) { return win32_vfprintf(pf, format, arglist); } Off_t PerlStdIOTell(struct IPerlStdIO* piPerl, FILE* pf) { return win32_ftell(pf); } int PerlStdIOSeek(struct IPerlStdIO* piPerl, FILE* pf, Off_t offset, int origin) { return win32_fseek(pf, offset, origin); } void PerlStdIORewind(struct IPerlStdIO* piPerl, FILE* pf) { win32_rewind(pf); } FILE* PerlStdIOTmpfile(struct IPerlStdIO* piPerl) { return win32_tmpfile(); } int PerlStdIOGetpos(struct IPerlStdIO* piPerl, FILE* pf, Fpos_t *p) { return win32_fgetpos(pf, p); } int PerlStdIOSetpos(struct IPerlStdIO* piPerl, FILE* pf, const Fpos_t *p) { return win32_fsetpos(pf, p); } void PerlStdIOInit(struct IPerlStdIO* piPerl) { } void PerlStdIOInitOSExtras(struct IPerlStdIO* piPerl) { Perl_init_os_extras(); } int PerlStdIOOpenOSfhandle(struct IPerlStdIO* piPerl, intptr_t osfhandle, int flags) { return win32_open_osfhandle(osfhandle, flags); } intptr_t PerlStdIOGetOSfhandle(struct IPerlStdIO* piPerl, int filenum) { return win32_get_osfhandle(filenum); } FILE* PerlStdIOFdupopen(struct IPerlStdIO* piPerl, FILE* pf) { #ifndef UNDER_CE FILE* pfdup; fpos_t pos; char mode[3]; int fileno = win32_dup(win32_fileno(pf)); /* open the file in the same mode */ #ifdef __BORLANDC__ if((pf)->flags & _F_READ) { mode[0] = 'r'; mode[1] = 0; } else if((pf)->flags & _F_WRIT) { mode[0] = 'a'; mode[1] = 0; } else if((pf)->flags & _F_RDWR) { mode[0] = 'r'; mode[1] = '+'; mode[2] = 0; } #else if((pf)->_flag & _IOREAD) { mode[0] = 'r'; mode[1] = 0; } else if((pf)->_flag & _IOWRT) { mode[0] = 'a'; mode[1] = 0; } else if((pf)->_flag & _IORW) { mode[0] = 'r'; mode[1] = '+'; mode[2] = 0; } #endif /* it appears that the binmode is attached to the * file descriptor so binmode files will be handled * correctly */ pfdup = win32_fdopen(fileno, mode); /* move the file pointer to the same position */ if (!fgetpos(pf, &pos)) { fsetpos(pfdup, &pos); } return pfdup; #else return 0; #endif } struct IPerlStdIO perlStdIO = { PerlStdIOStdin, PerlStdIOStdout, PerlStdIOStderr, PerlStdIOOpen, PerlStdIOClose, PerlStdIOEof, PerlStdIOError, PerlStdIOClearerr, PerlStdIOGetc, PerlStdIOGetBase, PerlStdIOGetBufsiz, PerlStdIOGetCnt, PerlStdIOGetPtr, PerlStdIOGets, PerlStdIOPutc, PerlStdIOPuts, PerlStdIOFlush, PerlStdIOUngetc, PerlStdIOFileno, PerlStdIOFdopen, PerlStdIOReopen, PerlStdIORead, PerlStdIOWrite, PerlStdIOSetBuf, PerlStdIOSetVBuf, PerlStdIOSetCnt, PerlStdIOSetPtr, PerlStdIOSetlinebuf, PerlStdIOPrintf, PerlStdIOVprintf, PerlStdIOTell, PerlStdIOSeek, PerlStdIORewind, PerlStdIOTmpfile, PerlStdIOGetpos, PerlStdIOSetpos, PerlStdIOInit, PerlStdIOInitOSExtras, PerlStdIOFdupopen, }; #undef IPERL2HOST #define IPERL2HOST(x) IPerlLIO2Host(x) /* IPerlLIO */ int PerlLIOAccess(struct IPerlLIO* piPerl, const char *path, int mode) { return win32_access(path, mode); } int PerlLIOChmod(struct IPerlLIO* piPerl, const char *filename, int pmode) { return win32_chmod(filename, pmode); } int PerlLIOChown(struct IPerlLIO* piPerl, const char *filename, uid_t owner, gid_t group) { return chown(filename, owner, group); } int PerlLIOChsize(struct IPerlLIO* piPerl, int handle, Off_t size) { return win32_chsize(handle, size); } int PerlLIOClose(struct IPerlLIO* piPerl, int handle) { return win32_close(handle); } int PerlLIODup(struct IPerlLIO* piPerl, int handle) { return win32_dup(handle); } int PerlLIODup2(struct IPerlLIO* piPerl, int handle1, int handle2) { return win32_dup2(handle1, handle2); } int PerlLIOFlock(struct IPerlLIO* piPerl, int fd, int oper) { return win32_flock(fd, oper); } int PerlLIOFileStat(struct IPerlLIO* piPerl, int handle, Stat_t *buffer) { return win32_fstat(handle, buffer); } int PerlLIOIOCtl(struct IPerlLIO* piPerl, int i, unsigned int u, char *data) { u_long u_long_arg; int retval; /* mauke says using memcpy avoids alignment issues */ memcpy(&u_long_arg, data, sizeof u_long_arg); retval = win32_ioctlsocket((SOCKET)i, (long)u, &u_long_arg); memcpy(data, &u_long_arg, sizeof u_long_arg); return retval; } int PerlLIOIsatty(struct IPerlLIO* piPerl, int fd) { return win32_isatty(fd); } int PerlLIOLink(struct IPerlLIO* piPerl, const char*oldname, const char *newname) { return win32_link(oldname, newname); } Off_t PerlLIOLseek(struct IPerlLIO* piPerl, int handle, Off_t offset, int origin) { return win32_lseek(handle, offset, origin); } int PerlLIOLstat(struct IPerlLIO* piPerl, const char *path, Stat_t *buffer) { return win32_stat(path, buffer); } char* PerlLIOMktemp(struct IPerlLIO* piPerl, char *Template) { return mktemp(Template); } int PerlLIOOpen(struct IPerlLIO* piPerl, const char *filename, int oflag) { return win32_open(filename, oflag); } int PerlLIOOpen3(struct IPerlLIO* piPerl, const char *filename, int oflag, int pmode) { return win32_open(filename, oflag, pmode); } int PerlLIORead(struct IPerlLIO* piPerl, int handle, void *buffer, unsigned int count) { return win32_read(handle, buffer, count); } int PerlLIORename(struct IPerlLIO* piPerl, const char *OldFileName, const char *newname) { return win32_rename(OldFileName, newname); } int PerlLIOSetmode(struct IPerlLIO* piPerl, int handle, int mode) { return win32_setmode(handle, mode); } int PerlLIONameStat(struct IPerlLIO* piPerl, const char *path, Stat_t *buffer) { return win32_stat(path, buffer); } char* PerlLIOTmpnam(struct IPerlLIO* piPerl, char *string) { return tmpnam(string); } int PerlLIOUmask(struct IPerlLIO* piPerl, int pmode) { return umask(pmode); } int PerlLIOUnlink(struct IPerlLIO* piPerl, const char *filename) { return win32_unlink(filename); } int PerlLIOUtime(struct IPerlLIO* piPerl, const char *filename, struct utimbuf *times) { return win32_utime(filename, times); } int PerlLIOWrite(struct IPerlLIO* piPerl, int handle, const void *buffer, unsigned int count) { return win32_write(handle, buffer, count); } struct IPerlLIO perlLIO = { PerlLIOAccess, PerlLIOChmod, PerlLIOChown, PerlLIOChsize, PerlLIOClose, PerlLIODup, PerlLIODup2, PerlLIOFlock, PerlLIOFileStat, PerlLIOIOCtl, PerlLIOIsatty, PerlLIOLink, PerlLIOLseek, PerlLIOLstat, PerlLIOMktemp, PerlLIOOpen, PerlLIOOpen3, PerlLIORead, PerlLIORename, PerlLIOSetmode, PerlLIONameStat, PerlLIOTmpnam, PerlLIOUmask, PerlLIOUnlink, PerlLIOUtime, PerlLIOWrite, }; #undef IPERL2HOST #define IPERL2HOST(x) IPerlDir2Host(x) /* IPerlDIR */ int PerlDirMakedir(struct IPerlDir* piPerl, const char *dirname, int mode) { return win32_mkdir(dirname, mode); } int PerlDirChdir(struct IPerlDir* piPerl, const char *dirname) { return IPERL2HOST(piPerl)->Chdir(dirname); } int PerlDirRmdir(struct IPerlDir* piPerl, const char *dirname) { return win32_rmdir(dirname); } int PerlDirClose(struct IPerlDir* piPerl, DIR *dirp) { return win32_closedir(dirp); } DIR* PerlDirOpen(struct IPerlDir* piPerl, const char *filename) { return win32_opendir(filename); } struct direct * PerlDirRead(struct IPerlDir* piPerl, DIR *dirp) { return win32_readdir(dirp); } void PerlDirRewind(struct IPerlDir* piPerl, DIR *dirp) { win32_rewinddir(dirp); } void PerlDirSeek(struct IPerlDir* piPerl, DIR *dirp, long loc) { win32_seekdir(dirp, loc); } long PerlDirTell(struct IPerlDir* piPerl, DIR *dirp) { return win32_telldir(dirp); } char* PerlDirMapPathA(struct IPerlDir* piPerl, const char* path) { return IPERL2HOST(piPerl)->MapPathA(path); } WCHAR* PerlDirMapPathW(struct IPerlDir* piPerl, const WCHAR* path) { return IPERL2HOST(piPerl)->MapPathW(path); } struct IPerlDir perlDir = { PerlDirMakedir, PerlDirChdir, PerlDirRmdir, PerlDirClose, PerlDirOpen, PerlDirRead, PerlDirRewind, PerlDirSeek, PerlDirTell, PerlDirMapPathA, PerlDirMapPathW, }; /* IPerlSock */ u_long PerlSockHtonl(struct IPerlSock* piPerl, u_long hostlong) { return win32_htonl(hostlong); } u_short PerlSockHtons(struct IPerlSock* piPerl, u_short hostshort) { return win32_htons(hostshort); } u_long PerlSockNtohl(struct IPerlSock* piPerl, u_long netlong) { return win32_ntohl(netlong); } u_short PerlSockNtohs(struct IPerlSock* piPerl, u_short netshort) { return win32_ntohs(netshort); } SOCKET PerlSockAccept(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* addr, int* addrlen) { return win32_accept(s, addr, addrlen); } int PerlSockBind(struct IPerlSock* piPerl, SOCKET s, const struct sockaddr* name, int namelen) { return win32_bind(s, name, namelen); } int PerlSockConnect(struct IPerlSock* piPerl, SOCKET s, const struct sockaddr* name, int namelen) { return win32_connect(s, name, namelen); } void PerlSockEndhostent(struct IPerlSock* piPerl) { win32_endhostent(); } void PerlSockEndnetent(struct IPerlSock* piPerl) { win32_endnetent(); } void PerlSockEndprotoent(struct IPerlSock* piPerl) { win32_endprotoent(); } void PerlSockEndservent(struct IPerlSock* piPerl) { win32_endservent(); } struct hostent* PerlSockGethostbyaddr(struct IPerlSock* piPerl, const char* addr, int len, int type) { return win32_gethostbyaddr(addr, len, type); } struct hostent* PerlSockGethostbyname(struct IPerlSock* piPerl, const char* name) { return win32_gethostbyname(name); } struct hostent* PerlSockGethostent(struct IPerlSock* piPerl) { dTHX; Perl_croak(aTHX_ "gethostent not implemented!\n"); return NULL; } int PerlSockGethostname(struct IPerlSock* piPerl, char* name, int namelen) { return win32_gethostname(name, namelen); } struct netent * PerlSockGetnetbyaddr(struct IPerlSock* piPerl, long net, int type) { return win32_getnetbyaddr(net, type); } struct netent * PerlSockGetnetbyname(struct IPerlSock* piPerl, const char *name) { return win32_getnetbyname((char*)name); } struct netent * PerlSockGetnetent(struct IPerlSock* piPerl) { return win32_getnetent(); } int PerlSockGetpeername(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* name, int* namelen) { return win32_getpeername(s, name, namelen); } struct protoent* PerlSockGetprotobyname(struct IPerlSock* piPerl, const char* name) { return win32_getprotobyname(name); } struct protoent* PerlSockGetprotobynumber(struct IPerlSock* piPerl, int number) { return win32_getprotobynumber(number); } struct protoent* PerlSockGetprotoent(struct IPerlSock* piPerl) { return win32_getprotoent(); } struct servent* PerlSockGetservbyname(struct IPerlSock* piPerl, const char* name, const char* proto) { return win32_getservbyname(name, proto); } struct servent* PerlSockGetservbyport(struct IPerlSock* piPerl, int port, const char* proto) { return win32_getservbyport(port, proto); } struct servent* PerlSockGetservent(struct IPerlSock* piPerl) { return win32_getservent(); } int PerlSockGetsockname(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* name, int* namelen) { return win32_getsockname(s, name, namelen); } int PerlSockGetsockopt(struct IPerlSock* piPerl, SOCKET s, int level, int optname, char* optval, int* optlen) { return win32_getsockopt(s, level, optname, optval, optlen); } unsigned long PerlSockInetAddr(struct IPerlSock* piPerl, const char* cp) { return win32_inet_addr(cp); } char* PerlSockInetNtoa(struct IPerlSock* piPerl, struct in_addr in) { return win32_inet_ntoa(in); } int PerlSockListen(struct IPerlSock* piPerl, SOCKET s, int backlog) { return win32_listen(s, backlog); } int PerlSockRecv(struct IPerlSock* piPerl, SOCKET s, char* buffer, int len, int flags) { return win32_recv(s, buffer, len, flags); } int PerlSockRecvfrom(struct IPerlSock* piPerl, SOCKET s, char* buffer, int len, int flags, struct sockaddr* from, int* fromlen) { return win32_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 win32_select(nfds, (Perl_fd_set*)readfds, (Perl_fd_set*)writefds, (Perl_fd_set*)exceptfds, timeout); } int PerlSockSend(struct IPerlSock* piPerl, SOCKET s, const char* buffer, int len, int flags) { return win32_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 win32_sendto(s, buffer, len, flags, to, tolen); } void PerlSockSethostent(struct IPerlSock* piPerl, int stayopen) { win32_sethostent(stayopen); } void PerlSockSetnetent(struct IPerlSock* piPerl, int stayopen) { win32_setnetent(stayopen); } void PerlSockSetprotoent(struct IPerlSock* piPerl, int stayopen) { win32_setprotoent(stayopen); } void PerlSockSetservent(struct IPerlSock* piPerl, int stayopen) { win32_setservent(stayopen); } int PerlSockSetsockopt(struct IPerlSock* piPerl, SOCKET s, int level, int optname, const char* optval, int optlen) { return win32_setsockopt(s, level, optname, optval, optlen); } int PerlSockShutdown(struct IPerlSock* piPerl, SOCKET s, int how) { return win32_shutdown(s, how); } SOCKET PerlSockSocket(struct IPerlSock* piPerl, int af, int type, int protocol) { return win32_socket(af, type, protocol); } int PerlSockSocketpair(struct IPerlSock* piPerl, int domain, int type, int protocol, int* fds) { return Perl_my_socketpair(domain, type, protocol, fds); } int PerlSockClosesocket(struct IPerlSock* piPerl, SOCKET s) { return win32_closesocket(s); } int PerlSockIoctlsocket(struct IPerlSock* piPerl, SOCKET s, long cmd, u_long *argp) { return win32_ioctlsocket(s, cmd, argp); } struct IPerlSock perlSock = { PerlSockHtonl, PerlSockHtons, PerlSockNtohl, PerlSockNtohs, PerlSockAccept, PerlSockBind, PerlSockConnect, PerlSockEndhostent, PerlSockEndnetent, PerlSockEndprotoent, PerlSockEndservent, PerlSockGethostname, PerlSockGetpeername, PerlSockGethostbyaddr, PerlSockGethostbyname, PerlSockGethostent, PerlSockGetnetbyaddr, PerlSockGetnetbyname, PerlSockGetnetent, PerlSockGetprotobyname, PerlSockGetprotobynumber, PerlSockGetprotoent, PerlSockGetservbyname, PerlSockGetservbyport, PerlSockGetservent, PerlSockGetsockname, PerlSockGetsockopt, PerlSockInetAddr, PerlSockInetNtoa, PerlSockListen, PerlSockRecv, PerlSockRecvfrom, PerlSockSelect, PerlSockSend, PerlSockSendto, PerlSockSethostent, PerlSockSetnetent, PerlSockSetprotoent, PerlSockSetservent, PerlSockSetsockopt, PerlSockShutdown, PerlSockSocket, PerlSockSocketpair, PerlSockClosesocket, }; /* IPerlProc */ #define EXECF_EXEC 1 #define EXECF_SPAWN 2 void PerlProcAbort(struct IPerlProc* piPerl) { win32_abort(); } char * PerlProcCrypt(struct IPerlProc* piPerl, const char* clear, const char* salt) { return win32_crypt(clear, salt); } void PerlProcExit(struct IPerlProc* piPerl, int status) { exit(status); } void PerlProc_Exit(struct IPerlProc* piPerl, int status) { _exit(status); } int PerlProcExecl(struct IPerlProc* piPerl, const char *cmdname, const char *arg0, const char *arg1, const char *arg2, const char *arg3) { return execl(cmdname, arg0, arg1, arg2, arg3); } int PerlProcExecv(struct IPerlProc* piPerl, const char *cmdname, const char *const *argv) { return win32_execvp(cmdname, argv); } int PerlProcExecvp(struct IPerlProc* piPerl, const char *cmdname, const char *const *argv) { return win32_execvp(cmdname, argv); } uid_t PerlProcGetuid(struct IPerlProc* piPerl) { return getuid(); } uid_t PerlProcGeteuid(struct IPerlProc* piPerl) { return geteuid(); } gid_t PerlProcGetgid(struct IPerlProc* piPerl) { return getgid(); } gid_t PerlProcGetegid(struct IPerlProc* piPerl) { return getegid(); } char * PerlProcGetlogin(struct IPerlProc* piPerl) { return g_getlogin(); } int PerlProcKill(struct IPerlProc* piPerl, int pid, int sig) { return win32_kill(pid, sig); } int PerlProcKillpg(struct IPerlProc* piPerl, int pid, int sig) { return win32_kill(pid, -sig); } int PerlProcPauseProc(struct IPerlProc* piPerl) { return win32_sleep((32767L << 16) + 32767); } PerlIO* PerlProcPopen(struct IPerlProc* piPerl, const char *command, const char *mode) { dTHX; PERL_FLUSHALL_FOR_CHILD; return win32_popen(command, mode); } PerlIO* PerlProcPopenList(struct IPerlProc* piPerl, const char *mode, IV narg, SV **args) { dTHX; PERL_FLUSHALL_FOR_CHILD; return win32_popenlist(mode, narg, args); } int PerlProcPclose(struct IPerlProc* piPerl, PerlIO *stream) { return win32_pclose(stream); } int PerlProcPipe(struct IPerlProc* piPerl, int *phandles) { return win32_pipe(phandles, 512, O_BINARY); } int PerlProcSetuid(struct IPerlProc* piPerl, uid_t u) { return setuid(u); } int PerlProcSetgid(struct IPerlProc* piPerl, gid_t g) { return setgid(g); } int PerlProcSleep(struct IPerlProc* piPerl, unsigned int s) { return win32_sleep(s); } int PerlProcTimes(struct IPerlProc* piPerl, struct tms *timebuf) { return win32_times(timebuf); } int PerlProcWait(struct IPerlProc* piPerl, int *status) { return win32_wait(status); } int PerlProcWaitpid(struct IPerlProc* piPerl, int pid, int *status, int flags) { return win32_waitpid(pid, status, flags); } Sighandler_t PerlProcSignal(struct IPerlProc* piPerl, int sig, Sighandler_t subcode) { return win32_signal(sig, subcode); } int PerlProcGetTimeOfDay(struct IPerlProc* piPerl, struct timeval *t, void *z) { return win32_gettimeofday(t, z); } #ifdef USE_ITHREADS static THREAD_RET_TYPE win32_start_child(LPVOID arg) { PerlInterpreter *my_perl = (PerlInterpreter*)arg; GV *tmpgv; int status; HWND parent_message_hwnd; #ifdef PERL_SYNC_FORK static long sync_fork_id = 0; long id = ++sync_fork_id; #endif PERL_SET_THX(my_perl); win32_checkTLS(my_perl); /* set $$ to pseudo id */ #ifdef PERL_SYNC_FORK w32_pseudo_id = id; #else w32_pseudo_id = GetCurrentThreadId(); if (IsWin95()) { int pid = (int)w32_pseudo_id; if (pid < 0) w32_pseudo_id = -pid; } #endif if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV)) { SV *sv = GvSV(tmpgv); SvREADONLY_off(sv); sv_setiv(sv, -(IV)w32_pseudo_id); SvREADONLY_on(sv); } #ifdef PERL_USES_PL_PIDSTATUS hv_clear(PL_pidstatus); #endif /* create message window and tell parent about it */ parent_message_hwnd = w32_message_hwnd; w32_message_hwnd = win32_create_message_window(); if (parent_message_hwnd != NULL) PostMessage(parent_message_hwnd, WM_USER_MESSAGE, w32_pseudo_id, (LPARAM)w32_message_hwnd); /* 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; { dJMPENV; volatile int oldscope = 1; /* We are responsible for all scopes */ restart: 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 * different interpreter, but we also cannot leave PL_scopestack_ix * dangling because that can trigger an assertion in perl_destruct(). */ if (PL_scopestack_ix > oldscope) { 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_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 */ win32_checkTLS(my_perl); 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); } /* destroy everything (waits for any pseudo-forked children) */ win32_checkTLS(my_perl); perl_destruct(my_perl); win32_checkTLS(my_perl); perl_free(my_perl); #ifdef PERL_SYNC_FORK return id; #else return (DWORD)status; #endif } #endif /* USE_ITHREADS */ int PerlProcFork(struct IPerlProc* piPerl) { dTHX; #ifdef USE_ITHREADS DWORD id; HANDLE handle; CPerlHost *h; if (w32_num_pseudo_children >= MAXIMUM_WAIT_OBJECTS) { 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 ); new_perl->Isys_intern.internal_host = h; h->host_perl = new_perl; # ifdef PERL_SYNC_FORK id = win32_start_child((LPVOID)new_perl); PERL_SET_THX(aTHX); # else if (w32_message_hwnd == INVALID_HANDLE_VALUE) w32_message_hwnd = win32_create_message_window(); new_perl->Isys_intern.message_hwnd = w32_message_hwnd; w32_pseudo_child_message_hwnds[w32_num_pseudo_children] = (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); # else handle = CreateThread(NULL, 0, win32_start_child, (LPVOID)new_perl, 0, &id); # endif PERL_SET_THX(aTHX); /* XXX perl_clone*() set TLS */ if (!handle) { errno = EAGAIN; return -1; } if (IsWin95()) { int pid = (int)id; if (pid < 0) id = -pid; } w32_pseudo_child_handles[w32_num_pseudo_children] = handle; w32_pseudo_child_pids[w32_num_pseudo_children] = id; ++w32_num_pseudo_children; # endif return -(int)id; #else Perl_croak(aTHX_ "fork() not implemented!\n"); return -1; #endif /* USE_ITHREADS */ } int PerlProcGetpid(struct IPerlProc* piPerl) { return win32_getpid(); } void* PerlProcDynaLoader(struct IPerlProc* piPerl, const char* filename) { return win32_dynaload(filename); } void PerlProcGetOSError(struct IPerlProc* piPerl, SV* sv, DWORD dwErr) { win32_str_os_error(sv, dwErr); } int PerlProcSpawnvp(struct IPerlProc* piPerl, int mode, const char *cmdname, const char *const *argv) { return win32_spawnvp(mode, cmdname, argv); } int PerlProcLastHost(struct IPerlProc* piPerl) { dTHX; CPerlHost *h = (CPerlHost*)w32_internal_host; return h->LastHost(); } struct IPerlProc perlProc = { PerlProcAbort, PerlProcCrypt, PerlProcExit, PerlProc_Exit, PerlProcExecl, PerlProcExecv, PerlProcExecvp, PerlProcGetuid, PerlProcGeteuid, PerlProcGetgid, PerlProcGetegid, PerlProcGetlogin, PerlProcKill, PerlProcKillpg, PerlProcPauseProc, PerlProcPopen, PerlProcPclose, PerlProcPipe, PerlProcSetuid, PerlProcSetgid, PerlProcSleep, PerlProcTimes, PerlProcWait, PerlProcWaitpid, PerlProcSignal, PerlProcFork, PerlProcGetpid, PerlProcDynaLoader, PerlProcGetOSError, PerlProcSpawnvp, PerlProcLastHost, PerlProcPopenList, PerlProcGetTimeOfDay }; /* * CPerlHost */ CPerlHost::CPerlHost(void) { /* Construct a host from scratch */ InterlockedIncrement(&num_hosts); m_pvDir = new VDir(); m_pVMem = new VMem(); m_pVMemShared = new VMem(); m_pVMemParse = new VMem(); m_pvDir->Init(NULL, m_pVMem); m_dwEnvCount = 0; m_lppEnvList = NULL; m_bTopLevel = TRUE; CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem)); CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared)); CopyMemory(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse)); CopyMemory(&m_hostperlEnv, &perlEnv, sizeof(perlEnv)); CopyMemory(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO)); CopyMemory(&m_hostperlLIO, &perlLIO, sizeof(perlLIO)); CopyMemory(&m_hostperlDir, &perlDir, sizeof(perlDir)); CopyMemory(&m_hostperlSock, &perlSock, sizeof(perlSock)); CopyMemory(&m_hostperlProc, &perlProc, sizeof(perlProc)); m_pHostperlMem = &m_hostperlMem; m_pHostperlMemShared = &m_hostperlMemShared; m_pHostperlMemParse = &m_hostperlMemParse; m_pHostperlEnv = &m_hostperlEnv; m_pHostperlStdIO = &m_hostperlStdIO; m_pHostperlLIO = &m_hostperlLIO; m_pHostperlDir = &m_hostperlDir; m_pHostperlSock = &m_hostperlSock; m_pHostperlProc = &m_hostperlProc; } #define SETUPEXCHANGE(xptr, iptr, table) \ STMT_START { \ 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) { InterlockedIncrement(&num_hosts); m_pvDir = new VDir(0); m_pVMem = new VMem(); m_pVMemShared = new VMem(); m_pVMemParse = new VMem(); m_pvDir->Init(NULL, m_pVMem); m_dwEnvCount = 0; m_lppEnvList = NULL; m_bTopLevel = FALSE; CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem)); CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared)); CopyMemory(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse)); CopyMemory(&m_hostperlEnv, &perlEnv, sizeof(perlEnv)); CopyMemory(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO)); CopyMemory(&m_hostperlLIO, &perlLIO, sizeof(perlLIO)); CopyMemory(&m_hostperlDir, &perlDir, sizeof(perlDir)); CopyMemory(&m_hostperlSock, &perlSock, sizeof(perlSock)); CopyMemory(&m_hostperlProc, &perlProc, sizeof(perlProc)); SETUPEXCHANGE(ppMem, m_pHostperlMem, m_hostperlMem); SETUPEXCHANGE(ppMemShared, m_pHostperlMemShared, m_hostperlMemShared); SETUPEXCHANGE(ppMemParse, m_pHostperlMemParse, m_hostperlMemParse); SETUPEXCHANGE(ppEnv, m_pHostperlEnv, m_hostperlEnv); SETUPEXCHANGE(ppStdIO, m_pHostperlStdIO, m_hostperlStdIO); SETUPEXCHANGE(ppLIO, m_pHostperlLIO, m_hostperlLIO); SETUPEXCHANGE(ppDir, m_pHostperlDir, m_hostperlDir); SETUPEXCHANGE(ppSock, m_pHostperlSock, m_hostperlSock); SETUPEXCHANGE(ppProc, m_pHostperlProc, m_hostperlProc); } #undef SETUPEXCHANGE CPerlHost::CPerlHost(CPerlHost& host) { /* Construct a host from another host */ InterlockedIncrement(&num_hosts); m_pVMem = new VMem(); m_pVMemShared = host.GetMemShared(); m_pVMemParse = host.GetMemParse(); /* duplicate directory info */ m_pvDir = new VDir(0); m_pvDir->Init(host.GetDir(), m_pVMem); CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem)); CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared)); CopyMemory(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse)); CopyMemory(&m_hostperlEnv, &perlEnv, sizeof(perlEnv)); CopyMemory(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO)); CopyMemory(&m_hostperlLIO, &perlLIO, sizeof(perlLIO)); CopyMemory(&m_hostperlDir, &perlDir, sizeof(perlDir)); CopyMemory(&m_hostperlSock, &perlSock, sizeof(perlSock)); CopyMemory(&m_hostperlProc, &perlProc, sizeof(perlProc)); m_pHostperlMem = &m_hostperlMem; m_pHostperlMemShared = &m_hostperlMemShared; m_pHostperlMemParse = &m_hostperlMemParse; m_pHostperlEnv = &m_hostperlEnv; m_pHostperlStdIO = &m_hostperlStdIO; m_pHostperlLIO = &m_hostperlLIO; m_pHostperlDir = &m_hostperlDir; m_pHostperlSock = &m_hostperlSock; m_pHostperlProc = &m_hostperlProc; m_dwEnvCount = 0; m_lppEnvList = NULL; m_bTopLevel = FALSE; /* duplicate environment info */ LPSTR lpPtr; DWORD dwIndex = 0; while(lpPtr = host.GetIndex(dwIndex)) Add(lpPtr); } CPerlHost::~CPerlHost(void) { Reset(); InterlockedDecrement(&num_hosts); delete m_pvDir; m_pVMemParse->Release(); m_pVMemShared->Release(); m_pVMem->Release(); } LPSTR CPerlHost::Find(LPCSTR lpStr) { LPSTR lpPtr; LPSTR* lppPtr = Lookup(lpStr); if(lppPtr != NULL) { for(lpPtr = *lppPtr; *lpPtr != '\0' && *lpPtr != '='; ++lpPtr) ; if(*lpPtr == '=') ++lpPtr; return lpPtr; } return NULL; } int lookup(const void *arg1, const void *arg2) { // Compare strings char*ptr1, *ptr2; char c1,c2; 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 } } } return 0; } LPSTR* CPerlHost::Lookup(LPCSTR lpStr) { #ifdef UNDER_CE if (!m_lppEnvList || !m_dwEnvCount) return NULL; #endif if (!lpStr) return NULL; return (LPSTR*)bsearch(&lpStr, m_lppEnvList, m_dwEnvCount, sizeof(LPSTR), lookup); } int compare(const void *arg1, const void *arg2) { // Compare strings char*ptr1, *ptr2; char c1,c2; 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 } } } return 0; } void CPerlHost::Add(LPCSTR lpStr) { dTHX; char szBuffer[1024]; LPSTR *lpPtr; int index, length = strlen(lpStr)+1; for(index = 0; lpStr[index] != '\0' && lpStr[index] != '='; ++index) szBuffer[index] = lpStr[index]; szBuffer[index] = '\0'; // replacing ? lpPtr = Lookup(szBuffer); 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); } 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); } } } } DWORD CPerlHost::CalculateEnvironmentSpace(void) { DWORD index; DWORD dwSize = 0; for(index = 0; index < m_dwEnvCount; ++index) dwSize += strlen(m_lppEnvList[index]) + 1; return dwSize; } void CPerlHost::FreeLocalEnvironmentStrings(LPSTR lpStr) { dTHX; Safefree(lpStr); } char* CPerlHost::GetChildDir(void) { dTHX; char* ptr; size_t length; Newx(ptr, MAX_PATH+1, char); m_pvDir->GetCurrentDirectoryA(MAX_PATH+1, ptr); length = strlen(ptr); if (length > 3) { if ((ptr[length-1] == '\\') || (ptr[length-1] == '/')) ptr[length-1] = 0; } return ptr; } void CPerlHost::FreeChildDir(char* pStr) { dTHX; Safefree(pStr); } LPSTR CPerlHost::CreateLocalEnvironmentStrings(VDir &vDir) { dTHX; LPSTR lpStr, lpPtr, lpEnvPtr, lpTmp, lpLocalEnv, lpAllocPtr; DWORD dwSize, dwEnvIndex; int nLength, compVal; // get the process environment strings lpAllocPtr = lpTmp = (LPSTR)GetEnvironmentStrings(); // step over current directory stuff while(*lpTmp == '=') 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; } // add the size of current directories dwSize += vDir.CalculateEnvironmentSpace(); // add the additional space used by changes made to the environment dwSize += CalculateEnvironmentSpace(); 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'; } // release the process environment strings FreeEnvironmentStrings(lpAllocPtr); return lpPtr; } void CPerlHost::Reset(void) { dTHX; if(m_lppEnvList != NULL) { for(DWORD index = 0; index < m_dwEnvCount; ++index) { Free(m_lppEnvList[index]); m_lppEnvList[index] = NULL; } } m_dwEnvCount = 0; Free(m_lppEnvList); m_lppEnvList = NULL; } void CPerlHost::Clearenv(void) { dTHX; 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; } } } /* get the process environment strings */ lpStr = lpEnvPtr = (LPSTR)GetEnvironmentStrings(); /* step over current directory stuff */ while(*lpStr == '=') 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; } FreeEnvironmentStrings(lpEnvPtr); } char* CPerlHost::Getenv(const char *varname) { dTHX; if (!m_bTopLevel) { char *pEnv = Find(varname); if (pEnv && *pEnv) return pEnv; } return win32_getenv(varname); } int CPerlHost::Putenv(const char *envstring) { dTHX; Add(envstring); if (m_bTopLevel) return win32_putenv(envstring); return 0; } int CPerlHost::Chdir(const char *dirname) { dTHX; int ret; if (!dirname) { errno = ENOENT; return -1; } ret = m_pvDir->SetCurrentDirectoryA((char*)dirname); if(ret < 0) { errno = ENOENT; } return ret; } #endif /* ___PerlHost_H___ */ perl-5.12.0-RC0/win32/config.gc0000444000175000017500000005301211325127002014641 0ustar jessejesse## Configured by: ~cf_email~ ## Target system: WIN32 Author='' Date='$Date' Header='' Id='$Id' Locker='' Log='$Log' RCSfile='$RCSfile' Revision='$Revision' Source='' State='' _a='.a' _exe='.exe' _o='.o' afs='false' afsroot='/afs' alignbytes='8' ansi2knr='' aphostname='' api_revision='~PERL_API_REVISION~' api_subversion='~PERL_API_SUBVERSION~' api_version='~PERL_API_VERSION~' api_versionstring='~PERL_API_REVISION~.~PERL_API_VERSION~.~PERL_API_SUBVERSION~' ar='ar' archlib='~INST_TOP~~INST_VER~\lib~INST_ARCH~' archlibexp='~INST_TOP~~INST_VER~\lib~INST_ARCH~' archname64='' archname='MSWin32' archobjs='' asctime_r_proto='0' awk='awk' baserev='5' bash='' bin='~INST_TOP~~INST_VER~\bin~INST_ARCH~' binexp='~INST_TOP~~INST_VER~\bin~INST_ARCH~' bison='' byacc='byacc' byteorder='1234' c='' castflags='0' cat='type' cc='gcc' cccdlflags=' ' ccdlflags=' ' ccflags='-MD -DWIN32' ccflags_uselargefiles='' ccname='~cc~' ccsymbols='' ccversion='' cf_by='nobody' cf_email='nobody@no.where.net' cf_time='' charbits='8' chgrp='' chmod='' chown='' clocktype='clock_t' comm='' compress='' contains='grep' cp='copy' cpio='' cpp='~cc~ -E' cpp_stuff='42' cppccsymbols='' cppflags='-DWIN32' cpplast='' cppminus='-' cpprun='~cc~ -E' cppstdin='~cc~ -E' cppsymbols='' crypt_r_proto='0' cryptlib='' csh='undef' ctermid_r_proto='0' ctime_r_proto='0' d_Gconvert='sprintf((b),"%.*g",(n),(x))' d_PRIEUldbl='undef' d_PRIFUldbl='undef' d_PRIGUldbl='undef' d_PRIXU64='undef' d_PRId64='undef' d_PRIeldbl='undef' d_PRIfldbl='undef' d_PRIgldbl='undef' d_PRIi64='undef' d_PRIo64='undef' d_PRIu64='undef' d_PRIx64='undef' d_SCNfldbl='undef' d__fwalk='undef' d_access='define' d_accessx='undef' d_aintl='undef' d_alarm='define' d_archlib='define' d_asctime64='undef' d_asctime_r='undef' d_atolf='undef' d_atoll='undef' d_attribute_deprecated='undef' d_attribute_format='undef' d_attribute_malloc='undef' d_attribute_nonnull='undef' d_attribute_noreturn='undef' d_attribute_pure='undef' d_attribute_unused='undef' d_attribute_warn_unused_result='undef' d_bcmp='undef' d_bcopy='undef' d_bsd='define' d_bsdgetpgrp='undef' d_bsdsetpgrp='undef' d_builtin_choose_expr='undef' d_builtin_expect='undef' d_bzero='undef' d_c99_variadic_macros='undef' d_casti32='define' d_castneg='define' d_charvspr='undef' d_chown='undef' d_chroot='undef' d_chsize='define' d_class='undef' d_clearenv='undef' d_closedir='define' d_cmsghdr_s='undef' d_const='define' d_copysignl='undef' d_cplusplus='undef' d_crypt='undef' d_crypt_r='undef' d_csh='undef' d_ctermid='undef' d_ctermid_r='undef' d_ctime64='undef' d_ctime_r='undef' d_cuserid='undef' d_dbl_dig='define' d_dbminitproto='undef' d_difftime64='undef' d_difftime='define' d_dir_dd_fd='undef' d_dirfd='undef' d_dirnamlen='define' d_dlerror='define' d_dlopen='define' d_dlsymun='undef' d_dosuid='undef' d_drand48_r='undef' d_drand48proto='undef' d_dup2='define' d_eaccess='undef' d_endgrent='undef' d_endgrent_r='undef' d_endhent='undef' d_endhostent_r='undef' d_endnent='undef' d_endnetent_r='undef' d_endpent='undef' d_endprotoent_r='undef' d_endpwent='undef' d_endpwent_r='undef' d_endsent='undef' d_endservent_r='undef' d_eofnblk='define' d_eunice='undef' d_faststdio='define' d_fchdir='undef' d_fchmod='undef' d_fchown='undef' d_fcntl_can_lock='undef' d_fcntl='undef' d_fd_macros='define' d_fd_set='define' d_fds_bits='define' d_fgetpos='define' d_finitel='undef' d_finite='undef' d_flexfnam='define' d_flock='define' d_flockproto='define' d_fork='undef' d_fp_class='undef' d_fpathconf='undef' d_fpclass='undef' d_fpclassify='undef' d_fpclassl='undef' d_fpos64_t='undef' d_frexpl='undef' d_fs_data_s='undef' d_fseeko='undef' d_fsetpos='define' d_fstatfs='undef' d_fstatvfs='undef' d_fsync='undef' d_ftello='undef' d_ftime='define' d_futimes='undef' d_gdbm_ndbm_h_uses_prototypes='undef' d_gdbmndbm_h_uses_prototypes='undef' d_getaddrinfo='undef' d_getcwd='define' d_getespwnam='undef' d_getfsstat='undef' d_getgrent='undef' d_getgrent_r='undef' d_getgrgid_r='undef' d_getgrnam_r='undef' d_getgrps='undef' d_gethbyaddr='define' d_gethbyname='define' d_gethent='undef' d_gethname='define' d_gethostbyaddr_r='undef' d_gethostbyname_r='undef' d_gethostent_r='undef' d_gethostprotos='define' d_getitimer='undef' d_getlogin='define' d_getlogin_r='undef' d_getmnt='undef' d_getmntent='undef' d_getnameinfo='undef' d_getnbyaddr='undef' d_getnbyname='undef' d_getnent='undef' d_getnetbyaddr_r='undef' d_getnetbyname_r='undef' d_getnetent_r='undef' d_getnetprotos='undef' d_getpagsz='undef' d_getpbyname='define' d_getpbynumber='define' d_getpent='undef' d_getpgid='undef' d_getpgrp2='undef' d_getpgrp='undef' d_getppid='undef' d_getprior='undef' d_getprotobyname_r='undef' d_getprotobynumber_r='undef' d_getprotoent_r='undef' d_getprotoprotos='define' d_getprpwnam='undef' d_getpwent='undef' d_getpwent_r='undef' d_getpwnam_r='undef' d_getpwuid_r='undef' d_getsbyname='define' d_getsbyport='define' d_getsent='undef' d_getservbyname_r='undef' d_getservbyport_r='undef' d_getservent_r='undef' d_getservprotos='define' d_getspnam='undef' d_getspnam_r='undef' d_gettimeod='define' d_gmtime64='undef' d_gmtime_r='undef' d_gnulibc='undef' d_grpasswd='undef' d_hasmntopt='undef' d_htonl='define' d_ilogbl='undef' d_inc_version_list='undef' d_index='undef' d_inetaton='undef' d_inetntop='undef' d_inetpton='undef' d_int64_t='undef' d_isascii='define' d_isfinite='undef' d_isinf='undef' d_isnan='define' d_isnanl='undef' d_killpg='define' d_lchown='undef' d_ldbl_dig='define' d_libm_lib_version='undef' d_link='define' d_localtime64='undef' d_localtime_r='undef' d_localtime_r_needs_tzset='undef' d_locconv='define' d_lockf='undef' d_longdbl='define' d_longlong='undef' d_lseekproto='define' d_lstat='undef' d_madvise='undef' d_malloc_good_size='undef' d_malloc_size='undef' d_mblen='define' d_mbstowcs='define' d_mbtowc='define' d_memchr='define' d_memcmp='define' d_memcpy='define' d_memmove='define' d_memset='define' d_mkdir='define' d_mkdtemp='undef' d_mkfifo='undef' d_mkstemp='undef' d_mkstemps='undef' d_mktime64='undef' d_mktime='define' d_mmap='undef' d_modfl='undef' d_modfl_pow32_bug='undef' d_modflproto='undef' d_mprotect='undef' d_msgctl='undef' d_msg_ctrunc='undef' d_msg_dontroute='undef' d_msgget='undef' d_msghdr_s='undef' d_msg_oob='undef' d_msg_peek='undef' d_msg_proxy='undef' d_msgrcv='undef' d_msgsnd='undef' d_msg='undef' d_msync='undef' d_munmap='undef' d_mymalloc='undef' d_ndbm='undef' d_ndbm_h_uses_prototypes='undef' d_nice='undef' d_nl_langinfo='undef' d_nv_preserves_uv='define' d_nv_zero_is_allbits_zero='define' d_off64_t='undef' d_old_pthread_create_joinable='undef' d_oldpthreads='undef' d_oldsock='undef' d_open3='undef' d_pathconf='undef' d_pause='define' d_perl_otherlibdirs='undef' d_phostname='undef' d_pipe='define' d_poll='undef' d_portable='define' d_printf_format_null='undef' d_procselfexe='undef' d_pseudofork='undef' d_pthread_atfork='undef' d_pthread_attr_setscope='undef' d_pthread_yield='undef' d_pwage='undef' d_pwchange='undef' d_pwclass='undef' d_pwcomment='undef' d_pwexpire='undef' d_pwgecos='undef' d_pwpasswd='undef' d_pwquota='undef' d_qgcvt='undef' d_quad='define' d_random_r='undef' d_readdir64_r='undef' d_readdir='define' d_readdir_r='undef' d_readlink='undef' d_readv='undef' d_recvmsg='undef' d_rename='define' d_rewinddir='define' d_rmdir='define' d_safebcpy='undef' d_safemcpy='undef' d_sanemcmp='define' d_sbrkproto='undef' d_scalbnl='undef' d_sched_yield='undef' d_scm_rights='undef' d_seekdir='define' d_select='define' d_sem='undef' d_semctl='undef' d_semctl_semid_ds='undef' d_semctl_semun='undef' d_semget='undef' d_semop='undef' d_sendmsg='undef' d_setegid='undef' d_seteuid='undef' d_setgrent='undef' d_setgrent_r='undef' d_setgrps='undef' d_sethent='undef' d_sethostent_r='undef' d_setitimer='undef' d_setlinebuf='undef' d_setlocale='define' d_setlocale_r='undef' d_setnent='undef' d_setnetent_r='undef' d_setpent='undef' d_setpgid='undef' d_setpgrp2='undef' d_setpgrp='undef' d_setprior='undef' d_setproctitle='undef' d_setprotoent_r='undef' d_setpwent='undef' d_setpwent_r='undef' d_setregid='undef' d_setresgid='undef' d_setresuid='undef' d_setreuid='undef' d_setrgid='undef' d_setruid='undef' d_setsent='undef' d_setservent_r='undef' d_setsid='undef' d_setvbuf='define' d_sfio='undef' d_shm='undef' d_shmat='undef' d_shmatprototype='undef' d_shmctl='undef' d_shmdt='undef' d_shmget='undef' d_sigaction='undef' d_signbit='undef' d_sigprocmask='undef' d_sigsetjmp='undef' d_sitearch='define' d_snprintf='define' d_sockatmark='undef' d_sockatmarkproto='undef' d_socket='define' d_socklen_t='undef' d_sockpair='undef' d_socks5_init='undef' d_sprintf_returns_strlen='define' d_sqrtl='undef' d_srand48_r='undef' d_srandom_r='undef' d_sresgproto='undef' d_sresuproto='undef' d_statblks='undef' d_statfs_f_flags='undef' d_statfs_s='undef' d_statvfs='undef' d_stdio_cnt_lval='define' d_stdio_ptr_lval='define' d_stdio_ptr_lval_nochange_cnt='define' d_stdio_ptr_lval_sets_cnt='undef' d_stdio_stream_array='undef' d_stdiobase='define' d_stdstdio='define' d_strchr='define' d_strcoll='define' d_strctcpy='define' d_strerrm='strerror(e)' d_strerror='define' d_strerror_r='undef' d_strftime='define' d_strlcat='undef' d_strlcpy='undef' d_strtod='define' d_strtol='define' d_strtold='undef' d_strtoll='undef' d_strtoq='undef' d_strtoul='define' d_strtoull='undef' d_strtouq='undef' d_strxfrm='define' d_suidsafe='undef' d_symlink='undef' d_syscall='undef' d_syscallproto='undef' d_sysconf='undef' d_sysernlst='' d_syserrlst='define' d_system='define' d_tcgetpgrp='undef' d_tcsetpgrp='undef' d_telldir='define' d_telldirproto='define' d_time='define' d_timegm='undef' d_times='define' d_tm_tm_gmtoff='undef' d_tm_tm_zone='undef' d_tmpnam_r='undef' d_truncate='undef' d_ttyname_r='undef' d_tzname='define' d_u32align='define' d_ualarm='undef' d_umask='define' d_uname='define' d_union_semun='define' d_unordered='undef' d_unsetenv='undef' d_usleep='undef' d_usleepproto='undef' d_ustat='undef' d_vendorarch='undef' d_vendorbin='undef' d_vendorlib='undef' d_vendorscript='undef' d_vfork='undef' d_void_closedir='undef' d_voidsig='define' d_voidtty='' d_volatile='define' d_vprintf='define' d_vsnprintf='define' d_wait4='undef' d_waitpid='define' d_wcstombs='define' d_wctomb='define' d_writev='undef' d_xenix='undef' date='date' db_hashtype='int' db_prefixtype='int' db_version_major='0' db_version_minor='0' db_version_patch='0' defvoidused='15' direntrytype='struct direct' dlext='dll' dlsrc='dl_win32.xs' doublesize='8' drand01='(rand()/(double)((unsigned)1< #include #include #include #include int main(int argc, char *argv[]) { int i; size_t len; char root[MAX_PATH]; char *dummy; char volname[MAX_PATH]; DWORD serial, maxname, flags; BOOL downcase = TRUE; /* 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); } } setmode(fileno(stdout), 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); } return 0; } perl-5.12.0-RC0/win32/config.vc0000444000175000017500000005302311325127002014662 0ustar jessejesse## Configured by: ~cf_email~ ## Target system: WIN32 Author='' Date='$Date' Header='' Id='$Id' Locker='' Log='$Log' RCSfile='$RCSfile' Revision='$Revision' Source='' State='' _a='.lib' _exe='.exe' _o='.obj' afs='false' afsroot='/afs' alignbytes='8' ansi2knr='' aphostname='' api_revision='~PERL_API_REVISION~' api_subversion='~PERL_API_SUBVERSION~' api_version='~PERL_API_VERSION~' api_versionstring='~PERL_API_REVISION~.~PERL_API_VERSION~.~PERL_API_SUBVERSION~' ar='lib' archlib='~INST_TOP~~INST_VER~\lib~INST_ARCH~' archlibexp='~INST_TOP~~INST_VER~\lib~INST_ARCH~' archname64='' archname='MSWin32' archobjs='' asctime_r_proto='0' awk='awk' baserev='5' bash='' bin='~INST_TOP~~INST_VER~\bin~INST_ARCH~' binexp='~INST_TOP~~INST_VER~\bin~INST_ARCH~' bison='' byacc='byacc' byteorder='1234' c='' castflags='0' cat='type' cc='cl' cccdlflags=' ' ccdlflags=' ' ccflags='-MD -DWIN32' ccflags_uselargefiles='' ccname='~cc~' ccsymbols='' ccversion='' cf_by='nobody' cf_email='nobody@no.where.net' cf_time='' charbits='8' chgrp='' chmod='' chown='' clocktype='clock_t' comm='' compress='' contains='grep' cp='copy' cpio='' cpp='~cc~ -nologo -E' cpp_stuff='42' cppccsymbols='' cppflags='-DWIN32' cpplast='' cppminus='' cpprun='~cc~ -nologo -E' cppstdin='cppstdin' cppsymbols='' crypt_r_proto='0' cryptlib='' csh='undef' ctermid_r_proto='0' ctime_r_proto='0' d_Gconvert='sprintf((b),"%.*g",(n),(x))' d_PRIEUldbl='undef' d_PRIFUldbl='undef' d_PRIGUldbl='undef' d_PRIXU64='undef' d_PRId64='undef' d_PRIeldbl='undef' d_PRIfldbl='undef' d_PRIgldbl='undef' d_PRIi64='undef' d_PRIo64='undef' d_PRIu64='undef' d_PRIx64='undef' d_SCNfldbl='undef' d__fwalk='undef' d_access='define' d_accessx='undef' d_aintl='undef' d_alarm='define' d_archlib='define' d_asctime64='undef' d_asctime_r='undef' d_atolf='undef' d_atoll='undef' d_attribute_deprecated='undef' d_attribute_format='undef' d_attribute_malloc='undef' d_attribute_nonnull='undef' d_attribute_noreturn='undef' d_attribute_pure='undef' d_attribute_unused='undef' d_attribute_warn_unused_result='undef' d_bcmp='undef' d_bcopy='undef' d_bsd='define' d_bsdgetpgrp='undef' d_bsdsetpgrp='undef' d_builtin_choose_expr='undef' d_builtin_expect='undef' d_bzero='undef' d_c99_variadic_macros='undef' d_casti32='undef' d_castneg='define' d_charvspr='undef' d_chown='undef' d_chroot='undef' d_chsize='define' d_class='undef' d_clearenv='undef' d_closedir='define' d_cmsghdr_s='undef' d_const='define' d_copysignl='undef' d_cplusplus='undef' d_crypt='undef' d_crypt_r='undef' d_csh='undef' d_ctermid='undef' d_ctermid_r='undef' d_ctime64='undef' d_ctime_r='undef' d_cuserid='undef' d_dbl_dig='define' d_dbminitproto='undef' d_difftime64='undef' d_difftime='define' d_dir_dd_fd='undef' d_dirfd='undef' d_dirnamlen='define' d_dlerror='define' d_dlopen='define' d_dlsymun='undef' d_dosuid='undef' d_drand48_r='undef' d_drand48proto='undef' d_dup2='define' d_eaccess='undef' d_endgrent='undef' d_endgrent_r='undef' d_endhent='undef' d_endhostent_r='undef' d_endnent='undef' d_endnetent_r='undef' d_endpent='undef' d_endprotoent_r='undef' d_endpwent='undef' d_endpwent_r='undef' d_endsent='undef' d_endservent_r='undef' d_eofnblk='define' d_eunice='undef' d_faststdio='define' d_fchdir='undef' d_fchmod='undef' d_fchown='undef' d_fcntl_can_lock='undef' d_fcntl='undef' d_fd_macros='define' d_fd_set='define' d_fds_bits='define' d_fgetpos='define' d_finitel='undef' d_finite='undef' d_flexfnam='define' d_flock='define' d_flockproto='define' d_fork='undef' d_fp_class='undef' d_fpathconf='undef' d_fpclass='undef' d_fpclassify='undef' d_fpclassl='undef' d_fpos64_t='undef' d_frexpl='undef' d_fs_data_s='undef' d_fseeko='undef' d_fsetpos='define' d_fstatfs='undef' d_fstatvfs='undef' d_fsync='undef' d_ftello='undef' d_ftime='define' d_futimes='undef' d_gdbm_ndbm_h_uses_prototypes='undef' d_gdbmndbm_h_uses_prototypes='undef' d_getaddrinfo='undef' d_getcwd='define' d_getespwnam='undef' d_getfsstat='undef' d_getgrent='undef' d_getgrent_r='undef' d_getgrgid_r='undef' d_getgrnam_r='undef' d_getgrps='undef' d_gethbyaddr='define' d_gethbyname='define' d_gethent='undef' d_gethname='define' d_gethostbyaddr_r='undef' d_gethostbyname_r='undef' d_gethostent_r='undef' d_gethostprotos='define' d_getitimer='undef' d_getlogin='define' d_getlogin_r='undef' d_getmnt='undef' d_getmntent='undef' d_getnameinfo='undef' d_getnbyaddr='undef' d_getnbyname='undef' d_getnent='undef' d_getnetbyaddr_r='undef' d_getnetbyname_r='undef' d_getnetent_r='undef' d_getnetprotos='undef' d_getpagsz='undef' d_getpbyname='define' d_getpbynumber='define' d_getpent='undef' d_getpgid='undef' d_getpgrp2='undef' d_getpgrp='undef' d_getppid='undef' d_getprior='undef' d_getprotobyname_r='undef' d_getprotobynumber_r='undef' d_getprotoent_r='undef' d_getprotoprotos='define' d_getprpwnam='undef' d_getpwent='undef' d_getpwent_r='undef' d_getpwnam_r='undef' d_getpwuid_r='undef' d_getsbyname='define' d_getsbyport='define' d_getsent='undef' d_getservbyname_r='undef' d_getservbyport_r='undef' d_getservent_r='undef' d_getservprotos='define' d_getspnam='undef' d_getspnam_r='undef' d_gettimeod='define' d_gmtime64='undef' d_gmtime_r='undef' d_gnulibc='undef' d_grpasswd='undef' d_hasmntopt='undef' d_htonl='define' d_ilogbl='undef' d_inc_version_list='undef' d_index='undef' d_inetaton='undef' d_inetntop='undef' d_inetpton='undef' d_int64_t='undef' d_isascii='define' d_isfinite='undef' d_isinf='undef' d_isnan='define' d_isnanl='undef' d_killpg='define' d_lchown='undef' d_ldbl_dig='define' d_libm_lib_version='undef' d_link='define' d_localtime64='undef' d_localtime_r='undef' d_localtime_r_needs_tzset='undef' d_locconv='define' d_lockf='undef' d_longdbl='define' d_longlong='undef' d_lseekproto='define' d_lstat='undef' d_madvise='undef' d_malloc_good_size='undef' d_malloc_size='undef' d_mblen='define' d_mbstowcs='define' d_mbtowc='define' d_memchr='define' d_memcmp='define' d_memcpy='define' d_memmove='define' d_memset='define' d_mkdir='define' d_mkdtemp='undef' d_mkfifo='undef' d_mkstemp='undef' d_mkstemps='undef' d_mktime64='undef' d_mktime='define' d_mmap='undef' d_modfl='undef' d_modfl_pow32_bug='undef' d_modflproto='undef' d_mprotect='undef' d_msgctl='undef' d_msg_ctrunc='undef' d_msg_dontroute='undef' d_msgget='undef' d_msghdr_s='undef' d_msg_oob='undef' d_msg_peek='undef' d_msg_proxy='undef' d_msgrcv='undef' d_msgsnd='undef' d_msg='undef' d_msync='undef' d_munmap='undef' d_mymalloc='undef' d_ndbm='undef' d_ndbm_h_uses_prototypes='undef' d_nice='undef' d_nl_langinfo='undef' d_nv_preserves_uv='define' d_nv_zero_is_allbits_zero='define' d_off64_t='undef' d_old_pthread_create_joinable='undef' d_oldpthreads='undef' d_oldsock='undef' d_open3='undef' d_pathconf='undef' d_pause='define' d_perl_otherlibdirs='undef' d_phostname='undef' d_pipe='define' d_poll='undef' d_portable='define' d_printf_format_null='undef' d_procselfexe='undef' d_pseudofork='undef' d_pthread_atfork='undef' d_pthread_attr_setscope='undef' d_pthread_yield='undef' d_pwage='undef' d_pwchange='undef' d_pwclass='undef' d_pwcomment='undef' d_pwexpire='undef' d_pwgecos='undef' d_pwpasswd='undef' d_pwquota='undef' d_qgcvt='undef' d_quad='define' d_random_r='undef' d_readdir64_r='undef' d_readdir='define' d_readdir_r='undef' d_readlink='undef' d_readv='undef' d_recvmsg='undef' d_rename='define' d_rewinddir='define' d_rmdir='define' d_safebcpy='undef' d_safemcpy='undef' d_sanemcmp='define' d_sbrkproto='undef' d_scalbnl='undef' d_sched_yield='undef' d_scm_rights='undef' d_seekdir='define' d_select='define' d_sem='undef' d_semctl='undef' d_semctl_semid_ds='undef' d_semctl_semun='undef' d_semget='undef' d_semop='undef' d_sendmsg='undef' d_setegid='undef' d_seteuid='undef' d_setgrent='undef' d_setgrent_r='undef' d_setgrps='undef' d_sethent='undef' d_sethostent_r='undef' d_setitimer='undef' d_setlinebuf='undef' d_setlocale='define' d_setlocale_r='undef' d_setnent='undef' d_setnetent_r='undef' d_setpent='undef' d_setpgid='undef' d_setpgrp2='undef' d_setpgrp='undef' d_setprior='undef' d_setproctitle='undef' d_setprotoent_r='undef' d_setpwent='undef' d_setpwent_r='undef' d_setregid='undef' d_setresgid='undef' d_setresuid='undef' d_setreuid='undef' d_setrgid='undef' d_setruid='undef' d_setsent='undef' d_setservent_r='undef' d_setsid='undef' d_setvbuf='define' d_sfio='undef' d_shm='undef' d_shmat='undef' d_shmatprototype='undef' d_shmctl='undef' d_shmdt='undef' d_shmget='undef' d_sigaction='undef' d_signbit='undef' d_sigprocmask='undef' d_sigsetjmp='undef' d_sitearch='define' d_snprintf='define' d_sockatmark='undef' d_sockatmarkproto='undef' d_socket='define' d_socklen_t='undef' d_sockpair='undef' d_socks5_init='undef' d_sprintf_returns_strlen='define' d_sqrtl='undef' d_srand48_r='undef' d_srandom_r='undef' d_sresgproto='undef' d_sresuproto='undef' d_statblks='undef' d_statfs_f_flags='undef' d_statfs_s='undef' d_statvfs='undef' d_stdio_cnt_lval='define' d_stdio_ptr_lval='define' d_stdio_ptr_lval_nochange_cnt='define' d_stdio_ptr_lval_sets_cnt='undef' d_stdio_stream_array='undef' d_stdiobase='define' d_stdstdio='define' d_strchr='define' d_strcoll='define' d_strctcpy='define' d_strerrm='strerror(e)' d_strerror='define' d_strerror_r='undef' d_strftime='define' d_strlcat='undef' d_strlcpy='undef' d_strtod='define' d_strtol='define' d_strtold='undef' d_strtoll='undef' d_strtoq='undef' d_strtoul='define' d_strtoull='undef' d_strtouq='undef' d_strxfrm='define' d_suidsafe='undef' d_symlink='undef' d_syscall='undef' d_syscallproto='undef' d_sysconf='undef' d_sysernlst='' d_syserrlst='define' d_system='define' d_tcgetpgrp='undef' d_tcsetpgrp='undef' d_telldir='define' d_telldirproto='define' d_time='define' d_timegm='undef' d_times='define' d_tm_tm_gmtoff='undef' d_tm_tm_zone='undef' d_tmpnam_r='undef' d_truncate='undef' d_ttyname_r='undef' d_tzname='define' d_u32align='define' d_ualarm='undef' d_umask='define' d_uname='define' d_union_semun='define' d_unordered='undef' d_unsetenv='undef' d_usleep='undef' d_usleepproto='undef' d_ustat='undef' d_vendorarch='undef' d_vendorbin='undef' d_vendorlib='undef' d_vendorscript='undef' d_vfork='undef' d_void_closedir='undef' d_voidsig='define' d_voidtty='' d_volatile='define' d_vprintf='define' d_vsnprintf='define' d_wait4='undef' d_waitpid='define' d_wcstombs='define' d_wctomb='define' d_writev='undef' d_xenix='undef' date='date' db_hashtype='int' db_prefixtype='int' db_version_major='0' db_version_minor='0' db_version_patch='0' defvoidused='15' direntrytype='struct direct' dlext='dll' dlsrc='dl_win32.xs' doublesize='8' drand01='(rand()/(double)((unsigned)1< */ #ifndef WIN32IOP_H #define WIN32IOP_H #ifndef START_EXTERN_C #ifdef __cplusplus # define START_EXTERN_C extern "C" { # define END_EXTERN_C } # define EXTERN_C extern "C" #else # define START_EXTERN_C # define END_EXTERN_C # define EXTERN_C #endif #endif #ifndef UNDER_CE #if defined(_MSC_VER) || defined(__MINGW32__) # include #else # include #endif #endif /* * defines for flock emulation */ #define LOCK_SH 1 #define LOCK_EX 2 #define LOCK_NB 4 #define LOCK_UN 8 /* * Make this as close to original stdio as possible. */ /* * function prototypes for our own win32io layer */ START_EXTERN_C DllExport int * win32_errno(void); DllExport char *** win32_environ(void); DllExport FILE* win32_stdin(void); DllExport FILE* win32_stdout(void); DllExport FILE* win32_stderr(void); DllExport int win32_ferror(FILE *fp); DllExport int win32_feof(FILE *fp); DllExport char* win32_strerror(int e); DllExport int win32_fprintf(FILE *pf, const char *format, ...); DllExport int win32_printf(const char *format, ...); DllExport int win32_vfprintf(FILE *pf, const char *format, va_list arg); DllExport int win32_vprintf(const char *format, va_list arg); DllExport size_t win32_fread(void *buf, size_t size, size_t count, FILE *pf); DllExport size_t win32_fwrite(const void *buf, size_t size, size_t count, FILE *pf); DllExport FILE* win32_fopen(const char *path, const char *mode); DllExport FILE* win32_fdopen(int fh, const char *mode); DllExport FILE* win32_freopen(const char *path, const char *mode, FILE *pf); DllExport int win32_fclose(FILE *pf); DllExport int win32_fputs(const char *s,FILE *pf); DllExport int win32_fputc(int c,FILE *pf); DllExport int win32_ungetc(int c,FILE *pf); DllExport int win32_getc(FILE *pf); DllExport int win32_fileno(FILE *pf); DllExport void win32_clearerr(FILE *pf); DllExport int win32_fflush(FILE *pf); DllExport long win32_ftell(FILE *pf); DllExport int win32_fseek(FILE *pf,long offset,int origin); DllExport int win32_fgetpos(FILE *pf,fpos_t *p); DllExport int win32_fsetpos(FILE *pf,const fpos_t *p); DllExport void win32_rewind(FILE *pf); DllExport FILE* win32_tmpfile(void); DllExport int win32_tmpfd(void); DllExport void win32_abort(void); DllExport int win32_fstat(int fd,struct stat *sbufptr); DllExport int win32_stat(const char *name,struct stat *sbufptr); DllExport int win32_pipe( int *phandles, unsigned int psize, int textmode ); DllExport PerlIO* win32_popen( const char *command, const char *mode ); DllExport PerlIO* win32_popenlist(const char *mode, IV narg, SV **args); DllExport int win32_pclose( FILE *pf); DllExport int win32_rename( const char *oname, const char *newname); DllExport int win32_setmode( int fd, int mode); DllExport int win32_chsize(int fd, Off_t size); DllExport long win32_lseek( int fd, long offset, int origin); DllExport long win32_tell( int fd); DllExport int win32_dup( int fd); DllExport int win32_dup2(int h1, int h2); DllExport int win32_open(const char *path, int oflag,...); DllExport int win32_close(int fd); DllExport int win32_eof(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); DllExport int win32_mkdir(const char *dir, int mode); DllExport int win32_rmdir(const char *dir); DllExport int win32_chdir(const char *dir); DllExport int win32_flock(int fd, int oper); DllExport int win32_execv(const char *cmdname, const char *const *argv); DllExport int win32_execvp(const char *cmdname, const char *const *argv); DllExport void win32_perror(const char *str); DllExport void win32_setbuf(FILE *pf, char *buf); DllExport int win32_setvbuf(FILE *pf, char *buf, int type, size_t size); DllExport int win32_flushall(void); DllExport int win32_fcloseall(void); DllExport char* win32_fgets(char *s, int n, FILE *pf); DllExport char* win32_gets(char *s); DllExport int win32_fgetc(FILE *pf); DllExport int win32_putc(int c, FILE *pf); DllExport int win32_puts(const char *s); DllExport int win32_getchar(void); DllExport int win32_putchar(int c); DllExport void* win32_malloc(size_t size); DllExport void* win32_calloc(size_t numitems, size_t size); DllExport void* win32_realloc(void *block, size_t size); DllExport void win32_free(void *block); DllExport int win32_open_osfhandle(long handle, int flags); DllExport long win32_get_osfhandle(int fd); DllExport DIR* win32_opendir(char *filename); DllExport struct direct* win32_readdir(DIR *dirp); DllExport long win32_telldir(DIR *dirp); DllExport void win32_seekdir(DIR *dirp, long loc); DllExport void win32_rewinddir(DIR *dirp); DllExport int win32_closedir(DIR *dirp); DllExport char* win32_getenv(const char *name); DllExport int win32_putenv(const char *name); DllExport unsigned win32_sleep(unsigned int); DllExport int win32_times(struct tms *timebuf); DllExport unsigned win32_alarm(unsigned int sec); DllExport int win32_stat(const char *path, struct stat *buf); DllExport char* win32_longpath(char *path); DllExport int win32_ioctl(int i, unsigned int u, char *data); DllExport int win32_link(const char *oldname, const char *newname); DllExport int win32_gettimeofday(struct timeval *tp, void *not_used); DllExport int win32_unlink(const char *f); DllExport int win32_utime(const char *f, struct utimbuf *t); DllExport int win32_uname(struct utsname *n); DllExport int win32_wait(int *status); DllExport int win32_waitpid(int pid, int *status, int flags); DllExport int win32_kill(int pid, int sig); DllExport unsigned long win32_os_id(void); DllExport void* win32_dynaload(const char*filename); DllExport int win32_access(const char *path, int mode); DllExport int win32_chmod(const char *path, int mode); DllExport int win32_getpid(void); DllExport Sighandler_t win32_signal(int sig, Sighandler_t subcode); DllExport char * win32_crypt(const char *txt, const char *salt); END_EXTERN_C /* * the following six(6) is #define in stdio.h */ #ifndef WIN32IO_IS_STDIO #undef errno #undef environ #undef stderr #undef stdin #undef stdout #undef ferror #undef feof #undef fclose #undef pipe #undef pause #undef sleep #undef times #undef alarm #undef ioctl #undef unlink #undef utime #undef uname #undef wait #ifdef __BORLANDC__ #undef ungetc #undef getc #undef putc #undef getchar #undef putchar #undef fileno #endif #define stderr win32_stderr() #define stdout win32_stdout() #define stdin win32_stdin() #define feof(f) win32_feof(f) #define ferror(f) win32_ferror(f) #define errno (*win32_errno()) #define environ (*win32_environ()) #define strerror win32_strerror /* * redirect to our own version */ #undef fprintf #define fprintf win32_fprintf #undef vfprintf #define vfprintf win32_vfprintf #undef printf #define printf win32_printf #undef vprintf #define vprintf win32_vprintf #undef fread #define fread(buf,size,count,f) win32_fread(buf,size,count,f) #undef fwrite #define fwrite(buf,size,count,f) win32_fwrite(buf,size,count,f) #undef fopen #define fopen win32_fopen #undef fdopen #define fdopen win32_fdopen #undef freopen #define freopen win32_freopen #define fclose(f) win32_fclose(f) #undef fputs #define fputs(s,f) win32_fputs(s,f) #undef fputc #define fputc(c,f) win32_fputc(c,f) #undef ungetc #define ungetc(c,f) win32_ungetc(c,f) #undef getc #define getc(f) win32_getc(f) #undef fileno #define fileno(f) win32_fileno(f) #undef clearerr #define clearerr(f) win32_clearerr(f) #undef fflush #define fflush(f) win32_fflush(f) #undef ftell #define ftell(f) win32_ftell(f) #undef fseek #define fseek(f,o,w) win32_fseek(f,o,w) #undef fgetpos #define fgetpos(f,p) win32_fgetpos(f,p) #undef fsetpos #define fsetpos(f,p) win32_fsetpos(f,p) #undef rewind #define rewind(f) win32_rewind(f) #define tmpfile() win32_tmpfile() #define abort() win32_abort() #define fstat(fd,bufptr) win32_fstat(fd,bufptr) #define stat(pth,bufptr) win32_stat(pth,bufptr) #define longpath(pth) win32_longpath(pth) #define rename(old,new) win32_rename(old,new) #define setmode(fd,mode) win32_setmode(fd,mode) #define lseek(fd,offset,orig) win32_lseek(fd,offset,orig) #define tell(fd) win32_tell(fd) #define dup(fd) win32_dup(fd) #define dup2(fd1,fd2) win32_dup2(fd1,fd2) #define open win32_open #define close(fd) win32_close(fd) #define eof(fd) win32_eof(fd) #define read(fd,b,s) win32_read(fd,b,s) #define write(fd,b,s) win32_write(fd,b,s) #define _open_osfhandle win32_open_osfhandle #define _get_osfhandle win32_get_osfhandle #define spawnvp win32_spawnvp #define mkdir win32_mkdir #define rmdir win32_rmdir #define chdir win32_chdir #define flock(fd,o) win32_flock(fd,o) #define execv win32_execv #define execvp win32_execvp #define perror win32_perror #define setbuf win32_setbuf #undef setvbuf #define setvbuf win32_setvbuf #undef flushall #define flushall win32_flushall #undef fcloseall #define fcloseall win32_fcloseall #undef fgets #define fgets win32_fgets #undef gets #define gets win32_gets #undef fgetc #define fgetc win32_fgetc #undef putc #define putc win32_putc #undef puts #define puts win32_puts #undef getchar #define getchar win32_getchar #undef putchar #define putchar win32_putchar #define access(p,m) win32_access(p,m) #define chmod(p,m) win32_chmod(p,m) #if !defined(MYMALLOC) || !defined(PERL_CORE) #undef malloc #undef calloc #undef realloc #undef free #define malloc win32_malloc #define calloc win32_calloc #define realloc win32_realloc #define free win32_free #endif #define pipe(fd) win32_pipe((fd), 512, O_BINARY) #define pause() win32_sleep((32767L << 16) + 32767) #define sleep win32_sleep #define times win32_times #define alarm win32_alarm #define ioctl win32_ioctl #define link win32_link #define unlink win32_unlink #define utime win32_utime #define uname win32_uname #define wait win32_wait #define waitpid win32_waitpid #define kill win32_kill #define opendir win32_opendir #define readdir win32_readdir #define telldir win32_telldir #define seekdir win32_seekdir #define rewinddir win32_rewinddir #define closedir win32_closedir #define os_id win32_os_id #define getpid win32_getpid #undef crypt #define crypt(t,s) win32_crypt(t,s) #undef getenv #define getenv win32_getenv #undef putenv #define putenv win32_putenv #endif /* WIN32IO_IS_STDIO */ #endif /* WIN32IOP_H */ perl-5.12.0-RC0/win32/wincesck.c0000444000175000017500000002220111325127002015027 0ustar jessejesse/* Time-stamp: <01/08/01 21:01:12 keuchel@w2k> */ /* wincesck.c * * (c) 1995 Microsoft Corporation. All rights reserved. * Developed by hip communications inc. * Portions (c) 1993 Intergraph Corporation. All rights reserved. * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. */ /* The socket calls use fd functions from celib... */ #define WIN32IO_IS_STDIO #define WIN32SCK_IS_STDSCK #define WIN32_LEAN_AND_MEAN #ifdef __GNUC__ #define Win32_Winsock #endif #include #define wince_private #include "errno.h" #include "EXTERN.h" #include "perl.h" #include "Win32iop.h" #include #ifndef UNDER_CE #include #include #include #include #endif #ifdef UNDER_CE XCE_EXPORT struct servent *xcegetservbyname(const char *sname, const char *sproto); XCE_EXPORT struct servent * xcegetservbyport(int aport, const char *sproto); XCE_EXPORT struct protoent *xcegetprotobyname(const char *name); XCE_EXPORT struct protoent *xcegetprotobynumber(int number); #define getservbyname xcegetservbyname #define getservbyport xcegetservbyport #define getprotobyname xcegetprotobyname #define getprotobynumber xcegetprotobynumber /* uses fdtab... */ #include "cesocket2.h" #endif #define TO_SOCKET(X) (X) #define StartSockets() \ STMT_START { \ if (!wsock_started) \ start_sockets(); \ } STMT_END #define SOCKET_TEST(x, y) \ STMT_START { \ StartSockets(); \ if((x) == (y)) \ errno = WSAGetLastError(); \ } STMT_END #define SOCKET_TEST_ERROR(x) SOCKET_TEST(x, SOCKET_ERROR) static struct servent* win32_savecopyservent(struct servent*d, struct servent*s, const char *proto); static int wsock_started = 0; EXTERN_C void EndSockets(void) { if (wsock_started) WSACleanup(); } void start_sockets(void) { dTHX; unsigned short version; WSADATA retdata; int ret; /* * initalize the winsock interface and insure that it is * cleaned up at exit. */ version = 0x101; if(ret = WSAStartup(version, &retdata)) Perl_croak_nocontext("Unable to locate winsock library!\n"); if(retdata.wVersion != version) Perl_croak_nocontext("Could not find version 1.1 of winsock dll\n"); /* atexit((void (*)(void)) EndSockets); */ wsock_started = 1; } u_long win32_htonl(u_long hostlong) { StartSockets(); return htonl(hostlong); } u_short win32_htons(u_short hostshort) { StartSockets(); return htons(hostshort); } u_long win32_ntohl(u_long netlong) { StartSockets(); return ntohl(netlong); } u_short win32_ntohs(u_short netshort) { StartSockets(); return ntohs(netshort); } SOCKET win32_socket(int af, int type, int protocol) { StartSockets(); return xcesocket(af, type, protocol); } SOCKET win32_accept(SOCKET s, struct sockaddr *addr, int *addrlen) { StartSockets(); return xceaccept(s, addr, addrlen); } int win32_bind(SOCKET s, const struct sockaddr *addr, int addrlen) { StartSockets(); return xcebind(s, addr, addrlen); } int win32_connect(SOCKET s, const struct sockaddr *addr, int addrlen) { StartSockets(); return xceconnect(s, addr, addrlen); } int win32_getpeername(SOCKET s, struct sockaddr *addr, int *addrlen) { StartSockets(); return xcegetpeername(s, addr, addrlen); } int win32_getsockname(SOCKET s, struct sockaddr *addr, int *addrlen) { StartSockets(); return xcegetsockname(s, addr, addrlen); } int win32_getsockopt(SOCKET s, int level, int optname, char *optval, int *optlen) { StartSockets(); return xcegetsockopt(s, level, optname, optval, optlen); } int win32_ioctlsocket(SOCKET s, long cmd, u_long *argp) { StartSockets(); return xceioctlsocket(s, cmd, argp); } int win32_listen(SOCKET s, int backlog) { StartSockets(); return xcelisten(s, backlog); } int win32_recv(SOCKET s, char *buf, int len, int flags) { StartSockets(); return xcerecv(s, buf, len, flags); } int win32_recvfrom(SOCKET s, char *buf, int len, int flags, struct sockaddr *from, int *fromlen) { StartSockets(); return xcerecvfrom(s, buf, len, flags, from, fromlen); } int win32_select(int nfds, Perl_fd_set* rd, Perl_fd_set* wr, Perl_fd_set* ex, const struct timeval* timeout) { StartSockets(); /* select not yet fixed */ errno = ENOSYS; return -1; } int win32_send(SOCKET s, const char *buf, int len, int flags) { StartSockets(); return xcesend(s, buf, len, flags); } int win32_sendto(SOCKET s, const char *buf, int len, int flags, const struct sockaddr *to, int tolen) { StartSockets(); return xcesendto(s, buf, len, flags, to, tolen); } int win32_setsockopt(SOCKET s, int level, int optname, const char *optval, int optlen) { StartSockets(); return xcesetsockopt(s, level, optname, optval, optlen); } int win32_shutdown(SOCKET s, int how) { StartSockets(); return xceshutdown(s, how); } int win32_closesocket(SOCKET s) { StartSockets(); return xceclosesocket(s); } struct hostent * win32_gethostbyaddr(const char *addr, int len, int type) { struct hostent *r; SOCKET_TEST(r = gethostbyaddr(addr, len, type), NULL); return r; } struct hostent * win32_gethostbyname(const char *name) { struct hostent *r; SOCKET_TEST(r = gethostbyname(name), NULL); return r; } int win32_gethostname(char *name, int len) { int r; SOCKET_TEST_ERROR(r = gethostname(name, len)); return r; } struct protoent * win32_getprotobyname(const char *name) { struct protoent *r; SOCKET_TEST(r = getprotobyname(name), NULL); return r; } struct protoent * win32_getprotobynumber(int num) { struct protoent *r; SOCKET_TEST(r = getprotobynumber(num), NULL); return r; } struct servent * win32_getservbyname(const char *name, const char *proto) { dTHX; struct servent *r; SOCKET_TEST(r = getservbyname(name, proto), NULL); if (r) { r = win32_savecopyservent(&w32_servent, r, proto); } return r; } struct servent * win32_getservbyport(int port, const char *proto) { dTHX; struct servent *r; SOCKET_TEST(r = getservbyport(port, proto), NULL); if (r) { r = win32_savecopyservent(&w32_servent, r, proto); } return r; } int win32_ioctl(int i, unsigned int u, char *data) { dTHX; u_long u_long_arg; int retval; if (!wsock_started) { Perl_croak_nocontext("ioctl implemented only on sockets"); /* NOTREACHED */ } /* mauke says using memcpy avoids alignment issues */ memcpy(&u_long_arg, data, sizeof u_long_arg); retval = ioctlsocket(TO_SOCKET(i), (long)u, &u_long_arg); memcpy(data, &u_long_arg, sizeof u_long_arg); if (retval == SOCKET_ERROR) { if (WSAGetLastError() == WSAENOTSOCK) { Perl_croak_nocontext("ioctl implemented only on sockets"); /* NOTREACHED */ } errno = WSAGetLastError(); } return retval; } char FAR * win32_inet_ntoa(struct in_addr in) { StartSockets(); return inet_ntoa(in); } unsigned long win32_inet_addr(const char FAR *cp) { StartSockets(); return inet_addr(cp); } /* * Networking stubs */ void win32_endhostent() { dTHX; Perl_croak_nocontext("endhostent not implemented!\n"); } void win32_endnetent() { dTHX; Perl_croak_nocontext("endnetent not implemented!\n"); } void win32_endprotoent() { dTHX; Perl_croak_nocontext("endprotoent not implemented!\n"); } void win32_endservent() { dTHX; Perl_croak_nocontext("endservent not implemented!\n"); } struct netent * win32_getnetent(void) { dTHX; Perl_croak_nocontext("getnetent not implemented!\n"); return (struct netent *) NULL; } struct netent * win32_getnetbyname(char *name) { dTHX; Perl_croak_nocontext("getnetbyname not implemented!\n"); return (struct netent *)NULL; } struct netent * win32_getnetbyaddr(long net, int type) { dTHX; Perl_croak_nocontext("getnetbyaddr not implemented!\n"); return (struct netent *)NULL; } struct protoent * win32_getprotoent(void) { dTHX; Perl_croak_nocontext("getprotoent not implemented!\n"); return (struct protoent *) NULL; } struct servent * win32_getservent(void) { dTHX; Perl_croak_nocontext("getservent not implemented!\n"); return (struct servent *) NULL; } void win32_sethostent(int stayopen) { dTHX; Perl_croak_nocontext("sethostent not implemented!\n"); } void win32_setnetent(int stayopen) { dTHX; Perl_croak_nocontext("setnetent not implemented!\n"); } void win32_setprotoent(int stayopen) { dTHX; Perl_croak_nocontext("setprotoent not implemented!\n"); } void win32_setservent(int stayopen) { dTHX; Perl_croak_nocontext("setservent not implemented!\n"); } static struct servent* win32_savecopyservent(struct servent*d, struct servent*s, const char *proto) { d->s_name = s->s_name; d->s_aliases = s->s_aliases; d->s_port = s->s_port; #ifndef __BORLANDC__ /* Buggy on Win95 and WinNT-with-Borland-WSOCK */ if (!IsWin95() && s->s_proto && strlen(s->s_proto)) d->s_proto = s->s_proto; else #endif if (proto && strlen(proto)) d->s_proto = (char *)proto; else d->s_proto = "tcp"; return d; } perl-5.12.0-RC0/win32/distclean.bat0000444000175000017500000000112411143650501015517 0ustar jessejesse@perl -w -Sx %0 %* @goto end_of_perl #!perl -w BEGIN { push(@INC,'lib') } use strict; use File::Find; use ExtUtils::Manifest qw(maniread); my $files = maniread(); my %files; foreach (keys %$files) { $files{lc($_)} = $files->{$_}; } my @dead; find(sub { return if -d $_; my $name = $File::Find::name; $name =~ s#^\./##; unless (exists $files{lc($name)}) { # print "new $name\n"; push(@dead,$name); } },'.'); foreach my $file (@dead) { chmod(0666,$file) unless -w $file; unlink($file) || warn "Cannot delete $file:$!"; } __END__ :end_of_perl del perl.exe del perl*.dllperl-5.12.0-RC0/win32/sync_ext.pl0000444000175000017500000000357711325127002015265 0ustar jessejesse=begin comment Synchronize filename cases for extensions. This script could be used to perform following renaming: if there exist file, for example, "FiLeNaME.c" and filename.obj then it renames "filename.obj" to "FiLeNaME.obj". There is a problem when some compilers (e.g.Borland) generate such .obj files and then "make" process will not treat them as dependant and already maked files. This script takes two arguments - first and second extensions to synchronize filename cases with. There may be specified following options: --verbose <== say everything what is going on --recurse <== recurse subdirectories --dummy <== do not perform actual renaming --say-subdir Every such option can be specified with an optional "no" prefix to negate it. Typically, it is invoked as: perl sync_ext.pl c obj --verbose =cut use strict; my ($ext1, $ext2) = map {quotemeta} grep {!/^--/} @ARGV; my %opts = ( #defaults 'verbose' => 0, 'recurse' => 1, 'dummy' => 0, 'say-subdir' => 0, #options itself (map {/^--([\-_\w]+)=(.*)$/} @ARGV), # --opt=smth (map {/^no-?(.*)$/i?($1=>0):($_=>1)} map {/^--([\-_\w]+)$/} @ARGV), # --opt --no-opt --noopt ); my $sp = ''; sub xx { opendir DIR, '.'; my @t = readdir DIR; my @f = map {/^(.*)\.$ext1$/i} @t; my %f = map {lc($_)=>$_} map {/^(.*)\.$ext2$/i} @t; for (@f) { my $lc = lc($_); if (exists $f{$lc} and $f{$lc} ne $_) { print STDERR "$sp$f{$lc}.$ext2 <==> $_.$ext1\n" if $opts{verbose}; if ($opts{dummy}) { print STDERR "ren $f{$lc}.$ext2 $_.$ext2\n"; } else { system "ren $f{$lc}.$ext2 $_.$ext2"; } } } if ($opts{recurse}) { for (grep {-d&&!/^\.\.?$/} @t) { print STDERR "$sp\\$_\n" if $opts{'say-subdir'}; $sp .= ' '; chdir $_ or die; xx(); chdir ".." or die; chop $sp; } } } xx(); perl-5.12.0-RC0/win32/makefile.mk0000644000175000017500000015153011347250766015217 0ustar jessejesse# # Makefile to build perl on Windows NT using DMAKE. # Supported compilers: # Visual C++ 2.0 or later # Borland C++ 5.02 or later # MinGW with gcc-2.95.2 or later # MS Platform SDK 64-bit compiler and tools **experimental** # # This is set up to build a perl.exe that runs off a shared library # (perl512.dll). Also makes individual DLLs for the XS extensions. # ## ## Make sure you read README.win32 *before* you mess with anything here! ## ## ## Build configuration. Edit the values below to suit your needs. ## # # Set these to wherever you want "dmake install" to put your # newly built perl. # INST_DRV *= c: INST_TOP *= $(INST_DRV)\perl # # Uncomment if you want to build a 32-bit Perl using a 32-bit compiler # on a 64-bit version of Windows. #WIN64 *= undef # # Comment this out if you DON'T want your perl installation to be versioned. # This means that the new installation will overwrite any files from the # old installation at the same INST_TOP location. Leaving it enabled is # the safest route, as perl adds the extra version directory to all the # locations it installs files to. If you disable it, an alternative # versioned installation can be obtained by setting INST_TOP above to a # path that includes an arbitrary version string. # #INST_VER *= \5.12.0 # # Comment this out if you DON'T want your perl installation to have # architecture specific components. This means that architecture- # specific files will be installed along with the architecture-neutral # files. Leaving it enabled is safer and more flexible, in case you # want to build multiple flavors of perl and install them together in # the same location. Commenting it out gives you a simpler # installation that is easier to understand for beginners. # #INST_ARCH *= \$(ARCHNAME) # # Uncomment this if you want perl to run # $Config{sitelibexp}\sitecustomize.pl # before anything else. This script can then be set up, for example, # to add additional entries to @INC. # #USE_SITECUST *= define # # uncomment to enable multiple interpreters. This is need for fork() # emulation and for thread support. # USE_MULTI *= define # # Interpreter cloning/threads; now reasonably complete. # This should be enabled to get the fork() emulation. # This needs USE_MULTI above. # USE_ITHREADS *= define # # uncomment to enable the implicit "host" layer for all system calls # made by perl. This needs USE_MULTI above. # This is also needed to get fork(). # USE_IMP_SYS *= define # # Comment out next assign to disable perl's I/O subsystem and use compiler's # stdio for IO - depending on your compiler vendor and run time library you may # then get a number of fails from make test i.e. bugs - complain to them not us ;-). # You will also be unable to take full advantage of perl5.8's support for multiple # encodings and may see lower IO performance. You have been warned. USE_PERLIO *= define # # Comment this out if you don't want to enable large file support for # some reason. Should normally only be changed to maintain compatibility # with an older release of perl. USE_LARGE_FILES *= define # # uncomment exactly one of the following # # Visual C++ 2.x #CCTYPE *= MSVC20 # Visual C++ > 2.x and < 6.x #CCTYPE *= MSVC # Visual C++ 6.x (aka Visual C++ 98) #CCTYPE *= MSVC60 # Visual C++ Toolkit 2003 (aka Visual C++ 7.x) (free command-line tools) #CCTYPE *= MSVC70FREE # Visual C++ .NET 2003 (aka Visual C++ 7.x) (full version) #CCTYPE *= MSVC70 # Visual C++ 2005 Express Edition (aka Visual C++ 8.x) (free version) #CCTYPE *= MSVC80FREE # Visual C++ 2005 (aka Visual C++ 8.x) (full version) #CCTYPE *= MSVC80 # Visual C++ 2008 Express Edition (aka Visual C++ 9.x) (free version) #CCTYPE *= MSVC90FREE # Visual C++ 2008 (aka Visual C++ 9.x) (full version) #CCTYPE *= MSVC90 # Borland 5.02 or later #CCTYPE *= BORLAND # MinGW or mingw-w64 with gcc-2.95.2 or later CCTYPE *= GCC # # uncomment this if your Borland compiler is older than v5.4. #BCCOLD *= define # # uncomment this if you want to use Borland's VCL as your CRT #BCCVCL *= define # # uncomment this if you are compiling under Windows 95/98 and command.com # (not needed if you're running under 4DOS/NT 6.01 or later) #IS_WIN95 *= define # # uncomment next line if you want debug version of perl (big,slow) # If not enabled, we automatically try to use maximum optimization # with all compilers that are known to have a working optimizer. # #CFG *= Debug # # uncomment to enable use of PerlCRT.DLL when using the Visual C compiler. # It has patches that fix known bugs in older versions of MSVCRT.DLL. # This currently requires VC 5.0 with Service Pack 3 or later. # Get it from CPAN at http://www.cpan.org/authors/id/D/DO/DOUGL/ # and follow the directions in the package to install. # # Not recommended if you have VC 6.x and you're not running Windows 9x. # #USE_PERLCRT *= define # # uncomment to enable linking with setargv.obj under the Visual C # compiler. Setting this options enables perl to expand wildcards in # arguments, but it may be harder to use alternate methods like # File::DosGlob that are more powerful. This option is supported only with # Visual C. # #USE_SETARGV *= define # # if you want to have the crypt() builtin function implemented, leave this or # CRYPT_LIB uncommented. The fcrypt.c file named here contains a suitable # version of des_fcrypt(). # CRYPT_SRC *= fcrypt.c # # if you didn't set CRYPT_SRC and if you have des_fcrypt() available in a # library, uncomment this, and make sure the library exists (see README.win32) # Specify the full pathname of the library. # #CRYPT_LIB *= fcrypt.lib # # set this if you wish to use perl's malloc # WARNING: Turning this on/off WILL break binary compatibility with extensions # you may have compiled with/without it. Be prepared to recompile all # extensions if you change the default. Currently, this cannot be enabled # if you ask for USE_IMP_SYS above. # #PERL_MALLOC *= define # # set this to enable debugging mstats # This must be enabled to use the Devel::Peek::mstat() function. This cannot # be enabled without PERL_MALLOC as well. # #DEBUG_MSTATS *= define # # set this to additionally provide a statically linked perl-static.exe. # Note that dynamic loading will not work with this perl, so you must # include required modules statically using the STATIC_EXT or ALL_STATIC # variables below. A static library perl512s.lib will also be created. # Ordinary perl.exe is not affected by this option. # #BUILD_STATIC *= define # # in addition to BUILD_STATIC the option ALL_STATIC makes *every* # extension get statically built # This will result in a very large perl executable, but the main purpose # is to have proper linking set so as to be able to create miscellaneous # executables with different built-in extensions # #ALL_STATIC *= define # # set the install locations of the compiler include/libraries # Running VCVARS32.BAT is *required* when using Visual C. # Some versions of Visual C don't define MSVCDIR in the environment, # so you may have to set CCHOME explicitly (spaces in the path name should # not be quoted) # .IF "$(CCTYPE)" == "BORLAND" CCHOME *= C:\Borland\BCC55 .ELIF "$(CCTYPE)" == "GCC" CCHOME *= C:\MinGW .ELSE CCHOME *= $(MSVCDIR) .ENDIF CCINCDIR *= $(CCHOME)\include CCLIBDIR *= $(CCHOME)\lib # # If building with gcc-4.x.x (or x86_64-w64-mingw32-gcc-4.x.x), then # uncomment the following assignment to GCC_4XX, make sure that CCHOME # has been set correctly above, and uncomment the appropriate # GCCHELPERDLL line. # The name of the dll can change, depending upon which vendor has supplied # your 4.x.x compiler, and upon the values of "x". # (The dll will be in your mingw/bin folder, so check there if you're # unsure about the correct name.) # Without these corrections, the op/taint.t test script will fail. # #GCC_4XX *= define #GCCHELPERDLL *= $(CCHOME)\bin\libgcc_s_sjlj-1.dll #GCCHELPERDLL *= $(CCHOME)\bin\libgcc_s_dw2-1.dll #GCCHELPERDLL *= $(CCHOME)\bin\libgcc_s_1.dll # # uncomment this if you are using x86_64-w64-mingw32 cross-compiler # ie if your gcc executable is called 'x86_64-w64-mingw32-gcc' # instead of the usual 'gcc'. # #GCCCROSS *= define # # Additional compiler flags can be specified here. # BUILDOPT *= $(BUILDOPTEXTRA) # # Adding -DPERL_HASH_SEED_EXPLICIT will disable randomization of Perl's # internal hash function unless the PERL_HASH_SEED environment variable is set. # Alternatively, adding -DNO_HASH_SEED will completely disable the # randomization feature. # The latter is required to maintain binary compatibility with Perl 5.8.0. # #BUILDOPT += -DPERL_HASH_SEED_EXPLICIT #BUILDOPT += -DNO_HASH_SEED # # This should normally be disabled. Adding -DPERL_POLLUTE enables support # for old symbols by default, at the expense of extreme pollution. You most # probably just want to build modules that won't compile with # perl Makefile.PL POLLUTE=1 # instead of enabling this. Please report such modules to the respective # authors. # #BUILDOPT += -DPERL_POLLUTE # # This should normally be disabled. Enabling it will disable the File::Glob # implementation of CORE::glob. # #BUILDOPT += -DPERL_EXTERNAL_GLOB # # This should normally be disabled. Enabling it causes perl to read scripts # in text mode (which is the 5.005 behavior) and will break ByteLoader. # #BUILDOPT += -DPERL_TEXTMODE_SCRIPTS # # specify semicolon-separated list of extra directories that modules will # look for libraries (spaces in path names need not be quoted) # EXTRALIBDIRS *= # # set this to point to cmd.exe (only needed if you use some # alternate shell that doesn't grok cmd.exe style commands) # #SHELL *= g:\winnt\system32\cmd.exe # # set this to your email address (perl will guess a value from # from your loginname and your hostname, which may not be right) # #EMAIL *= ## ## Build configuration ends. ## ##################### CHANGE THESE ONLY IF YOU MUST ##################### .IF "$(CRYPT_SRC)$(CRYPT_LIB)" == "" D_CRYPT = undef .ELSE D_CRYPT = define CRYPT_FLAG = -DHAVE_DES_FCRYPT .ENDIF PERL_MALLOC *= undef DEBUG_MSTATS *= undef USE_SITECUST *= undef USE_MULTI *= undef USE_ITHREADS *= undef USE_IMP_SYS *= undef USE_PERLIO *= undef USE_LARGE_FILES *= undef USE_PERLCRT *= undef .IF "$(USE_IMP_SYS)" == "define" PERL_MALLOC = undef .ENDIF .IF "$(PERL_MALLOC)" == "undef" DEBUG_MSTATS = undef .ENDIF .IF "$(DEBUG_MSTATS)" == "define" BUILDOPT += -DPERL_DEBUGGING_MSTATS .ENDIF .IF "$(USE_IMP_SYS) $(USE_MULTI)" == "define undef" USE_MULTI != define .ENDIF .IF "$(USE_ITHREADS) $(USE_MULTI)" == "define undef" USE_MULTI != define .ENDIF .IF "$(USE_SITECUST)" == "define" BUILDOPT += -DUSE_SITECUSTOMIZE .ENDIF .IF "$(USE_MULTI)" != "undef" BUILDOPT += -DPERL_IMPLICIT_CONTEXT .ENDIF .IF "$(USE_IMP_SYS)" != "undef" BUILDOPT += -DPERL_IMPLICIT_SYS .ENDIF .IMPORT .IGNORE : PROCESSOR_ARCHITECTURE PROCESSOR_ARCHITEW6432 WIN64 PROCESSOR_ARCHITECTURE *= x86 .IF "$(WIN64)" == "" # When we are running from a 32bit cmd.exe on AMD64 then # PROCESSOR_ARCHITECTURE is set to x86 and PROCESSOR_ARCHITEW6432 # is set to AMD64 .IF "$(PROCESSOR_ARCHITEW6432)" != "" PROCESSOR_ARCHITECTURE != $(PROCESSOR_ARCHITEW6432) WIN64 = define .ELIF "$(PROCESSOR_ARCHITECTURE)" == "AMD64" || "$(PROCESSOR_ARCHITECTURE)" == "IA64" WIN64 = define .ELSE WIN64 = undef .ENDIF .ENDIF ARCHITECTURE = $(PROCESSOR_ARCHITECTURE) .IF "$(ARCHITECTURE)" == "AMD64" ARCHITECTURE = x64 .ENDIF .IF "$(ARCHITECTURE)" == "IA64" ARCHITECTURE = ia64 .ENDIF .IF "$(USE_MULTI)" == "define" ARCHNAME = MSWin32-$(ARCHITECTURE)-multi .ELSE .IF "$(USE_PERLIO)" == "define" ARCHNAME = MSWin32-$(ARCHITECTURE)-perlio .ELSE ARCHNAME = MSWin32-$(ARCHITECTURE) .ENDIF .ENDIF .IF "$(USE_ITHREADS)" == "define" ARCHNAME !:= $(ARCHNAME)-thread .ENDIF # Visual C++ 98, .NET 2003, 2005 and 2008 specific. # VC++ 6.x, 7.x, 8.x and 9.x can load DLL's on demand. Makes the test suite run # in about 10% less time. (The free version of 7.x can't do this, but the free # versions of 8.x and 9.x can.) .IF "$(CCTYPE)" == "MSVC60" || "$(CCTYPE)" == "MSVC70" || \ "$(CCTYPE)" == "MSVC80" || "$(CCTYPE)" == "MSVC80FREE" || "$(CCTYPE)" == "MSVC90" || "$(CCTYPE)" == "MSVC90FREE" DELAYLOAD *= -DELAYLOAD:ws2_32.dll delayimp.lib .ENDIF # Visual C++ 2005 and 2008 (VC++ 8.x and 9.x) create manifest files for EXEs and # DLLs. These either need copying everywhere with the binaries, or else need # embedding in them otherwise MSVCR80.dll or MSVCR90.dll won't be found. For # simplicity, embed them if they exist (and delete them afterwards so that they # don't get installed too). EMBED_EXE_MANI = if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;1 && \ if exist $@.manifest del $@.manifest EMBED_DLL_MANI = if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;2 && \ if exist $@.manifest del $@.manifest ARCHDIR = ..\lib\$(ARCHNAME) COREDIR = ..\lib\CORE AUTODIR = ..\lib\auto LIBDIR = ..\lib EXTDIR = ..\ext DISTDIR = ..\dist CPANDIR = ..\cpan PODDIR = ..\pod EXTUTILSDIR = $(LIBDIR)\ExtUtils HTMLDIR = .\html # INST_SCRIPT = $(INST_TOP)$(INST_VER)\bin INST_BIN = $(INST_SCRIPT)$(INST_ARCH) INST_LIB = $(INST_TOP)$(INST_VER)\lib INST_ARCHLIB = $(INST_LIB)$(INST_ARCH) INST_COREDIR = $(INST_ARCHLIB)\CORE INST_HTML = $(INST_TOP)$(INST_VER)\html # # Programs to compile, build .lib files and link # .USESHELL : .IF "$(CCTYPE)" == "BORLAND" CC = bcc32 .IF "$(BCCOLD)" != "define" LINK32 = ilink32 .ELSE LINK32 = tlink32 .ENDIF LIB32 = tlib /a /P128 IMPLIB = implib -c RSC = brcc32 # # Options # INCLUDES = -I$(COREDIR) -I.\include -I. -I.. -I"$(CCINCDIR)" #PCHFLAGS = -H -Hc -H=c:\temp\bcmoduls.pch DEFINES = -DWIN32 $(CRYPT_FLAG) LOCDEFS = -DPERLDLL -DPERL_CORE SUBSYS = console CXX_FLAG = -P LIBC = cw32mti.lib # same libs as MSVC, except Borland doesn't have oldnames.lib LIBFILES = $(CRYPT_LIB) \ kernel32.lib user32.lib gdi32.lib winspool.lib \ comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib \ netapi32.lib uuid.lib ws2_32.lib mpr.lib winmm.lib \ version.lib odbc32.lib odbccp32.lib comctl32.lib \ import32.lib $(LIBC) .IF "$(CFG)" == "Debug" OPTIMIZE = -v -D_RTLDLL -DDEBUGGING LINK_DBG = -v .ELSE OPTIMIZE = -O2 -D_RTLDLL LINK_DBG = .ENDIF EXTRACFLAGS = CFLAGS = -w -g0 -tWM -tWD $(INCLUDES) $(DEFINES) $(LOCDEFS) \ $(PCHFLAGS) $(OPTIMIZE) LINK_FLAGS = $(LINK_DBG) -x -L"$(INST_COREDIR)" -L"$(CCLIBDIR)" \ -L"$(CCLIBDIR)\PSDK" OBJOUT_FLAG = -o EXEOUT_FLAG = -e LIBOUT_FLAG = .IF "$(BCCOLD)" != "define" LINK_FLAGS += -Gn DEFINES += -D_MT -D__USELOCALES__ -D_WIN32_WINNT=0x0410 .END .IF "$(BCCVCL)" == "define" LIBC = cp32mti.lib vcl.lib vcl50.lib vclx50.lib vcle50.lib LINK_FLAGS += -L"$(CCLIBDIR)\Release" .END .ELIF "$(CCTYPE)" == "GCC" .IF "$(GCCCROSS)" == "define" ARCHPREFIX = x86_64-w64-mingw32- .ENDIF CC = $(ARCHPREFIX)gcc LINK32 = $(ARCHPREFIX)g++ LIB32 = $(ARCHPREFIX)ar rc IMPLIB = $(ARCHPREFIX)dlltool RSC = $(ARCHPREFIX)windres i = .i o = .o a = .a # # Options # INCLUDES = -I.\include -I. -I.. -I$(COREDIR) DEFINES = -DWIN32 $(CRYPT_FLAG) .IF "$(WIN64)" == "define" DEFINES += -DWIN64 -DCONSERVATIVE .ENDIF LOCDEFS = -DPERLDLL -DPERL_CORE SUBSYS = console CXX_FLAG = -xc++ # Current releases of MinGW 5.1.4 (as of 11-Aug-2009) will fail to link # correctly if -lmsvcrt is specified explicitly. LIBC = #LIBC = -lmsvcrt # same libs as MSVC LIBFILES = $(CRYPT_LIB) $(LIBC) \ -lmoldname -lkernel32 -luser32 -lgdi32 \ -lwinspool -lcomdlg32 -ladvapi32 -lshell32 -lole32 \ -loleaut32 -lnetapi32 -luuid -lws2_32 -lmpr \ -lwinmm -lversion -lodbc32 -lodbccp32 -lcomctl32 .IF "$(CFG)" == "Debug" OPTIMIZE = -g -O2 -DDEBUGGING LINK_DBG = -g .ELSE OPTIMIZE = -s -O2 LINK_DBG = -s .ENDIF EXTRACFLAGS = CFLAGS = $(INCLUDES) $(DEFINES) $(LOCDEFS) $(OPTIMIZE) LINK_FLAGS = $(LINK_DBG) -L"$(INST_COREDIR)" -L"$(CCLIBDIR)" OBJOUT_FLAG = -o EXEOUT_FLAG = -o LIBOUT_FLAG = # NOTE: we assume that GCC uses MSVCRT.DLL # See comments about PERL_MSVCRT_READFIX in the "cl" compiler section below. BUILDOPT += -fno-strict-aliasing -mms-bitfields -DPERL_MSVCRT_READFIX .ELSE CC = cl LINK32 = link LIB32 = $(LINK32) -lib RSC = rc # # Options # INCLUDES = -I$(COREDIR) -I.\include -I. -I.. #PCHFLAGS = -Fpc:\temp\vcmoduls.pch -YX DEFINES = -DWIN32 -D_CONSOLE -DNO_STRICT $(CRYPT_FLAG) LOCDEFS = -DPERLDLL -DPERL_CORE SUBSYS = console CXX_FLAG = -TP -EHsc .IF "$(USE_PERLCRT)" != "define" LIBC = msvcrt.lib .ELSE LIBC = PerlCRT.lib .ENDIF .IF "$(CFG)" == "Debug" .IF "$(CCTYPE)" == "MSVC20" OPTIMIZE = -Od -MD -Z7 -DDEBUGGING .ELSE OPTIMIZE = -O1 -MD -Zi -DDEBUGGING .ENDIF LINK_DBG = -debug .ELSE OPTIMIZE = -MD -Zi -DNDEBUG # we enable debug symbols in release builds also LINK_DBG = -debug -opt:ref,icf # you may want to enable this if you want COFF symbols in the executables # in addition to the PDB symbols. The default Dr. Watson that ships with # Windows can use the the former but not latter. The free WinDbg can be # installed to get better stack traces from just the PDB symbols, so we # avoid the bloat of COFF symbols by default. #LINK_DBG = $(LINK_DBG) -debugtype:both .IF "$(WIN64)" == "define" # enable Whole Program Optimizations (WPO) and Link Time Code Generation (LTCG) OPTIMIZE += -Ox -GL LINK_DBG += -ltcg .ELSE # -O1 yields smaller code, which turns out to be faster than -O2 on x86 OPTIMIZE += -O1 #OPTIMIZE += -O2 .ENDIF .ENDIF .IF "$(WIN64)" == "define" DEFINES += -DWIN64 -DCONSERVATIVE OPTIMIZE += -Wp64 -fp:precise .ENDIF # For now, silence VC++ 8.x's and 9.x's warnings about "unsafe" CRT functions # and POSIX CRT function names being deprecated. .IF "$(CCTYPE)" == "MSVC80" || "$(CCTYPE)" == "MSVC80FREE" || \ "$(CCTYPE)" == "MSVC90" || "$(CCTYPE)" == "MSVC90FREE" DEFINES += -D_CRT_SECURE_NO_DEPRECATE -D_CRT_NONSTDC_NO_DEPRECATE .ENDIF # Use the MSVCRT read() fix if the PerlCRT was not chosen, but only when using # VC++ 6.x or earlier. Later versions use MSVCR70.dll, MSVCR71.dll, etc, which # do not require the fix. .IF "$(CCTYPE)" == "MSVC20" || "$(CCTYPE)" == "MSVC" || "$(CCTYPE)" == "MSVC60" .IF "$(USE_PERLCRT)" != "define" BUILDOPT += -DPERL_MSVCRT_READFIX .ENDIF .ENDIF LIBBASEFILES = $(CRYPT_LIB) \ oldnames.lib kernel32.lib user32.lib gdi32.lib winspool.lib \ comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib \ netapi32.lib uuid.lib ws2_32.lib mpr.lib winmm.lib \ version.lib odbc32.lib odbccp32.lib comctl32.lib # The 64 bit Platform SDK compilers contain a runtime library that doesn't # include the buffer overrun verification code used by the /GS switch. # Since the code links against libraries that are compiled with /GS, this # "security cookie verification" must be included via bufferoverlow.lib. .IF "$(WIN64)" == "define" LIBBASEFILES += bufferoverflowU.lib .ENDIF # we add LIBC here, since we may be using PerlCRT.dll LIBFILES = $(LIBBASEFILES) $(LIBC) EXTRACFLAGS = -nologo -GF -W3 CFLAGS = $(EXTRACFLAGS) $(INCLUDES) $(DEFINES) $(LOCDEFS) \ $(PCHFLAGS) $(OPTIMIZE) LINK_FLAGS = -nologo -nodefaultlib $(LINK_DBG) \ -libpath:"$(INST_COREDIR)" \ -machine:$(PROCESSOR_ARCHITECTURE) LIB_FLAGS = -nologo OBJOUT_FLAG = -Fo EXEOUT_FLAG = -Fe LIBOUT_FLAG = /out: .ENDIF CFLAGS_O = $(CFLAGS) $(BUILDOPT) .IF "$(CCTYPE)" == "MSVC80" || "$(CCTYPE)" == "MSVC80FREE" || \ "$(CCTYPE)" == "MSVC90" || "$(CCTYPE)" == "MSVC90FREE" LINK_FLAGS += "/manifestdependency:type='Win32' name='Microsoft.Windows.Common-Controls' version='6.0.0.0' processorArchitecture='*' publicKeyToken='6595b64144ccf1df' language='*'" .ELSE RSC_FLAGS = -DINCLUDE_MANIFEST .ENDIF # used to allow local linking flags that are not propogated into Config.pm, # currently unused # -- BKS, 12-12-1999 PRIV_LINK_FLAGS *= BLINK_FLAGS = $(PRIV_LINK_FLAGS) $(LINK_FLAGS) #################### do not edit below this line ####################### ############# NO USER-SERVICEABLE PARTS BEYOND THIS POINT ############## # Some old dmakes (including Sarathy's one at # http://search.cpan.org/CPAN/authors/id/G/GS/GSAR/dmake-4.1pl1-win32.zip) # don't support logical OR (||) or logical AND (&&) in conditional # expressions and hence don't process this makefile correctly. Determine # whether this is the case so that we can give the user an error message. .IF 1 == 1 || 1 == 1 NEWDMAKE = define .ELSE NEWDMAKE = undef .ENDIF o *= .obj a *= .lib LKPRE = INPUT ( LKPOST = ) # # Rules # .SUFFIXES : .c .i $(o) .dll $(a) .exe .rc .res .c$(o): $(CC) -c $(null,$(<:d) $(NULL) -I$(<:d)) $(CFLAGS_O) $(OBJOUT_FLAG)$@ $< .c.i: $(CC) -c $(null,$(<:d) $(NULL) -I$(<:d)) $(CFLAGS_O) -E $< >$@ .y.c: $(NOOP) $(o).dll: .IF "$(CCTYPE)" == "BORLAND" $(LINK32) -Tpd -ap $(BLINK_FLAGS) c0d32$(o) $<,$@,,$(LIBFILES),$(*B).def $(IMPLIB) $(*B).lib $@ .ELIF "$(CCTYPE)" == "GCC" $(LINK32) -o $@ $(BLINK_FLAGS) $< $(LIBFILES) $(IMPLIB) --input-def $(*B).def --output-lib $(*B).a $@ .ELSE $(LINK32) -dll -subsystem:windows -implib:$(*B).lib -def:$(*B).def \ -out:$@ $(BLINK_FLAGS) $(LIBFILES) $< $(LIBPERL) $(EMBED_DLL_MANI) .ENDIF .rc.res: .IF "$(CCTYPE)" == "GCC" $(RSC) --use-temp-file --include-dir=. --include-dir=.. -O COFF -D INCLUDE_MANIFEST -i $< -o $@ .ELSE $(RSC) -i.. -DINCLUDE_MANIFEST $< .ENDIF # # various targets MINIPERL = ..\miniperl.exe MINIDIR = .\mini PERLEXE = ..\perl.exe WPERLEXE = ..\wperl.exe PERLEXESTATIC = ..\perl-static.exe GLOBEXE = ..\perlglob.exe CONFIGPM = ..\lib\Config.pm ..\lib\Config_heavy.pl MINIMOD = ..\lib\ExtUtils\Miniperl.pm X2P = ..\x2p\a2p.exe GENUUDMAP = ..\generate_uudmap.exe .IF "$(BUILD_STATIC)" == "define" PERLSTATIC = static .ELSE PERLSTATIC = .ENDIF # Unicode data files generated by mktables UNIDATAFILES = ..\lib\unicore\Decomposition.pl ..\lib\unicore\TestProp.pl \ ..\lib\unicore\CombiningClass.pl ..\lib\unicore\Name.pl \ ..\lib\unicore\Heavy.pl ..\lib\unicore\mktables.lst # Directories of Unicode data files generated by mktables UNIDATADIR1 = ..\lib\unicore\To UNIDATADIR2 = ..\lib\unicore\lib PERLEXE_MANIFEST= .\perlexe.manifest PERLEXE_ICO = .\perlexe.ico PERLEXE_RES = .\perlexe.res PERLDLL_RES = # Nominate a target which causes extensions to be re-built # This used to be $(PERLEXE), but at worst it is the .dll that they depend # on and really only the interface - i.e. the .def file used to export symbols # from the .dll PERLDEP = perldll.def PL2BAT = bin\pl2bat.pl GLOBBAT = bin\perlglob.bat UTILS = \ ..\utils\h2ph \ ..\utils\splain \ ..\utils\dprofpp \ ..\utils\perlbug \ ..\utils\pl2pm \ ..\utils\c2ph \ ..\utils\pstruct \ ..\utils\h2xs \ ..\utils\perldoc \ ..\utils\perlivp \ ..\utils\libnetcfg \ ..\utils\enc2xs \ ..\utils\piconv \ ..\utils\config_data \ ..\utils\corelist \ ..\utils\cpan \ ..\utils\xsubpp \ ..\utils\prove \ ..\utils\ptar \ ..\utils\ptardiff \ ..\utils\cpanp-run-perl \ ..\utils\cpanp \ ..\utils\cpan2dist \ ..\utils\shasum \ ..\utils\instmodsh \ ..\pod\pod2html \ ..\pod\pod2latex \ ..\pod\pod2man \ ..\pod\pod2text \ ..\pod\pod2usage \ ..\pod\podchecker \ ..\pod\podselect \ ..\x2p\find2perl \ ..\x2p\psed \ ..\x2p\s2p \ bin\exetype.pl \ bin\runperl.pl \ bin\pl2bat.pl \ bin\perlglob.pl \ bin\search.pl .IF "$(CCTYPE)" == "BORLAND" CFGSH_TMPL = config.bc CFGH_TMPL = config_H.bc .ELIF "$(CCTYPE)" == "GCC" .IF "$(WIN64)" == "define" .IF "$(GCCCROSS)" == "define" CFGSH_TMPL = config.gc64 CFGH_TMPL = config_H.gc64 .ELSE CFGSH_TMPL = config.gc64nox CFGH_TMPL = config_H.gc64nox .ENDIF .ELSE CFGSH_TMPL = config.gc CFGH_TMPL = config_H.gc .ENDIF PERLIMPLIB = ..\libperl511$(a) PERLSTATICLIB = ..\libperl511s$(a) .ELSE .IF "$(WIN64)" == "define" CFGSH_TMPL = config.vc64 CFGH_TMPL = config_H.vc64 .ELSE CFGSH_TMPL = config.vc CFGH_TMPL = config_H.vc .ENDIF .ENDIF # makedef.pl must be updated if this changes, and this should normally # only change when there is an incompatible revision of the public API. PERLIMPLIB *= ..\perl512$(a) PERLSTATICLIB *= ..\perl512s$(a) PERLDLL = ..\perl512.dll XCOPY = xcopy /f /r /i /d /y RCOPY = xcopy /f /r /i /e /d /y NOOP = @rem MICROCORE_SRC = \ ..\av.c \ ..\deb.c \ ..\doio.c \ ..\doop.c \ ..\dump.c \ ..\globals.c \ ..\gv.c \ ..\mro.c \ ..\hv.c \ ..\locale.c \ ..\mathoms.c \ ..\mg.c \ ..\numeric.c \ ..\op.c \ ..\pad.c \ ..\perl.c \ ..\perlapi.c \ ..\perly.c \ ..\pp.c \ ..\pp_ctl.c \ ..\pp_hot.c \ ..\pp_pack.c \ ..\pp_sort.c \ ..\pp_sys.c \ ..\reentr.c \ ..\regcomp.c \ ..\regexec.c \ ..\run.c \ ..\scope.c \ ..\sv.c \ ..\taint.c \ ..\toke.c \ ..\universal.c \ ..\utf8.c \ ..\util.c EXTRACORE_SRC += perllib.c .IF "$(PERL_MALLOC)" == "define" EXTRACORE_SRC += ..\malloc.c .ENDIF EXTRACORE_SRC += ..\perlio.c WIN32_SRC = \ .\win32.c \ .\win32sck.c \ .\win32thread.c # We need this for miniperl build unless we override canned # config.h #define building mini\* #.IF "$(USE_PERLIO)" == "define" WIN32_SRC += .\win32io.c #.ENDIF .IF "$(CRYPT_SRC)" != "" WIN32_SRC += .\$(CRYPT_SRC) .ENDIF X2P_SRC = \ ..\x2p\a2p.c \ ..\x2p\hash.c \ ..\x2p\str.c \ ..\x2p\util.c \ ..\x2p\walk.c CORE_NOCFG_H = \ ..\av.h \ ..\cop.h \ ..\cv.h \ ..\dosish.h \ ..\embed.h \ ..\form.h \ ..\gv.h \ ..\handy.h \ ..\hv.h \ ..\iperlsys.h \ ..\mg.h \ ..\nostdio.h \ ..\op.h \ ..\opcode.h \ ..\perl.h \ ..\perlapi.h \ ..\perlsdio.h \ ..\perlsfio.h \ ..\perly.h \ ..\pp.h \ ..\proto.h \ ..\regcomp.h \ ..\regexp.h \ ..\scope.h \ ..\sv.h \ ..\thread.h \ ..\unixish.h \ ..\utf8.h \ ..\util.h \ ..\warnings.h \ ..\XSUB.h \ ..\EXTERN.h \ ..\perlvars.h \ ..\intrpvar.h \ .\include\dirent.h \ .\include\netdb.h \ .\include\sys\socket.h \ .\win32.h CORE_H = $(CORE_NOCFG_H) .\config.h ..\git_version.h UUDMAP_H = ..\uudmap.h BITCOUNT_H = ..\bitcount.h MICROCORE_OBJ = $(MICROCORE_SRC:db:+$(o)) CORE_OBJ = $(MICROCORE_OBJ) $(EXTRACORE_SRC:db:+$(o)) WIN32_OBJ = $(WIN32_SRC:db:+$(o)) MINICORE_OBJ = $(MINIDIR)\{$(MICROCORE_OBJ:f) miniperlmain$(o) perlio$(o)} MINIWIN32_OBJ = $(MINIDIR)\{$(WIN32_OBJ:f)} MINI_OBJ = $(MINICORE_OBJ) $(MINIWIN32_OBJ) DLL_OBJ = $(DYNALOADER) X2P_OBJ = $(X2P_SRC:db:+$(o)) GENUUDMAP_OBJ = $(GENUUDMAP:db:+$(o)) PERLDLL_OBJ = $(CORE_OBJ) PERLEXE_OBJ = perlmain$(o) PERLEXEST_OBJ = perlmainst$(o) PERLDLL_OBJ += $(WIN32_OBJ) $(DLL_OBJ) .IF "$(USE_SETARGV)" != "" SETARGV_OBJ = setargv$(o) .ENDIF .IF "$(ALL_STATIC)" == "define" # some exclusions, unfortunately, until fixed: # - Win32 extension contains overlapped symbols with win32.c (BUG!) # - MakeMaker isn't capable enough for SDBM_File (smaller bug) # - Encode (encoding search algorithm relies on shared library?) STATIC_EXT = * !Win32 !SDBM_File !Encode .ELSE # specify static extensions here, for example: #STATIC_EXT = Cwd Compress/Raw/Zlib STATIC_EXT = Win32CORE .ENDIF DYNALOADER = ..\DynaLoader$(o) # vars must be separated by "\t+~\t+", since we're using the tempfile # version of config_sh.pl (we were overflowing someone's buffer by # trying to fit them all on the command line) # -- BKS 10-17-1999 CFG_VARS = \ INST_DRV=$(INST_DRV) ~ \ INST_TOP=$(INST_TOP) ~ \ INST_VER=$(INST_VER) ~ \ INST_ARCH=$(INST_ARCH) ~ \ archname=$(ARCHNAME) ~ \ cc=$(CC) ~ \ ld=$(LINK32) ~ \ ccflags=$(EXTRACFLAGS) $(OPTIMIZE) $(DEFINES) $(BUILDOPT) ~ \ cf_email=$(EMAIL) ~ \ d_crypt=$(D_CRYPT) ~ \ d_mymalloc=$(PERL_MALLOC) ~ \ libs=$(LIBFILES:f) ~ \ incpath=$(CCINCDIR) ~ \ libperl=$(PERLIMPLIB:f) ~ \ libpth=$(CCLIBDIR);$(EXTRALIBDIRS) ~ \ libc=$(LIBC) ~ \ make=dmake ~ \ _o=$(o) ~ \ obj_ext=$(o) ~ \ _a=$(a) ~ \ lib_ext=$(a) ~ \ static_ext=$(STATIC_EXT) ~ \ usethreads=$(USE_ITHREADS) ~ \ useithreads=$(USE_ITHREADS) ~ \ usemultiplicity=$(USE_MULTI) ~ \ useperlio=$(USE_PERLIO) ~ \ uselargefiles=$(USE_LARGE_FILES) ~ \ usesitecustomize=$(USE_SITECUST) ~ \ LINK_FLAGS=$(LINK_FLAGS) ~ \ optimize=$(OPTIMIZE) # # set up targets varying between Win95 and WinNT builds # .IF "$(IS_WIN95)" == "define" MK2 = .\makefile.95 RIGHTMAKE = __switch_makefiles .ELSE MK2 = __not_needed RIGHTMAKE = .ENDIF .IMPORT .IGNORE : SystemRoot windir # Don't just .IMPORT OS from the environment because dmake sets OS itself. ENV_OS=$(subst,OS=, $(shell @set OS)) .IF "$(ENV_OS)" == "Windows_NT" ODBCCP32_DLL = $(SystemRoot)\system32\odbccp32.dll .ELSE ODBCCP32_DLL = $(windir)\system\odbccp32.dll .ENDIF ICWD = -I..\cpan\Cwd -I..\cpan\Cwd\lib # # Top targets # all : CHECKDMAKE .\config.h ..\git_version.h $(GLOBEXE) $(MINIPERL) $(MK2) \ $(RIGHTMAKE) $(MINIMOD) $(CONFIGPM) $(UNIDATAFILES) MakePPPort \ $(PERLEXE) $(X2P) Extensions Extensions_nonxs $(PERLSTATIC) ..\regcharclass.h : ..\Porting\regcharclass.pl cd .. && miniperl Porting\regcharclass.pl && cd win32 regnodes : ..\regnodes.h ..\regcomp$(o) : ..\regnodes.h ..\regcharclass.h ..\regexec$(o) : ..\regnodes.h ..\regcharclass.h reonly : regnodes .\config.h ..\git_version.h $(GLOBEXE) $(MINIPERL) $(MK2) \ $(RIGHTMAKE) $(MINIMOD) $(CONFIGPM) $(UNIDATAFILES) $(PERLEXE) \ $(X2P) Extensions_reonly static: $(PERLEXESTATIC) #---------------------------------------------------------------- #-------------------- BEGIN Win95 SPECIFIC ---------------------- # this target is a jump-off point for Win95 # 1. it switches to the Win95-specific makefile if it exists # (__do_switch_makefiles) # 2. it prints a message when the Win95-specific one finishes (__done) # 3. it then kills this makefile by trying to make __no_such_target __switch_makefiles: __do_switch_makefiles __done __no_such_target __do_switch_makefiles: .IF "$(NOTFIRST)" != "true" if exist $(MK2) $(MAKE:s/-S//) -f $(MK2) $(MAKETARGETS) NOTFIRST=true .ELSE $(NOOP) .ENDIF .IF "$(NOTFIRST)" != "true" __done: @echo Build process complete. Ignore any errors after this message. @echo Run "dmake test" to test and "dmake install" to install .ELSE # dummy targets for Win95-specific makefile __done: $(NOOP) __no_such_target: $(NOOP) .ENDIF # This target is used to generate the new makefile (.\makefile.95) for Win95 .\makefile.95: .\makefile.mk $(MINIPERL) genmk95.pl makefile.mk $(MK2) #--------------------- END Win95 SPECIFIC --------------------- # a blank target for when builds don't need to do certain things # this target added for Win95 port but used to keep the WinNT port able to # use this file __not_needed: $(NOOP) CHECKDMAKE : .IF "$(NEWDMAKE)" == "define" $(NOOP) .ELSE @echo Your dmake doesn't support ^|^| or ^&^& in conditional expressions. @echo Please get the latest dmake from http://search.cpan.org/dist/dmake/ @exit 1 .ENDIF $(GLOBEXE) : perlglob$(o) .IF "$(CCTYPE)" == "BORLAND" $(CC) -c -w -v -tWM -I"$(CCINCDIR)" perlglob.c $(LINK32) -Tpe -ap $(BLINK_FLAGS) c0x32$(o) perlglob$(o) \ "$(CCLIBDIR)\32BIT\wildargs$(o)",$@,,import32.lib cw32mt.lib, .ELIF "$(CCTYPE)" == "GCC" $(LINK32) $(BLINK_FLAGS) -mconsole -o $@ perlglob$(o) $(LIBFILES) .ELSE $(LINK32) $(BLINK_FLAGS) $(LIBFILES) -out:$@ -subsystem:$(SUBSYS) \ perlglob$(o) setargv$(o) $(EMBED_EXE_MANI) .ENDIF perlglob$(o) : perlglob.c config.w32 : $(CFGSH_TMPL) copy $(CFGSH_TMPL) config.w32 .\config.h : $(CFGH_TMPL) $(CORE_NOCFG_H) -del /f config.h copy $(CFGH_TMPL) config.h ..\git_version.h : $(MINIPERL) ..\make_patchnum.pl cd .. && miniperl -Ilib make_patchnum.pl # make sure that we recompile perl.c if the git version changes ..\perl$(o) : ..\git_version.h ..\config.sh : config.w32 $(MINIPERL) config_sh.PL FindExt.pm $(MINIPERL) -I..\lib config_sh.PL --cfgsh-option-file \ $(mktmp $(CFG_VARS)) config.w32 > ..\config.sh # this target is for when changes to the main config.sh happen. # edit config.gc, then make perl using GCC in a minimal configuration (i.e. # with MULTI, ITHREADS, IMP_SYS, LARGE_FILES, PERLIO and CRYPT off), then make # this target to regenerate config_H.gc. # unfortunately, some further manual editing is also then required to restore all # the special _MSC_VER handling that is otherwise lost. # repeat for config.bc and config_H.bc (using BORLAND), except that there is no # _MSC_VER stuff in that case. regen_config_h: $(MINIPERL) -I..\lib config_sh.PL --cfgsh-option-file $(mktmp $(CFG_VARS)) \ $(CFGSH_TMPL) > ..\config.sh $(MINIPERL) -I..\lib ..\configpm --chdir=.. -del /f $(CFGH_TMPL) -$(MINIPERL) -I..\lib $(ICWD) config_h.PL "INST_VER=$(INST_VER)" rename config.h $(CFGH_TMPL) $(CONFIGPM) : $(MINIPERL) ..\config.sh config_h.PL ..\minimod.pl $(MINIPERL) -I..\lib ..\configpm --chdir=.. if exist lib\* $(RCOPY) lib\*.* ..\lib\$(NULL) $(XCOPY) ..\*.h $(COREDIR)\*.* $(XCOPY) *.h $(COREDIR)\*.* $(XCOPY) ..\ext\re\re.pm $(LIBDIR)\*.* $(RCOPY) include $(COREDIR)\*.* $(MINIPERL) -I..\lib $(ICWD) config_h.PL "INST_VER=$(INST_VER)" \ || $(MAKE) $(MAKEMACROS) $(CONFIGPM) $(MAKEFILE) $(MINIPERL) : $(MINIDIR) $(MINI_OBJ) $(CRTIPMLIBS) .IF "$(CCTYPE)" == "BORLAND" if not exist $(CCLIBDIR)\PSDK\odbccp32.lib \ cd $(CCLIBDIR)\PSDK && implib odbccp32.lib $(ODBCCP32_DLL) $(LINK32) -Tpe -ap $(BLINK_FLAGS) \ @$(mktmp c0x32$(o) $(MINI_OBJ),$@,,$(LIBFILES),) .ELIF "$(CCTYPE)" == "GCC" $(LINK32) -v -mconsole -o $@ $(BLINK_FLAGS) \ $(mktmp $(LKPRE) $(MINI_OBJ) $(LIBFILES) $(LKPOST)) .ELSE $(LINK32) -subsystem:console -out:$@ $(BLINK_FLAGS) \ @$(mktmp $(LIBFILES) $(MINI_OBJ)) $(EMBED_EXE_MANI) .ENDIF $(MINIDIR) : if not exist "$(MINIDIR)" mkdir "$(MINIDIR)" $(MINICORE_OBJ) : $(CORE_NOCFG_H) $(CC) -c $(CFLAGS) -DPERL_EXTERNAL_GLOB -DPERL_IS_MINIPERL $(OBJOUT_FLAG)$@ ..\$(*B).c $(MINIWIN32_OBJ) : $(CORE_NOCFG_H) $(CC) -c $(CFLAGS) $(OBJOUT_FLAG)$@ $(*B).c # -DPERL_IMPLICIT_SYS needs C++ for perllib.c # rules wrapped in .IFs break Win9X build (we end up with unbalanced []s unless # unless the .IF is true), so instead we use a .ELSE with the default. # This is the only file that depends on perlhost.h, vmem.h, and vdir.h perllib$(o) : perllib.c .\perlhost.h .\vdir.h .\vmem.h .IF "$(USE_IMP_SYS)" == "define" $(CC) -c -I. $(CFLAGS_O) $(CXX_FLAG) $(OBJOUT_FLAG)$@ perllib.c .ELSE $(CC) -c -I. $(CFLAGS_O) $(OBJOUT_FLAG)$@ perllib.c .ENDIF # 1. we don't want to rebuild miniperl.exe when config.h changes # 2. we don't want to rebuild miniperl.exe with non-default config.h # 3. we can't have miniperl.exe depend on git_version.h, as miniperl creates it $(MINI_OBJ) : $(CORE_NOCFG_H) $(WIN32_OBJ) : $(CORE_H) $(CORE_OBJ) : $(CORE_H) $(DLL_OBJ) : $(CORE_H) $(X2P_OBJ) : $(CORE_H) perldll.def : $(MINIPERL) $(CONFIGPM) ..\global.sym ..\pp.sym ..\makedef.pl create_perllibst_h.pl $(MINIPERL) -I..\lib create_perllibst_h.pl $(MINIPERL) -I..\lib -w ..\makedef.pl PLATFORM=win32 $(OPTIMIZE) $(DEFINES) \ $(BUILDOPT) CCTYPE=$(CCTYPE) > perldll.def $(PERLDLL): perldll.def $(PERLDLL_OBJ) $(PERLDLL_RES) Extensions_static .IF "$(CCTYPE)" == "BORLAND" $(LINK32) -Tpd -ap $(BLINK_FLAGS) \ @$(mktmp c0d32$(o) $(PERLDLL_OBJ),$@,, \ $(shell @type Extensions_static) $(LIBFILES),perldll.def) $(IMPLIB) $*.lib $@ .ELIF "$(CCTYPE)" == "GCC" $(LINK32) -mdll -o $@ -Wl,--base-file -Wl,perl.base $(BLINK_FLAGS) \ $(mktmp $(LKPRE) $(PERLDLL_OBJ) \ $(shell @type Extensions_static) \ $(LIBFILES) $(LKPOST)) $(IMPLIB) --output-lib $(PERLIMPLIB) \ --dllname $(PERLDLL:b).dll \ --def perldll.def \ --base-file perl.base \ --output-exp perl.exp $(LINK32) -mdll -o $@ $(BLINK_FLAGS) \ $(mktmp $(LKPRE) $(PERLDLL_OBJ) \ $(shell @type Extensions_static) \ $(LIBFILES) perl.exp $(LKPOST)) .ELSE $(LINK32) -dll -def:perldll.def -out:$@ $(BLINK_FLAGS) \ @Extensions_static \ @$(mktmp -base:0x28000000 $(DELAYLOAD) $(LIBFILES) \ $(PERLDLL_RES) $(PERLDLL_OBJ)) $(EMBED_DLL_MANI) .ENDIF $(XCOPY) $(PERLIMPLIB) $(COREDIR) $(PERLSTATICLIB): Extensions_static .IF "$(CCTYPE)" == "BORLAND" $(LIB32) $(LIB_FLAGS) $@ \ @$(mktmp $(shell @type Extensions_static) \ $(PERLDLL_OBJ)) .ELIF "$(CCTYPE)" == "GCC" # XXX: It would be nice if MinGW's ar accepted a temporary file, but this # doesn't seem to work: # $(LIB32) $(LIB_FLAGS) $@ \ # $(mktmp $(LKPRE) $(shell @type Extensions_static) \ # $(PERLDLL_OBJ) $(LKPOST)) $(LIB32) $(LIB_FLAGS) $@ \ $(shell @type Extensions_static) \ $(PERLDLL_OBJ) .ELSE $(LIB32) $(LIB_FLAGS) -out:$@ @Extensions_static \ @$(mktmp $(PERLDLL_OBJ)) .ENDIF $(XCOPY) $(PERLSTATICLIB) $(COREDIR) $(PERLEXE_RES): perlexe.rc $(PERLEXE_MANIFEST) $(PERLEXE_ICO) $(MINIMOD) : $(MINIPERL) ..\minimod.pl cd .. && miniperl minimod.pl > lib\ExtUtils\Miniperl.pm ..\x2p\a2p$(o) : ..\x2p\a2p.c $(CC) -I..\x2p $(CFLAGS) $(OBJOUT_FLAG)$@ -c ..\x2p\a2p.c ..\x2p\hash$(o) : ..\x2p\hash.c $(CC) -I..\x2p $(CFLAGS) $(OBJOUT_FLAG)$@ -c ..\x2p\hash.c ..\x2p\str$(o) : ..\x2p\str.c $(CC) -I..\x2p $(CFLAGS) $(OBJOUT_FLAG)$@ -c ..\x2p\str.c ..\x2p\util$(o) : ..\x2p\util.c $(CC) -I..\x2p $(CFLAGS) $(OBJOUT_FLAG)$@ -c ..\x2p\util.c ..\x2p\walk$(o) : ..\x2p\walk.c $(CC) -I..\x2p $(CFLAGS) $(OBJOUT_FLAG)$@ -c ..\x2p\walk.c $(X2P) : $(MINIPERL) $(X2P_OBJ) Extensions $(MINIPERL) -I..\lib ..\x2p\find2perl.PL $(MINIPERL) -I..\lib ..\x2p\s2p.PL .IF "$(CCTYPE)" == "BORLAND" $(LINK32) -Tpe -ap $(BLINK_FLAGS) \ @$(mktmp c0x32$(o) $(X2P_OBJ),$@,,$(LIBFILES),) .ELIF "$(CCTYPE)" == "GCC" $(LINK32) -v -o $@ $(BLINK_FLAGS) \ $(mktmp $(LKPRE) $(X2P_OBJ) $(LIBFILES) $(LKPOST)) .ELSE $(LINK32) -subsystem:console -out:$@ $(BLINK_FLAGS) \ @$(mktmp $(LIBFILES) $(X2P_OBJ)) $(EMBED_EXE_MANI) .ENDIF $(MINIDIR)\globals$(o) : $(UUDMAP_H) $(BITCOUNT_H) $(UUDMAP_H) $(BITCOUNT_H) : $(GENUUDMAP) $(GENUUDMAP) $(UUDMAP_H) $(BITCOUNT_H) $(GENUUDMAP) : $(GENUUDMAP_OBJ) .IF "$(CCTYPE)" == "BORLAND" $(LINK32) -Tpe -ap $(BLINK_FLAGS) \ @$(mktmp c0x32$(o) $(GENUUDMAP_OBJ),$@,,$(LIBFILES),) .ELIF "$(CCTYPE)" == "GCC" $(LINK32) -v -o $@ $(BLINK_FLAGS) \ $(mktmp $(LKPRE) $(GENUUDMAP_OBJ) $(LIBFILES) $(LKPOST)) .ELSE $(LINK32) -subsystem:console -out:$@ $(BLINK_FLAGS) \ @$(mktmp $(LIBFILES) $(GENUUDMAP_OBJ)) $(EMBED_EXE_MANI) .ENDIF perlmain.c : runperl.c copy runperl.c perlmain.c perlmain$(o) : perlmain.c $(CC) $(CFLAGS_O:s,-DPERLDLL,-UPERLDLL,) $(OBJOUT_FLAG)$@ -c perlmain.c perlmainst.c : runperl.c copy runperl.c perlmainst.c perlmainst$(o) : perlmainst.c $(CC) $(CFLAGS_O) $(OBJOUT_FLAG)$@ -c perlmainst.c $(PERLEXE): $(PERLDLL) $(CONFIGPM) $(PERLEXE_OBJ) $(PERLEXE_RES) .IF "$(CCTYPE)" == "BORLAND" $(LINK32) -Tpe -ap $(BLINK_FLAGS) \ @$(mktmp c0x32$(o) $(PERLEXE_OBJ),$@,, \ $(PERLIMPLIB) $(LIBFILES),,$(PERLEXE_RES)) .ELIF "$(CCTYPE)" == "GCC" $(LINK32) -mconsole -o $@ $(BLINK_FLAGS) \ $(PERLEXE_OBJ) $(PERLEXE_RES) $(PERLIMPLIB) $(LIBFILES) .ELSE $(LINK32) -subsystem:console -out:$@ -stack:0x1000000 $(BLINK_FLAGS) \ $(LIBFILES) $(PERLEXE_OBJ) $(SETARGV_OBJ) $(PERLIMPLIB) $(PERLEXE_RES) $(EMBED_EXE_MANI) .ENDIF copy $(PERLEXE) $(WPERLEXE) $(MINIPERL) -I..\lib bin\exetype.pl $(WPERLEXE) WINDOWS $(PERLEXESTATIC): $(PERLSTATICLIB) $(CONFIGPM) $(PERLEXEST_OBJ) $(PERLEXE_RES) .IF "$(CCTYPE)" == "BORLAND" $(LINK32) -Tpe -ap $(BLINK_FLAGS) \ @$(mktmp c0x32$(o) $(PERLEXEST_OBJ),$@,, \ $(shell @type Extensions_static) $(PERLSTATICLIB) $(LIBFILES),, \ $(PERLEXE_RES)) .ELIF "$(CCTYPE)" == "GCC" $(LINK32) -mconsole -o $@ $(BLINK_FLAGS) \ $(mktmp $(LKPRE) $(shell @type Extensions_static) \ $(PERLSTATICLIB) $(LIBFILES) $(PERLEXEST_OBJ) \ $(PERLEXE_RES) $(LKPOST)) .ELSE $(LINK32) -subsystem:console -out:$@ -stack:0x1000000 $(BLINK_FLAGS) \ @Extensions_static $(PERLSTATICLIB) /PDB:NONE \ $(LIBFILES) $(PERLEXEST_OBJ) $(SETARGV_OBJ) $(PERLEXE_RES) $(EMBED_EXE_MANI) .ENDIF MakePPPort: $(MINIPERL) $(CONFIGPM) Extensions_nonxs $(MINIPERL) -I..\lib $(ICWD) ..\mkppport #------------------------------------------------------------------------------- # There's no direct way to mark a dependency on # DynaLoader.pm, so this will have to do Extensions : ..\make_ext.pl $(PERLDEP) $(CONFIGPM) $(DYNALOADER) $(XCOPY) ..\*.h $(COREDIR)\*.* $(MINIPERL) -I..\lib ..\make_ext.pl "MAKE=$(MAKE)" --dir=$(CPANDIR) --dir=$(DISTDIR) --dir=$(EXTDIR) --dynamic Extensions_reonly : ..\make_ext.pl $(PERLDEP) $(CONFIGPM) $(DYNALOADER) $(XCOPY) ..\*.h $(COREDIR)\*.* $(MINIPERL) -I..\lib ..\make_ext.pl "MAKE=$(MAKE)" --dir=$(CPANDIR) --dir=$(DISTDIR) --dir=$(EXTDIR) --dynamic +re Extensions_static : ..\make_ext.pl list_static_libs.pl $(PERLDEP) $(CONFIGPM) $(XCOPY) ..\*.h $(COREDIR)\*.* $(MINIPERL) -I..\lib ..\make_ext.pl "MAKE=$(MAKE)" --dir=$(CPANDIR) --dir=$(DISTDIR) --dir=$(EXTDIR) --static $(MINIPERL) -I..\lib list_static_libs.pl > Extensions_static Extensions_nonxs : ..\make_ext.pl $(PERLDEP) $(CONFIGPM) $(XCOPY) ..\*.h $(COREDIR)\*.* $(MINIPERL) -I..\lib ..\make_ext.pl "MAKE=$(MAKE)" --dir=$(CPANDIR) --dir=$(DISTDIR) --dir=$(EXTDIR) --nonxs $(DYNALOADER) : ..\make_ext.pl $(PERLDEP) $(CONFIGPM) Extensions_nonxs $(XCOPY) ..\*.h $(COREDIR)\*.* $(MINIPERL) -I..\lib ..\make_ext.pl "MAKE=$(MAKE)" --dir=$(EXTDIR) --dynaloader Extensions_clean : -if exist $(MINIPERL) $(MINIPERL) -I..\lib ..\make_ext.pl "MAKE=$(MAKE)" --dir=$(CPANDIR) --dir=$(DISTDIR) --dir=$(EXTDIR) --all --target=clean Extensions_realclean : -if exist $(MINIPERL) $(MINIPERL) -I..\lib ..\make_ext.pl "MAKE=$(MAKE)" --dir=$(CPANDIR) --dir=$(DISTDIR) --dir=$(EXTDIR) --all --target=realclean #------------------------------------------------------------------------------- doc: $(PERLEXE) ..\pod\perltoc.pod $(PERLEXE) -I..\lib ..\installhtml --podroot=.. --htmldir=$(HTMLDIR) \ --podpath=pod:lib:ext:utils --htmlroot="file://$(INST_HTML:s,:,|,)"\ --libpod=perlfunc:perlguts:perlvar:perlrun:perlop --recurse # Note that this next section is parsed (and regenerated) by pod/buildtoc # so please check that script before making structural changes here utils: $(PERLEXE) $(X2P) cd ..\utils && $(MAKE) PERL=$(MINIPERL) copy ..\README.aix ..\pod\perlaix.pod copy ..\README.amiga ..\pod\perlamiga.pod copy ..\README.apollo ..\pod\perlapollo.pod copy ..\README.beos ..\pod\perlbeos.pod copy ..\README.bs2000 ..\pod\perlbs2000.pod copy ..\README.ce ..\pod\perlce.pod copy ..\README.cn ..\pod\perlcn.pod copy ..\README.cygwin ..\pod\perlcygwin.pod copy ..\README.dgux ..\pod\perldgux.pod copy ..\README.dos ..\pod\perldos.pod copy ..\README.epoc ..\pod\perlepoc.pod copy ..\README.freebsd ..\pod\perlfreebsd.pod copy ..\README.haiku ..\pod\perlhaiku.pod copy ..\README.hpux ..\pod\perlhpux.pod copy ..\README.hurd ..\pod\perlhurd.pod copy ..\README.irix ..\pod\perlirix.pod copy ..\README.jp ..\pod\perljp.pod copy ..\README.ko ..\pod\perlko.pod copy ..\README.linux ..\pod\perllinux.pod copy ..\README.macos ..\pod\perlmacos.pod copy ..\README.macosx ..\pod\perlmacosx.pod copy ..\README.mpeix ..\pod\perlmpeix.pod copy ..\README.netware ..\pod\perlnetware.pod copy ..\README.openbsd ..\pod\perlopenbsd.pod copy ..\README.os2 ..\pod\perlos2.pod copy ..\README.os390 ..\pod\perlos390.pod copy ..\README.os400 ..\pod\perlos400.pod copy ..\README.plan9 ..\pod\perlplan9.pod copy ..\README.qnx ..\pod\perlqnx.pod copy ..\README.riscos ..\pod\perlriscos.pod copy ..\README.solaris ..\pod\perlsolaris.pod copy ..\README.symbian ..\pod\perlsymbian.pod copy ..\README.tru64 ..\pod\perltru64.pod copy ..\README.tw ..\pod\perltw.pod copy ..\README.uts ..\pod\perluts.pod copy ..\README.vmesa ..\pod\perlvmesa.pod copy ..\README.vos ..\pod\perlvos.pod copy ..\README.win32 ..\pod\perlwin32.pod copy ..\pod\perl5116delta.pod ..\pod\perldelta.pod cd ..\pod && $(MAKE) -f ..\win32\pod.mak converters $(PERLEXE) $(PL2BAT) $(UTILS) $(PERLEXE) $(ICWD) ..\autodoc.pl .. $(PERLEXE) $(ICWD) ..\pod\perlmodlib.pl -q ..\pod\perltoc.pod: $(PERLEXE) Extensions Extensions_nonxs $(PERLEXE) -f ..\pod\buildtoc --build-toc -q # Note that the pod cleanup in this next section is parsed (and regenerated # by pod/buildtoc so please check that script before making changes here distclean: realclean -del /f $(MINIPERL) $(PERLEXE) $(PERLDLL) $(GLOBEXE) \ $(PERLIMPLIB) ..\miniperl$(a) $(MINIMOD) \ $(PERLEXESTATIC) $(PERLSTATICLIB) -del /f *.def *.map -del /f $(LIBDIR)\Encode.pm $(LIBDIR)\encoding.pm $(LIBDIR)\Errno.pm -del /f $(LIBDIR)\Config.pod $(LIBDIR)\POSIX.pod $(LIBDIR)\threads.pm -del /f $(LIBDIR)\.exists $(LIBDIR)\attributes.pm $(LIBDIR)\DynaLoader.pm -del /f $(LIBDIR)\Fcntl.pm $(LIBDIR)\IO.pm $(LIBDIR)\Opcode.pm -del /f $(LIBDIR)\ops.pm $(LIBDIR)\Safe.pm -del /f $(LIBDIR)\SDBM_File.pm $(LIBDIR)\Socket.pm $(LIBDIR)\POSIX.pm -del /f $(LIBDIR)\B.pm $(LIBDIR)\O.pm $(LIBDIR)\re.pm -del /f $(LIBDIR)\File\Glob.pm -del /f $(LIBDIR)\Storable.pm -del /f $(LIBDIR)\Sys\Hostname.pm -del /f $(LIBDIR)\Time\HiRes.pm -del /f $(LIBDIR)\Unicode\Normalize.pm -del /f $(LIBDIR)\Math\BigInt\FastCalc.pm -del /f $(LIBDIR)\Win32.pm -del /f $(LIBDIR)\Win32CORE.pm -del /f $(LIBDIR)\Win32API\File.pm -del /f $(LIBDIR)\Win32API\File\cFile.pc -del /f $(DISTDIR)\XSLoader\XSLoader.pm -if exist $(LIBDIR)\App rmdir /s /q $(LIBDIR)\App -if exist $(LIBDIR)\Archive rmdir /s /q $(LIBDIR)\Archive -if exist $(LIBDIR)\Attribute rmdir /s /q $(LIBDIR)\Attribute -if exist $(LIBDIR)\autodie rmdir /s /q $(LIBDIR)\autodie -if exist $(LIBDIR)\B rmdir /s /q $(LIBDIR)\B -if exist $(LIBDIR)\CGI rmdir /s /q $(LIBDIR)\CGI -if exist $(LIBDIR)\CPAN rmdir /s /q $(LIBDIR)\CPAN -if exist $(LIBDIR)\CPANPLUS rmdir /s /q $(LIBDIR)\CPANPLUS -if exist $(LIBDIR)\Compress rmdir /s /q $(LIBDIR)\Compress -if exist $(LIBDIR)\Data rmdir /s /q $(LIBDIR)\Data -if exist $(LIBDIR)\Devel rmdir /s /q $(LIBDIR)\Devel -if exist $(LIBDIR)\Digest rmdir /s /q $(LIBDIR)\Digest -if exist $(LIBDIR)\Encode rmdir /s /q $(LIBDIR)\Encode -if exist $(LIBDIR)\encoding rmdir /s /q $(LIBDIR)\encoding -if exist $(LIBDIR)\ExtUtils\CBuilder rmdir /s /q $(LIBDIR)\ExtUtils\CBuilder -if exist $(LIBDIR)\ExtUtils\Command rmdir /s /q $(LIBDIR)\ExtUtils\Command -if exist $(LIBDIR)\ExtUtils\Constant rmdir /s /q $(LIBDIR)\ExtUtils\Constant -if exist $(LIBDIR)\ExtUtils\Liblist rmdir /s /q $(LIBDIR)\ExtUtils\Liblist -if exist $(LIBDIR)\ExtUtils\MakeMaker rmdir /s /q $(LIBDIR)\ExtUtils\MakeMaker -if exist $(LIBDIR)\File\Spec rmdir /s /q $(LIBDIR)\File\Spec -if exist $(LIBDIR)\Filter rmdir /s /q $(LIBDIR)\Filter -if exist $(LIBDIR)\Hash rmdir /s /q $(LIBDIR)\Hash -if exist $(LIBDIR)\I18N\LangTags rmdir /s /q $(LIBDIR)\I18N\LangTags -if exist $(LIBDIR)\inc rmdir /s /q $(LIBDIR)\inc -if exist $(LIBDIR)\Module\Pluggable rmdir /s /q $(LIBDIR)\Module\Pluggable -if exist $(LIBDIR)\IO rmdir /s /q $(LIBDIR)\IO -if exist $(LIBDIR)\IPC rmdir /s /q $(LIBDIR)\IPC -if exist $(LIBDIR)\List rmdir /s /q $(LIBDIR)\List -if exist $(LIBDIR)\Locale rmdir /s /q $(LIBDIR)\Locale -if exist $(LIBDIR)\Log rmdir /s /q $(LIBDIR)\Log -if exist $(LIBDIR)\Math rmdir /s /q $(LIBDIR)\Math -if exist $(LIBDIR)\Memoize rmdir /s /q $(LIBDIR)\Memoize -if exist $(LIBDIR)\MIME rmdir /s /q $(LIBDIR)\MIME -if exist $(LIBDIR)\Module rmdir /s /q $(LIBDIR)\Module -if exist $(LIBDIR)\mro rmdir /s /q $(LIBDIR)\mro -if exist $(LIBDIR)\Net\FTP rmdir /s /q $(LIBDIR)\Net\FTP -if exist $(LIBDIR)\Object rmdir /s /q $(LIBDIR)\Object -if exist $(LIBDIR)\Package rmdir /s /q $(LIBDIR)\Package -if exist $(LIBDIR)\Params rmdir /s /q $(LIBDIR)\Params -if exist $(LIBDIR)\Parse rmdir /s /q $(LIBDIR)\Parse -if exist $(LIBDIR)\PerlIO rmdir /s /q $(LIBDIR)\PerlIO -if exist $(LIBDIR)\Pod\Perldoc rmdir /s /q $(LIBDIR)\Pod\Perldoc -if exist $(LIBDIR)\Pod\Simple rmdir /s /q $(LIBDIR)\Pod\Simple -if exist $(LIBDIR)\Pod\Text rmdir /s /q $(LIBDIR)\Pod\Text -if exist $(LIBDIR)\re rmdir /s /q $(LIBDIR)\re -if exist $(LIBDIR)\Scalar rmdir /s /q $(LIBDIR)\Scalar -if exist $(LIBDIR)\Sys rmdir /s /q $(LIBDIR)\Sys -if exist $(LIBDIR)\TAP rmdir /s /q $(LIBDIR)\TAP -if exist $(LIBDIR)\Term\UI rmdir /s /q $(LIBDIR)\Term\UI -if exist $(LIBDIR)\Test rmdir /s /q $(LIBDIR)\Test -if exist $(LIBDIR)\Thread rmdir /s /q $(LIBDIR)\Thread -if exist $(LIBDIR)\threads rmdir /s /q $(LIBDIR)\threads -if exist $(LIBDIR)\Unicode\Collate rmdir /s /q $(LIBDIR)\Unicode\Collate -if exist $(LIBDIR)\XS rmdir /s /q $(LIBDIR)\XS -if exist $(LIBDIR)\Win32API rmdir /s /q $(LIBDIR)\Win32API -cd $(PODDIR) && del /f *.html *.bat \ perlaix.pod perlamiga.pod perlapi.pod perlapollo.pod \ perlbeos.pod perlbs2000.pod perlce.pod perlcn.pod \ perlcygwin.pod perldelta.pod perldgux.pod perldos.pod \ perlepoc.pod perlfreebsd.pod perlhaiku.pod perlhpux.pod \ perlhurd.pod perlintern.pod perlirix.pod perljp.pod perlko.pod \ perllinux.pod perlmacos.pod perlmacosx.pod perlmodlib.pod \ perlmpeix.pod perlnetware.pod perlopenbsd.pod perlos2.pod \ perlos390.pod perlos400.pod perlplan9.pod perlqnx.pod \ perlriscos.pod perlsolaris.pod perlsymbian.pod perltoc.pod \ perltru64.pod perltw.pod perluniprops.pod perluts.pod \ perlvmesa.pod perlvos.pod perlwin32.pod \ pod2html pod2latex pod2man pod2text pod2usage \ podchecker podselect -cd ..\utils && del /f h2ph splain perlbug pl2pm c2ph pstruct h2xs \ perldoc perlivp dprofpp libnetcfg enc2xs piconv cpan *.bat \ xsubpp instmodsh prove ptar ptardiff cpanp-run-perl cpanp cpan2dist shasum corelist config_data -cd ..\x2p && del /f find2perl s2p psed *.bat -del /f ..\config.sh perlmain.c dlutils.c config.h.new \ perlmainst.c -del /f $(CONFIGPM) -del /f ..\lib\Config_git.pl -del /f bin\*.bat -del /f perllibst.h -del /f $(PERLEXE_RES) perl.base -cd .. && del /s *$(a) *.map *.pdb *.ilk *.tds *.bs *$(o) .exists pm_to_blib ppport.h -cd $(EXTDIR) && del /s *.def Makefile Makefile.old -cd $(DISTDIR) && del /s *.def Makefile Makefile.old -cd $(CPANDIR) && del /s *.def Makefile Makefile.old -if exist $(AUTODIR) rmdir /s /q $(AUTODIR) -if exist $(COREDIR) rmdir /s /q $(COREDIR) -if exist pod2htmd.tmp del pod2htmd.tmp -if exist pod2htmi.tmp del pod2htmi.tmp -if exist $(HTMLDIR) rmdir /s /q $(HTMLDIR) -del /f ..\t\test_state install : all installbare installhtml installbare : $(RIGHTMAKE) utils ..\pod\perltoc.pod $(PERLEXE) ..\installperl if exist $(WPERLEXE) $(XCOPY) $(WPERLEXE) $(INST_BIN)\*.* if exist $(PERLEXESTATIC) $(XCOPY) $(PERLEXESTATIC) $(INST_BIN)\*.* $(XCOPY) $(GLOBEXE) $(INST_BIN)\*.* if exist ..\perl*.pdb $(XCOPY) ..\perl*.pdb $(INST_BIN)\*.* if exist ..\x2p\a2p.pdb $(XCOPY) ..\x2p\a2p.pdb $(INST_BIN)\*.* $(XCOPY) bin\*.bat $(INST_SCRIPT)\*.* installhtml : doc $(RCOPY) $(HTMLDIR)\*.* $(INST_HTML)\*.* inst_lib : $(CONFIGPM) $(RCOPY) ..\lib $(INST_LIB)\*.* $(UNIDATAFILES) ..\pod\perluniprops.pod .UPDATEALL : $(MINIPERL) $(CONFIGPM) ..\lib\unicore\mktables Extensions_nonxs cd ..\lib\unicore && \ ..\$(MINIPERL) -I.. -I..\..\cpan\Cwd\lib -I..\..\cpan\Cwd mktables -P ..\..\pod -maketest -makelist -p minitest : $(MINIPERL) $(GLOBEXE) $(CONFIGPM) $(UNIDATAFILES) utils $(XCOPY) $(MINIPERL) ..\t\$(NULL) if exist ..\t\perl.exe del /f ..\t\perl.exe rename ..\t\miniperl.exe perl.exe .IF "$(CCTYPE)" == "BORLAND" $(XCOPY) $(GLOBBAT) ..\t\$(NULL) .ELSE $(XCOPY) $(GLOBEXE) ..\t\$(NULL) .ENDIF attrib -r ..\t\*.* cd ..\t && \ $(MINIPERL) -I..\lib harness base/*.t comp/*.t cmd/*.t io/*.t op/*.t pragma/*.t test-prep : all utils $(XCOPY) $(PERLEXE) ..\t\$(NULL) $(XCOPY) $(PERLDLL) ..\t\$(NULL) .IF "$(CCTYPE)" == "BORLAND" $(XCOPY) $(GLOBBAT) ..\t\$(NULL) .ELSE $(XCOPY) $(GLOBEXE) ..\t\$(NULL) .ENDIF .IF "$(CCTYPE)" == "GCC" .IF "$(GCC_4XX)" == "define" $(XCOPY) $(GCCHELPERDLL) ..\t\$(NULL) .ENDIF .ENDIF test : $(RIGHTMAKE) test-prep cd ..\t && $(PERLEXE) -I..\lib harness $(TEST_SWITCHES) $(TEST_FILES) test-reonly : reonly utils $(XCOPY) $(PERLEXE) ..\t\$(NULL) $(XCOPY) $(PERLDLL) ..\t\$(NULL) $(XCOPY) $(GLOBEXE) ..\t\$(NULL) cd ..\t && \ $(PERLEXE) -I..\lib harness $(OPT) -re \bpat\\/ $(EXTRA) && \ cd ..\win32 regen : cd .. && regen.pl && cd win32 test-notty : test-prep set PERL_SKIP_TTY_TEST=1 && \ cd ..\t && $(PERLEXE) -I.\lib harness $(TEST_SWITCHES) $(TEST_FILES) _test : $(RIGHTMAKE) $(XCOPY) $(PERLEXE) ..\t\$(NULL) $(XCOPY) $(PERLDLL) ..\t\$(NULL) .IF "$(CCTYPE)" == "BORLAND" $(XCOPY) $(GLOBBAT) ..\t\$(NULL) .ELSE $(XCOPY) $(GLOBEXE) ..\t\$(NULL) .ENDIF cd ..\t && $(PERLEXE) -I..\lib harness $(TEST_SWITCHES) $(TEST_FILES) _clean : -@erase miniperlmain$(o) -@erase $(MINIPERL) -@erase perlglob$(o) -@erase perlmain$(o) -@erase perlmainst$(o) -@erase config.w32 -@erase /f config.h -@erase /f ..\git_version.h -@erase $(GLOBEXE) -@erase $(PERLEXE) -@erase $(WPERLEXE) -@erase $(PERLEXESTATIC) -@erase $(PERLSTATICLIB) -@erase $(PERLDLL) -@erase $(CORE_OBJ) -@erase $(GENUUDMAP) $(GENUUDMAP_OBJ) $(UUDMAP_H) $(BITCOUNT_H) -if exist $(MINIDIR) rmdir /s /q $(MINIDIR) -if exist $(UNIDATADIR1) rmdir /s /q $(UNIDATADIR1) -if exist $(UNIDATADIR2) rmdir /s /q $(UNIDATADIR2) -@erase $(UNIDATAFILES) -@erase $(WIN32_OBJ) -@erase $(DLL_OBJ) -@erase $(X2P_OBJ) -@erase ..\*$(o) ..\*$(a) ..\*.exp *$(o) *$(a) *.exp *.res -@erase ..\t\*.exe ..\t\*.dll ..\t\*.bat -@erase ..\x2p\*.exe ..\x2p\*.bat -@erase *.ilk -@erase *.pdb -@erase *.tds -@erase Extensions_static clean : Extensions_clean _clean realclean : Extensions_realclean _clean # Handy way to run perlbug -ok without having to install and run the # installed perlbug. We don't re-run the tests here - we trust the user. # Please *don't* use this unless all tests pass. # If you want to report test failures, use "dmake nok" instead. ok: utils $(PERLEXE) -I..\lib ..\utils\perlbug -ok -s "(UNINSTALLED)" okfile: utils $(PERLEXE) -I..\lib ..\utils\perlbug -ok -s "(UNINSTALLED)" -F perl.ok nok: utils $(PERLEXE) -I..\lib ..\utils\perlbug -nok -s "(UNINSTALLED)" nokfile: utils $(PERLEXE) -I..\lib ..\utils\perlbug -nok -s "(UNINSTALLED)" -F perl.nok perl-5.12.0-RC0/win32/win32iop.h0000444000175000017500000002611211325127002014705 0ustar jessejesse#ifndef WIN32IOP_H #define WIN32IOP_H #ifndef START_EXTERN_C #ifdef __cplusplus # define START_EXTERN_C extern "C" { # define END_EXTERN_C } # define EXTERN_C extern "C" #else # define START_EXTERN_C # define END_EXTERN_C # define EXTERN_C #endif #endif #if defined(_MSC_VER) || defined(__MINGW32__) # include #else # include #endif /* * defines for flock emulation */ #define LOCK_SH 1 #define LOCK_EX 2 #define LOCK_NB 4 #define LOCK_UN 8 /* * Make this as close to original stdio as possible. */ /* * function prototypes for our own win32io layer */ START_EXTERN_C DllExport int * win32_errno(void); DllExport char *** win32_environ(void); DllExport FILE* win32_stdin(void); DllExport FILE* win32_stdout(void); DllExport FILE* win32_stderr(void); DllExport int win32_ferror(FILE *fp); DllExport int win32_feof(FILE *fp); DllExport char* win32_strerror(int e); DllExport int win32_fprintf(FILE *pf, const char *format, ...); DllExport int win32_printf(const char *format, ...); DllExport int win32_vfprintf(FILE *pf, const char *format, va_list arg); DllExport int win32_vprintf(const char *format, va_list arg); DllExport size_t win32_fread(void *buf, size_t size, size_t count, FILE *pf); DllExport size_t win32_fwrite(const void *buf, size_t size, size_t count, FILE *pf); DllExport FILE* win32_fopen(const char *path, const char *mode); DllExport FILE* win32_fdopen(int fh, const char *mode); DllExport FILE* win32_freopen(const char *path, const char *mode, FILE *pf); DllExport int win32_fclose(FILE *pf); DllExport int win32_fputs(const char *s,FILE *pf); DllExport int win32_fputc(int c,FILE *pf); DllExport int win32_ungetc(int c,FILE *pf); DllExport int win32_getc(FILE *pf); DllExport int win32_fileno(FILE *pf); DllExport void win32_clearerr(FILE *pf); DllExport int win32_fflush(FILE *pf); DllExport Off_t win32_ftell(FILE *pf); DllExport int win32_fseek(FILE *pf,Off_t offset,int origin); DllExport int win32_fgetpos(FILE *pf,fpos_t *p); DllExport int win32_fsetpos(FILE *pf,const fpos_t *p); DllExport void win32_rewind(FILE *pf); DllExport int win32_tmpfd(void); DllExport FILE* win32_tmpfile(void); DllExport void win32_abort(void); DllExport int win32_fstat(int fd,Stat_t *sbufptr); DllExport int win32_stat(const char *name,Stat_t *sbufptr); DllExport int win32_pipe( int *phandles, unsigned int psize, int textmode ); DllExport PerlIO* win32_popen( const char *command, const char *mode ); DllExport PerlIO* win32_popenlist(const char *mode, IV narg, SV **args); DllExport int win32_pclose( PerlIO *pf); DllExport int win32_rename( const char *oname, const char *newname); DllExport int win32_setmode( int fd, int mode); DllExport int win32_chsize(int fd, Off_t size); DllExport Off_t win32_lseek( int fd, Off_t offset, int origin); DllExport Off_t win32_tell( int fd); DllExport int win32_dup( int fd); DllExport int win32_dup2(int h1, int h2); DllExport int win32_open(const char *path, int oflag,...); DllExport int win32_close(int fd); DllExport int win32_eof(int fd); 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); DllExport int win32_mkdir(const char *dir, int mode); DllExport int win32_rmdir(const char *dir); DllExport int win32_chdir(const char *dir); DllExport int win32_flock(int fd, int oper); DllExport int win32_execv(const char *cmdname, const char *const *argv); DllExport int win32_execvp(const char *cmdname, const char *const *argv); DllExport void win32_perror(const char *str); DllExport void win32_setbuf(FILE *pf, char *buf); DllExport int win32_setvbuf(FILE *pf, char *buf, int type, size_t size); DllExport int win32_flushall(void); DllExport int win32_fcloseall(void); DllExport char* win32_fgets(char *s, int n, FILE *pf); DllExport char* win32_gets(char *s); DllExport int win32_fgetc(FILE *pf); DllExport int win32_putc(int c, FILE *pf); DllExport int win32_puts(const char *s); DllExport int win32_getchar(void); DllExport int win32_putchar(int c); DllExport void* win32_malloc(size_t size); DllExport void* win32_calloc(size_t numitems, size_t size); DllExport void* win32_realloc(void *block, size_t size); DllExport void win32_free(void *block); DllExport int win32_open_osfhandle(intptr_t handle, int flags); DllExport intptr_t win32_get_osfhandle(int fd); DllExport FILE* win32_fdupopen(FILE *pf); DllExport DIR* win32_opendir(const char *filename); DllExport struct direct* win32_readdir(DIR *dirp); DllExport long win32_telldir(DIR *dirp); DllExport void win32_seekdir(DIR *dirp, long loc); DllExport void win32_rewinddir(DIR *dirp); DllExport int win32_closedir(DIR *dirp); DllExport char* win32_getenv(const char *name); DllExport int win32_putenv(const char *name); DllExport unsigned win32_sleep(unsigned int); DllExport int win32_times(struct tms *timebuf); DllExport unsigned win32_alarm(unsigned int sec); DllExport int win32_stat(const char *path, Stat_t *buf); DllExport char* win32_longpath(char *path); DllExport char* win32_ansipath(const WCHAR *path); DllExport int win32_ioctl(int i, unsigned int u, char *data); DllExport int win32_link(const char *oldname, const char *newname); DllExport int win32_unlink(const char *f); DllExport int win32_utime(const char *f, struct utimbuf *t); DllExport int win32_gettimeofday(struct timeval *tp, void *not_used); DllExport int win32_uname(struct utsname *n); DllExport int win32_wait(int *status); DllExport int win32_waitpid(int pid, int *status, int flags); DllExport int win32_kill(int pid, int sig); DllExport unsigned long win32_os_id(void); DllExport void* win32_dynaload(const char*filename); DllExport int win32_access(const char *path, int mode); DllExport int win32_chmod(const char *path, int mode); DllExport int win32_getpid(void); DllExport char * win32_crypt(const char *txt, const char *salt); DllExport void * win32_get_childenv(void); DllExport void win32_free_childenv(void* d); DllExport void win32_clearenv(void); DllExport char * win32_get_childdir(void); DllExport void win32_free_childdir(char* d); DllExport Sighandler_t win32_signal(int sig, Sighandler_t subcode); END_EXTERN_C #undef alarm #define alarm win32_alarm #undef strerror #define strerror win32_strerror /* * the following six(6) is #define in stdio.h */ #ifndef WIN32IO_IS_STDIO #undef errno #undef environ #undef stderr #undef stdin #undef stdout #undef ferror #undef feof #undef fclose #undef pipe #undef pause #undef sleep #undef times #undef ioctl #undef unlink #undef utime #undef gettimeofday #undef uname #undef wait #ifdef __BORLANDC__ #undef ungetc #undef getc #undef putc #undef getchar #undef putchar #endif #if defined(__MINGW32__) || defined(__BORLANDC__) #undef fileno #endif #define stderr win32_stderr() #define stdout win32_stdout() #define stdin win32_stdin() #define feof(f) win32_feof(f) #define ferror(f) win32_ferror(f) #define errno (*win32_errno()) #define environ (*win32_environ()) /* * redirect to our own version */ #undef fprintf #define fprintf win32_fprintf #define vfprintf win32_vfprintf #define printf win32_printf #define vprintf win32_vprintf #define fread(buf,size,count,f) win32_fread(buf,size,count,f) #define fwrite(buf,size,count,f) win32_fwrite(buf,size,count,f) #define fopen win32_fopen #undef fdopen #define fdopen win32_fdopen #define freopen win32_freopen #define fclose(f) win32_fclose(f) #define fputs(s,f) win32_fputs(s,f) #define fputc(c,f) win32_fputc(c,f) #define ungetc(c,f) win32_ungetc(c,f) #undef getc #define getc(f) win32_getc(f) #define fileno(f) win32_fileno(f) #define clearerr(f) win32_clearerr(f) #define fflush(f) win32_fflush(f) #define ftell(f) win32_ftell(f) #define fseek(f,o,w) win32_fseek(f,o,w) #define fgetpos(f,p) win32_fgetpos(f,p) #define fsetpos(f,p) win32_fsetpos(f,p) #define rewind(f) win32_rewind(f) #define tmpfile() win32_tmpfile() #define abort() win32_abort() #define fstat(fd,bufptr) win32_fstat(fd,bufptr) #define stat(pth,bufptr) win32_stat(pth,bufptr) #define longpath(pth) win32_longpath(pth) #define ansipath(pth) win32_ansipath(pth) #define rename(old,new) win32_rename(old,new) #define setmode(fd,mode) win32_setmode(fd,mode) #define chsize(fd,sz) win32_chsize(fd,sz) #define lseek(fd,offset,orig) win32_lseek(fd,offset,orig) #define tell(fd) win32_tell(fd) #define dup(fd) win32_dup(fd) #define dup2(fd1,fd2) win32_dup2(fd1,fd2) #define open win32_open #define close(fd) win32_close(fd) #define eof(fd) win32_eof(fd) #define isatty(fd) win32_isatty(fd) #define read(fd,b,s) win32_read(fd,b,s) #define write(fd,b,s) win32_write(fd,b,s) #define _open_osfhandle win32_open_osfhandle #define _get_osfhandle win32_get_osfhandle #define spawnvp win32_spawnvp #define mkdir win32_mkdir #define rmdir win32_rmdir #define chdir win32_chdir #define flock(fd,o) win32_flock(fd,o) #define execv win32_execv #define execvp win32_execvp #define perror win32_perror #define setbuf win32_setbuf #define setvbuf win32_setvbuf #undef flushall #define flushall win32_flushall #undef fcloseall #define fcloseall win32_fcloseall #define fgets win32_fgets #define gets win32_gets #define fgetc win32_fgetc #undef putc #define putc win32_putc #define puts win32_puts #undef getchar #define getchar win32_getchar #undef putchar #define putchar win32_putchar #define access(p,m) win32_access(p,m) #define chmod(p,m) win32_chmod(p,m) #if !defined(MYMALLOC) || !defined(PERL_CORE) #undef malloc #undef calloc #undef realloc #undef free #define malloc win32_malloc #define calloc win32_calloc #define realloc win32_realloc #define free win32_free #endif /* XXX Why are APIs like sleep(), times() etc. inside a block * XXX guarded by "#ifndef WIN32IO_IS_STDIO"? */ #define pipe(fd) win32_pipe((fd), 512, O_BINARY) #define pause() win32_sleep((32767L << 16) + 32767) #define sleep win32_sleep #define times win32_times #define ioctl win32_ioctl #define link win32_link #define unlink win32_unlink #define utime win32_utime #define gettimeofday win32_gettimeofday #define uname win32_uname #define wait win32_wait #define waitpid win32_waitpid #define kill win32_kill #define opendir win32_opendir #define readdir win32_readdir #define telldir win32_telldir #define seekdir win32_seekdir #define rewinddir win32_rewinddir #define closedir win32_closedir #define os_id win32_os_id #define getpid win32_getpid #undef crypt #define crypt(t,s) win32_crypt(t,s) #undef get_childenv #undef free_childenv #undef clearenv #undef get_childdir #undef free_childdir #define get_childenv() win32_get_childenv() #define free_childenv(d) win32_free_childenv(d) #define clearenv() win32_clearenv() #define get_childdir() win32_get_childdir() #define free_childdir(d) win32_free_childdir(d) #undef getenv #define getenv win32_getenv #undef putenv #define putenv win32_putenv #endif /* WIN32IO_IS_STDIO */ #endif /* WIN32IOP_H */ perl-5.12.0-RC0/win32/FindExt.t0000444000175000017500000000220011325127002014600 0ustar jessejesse#!../miniperl -w BEGIN { @INC = qw(../win32 ../lib); } use strict; use Test::More tests => 10; use FindExt; use Config; FindExt::scan_ext('../cpan'); FindExt::scan_ext('../ext'); # Config.pm and FindExt.pm make different choices about what should be built my @config_built; my @found_built; { foreach my $type (qw(static dynamic nonxs)) { push @found_built, eval "FindExt::${type}_ext()"; push @config_built, split ' ', $Config{"${type}_ext"}; } } @config_built = sort @config_built; @found_built = sort @found_built; foreach (['static_ext', [FindExt::static_ext()], $Config{static_ext}], ['nonxs_ext', [FindExt::nonxs_ext()], $Config{nonxs_ext}], ['known_extensions', [FindExt::known_extensions()], $Config{known_extensions}], ['"config" dynamic + static + nonxs', \@config_built, $Config{extensions}], ['"found" dynamic + static + nonxs', \@found_built, join " ", FindExt::extensions()], ) { my ($type, $found, $config) = @$_; my @config = sort split ' ', $config; is (scalar @$found, scalar @config, "We find the same number of $type"); is_deeply($found, \@config, "We find the same"); } perl-5.12.0-RC0/win32/win32thread.c0000444000175000017500000000120411143650502015357 0ustar jessejesse#include "EXTERN.h" #include "perl.h" #ifdef USE_DECLSPEC_THREAD __declspec(thread) void *PL_current_context = NULL; #endif void Perl_set_context(void *t) { #if defined(USE_ITHREADS) # ifdef USE_DECLSPEC_THREAD Perl_current_context = t; # else DWORD err = GetLastError(); TlsSetValue(PL_thr_key,t); SetLastError(err); # endif #endif } void * Perl_get_context(void) { #if defined(USE_ITHREADS) # ifdef USE_DECLSPEC_THREAD return Perl_current_context; # else DWORD err = GetLastError(); void *result = TlsGetValue(PL_thr_key); SetLastError(err); return result; # endif #else return NULL; #endif } perl-5.12.0-RC0/win32/config_sh.PL0000444000175000017500000001123611325127002015257 0ustar jessejesseuse FindExt; # take a semicolon separated path list and turn it into a quoted # list of paths that Text::Parsewords will grok sub mungepath { my $p = shift; # remove leading/trailing semis/spaces $p =~ s/^[ ;]+//; $p =~ s/[ ;]+$//; $p =~ s/'/"/g; my @p = map { $_ = "\"$_\"" if /\s/ and !/^".*"$/; $_ } split /;/, $p; return join(' ', @p); } # generate an array of option strings from command-line args # or an option file # -- added by BKS, 10-17-1999 to fix command-line overflow problems sub loadopts { if ($ARGV[0] =~ /--cfgsh-option-file/) { shift @ARGV; my $optfile = shift @ARGV; local (*F); open OPTF, $optfile or die "Can't open $optfile: $!\n"; my @opts; chomp(my $line = ); my @vars = split(/\t+~\t+/, $line); for (@vars) { push(@opts, $_) unless (/^\s*$/); } close OPTF; return \@opts; } else { return \@ARGV; } } my %opt; my $optref = loadopts(); while (@{$optref} && $optref->[0] =~ /^([\w_]+)=(.*)$/) { $opt{$1}=$2; shift(@{$optref}); } FindExt::scan_ext("../cpan"); FindExt::scan_ext("../dist"); FindExt::scan_ext("../ext"); FindExt::set_static_extensions(split ' ', $opt{'static_ext'}); $opt{'nonxs_ext'} = join(' ',FindExt::nonxs_ext()) || ' '; $opt{'static_ext'} = join(' ',FindExt::static_ext()) || ' '; $opt{'dynamic_ext'} = join(' ',FindExt::dynamic_ext()) || ' '; $opt{'extensions'} = join(' ',FindExt::extensions()) || ' '; $opt{'known_extensions'} = join(' ',FindExt::known_extensions()) || ' '; my $pl_h = '../patchlevel.h'; if (-e $pl_h) { open PL, "<$pl_h" or die "Can't open $pl_h: $!"; while () { if (/^#\s*define\s+(PERL_\w+)\s+([\d.]+)/) { $opt{$1} = $2; } } close PL; } else { die "Can't find $pl_h: $!"; } my $patch_file = '../.patch'; if (-e $patch_file) { open my $fh, "<", $patch_file or die "Can't open $patch_file: $!"; chomp($opt{PERL_PATCHLEVEL} = <$fh>); close $fh; } $opt{VERSION} = "$opt{PERL_REVISION}.$opt{PERL_VERSION}.$opt{PERL_SUBVERSION}"; $opt{INST_VER} =~ s|~VERSION~|$opt{VERSION}|g; $opt{'version_patchlevel_string'} = "version $opt{PERL_VERSION} subversion $opt{PERL_SUBVERSION}"; $opt{'version_patchlevel_string'} .= " patch $opt{PERL_PATCHLEVEL}" if exists $opt{PERL_PATCHLEVEL}; my $ver = `ver 2>nul`; if ($ver =~ /Version (\d+\.\d+)/) { $opt{'osvers'} = $1; } else { $opt{'osvers'} = '4.0'; } if (exists $opt{cc}) { # cl and bcc32 version detection borrowed from Test::Smoke's configsmoke.pl if ($opt{cc} eq 'cl') { my $output = `cl --version 2>&1`; $opt{ccversion} = $output =~ /^.*Version\s+([\d.]+)/ ? $1 : '?'; } elsif ($opt{cc} eq 'bcc32') { my $output = `bcc32 --version 2>&1`; $opt{ccversion} = $output =~ /([\d.]+)/ ? $1 : '?'; } elsif ($opt{cc} eq 'gcc') { chomp($opt{gccversion} = `gcc -dumpversion`); } } $opt{'cf_by'} = $ENV{USERNAME} unless $opt{'cf_by'}; $opt{'cf_email'} = $opt{'cf_by'} . '@' . (gethostbyname('localhost'))[0] unless $opt{'cf_email'}; $opt{'usemymalloc'} = 'y' if $opt{'d_mymalloc'} eq 'define'; $opt{libpth} = mungepath($opt{libpth}) if exists $opt{libpth}; $opt{incpath} = mungepath($opt{incpath}) if exists $opt{incpath}; # some functions are not available on Win9x unless (defined $ENV{SYSTEMROOT}) { # SystemRoot has been introduced by WinNT $opt{d_flock} = 'undef'; $opt{d_link} = 'undef'; } # change the lseeksize and lseektype from their canned default values (which # are set-up for a non-uselargefiles build) if we are building with # uselargefiles. don't do this for bcc32: the code contains special handling # for bcc32 and the lseeksize and lseektype should not be changed. if ($opt{uselargefiles} eq 'define' and $opt{cc} ne 'bcc32') { $opt{lseeksize} = 8; if ($opt{cc} eq 'cl') { $opt{lseektype} = '__int64'; } elsif ($opt{cc} eq 'gcc') { $opt{lseektype} = 'long long'; } } # change the s{GM|LOCAL}TIME_{min|max} for VS2005 (aka VC 8) and # VS2008 (aka VC 9) or higher (presuming that later versions will have # at least the range of that). if ($opt{cc} eq 'cl' and $opt{ccversion} =~ /^(\d+)/) { my $ccversion = $1; if ($ccversion >= 14) { $opt{sGMTIME_max} = 32535291599; $opt{sLOCALTIME_max} = 32535244799; } } if ($opt{useithreads} eq 'define' && $opt{ccflags} =~ /-DPERL_IMPLICIT_SYS\b/) { $opt{d_pseudofork} = 'define'; } while (<>) { s/~([\w_]+)~/$opt{$1}/g; if (/^([\w_]+)=(.*)$/) { my($k,$v) = ($1,$2); # this depends on cf_time being empty in the template (or we'll # get a loop) if ($k eq 'cf_time') { $_ = "$k='" . localtime(time) . "'\n" if $v =~ /^\s*'\s*'/; } elsif (exists $opt{$k}) { $_ = "$k='$opt{$k}'\n"; } } print; } perl-5.12.0-RC0/win32/config_H.vc0000644000175000017500000043404411325127002015141 0ustar jessejesse/* * This file was produced by running the config_h.SH script, which * gets its values from undef, which is generally produced by * running Configure. * * Feel free to modify any of this as the need arises. Note, however, * that running config_h.SH again will wipe out any changes you've made. * For a more permanent change edit undef and rerun config_h.SH. * * $Id: Config_h.U 1 2006-08-24 12:32:52Z rmanfredi $ */ /* * Package name : perl5 * Source directory : * Configuration time: Sat Jan 9 17:22:03 2010 * Configured by : Steve * Target system : */ #ifndef _config_h_ #define _config_h_ /* LOC_SED: * This symbol holds the complete pathname to the sed program. */ #define LOC_SED "" /**/ /* HAS_ALARM: * This symbol, if defined, indicates that the alarm routine is * available. */ #define HAS_ALARM /**/ /* HAS_BCMP: * This symbol is defined if the bcmp() routine is available to * compare blocks of memory. */ /*#define HAS_BCMP / **/ /* HAS_BCOPY: * This symbol is defined if the bcopy() routine is available to * copy blocks of memory. */ /*#define HAS_BCOPY / **/ /* HAS_BZERO: * This symbol is defined if the bzero() routine is available to * set a memory block to 0. */ /*#define HAS_BZERO / **/ /* HAS_CHOWN: * This symbol, if defined, indicates that the chown routine is * available. */ /*#define HAS_CHOWN / **/ /* HAS_CHROOT: * This symbol, if defined, indicates that the chroot routine is * available. */ /*#define HAS_CHROOT / **/ /* HAS_CHSIZE: * This symbol, if defined, indicates that the chsize routine is available * to truncate files. You might need a -lx to get this routine. */ #define HAS_CHSIZE /**/ /* HAS_CRYPT: * This symbol, if defined, indicates that the crypt routine is available * to encrypt passwords and the like. */ /*#define HAS_CRYPT / **/ /* HAS_CTERMID: * This symbol, if defined, indicates that the ctermid routine is * available to generate filename for terminal. */ /*#define HAS_CTERMID / **/ /* HAS_CUSERID: * This symbol, if defined, indicates that the cuserid routine is * available to get character login names. */ /*#define HAS_CUSERID / **/ /* HAS_DBL_DIG: * This symbol, if defined, indicates that this system's * or defines the symbol DBL_DIG, which is the number * of significant digits in a double precision number. If this * symbol is not defined, a guess of 15 is usually pretty good. */ #define HAS_DBL_DIG /**/ /* HAS_DIFFTIME: * This symbol, if defined, indicates that the difftime routine is * available. */ #define HAS_DIFFTIME /**/ /* HAS_DLERROR: * This symbol, if defined, indicates that the dlerror routine is * available to return a string describing the last error that * occurred from a call to dlopen(), dlclose() or dlsym(). */ #define HAS_DLERROR /**/ /* HAS_DUP2: * This symbol, if defined, indicates that the dup2 routine is * available to duplicate file descriptors. */ #define HAS_DUP2 /**/ /* HAS_FCHMOD: * This symbol, if defined, indicates that the fchmod routine is available * to change mode of opened files. If unavailable, use chmod(). */ /*#define HAS_FCHMOD / **/ /* HAS_FCHOWN: * This symbol, if defined, indicates that the fchown routine is available * to change ownership of opened files. If unavailable, use chown(). */ /*#define HAS_FCHOWN / **/ /* HAS_FCNTL: * This symbol, if defined, indicates to the C program that * the fcntl() function exists. */ /*#define HAS_FCNTL / **/ /* HAS_FGETPOS: * This symbol, if defined, indicates that the fgetpos routine is * available to get the file position indicator, similar to ftell(). */ #define HAS_FGETPOS /**/ /* HAS_FLOCK: * This symbol, if defined, indicates that the flock routine is * available to do file locking. */ #define HAS_FLOCK /**/ /* HAS_FORK: * This symbol, if defined, indicates that the fork routine is * available. */ /*#define HAS_FORK / **/ /* HAS_FSETPOS: * This symbol, if defined, indicates that the fsetpos routine is * available to set the file position indicator, similar to fseek(). */ #define HAS_FSETPOS /**/ /* HAS_GETTIMEOFDAY: * This symbol, if defined, indicates that the gettimeofday() system * call is available for a sub-second accuracy clock. Usually, the file * needs to be included (see I_SYS_RESOURCE). * The type "Timeval" should be used to refer to "struct timeval". */ #define HAS_GETTIMEOFDAY /**/ #ifdef HAS_GETTIMEOFDAY #define Timeval struct timeval /* Structure used by gettimeofday() */ #endif /* HAS_GETGROUPS: * This symbol, if defined, indicates that the getgroups() routine is * available to get the list of process groups. If unavailable, multiple * groups are probably not supported. */ /*#define HAS_GETGROUPS / **/ /* HAS_GETLOGIN: * This symbol, if defined, indicates that the getlogin routine is * available to get the login name. */ #define HAS_GETLOGIN /**/ /* HAS_GETPGID: * This symbol, if defined, indicates to the C program that * the getpgid(pid) function is available to get the * process group id. */ /*#define HAS_GETPGID / **/ /* HAS_GETPGRP2: * This symbol, if defined, indicates that the getpgrp2() (as in DG/UX) * routine is available to get the current process group. */ /*#define HAS_GETPGRP2 / **/ /* HAS_GETPPID: * This symbol, if defined, indicates that the getppid routine is * available to get the parent process ID. */ /*#define HAS_GETPPID / **/ /* HAS_GETPRIORITY: * This symbol, if defined, indicates that the getpriority routine is * available to get a process's priority. */ /*#define HAS_GETPRIORITY / **/ /* HAS_INET_ATON: * This symbol, if defined, indicates to the C program that the * inet_aton() function is available to parse IP address "dotted-quad" * strings. */ /*#define HAS_INET_ATON / **/ /* HAS_KILLPG: * This symbol, if defined, indicates that the killpg routine is available * to kill process groups. If unavailable, you probably should use kill * with a negative process number. */ #define HAS_KILLPG /**/ /* HAS_LINK: * This symbol, if defined, indicates that the link routine is * available to create hard links. */ #define HAS_LINK /**/ /* HAS_LOCALECONV: * This symbol, if defined, indicates that the localeconv routine is * available for numeric and monetary formatting conventions. */ #define HAS_LOCALECONV /**/ /* HAS_LOCKF: * This symbol, if defined, indicates that the lockf routine is * available to do file locking. */ /*#define HAS_LOCKF / **/ /* HAS_LSTAT: * This symbol, if defined, indicates that the lstat routine is * available to do file stats on symbolic links. */ /*#define HAS_LSTAT / **/ /* HAS_MBLEN: * This symbol, if defined, indicates that the mblen routine is available * to find the number of bytes in a multibye character. */ #define HAS_MBLEN /**/ /* HAS_MBSTOWCS: * This symbol, if defined, indicates that the mbstowcs routine is * available to covert a multibyte string into a wide character string. */ #define HAS_MBSTOWCS /**/ /* HAS_MBTOWC: * This symbol, if defined, indicates that the mbtowc routine is available * to covert a multibyte to a wide character. */ #define HAS_MBTOWC /**/ /* HAS_MEMCMP: * This symbol, if defined, indicates that the memcmp routine is available * to compare blocks of memory. */ #define HAS_MEMCMP /**/ /* HAS_MEMCPY: * This symbol, if defined, indicates that the memcpy routine is available * to copy blocks of memory. */ #define HAS_MEMCPY /**/ /* HAS_MEMMOVE: * This symbol, if defined, indicates that the memmove routine is available * to copy potentially overlapping blocks of memory. This should be used * only when HAS_SAFE_BCOPY is not defined. If neither is there, roll your * own version. */ #define HAS_MEMMOVE /**/ /* HAS_MEMSET: * This symbol, if defined, indicates that the memset routine is available * to set blocks of memory. */ #define HAS_MEMSET /**/ /* HAS_MKDIR: * This symbol, if defined, indicates that the mkdir routine is available * to create directories. Otherwise you should fork off a new process to * exec /bin/mkdir. */ #define HAS_MKDIR /**/ /* HAS_MKFIFO: * This symbol, if defined, indicates that the mkfifo routine is * available to create FIFOs. Otherwise, mknod should be able to * do it for you. However, if mkfifo is there, mknod might require * super-user privileges which mkfifo will not. */ /*#define HAS_MKFIFO / **/ /* HAS_MKTIME: * This symbol, if defined, indicates that the mktime routine is * available. */ #define HAS_MKTIME /**/ /* HAS_MSYNC: * This symbol, if defined, indicates that the msync system call is * available to synchronize a mapped file. */ /*#define HAS_MSYNC / **/ /* HAS_MUNMAP: * This symbol, if defined, indicates that the munmap system call is * available to unmap a region, usually mapped by mmap(). */ /*#define HAS_MUNMAP / **/ /* HAS_NICE: * This symbol, if defined, indicates that the nice routine is * available. */ /*#define HAS_NICE / **/ /* HAS_PATHCONF: * This symbol, if defined, indicates that pathconf() is available * to determine file-system related limits and options associated * with a given filename. */ /* HAS_FPATHCONF: * This symbol, if defined, indicates that pathconf() is available * to determine file-system related limits and options associated * with a given open file descriptor. */ /*#define HAS_PATHCONF / **/ /*#define HAS_FPATHCONF / **/ /* HAS_PAUSE: * This symbol, if defined, indicates that the pause routine is * available to suspend a process until a signal is received. */ #define HAS_PAUSE /**/ /* HAS_PIPE: * This symbol, if defined, indicates that the pipe routine is * available to create an inter-process channel. */ #define HAS_PIPE /**/ /* HAS_POLL: * This symbol, if defined, indicates that the poll routine is * available to poll active file descriptors. Please check I_POLL and * I_SYS_POLL to know which header should be included as well. */ /*#define HAS_POLL / **/ /* HAS_READDIR: * This symbol, if defined, indicates that the readdir routine is * available to read directory entries. You may have to include * . See I_DIRENT. */ #define HAS_READDIR /**/ /* HAS_SEEKDIR: * This symbol, if defined, indicates that the seekdir routine is * available. You may have to include . See I_DIRENT. */ #define HAS_SEEKDIR /**/ /* HAS_TELLDIR: * This symbol, if defined, indicates that the telldir routine is * available. You may have to include . See I_DIRENT. */ #define HAS_TELLDIR /**/ /* HAS_REWINDDIR: * This symbol, if defined, indicates that the rewinddir routine is * available. You may have to include . See I_DIRENT. */ #define HAS_REWINDDIR /**/ /* HAS_READLINK: * This symbol, if defined, indicates that the readlink routine is * available to read the value of a symbolic link. */ /*#define HAS_READLINK / **/ /* HAS_RENAME: * This symbol, if defined, indicates that the rename routine is available * to rename files. Otherwise you should do the unlink(), link(), unlink() * trick. */ #define HAS_RENAME /**/ /* HAS_RMDIR: * This symbol, if defined, indicates that the rmdir routine is * available to remove directories. Otherwise you should fork off a * new process to exec /bin/rmdir. */ #define HAS_RMDIR /**/ /* HAS_SELECT: * This symbol, if defined, indicates that the select routine is * available to select active file descriptors. If the timeout field * is used, may need to be included. */ #define HAS_SELECT /**/ /* HAS_SETEGID: * This symbol, if defined, indicates that the setegid routine is available * to change the effective gid of the current program. */ /*#define HAS_SETEGID / **/ /* HAS_SETEUID: * This symbol, if defined, indicates that the seteuid routine is available * to change the effective uid of the current program. */ /*#define HAS_SETEUID / **/ /* HAS_SETGROUPS: * This symbol, if defined, indicates that the setgroups() routine is * available to set the list of process groups. If unavailable, multiple * groups are probably not supported. */ /*#define HAS_SETGROUPS / **/ /* HAS_SETLINEBUF: * This symbol, if defined, indicates that the setlinebuf routine is * available to change stderr or stdout from block-buffered or unbuffered * to a line-buffered mode. */ /*#define HAS_SETLINEBUF / **/ /* HAS_SETLOCALE: * This symbol, if defined, indicates that the setlocale routine is * available to handle locale-specific ctype implementations. */ #define HAS_SETLOCALE /**/ /* HAS_SETPGID: * This symbol, if defined, indicates that the setpgid(pid, gpid) * routine is available to set process group ID. */ /*#define HAS_SETPGID / **/ /* HAS_SETPGRP2: * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX) * routine is available to set the current process group. */ /*#define HAS_SETPGRP2 / **/ /* HAS_SETPRIORITY: * This symbol, if defined, indicates that the setpriority routine is * available to set a process's priority. */ /*#define HAS_SETPRIORITY / **/ /* HAS_SETREGID: * This symbol, if defined, indicates that the setregid routine is * available to change the real and effective gid of the current * process. */ /* HAS_SETRESGID: * This symbol, if defined, indicates that the setresgid routine is * available to change the real, effective and saved gid of the current * process. */ /*#define HAS_SETREGID / **/ /*#define HAS_SETRESGID / **/ /* HAS_SETREUID: * This symbol, if defined, indicates that the setreuid routine is * available to change the real and effective uid of the current * process. */ /* HAS_SETRESUID: * This symbol, if defined, indicates that the setresuid routine is * available to change the real, effective and saved uid of the current * process. */ /*#define HAS_SETREUID / **/ /*#define HAS_SETRESUID / **/ /* HAS_SETRGID: * This symbol, if defined, indicates that the setrgid routine is available * to change the real gid of the current program. */ /*#define HAS_SETRGID / **/ /* HAS_SETRUID: * This symbol, if defined, indicates that the setruid routine is available * to change the real uid of the current program. */ /*#define HAS_SETRUID / **/ /* HAS_SETSID: * This symbol, if defined, indicates that the setsid routine is * available to set the process group ID. */ /*#define HAS_SETSID / **/ /* HAS_STRCHR: * This symbol is defined to indicate that the strchr()/strrchr() * functions are available for string searching. If not, try the * index()/rindex() pair. */ /* HAS_INDEX: * This symbol is defined to indicate that the index()/rindex() * functions are available for string searching. */ #define HAS_STRCHR /**/ /*#define HAS_INDEX / **/ /* HAS_STRCOLL: * This symbol, if defined, indicates that the strcoll routine is * available to compare strings using collating information. */ #define HAS_STRCOLL /**/ /* HAS_STRTOD: * This symbol, if defined, indicates that the strtod routine is * available to provide better numeric string conversion than atof(). */ #define HAS_STRTOD /**/ /* HAS_STRTOL: * This symbol, if defined, indicates that the strtol routine is available * to provide better numeric string conversion than atoi() and friends. */ #define HAS_STRTOL /**/ /* HAS_STRXFRM: * This symbol, if defined, indicates that the strxfrm() routine is * available to transform strings. */ #define HAS_STRXFRM /**/ /* HAS_SYMLINK: * This symbol, if defined, indicates that the symlink routine is available * to create symbolic links. */ /*#define HAS_SYMLINK / **/ /* HAS_SYSCALL: * This symbol, if defined, indicates that the syscall routine is * available to call arbitrary system calls. If undefined, that's tough. */ /*#define HAS_SYSCALL / **/ /* HAS_SYSCONF: * This symbol, if defined, indicates that sysconf() is available * to determine system related limits and options. */ /*#define HAS_SYSCONF / **/ /* HAS_SYSTEM: * This symbol, if defined, indicates that the system routine is * available to issue a shell command. */ #define HAS_SYSTEM /**/ /* HAS_TCGETPGRP: * This symbol, if defined, indicates that the tcgetpgrp routine is * available to get foreground process group ID. */ /*#define HAS_TCGETPGRP / **/ /* HAS_TCSETPGRP: * This symbol, if defined, indicates that the tcsetpgrp routine is * available to set foreground process group ID. */ /*#define HAS_TCSETPGRP / **/ /* HAS_TRUNCATE: * This symbol, if defined, indicates that the truncate routine is * available to truncate files. */ /*#define HAS_TRUNCATE / **/ /* HAS_TZNAME: * This symbol, if defined, indicates that the tzname[] array is * available to access timezone names. */ #define HAS_TZNAME /**/ /* HAS_UMASK: * This symbol, if defined, indicates that the umask routine is * available to set and get the value of the file creation mask. */ #define HAS_UMASK /**/ /* HAS_USLEEP: * This symbol, if defined, indicates that the usleep routine is * available to let the process sleep on a sub-second accuracy. */ /*#define HAS_USLEEP / **/ /* HAS_WAIT4: * This symbol, if defined, indicates that wait4() exists. */ /*#define HAS_WAIT4 / **/ /* HAS_WAITPID: * This symbol, if defined, indicates that the waitpid routine is * available to wait for child process. */ #define HAS_WAITPID /**/ /* HAS_WCSTOMBS: * This symbol, if defined, indicates that the wcstombs routine is * available to convert wide character strings to multibyte strings. */ #define HAS_WCSTOMBS /**/ /* HAS_WCTOMB: * This symbol, if defined, indicates that the wctomb routine is available * to covert a wide character to a multibyte. */ #define HAS_WCTOMB /**/ /* Groups_t: * This symbol holds the type used for the second argument to * getgroups() and setgroups(). Usually, this is the same as * gidtype (gid_t) , but sometimes it isn't. * It can be int, ushort, gid_t, etc... * It may be necessary to include to get any * typedef'ed information. This is only required if you have * getgroups() or setgroups().. */ #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS) #define Groups_t gid_t /* Type for 2nd arg to [sg]etgroups() */ #endif /* I_ARPA_INET: * This symbol, if defined, indicates to the C program that it should * include to get inet_addr and friends declarations. */ #define I_ARPA_INET /**/ /* I_DBM: * This symbol, if defined, indicates that exists and should * be included. */ /* I_RPCSVC_DBM: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_DBM / **/ #define I_RPCSVC_DBM /**/ /* I_DLFCN: * This symbol, if defined, indicates that exists and should * be included. */ #define I_DLFCN /**/ /* I_FCNTL: * This manifest constant tells the C program to include . */ #define I_FCNTL /**/ /* I_FLOAT: * This symbol, if defined, indicates to the C program that it should * include to get definition of symbols like DBL_MAX or * DBL_MIN, i.e. machine dependent floating point values. */ #define I_FLOAT /**/ /* I_GDBM: * This symbol, if defined, indicates that exists and should * be included. */ /*#define I_GDBM / **/ /* I_LIMITS: * This symbol, if defined, indicates to the C program that it should * include to get definition of symbols like WORD_BIT or * LONG_MAX, i.e. machine dependant limitations. */ #define I_LIMITS /**/ /* I_LOCALE: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_LOCALE /**/ /* I_MATH: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_MATH /**/ /* I_MEMORY: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_MEMORY / **/ /* I_NETINET_IN: * This symbol, if defined, indicates to the C program that it should * include . Otherwise, you may try . */ /*#define I_NETINET_IN / **/ /* I_SFIO: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SFIO / **/ /* I_STDDEF: * This symbol, if defined, indicates that exists and should * be included. */ #define I_STDDEF /**/ /* I_STDLIB: * This symbol, if defined, indicates that exists and should * be included. */ #define I_STDLIB /**/ /* I_STRING: * This symbol, if defined, indicates to the C program that it should * include (USG systems) instead of (BSD systems). */ #define I_STRING /**/ /* I_SYS_DIR: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_DIR / **/ /* I_SYS_FILE: * This symbol, if defined, indicates to the C program that it should * include to get definition of R_OK and friends. */ /*#define I_SYS_FILE / **/ /* I_SYS_IOCTL: * This symbol, if defined, indicates that exists and should * be included. Otherwise, include or . */ /* I_SYS_SOCKIO: * This symbol, if defined, indicates the should be included * to get socket ioctl options, like SIOCATMARK. */ /*#define I_SYS_IOCTL / **/ /*#define I_SYS_SOCKIO / **/ /* I_SYS_NDIR: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_NDIR / **/ /* I_SYS_PARAM: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_PARAM / **/ /* I_SYS_POLL: * This symbol, if defined, indicates that the program may include * . When I_POLL is also defined, it's probably safest * to only include . */ /*#define I_SYS_POLL / **/ /* I_SYS_RESOURCE: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_RESOURCE / **/ /* I_SYS_SELECT: * This symbol, if defined, indicates to the C program that it should * include in order to get definition of struct timeval. */ /*#define I_SYS_SELECT / **/ /* I_SYS_STAT: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_STAT /**/ /* I_SYS_TIMES: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_TIMES / **/ /* I_SYS_TYPES: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_TYPES /**/ /* I_SYS_UN: * This symbol, if defined, indicates to the C program that it should * include to get UNIX domain socket definitions. */ /*#define I_SYS_UN / **/ /* I_SYS_WAIT: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_WAIT / **/ /* I_TERMIO: * This symbol, if defined, indicates that the program should include * rather than . There are also differences in * the ioctl() calls that depend on the value of this symbol. */ /* I_TERMIOS: * This symbol, if defined, indicates that the program should include * the POSIX termios.h rather than sgtty.h or termio.h. * There are also differences in the ioctl() calls that depend on the * value of this symbol. */ /* I_SGTTY: * This symbol, if defined, indicates that the program should include * rather than . There are also differences in * the ioctl() calls that depend on the value of this symbol. */ /*#define I_TERMIO / **/ /*#define I_TERMIOS / **/ /*#define I_SGTTY / **/ /* I_UNISTD: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_UNISTD / **/ /* I_UTIME: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_UTIME /**/ /* I_VALUES: * This symbol, if defined, indicates to the C program that it should * include to get definition of symbols like MINFLOAT or * MAXLONG, i.e. machine dependant limitations. Probably, you * should use instead, if it is available. */ /*#define I_VALUES / **/ /* I_VFORK: * This symbol, if defined, indicates to the C program that it should * include vfork.h. */ /*#define I_VFORK / **/ /* CAN_VAPROTO: * This variable is defined on systems supporting prototype declaration * of functions with a variable number of arguments. */ /* _V: * This macro is used to declare function parameters in prototypes for * functions with a variable number of parameters. Use double parentheses. * For example: * * int printf _V((char *fmt, ...)); * * Remember to use the plain simple _() macro when declaring a function * with no variable number of arguments, since it might be possible to * have a non-effect _V() macro and still get prototypes via _(). */ /*#define CAN_VAPROTO / **/ #ifdef CAN_VAPROTO #define _V(args) args #else #define _V(args) () #endif /* INTSIZE: * This symbol contains the value of sizeof(int) so that the C * preprocessor can make decisions based on it. */ /* LONGSIZE: * This symbol contains the value of sizeof(long) so that the C * preprocessor can make decisions based on it. */ /* SHORTSIZE: * This symbol contains the value of sizeof(short) so that the C * preprocessor can make decisions based on it. */ #define INTSIZE 4 /**/ #define LONGSIZE 4 /**/ #define SHORTSIZE 2 /**/ /* MULTIARCH: * This symbol, if defined, signifies that the build * process will produce some binary files that are going to be * used in a cross-platform environment. This is the case for * example with the NeXT "fat" binaries that contain executables * for several CPUs. */ /*#define MULTIARCH / **/ /* HAS_QUAD: * This symbol, if defined, tells that there's a 64-bit integer type, * Quad_t, and its unsigned counterpar, Uquad_t. QUADKIND will be one * of QUAD_IS_INT, QUAD_IS_LONG, QUAD_IS_LONG_LONG, QUAD_IS_INT64_T * or QUAD_IS___INT64. */ #define HAS_QUAD /**/ #ifdef HAS_QUAD # ifndef __GNUC__ # define Quad_t __int64 /**/ # define Uquad_t unsigned __int64 /**/ # define QUADKIND 5 /**/ # else # define Quad_t long long /**/ # define Uquad_t unsigned long long /**/ # define QUADKIND 3 /**/ # endif # define QUAD_IS_INT 1 # define QUAD_IS_LONG 2 # define QUAD_IS_LONG_LONG 3 # define QUAD_IS_INT64_T 4 # define QUAD_IS___INT64 5 #endif /* OSNAME: * This symbol contains the name of the operating system, as determined * by Configure. You shouldn't rely on it too much; the specific * feature tests from Configure are generally more reliable. */ /* OSVERS: * This symbol contains the version of the operating system, as determined * by Configure. You shouldn't rely on it too much; the specific * feature tests from Configure are generally more reliable. */ #define OSNAME "MSWin32" /**/ #define OSVERS "5.1" /**/ /* ARCHLIB: * This variable, if defined, holds the name of the directory in * which the user wants to put architecture-dependent public * library files for perl5. It is most often a local directory * such as /usr/local/lib. Programs using this variable must be * prepared to deal with filename expansion. If ARCHLIB is the * same as PRIVLIB, it is not defined, since presumably the * program already searches PRIVLIB. */ /* ARCHLIB_EXP: * This symbol contains the ~name expanded version of ARCHLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ #define ARCHLIB "c:\\perl\\lib" /**/ /*#define ARCHLIB_EXP "" / **/ /* ARCHNAME: * This symbol holds a string representing the architecture name. * It may be used to construct an architecture-dependant pathname * where library files may be held under a private library, for * instance. */ #define ARCHNAME "MSWin32-x86" /**/ /* BIN: * This symbol holds the path of the bin directory where the package will * be installed. Program must be prepared to deal with ~name substitution. */ /* BIN_EXP: * This symbol is the filename expanded version of the BIN symbol, for * programs that do not want to deal with that at run-time. */ /* PERL_RELOCATABLE_INC: * This symbol, if defined, indicates that we'd like to relocate entries * in @INC at run time based on the location of the perl binary. */ #define BIN "c:\\perl\\bin" /**/ #define BIN_EXP "c:\\perl\\bin" /**/ #define PERL_RELOCATABLE_INC "undef" /**/ /* CAT2: * This macro concatenates 2 tokens together. */ /* STRINGIFY: * This macro surrounds its token with double quotes. */ #if 42 == 1 #define CAT2(a,b) a/**/b #define STRINGIFY(a) "a" #endif #if 42 == 42 #define PeRl_CaTiFy(a, b) a ## b #define PeRl_StGiFy(a) #a #define CAT2(a,b) PeRl_CaTiFy(a,b) #define StGiFy(a) PeRl_StGiFy(a) #define STRINGIFY(a) PeRl_StGiFy(a) #endif #if 42 != 1 && 42 != 42 #include "Bletch: How does this C preprocessor concatenate tokens?" #endif /* CPPSTDIN: * This symbol contains the first part of the string which will invoke * the C preprocessor on the standard input and produce to standard * output. Typical value of "cc -E" or "/lib/cpp", but it can also * call a wrapper. See CPPRUN. */ /* CPPMINUS: * This symbol contains the second part of the string which will invoke * the C preprocessor on the standard input and produce to standard * output. This symbol will have the value "-" if CPPSTDIN needs a minus * to specify standard input, otherwise the value is "". */ /* CPPRUN: * This symbol contains the string which will invoke a C preprocessor on * the standard input and produce to standard output. It needs to end * with CPPLAST, after all other preprocessor flags have been specified. * The main difference with CPPSTDIN is that this program will never be a * pointer to a shell wrapper, i.e. it will be empty if no preprocessor is * available directly to the user. Note that it may well be different from * the preprocessor used to compile the C program. */ /* CPPLAST: * This symbol is intended to be used along with CPPRUN in the same manner * symbol CPPMINUS is used with CPPSTDIN. It contains either "-" or "". */ #ifndef __GNUC__ # define CPPSTDIN "cppstdin" # define CPPMINUS "" # define CPPRUN "cl -nologo -E" #else # define CPPSTDIN "gcc -E" # define CPPMINUS "-" # define CPPRUN "gcc -E" #endif #define CPPLAST "" /* HAS_ACCESS: * This manifest constant lets the C program know that the access() * system call is available to check for accessibility using real UID/GID. * (always present on UNIX.) */ #define HAS_ACCESS /**/ /* HAS_ACCESSX: * This symbol, if defined, indicates that the accessx routine is * available to do extended access checks. */ /*#define HAS_ACCESSX / **/ /* HAS_ASCTIME_R: * This symbol, if defined, indicates that the asctime_r routine * is available to asctime re-entrantly. */ /* ASCTIME_R_PROTO: * This symbol encodes the prototype of asctime_r. * It is zero if d_asctime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_asctime_r * is defined. */ /*#define HAS_ASCTIME_R / **/ #define ASCTIME_R_PROTO 0 /**/ /* HASATTRIBUTE_FORMAT: * Can we handle GCC attribute for checking printf-style formats */ /* PRINTF_FORMAT_NULL_OK: * Allows __printf__ format to be null when checking printf-style */ /* HASATTRIBUTE_MALLOC: * Can we handle GCC attribute for malloc-style functions. */ /* HASATTRIBUTE_NONNULL: * Can we handle GCC attribute for nonnull function parms. */ /* HASATTRIBUTE_NORETURN: * Can we handle GCC attribute for functions that do not return */ /* HASATTRIBUTE_PURE: * Can we handle GCC attribute for pure functions */ /* HASATTRIBUTE_UNUSED: * Can we handle GCC attribute for unused variables and arguments */ /* HASATTRIBUTE_DEPRECATED: * Can we handle GCC attribute for marking deprecated APIs */ /* HASATTRIBUTE_WARN_UNUSED_RESULT: * Can we handle GCC attribute for warning on unused results */ /*#define HASATTRIBUTE_DEPRECATED / **/ /*#define HASATTRIBUTE_FORMAT / **/ /*#define PRINTF_FORMAT_NULL_OK / **/ /*#define HASATTRIBUTE_NORETURN / **/ /*#define HASATTRIBUTE_MALLOC / **/ /*#define HASATTRIBUTE_NONNULL / **/ /*#define HASATTRIBUTE_PURE / **/ /*#define HASATTRIBUTE_UNUSED / **/ /*#define HASATTRIBUTE_WARN_UNUSED_RESULT / **/ /* HASCONST: * This symbol, if defined, indicates that this C compiler knows about * the const type. There is no need to actually test for that symbol * within your programs. The mere use of the "const" keyword will * trigger the necessary tests. */ #define HASCONST /**/ #ifndef HASCONST #define const #endif /* HAS_CRYPT_R: * This symbol, if defined, indicates that the crypt_r routine * is available to crypt re-entrantly. */ /* CRYPT_R_PROTO: * This symbol encodes the prototype of crypt_r. * It is zero if d_crypt_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_crypt_r * is defined. */ /*#define HAS_CRYPT_R / **/ #define CRYPT_R_PROTO 0 /**/ /* HAS_CSH: * This symbol, if defined, indicates that the C-shell exists. */ /* CSH: * This symbol, if defined, contains the full pathname of csh. */ /*#define HAS_CSH / **/ #ifdef HAS_CSH #define CSH "" /**/ #endif /* HAS_CTERMID_R: * This symbol, if defined, indicates that the ctermid_r routine * is available to ctermid re-entrantly. */ /* CTERMID_R_PROTO: * This symbol encodes the prototype of ctermid_r. * It is zero if d_ctermid_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ctermid_r * is defined. */ /*#define HAS_CTERMID_R / **/ #define CTERMID_R_PROTO 0 /**/ /* HAS_CTIME_R: * This symbol, if defined, indicates that the ctime_r routine * is available to ctime re-entrantly. */ /* CTIME_R_PROTO: * This symbol encodes the prototype of ctime_r. * It is zero if d_ctime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ctime_r * is defined. */ /*#define HAS_CTIME_R / **/ #define CTIME_R_PROTO 0 /**/ /* HAS_DRAND48_R: * This symbol, if defined, indicates that the drand48_r routine * is available to drand48 re-entrantly. */ /* DRAND48_R_PROTO: * This symbol encodes the prototype of drand48_r. * It is zero if d_drand48_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_drand48_r * is defined. */ /*#define HAS_DRAND48_R / **/ #define DRAND48_R_PROTO 0 /**/ /* HAS_DRAND48_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the drand48() function. Otherwise, it is up * to the program to supply one. A good guess is * extern double drand48(void); */ /*#define HAS_DRAND48_PROTO / **/ /* HAS_EACCESS: * This symbol, if defined, indicates that the eaccess routine is * available to do extended access checks. */ /*#define HAS_EACCESS / **/ /* HAS_ENDGRENT: * This symbol, if defined, indicates that the getgrent routine is * available for finalizing sequential access of the group database. */ /*#define HAS_ENDGRENT / **/ /* HAS_ENDGRENT_R: * This symbol, if defined, indicates that the endgrent_r routine * is available to endgrent re-entrantly. */ /* ENDGRENT_R_PROTO: * This symbol encodes the prototype of endgrent_r. * It is zero if d_endgrent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endgrent_r * is defined. */ /*#define HAS_ENDGRENT_R / **/ #define ENDGRENT_R_PROTO 0 /**/ /* HAS_ENDHOSTENT: * This symbol, if defined, indicates that the endhostent() routine is * available to close whatever was being used for host queries. */ /*#define HAS_ENDHOSTENT / **/ /* HAS_ENDHOSTENT_R: * This symbol, if defined, indicates that the endhostent_r routine * is available to endhostent re-entrantly. */ /* ENDHOSTENT_R_PROTO: * This symbol encodes the prototype of endhostent_r. * It is zero if d_endhostent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endhostent_r * is defined. */ /*#define HAS_ENDHOSTENT_R / **/ #define ENDHOSTENT_R_PROTO 0 /**/ /* HAS_ENDNETENT: * This symbol, if defined, indicates that the endnetent() routine is * available to close whatever was being used for network queries. */ /*#define HAS_ENDNETENT / **/ /* HAS_ENDNETENT_R: * This symbol, if defined, indicates that the endnetent_r routine * is available to endnetent re-entrantly. */ /* ENDNETENT_R_PROTO: * This symbol encodes the prototype of endnetent_r. * It is zero if d_endnetent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endnetent_r * is defined. */ /*#define HAS_ENDNETENT_R / **/ #define ENDNETENT_R_PROTO 0 /**/ /* HAS_ENDPROTOENT: * This symbol, if defined, indicates that the endprotoent() routine is * available to close whatever was being used for protocol queries. */ /*#define HAS_ENDPROTOENT / **/ /* HAS_ENDPROTOENT_R: * This symbol, if defined, indicates that the endprotoent_r routine * is available to endprotoent re-entrantly. */ /* ENDPROTOENT_R_PROTO: * This symbol encodes the prototype of endprotoent_r. * It is zero if d_endprotoent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endprotoent_r * is defined. */ /*#define HAS_ENDPROTOENT_R / **/ #define ENDPROTOENT_R_PROTO 0 /**/ /* HAS_ENDPWENT: * This symbol, if defined, indicates that the getgrent routine is * available for finalizing sequential access of the passwd database. */ /*#define HAS_ENDPWENT / **/ /* HAS_ENDPWENT_R: * This symbol, if defined, indicates that the endpwent_r routine * is available to endpwent re-entrantly. */ /* ENDPWENT_R_PROTO: * This symbol encodes the prototype of endpwent_r. * It is zero if d_endpwent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endpwent_r * is defined. */ /*#define HAS_ENDPWENT_R / **/ #define ENDPWENT_R_PROTO 0 /**/ /* HAS_ENDSERVENT: * This symbol, if defined, indicates that the endservent() routine is * available to close whatever was being used for service queries. */ /*#define HAS_ENDSERVENT / **/ /* HAS_ENDSERVENT_R: * This symbol, if defined, indicates that the endservent_r routine * is available to endservent re-entrantly. */ /* ENDSERVENT_R_PROTO: * This symbol encodes the prototype of endservent_r. * It is zero if d_endservent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endservent_r * is defined. */ /*#define HAS_ENDSERVENT_R / **/ #define ENDSERVENT_R_PROTO 0 /**/ /* FLEXFILENAMES: * This symbol, if defined, indicates that the system supports filenames * longer than 14 characters. */ #define FLEXFILENAMES /**/ /* HAS_GETGRENT: * This symbol, if defined, indicates that the getgrent routine is * available for sequential access of the group database. */ /*#define HAS_GETGRENT / **/ /* HAS_GETGRENT_R: * This symbol, if defined, indicates that the getgrent_r routine * is available to getgrent re-entrantly. */ /* GETGRENT_R_PROTO: * This symbol encodes the prototype of getgrent_r. * It is zero if d_getgrent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrent_r * is defined. */ /*#define HAS_GETGRENT_R / **/ #define GETGRENT_R_PROTO 0 /**/ /* HAS_GETGRGID_R: * This symbol, if defined, indicates that the getgrgid_r routine * is available to getgrgid re-entrantly. */ /* GETGRGID_R_PROTO: * This symbol encodes the prototype of getgrgid_r. * It is zero if d_getgrgid_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrgid_r * is defined. */ /*#define HAS_GETGRGID_R / **/ #define GETGRGID_R_PROTO 0 /**/ /* HAS_GETGRNAM_R: * This symbol, if defined, indicates that the getgrnam_r routine * is available to getgrnam re-entrantly. */ /* GETGRNAM_R_PROTO: * This symbol encodes the prototype of getgrnam_r. * It is zero if d_getgrnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrnam_r * is defined. */ /*#define HAS_GETGRNAM_R / **/ #define GETGRNAM_R_PROTO 0 /**/ /* HAS_GETHOSTBYADDR: * This symbol, if defined, indicates that the gethostbyaddr() routine is * available to look up hosts by their IP addresses. */ #define HAS_GETHOSTBYADDR /**/ /* HAS_GETHOSTBYNAME: * This symbol, if defined, indicates that the gethostbyname() routine is * available to look up host names in some data base or other. */ #define HAS_GETHOSTBYNAME /**/ /* HAS_GETHOSTENT: * This symbol, if defined, indicates that the gethostent() routine is * available to look up host names in some data base or another. */ /*#define HAS_GETHOSTENT / **/ /* HAS_GETHOSTNAME: * This symbol, if defined, indicates that the C program may use the * gethostname() routine to derive the host name. See also HAS_UNAME * and PHOSTNAME. */ /* HAS_UNAME: * This symbol, if defined, indicates that the C program may use the * uname() routine to derive the host name. See also HAS_GETHOSTNAME * and PHOSTNAME. */ /* PHOSTNAME: * This symbol, if defined, indicates the command to feed to the * popen() routine to derive the host name. See also HAS_GETHOSTNAME * and HAS_UNAME. Note that the command uses a fully qualified path, * so that it is safe even if used by a process with super-user * privileges. */ /* HAS_PHOSTNAME: * This symbol, if defined, indicates that the C program may use the * contents of PHOSTNAME as a command to feed to the popen() routine * to derive the host name. */ #define HAS_GETHOSTNAME /**/ #define HAS_UNAME /**/ /*#define HAS_PHOSTNAME / **/ #ifdef HAS_PHOSTNAME #define PHOSTNAME "" /* How to get the host name */ #endif /* HAS_GETHOSTBYADDR_R: * This symbol, if defined, indicates that the gethostbyaddr_r routine * is available to gethostbyaddr re-entrantly. */ /* GETHOSTBYADDR_R_PROTO: * This symbol encodes the prototype of gethostbyaddr_r. * It is zero if d_gethostbyaddr_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostbyaddr_r * is defined. */ /*#define HAS_GETHOSTBYADDR_R / **/ #define GETHOSTBYADDR_R_PROTO 0 /**/ /* HAS_GETHOSTBYNAME_R: * This symbol, if defined, indicates that the gethostbyname_r routine * is available to gethostbyname re-entrantly. */ /* GETHOSTBYNAME_R_PROTO: * This symbol encodes the prototype of gethostbyname_r. * It is zero if d_gethostbyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostbyname_r * is defined. */ /*#define HAS_GETHOSTBYNAME_R / **/ #define GETHOSTBYNAME_R_PROTO 0 /**/ /* HAS_GETHOSTENT_R: * This symbol, if defined, indicates that the gethostent_r routine * is available to gethostent re-entrantly. */ /* GETHOSTENT_R_PROTO: * This symbol encodes the prototype of gethostent_r. * It is zero if d_gethostent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostent_r * is defined. */ /*#define HAS_GETHOSTENT_R / **/ #define GETHOSTENT_R_PROTO 0 /**/ /* HAS_GETHOST_PROTOS: * This symbol, if defined, indicates that includes * prototypes for gethostent(), gethostbyname(), and * gethostbyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ #define HAS_GETHOST_PROTOS /**/ /* HAS_GETLOGIN_R: * This symbol, if defined, indicates that the getlogin_r routine * is available to getlogin re-entrantly. */ /* GETLOGIN_R_PROTO: * This symbol encodes the prototype of getlogin_r. * It is zero if d_getlogin_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getlogin_r * is defined. */ /*#define HAS_GETLOGIN_R / **/ #define GETLOGIN_R_PROTO 0 /**/ /* HAS_GETNETBYADDR: * This symbol, if defined, indicates that the getnetbyaddr() routine is * available to look up networks by their IP addresses. */ /*#define HAS_GETNETBYADDR / **/ /* HAS_GETNETBYNAME: * This symbol, if defined, indicates that the getnetbyname() routine is * available to look up networks by their names. */ /*#define HAS_GETNETBYNAME / **/ /* HAS_GETNETENT: * This symbol, if defined, indicates that the getnetent() routine is * available to look up network names in some data base or another. */ /*#define HAS_GETNETENT / **/ /* HAS_GETNETBYADDR_R: * This symbol, if defined, indicates that the getnetbyaddr_r routine * is available to getnetbyaddr re-entrantly. */ /* GETNETBYADDR_R_PROTO: * This symbol encodes the prototype of getnetbyaddr_r. * It is zero if d_getnetbyaddr_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetbyaddr_r * is defined. */ /*#define HAS_GETNETBYADDR_R / **/ #define GETNETBYADDR_R_PROTO 0 /**/ /* HAS_GETNETBYNAME_R: * This symbol, if defined, indicates that the getnetbyname_r routine * is available to getnetbyname re-entrantly. */ /* GETNETBYNAME_R_PROTO: * This symbol encodes the prototype of getnetbyname_r. * It is zero if d_getnetbyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetbyname_r * is defined. */ /*#define HAS_GETNETBYNAME_R / **/ #define GETNETBYNAME_R_PROTO 0 /**/ /* HAS_GETNETENT_R: * This symbol, if defined, indicates that the getnetent_r routine * is available to getnetent re-entrantly. */ /* GETNETENT_R_PROTO: * This symbol encodes the prototype of getnetent_r. * It is zero if d_getnetent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetent_r * is defined. */ /*#define HAS_GETNETENT_R / **/ #define GETNETENT_R_PROTO 0 /**/ /* HAS_GETNET_PROTOS: * This symbol, if defined, indicates that includes * prototypes for getnetent(), getnetbyname(), and * getnetbyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ /*#define HAS_GETNET_PROTOS / **/ /* HAS_GETPROTOENT: * This symbol, if defined, indicates that the getprotoent() routine is * available to look up protocols in some data base or another. */ /*#define HAS_GETPROTOENT / **/ /* HAS_GETPGRP: * This symbol, if defined, indicates that the getpgrp routine is * available to get the current process group. */ /* USE_BSD_GETPGRP: * This symbol, if defined, indicates that getpgrp needs one * arguments whereas USG one needs none. */ /*#define HAS_GETPGRP / **/ /*#define USE_BSD_GETPGRP / **/ /* HAS_GETPROTOBYNAME: * This symbol, if defined, indicates that the getprotobyname() * routine is available to look up protocols by their name. */ /* HAS_GETPROTOBYNUMBER: * This symbol, if defined, indicates that the getprotobynumber() * routine is available to look up protocols by their number. */ #define HAS_GETPROTOBYNAME /**/ #define HAS_GETPROTOBYNUMBER /**/ /* HAS_GETPROTOBYNAME_R: * This symbol, if defined, indicates that the getprotobyname_r routine * is available to getprotobyname re-entrantly. */ /* GETPROTOBYNAME_R_PROTO: * This symbol encodes the prototype of getprotobyname_r. * It is zero if d_getprotobyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotobyname_r * is defined. */ /*#define HAS_GETPROTOBYNAME_R / **/ #define GETPROTOBYNAME_R_PROTO 0 /**/ /* HAS_GETPROTOBYNUMBER_R: * This symbol, if defined, indicates that the getprotobynumber_r routine * is available to getprotobynumber re-entrantly. */ /* GETPROTOBYNUMBER_R_PROTO: * This symbol encodes the prototype of getprotobynumber_r. * It is zero if d_getprotobynumber_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotobynumber_r * is defined. */ /*#define HAS_GETPROTOBYNUMBER_R / **/ #define GETPROTOBYNUMBER_R_PROTO 0 /**/ /* HAS_GETPROTOENT_R: * This symbol, if defined, indicates that the getprotoent_r routine * is available to getprotoent re-entrantly. */ /* GETPROTOENT_R_PROTO: * This symbol encodes the prototype of getprotoent_r. * It is zero if d_getprotoent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotoent_r * is defined. */ /*#define HAS_GETPROTOENT_R / **/ #define GETPROTOENT_R_PROTO 0 /**/ /* HAS_GETPROTO_PROTOS: * This symbol, if defined, indicates that includes * prototypes for getprotoent(), getprotobyname(), and * getprotobyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ #define HAS_GETPROTO_PROTOS /**/ /* HAS_GETPWENT: * This symbol, if defined, indicates that the getpwent routine is * available for sequential access of the passwd database. * If this is not available, the older getpw() function may be available. */ /*#define HAS_GETPWENT / **/ /* HAS_GETPWENT_R: * This symbol, if defined, indicates that the getpwent_r routine * is available to getpwent re-entrantly. */ /* GETPWENT_R_PROTO: * This symbol encodes the prototype of getpwent_r. * It is zero if d_getpwent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwent_r * is defined. */ /*#define HAS_GETPWENT_R / **/ #define GETPWENT_R_PROTO 0 /**/ /* HAS_GETPWNAM_R: * This symbol, if defined, indicates that the getpwnam_r routine * is available to getpwnam re-entrantly. */ /* GETPWNAM_R_PROTO: * This symbol encodes the prototype of getpwnam_r. * It is zero if d_getpwnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwnam_r * is defined. */ /*#define HAS_GETPWNAM_R / **/ #define GETPWNAM_R_PROTO 0 /**/ /* HAS_GETPWUID_R: * This symbol, if defined, indicates that the getpwuid_r routine * is available to getpwuid re-entrantly. */ /* GETPWUID_R_PROTO: * This symbol encodes the prototype of getpwuid_r. * It is zero if d_getpwuid_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwuid_r * is defined. */ /*#define HAS_GETPWUID_R / **/ #define GETPWUID_R_PROTO 0 /**/ /* HAS_GETSERVENT: * This symbol, if defined, indicates that the getservent() routine is * available to look up network services in some data base or another. */ /*#define HAS_GETSERVENT / **/ /* HAS_GETSERVBYNAME_R: * This symbol, if defined, indicates that the getservbyname_r routine * is available to getservbyname re-entrantly. */ /* GETSERVBYNAME_R_PROTO: * This symbol encodes the prototype of getservbyname_r. * It is zero if d_getservbyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservbyname_r * is defined. */ /*#define HAS_GETSERVBYNAME_R / **/ #define GETSERVBYNAME_R_PROTO 0 /**/ /* HAS_GETSERVBYPORT_R: * This symbol, if defined, indicates that the getservbyport_r routine * is available to getservbyport re-entrantly. */ /* GETSERVBYPORT_R_PROTO: * This symbol encodes the prototype of getservbyport_r. * It is zero if d_getservbyport_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservbyport_r * is defined. */ /*#define HAS_GETSERVBYPORT_R / **/ #define GETSERVBYPORT_R_PROTO 0 /**/ /* HAS_GETSERVENT_R: * This symbol, if defined, indicates that the getservent_r routine * is available to getservent re-entrantly. */ /* GETSERVENT_R_PROTO: * This symbol encodes the prototype of getservent_r. * It is zero if d_getservent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservent_r * is defined. */ /*#define HAS_GETSERVENT_R / **/ #define GETSERVENT_R_PROTO 0 /**/ /* HAS_GETSERV_PROTOS: * This symbol, if defined, indicates that includes * prototypes for getservent(), getservbyname(), and * getservbyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ #define HAS_GETSERV_PROTOS /**/ /* HAS_GETSPNAM_R: * This symbol, if defined, indicates that the getspnam_r routine * is available to getspnam re-entrantly. */ /* GETSPNAM_R_PROTO: * This symbol encodes the prototype of getspnam_r. * It is zero if d_getspnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getspnam_r * is defined. */ /*#define HAS_GETSPNAM_R / **/ #define GETSPNAM_R_PROTO 0 /**/ /* HAS_GETSERVBYNAME: * This symbol, if defined, indicates that the getservbyname() * routine is available to look up services by their name. */ /* HAS_GETSERVBYPORT: * This symbol, if defined, indicates that the getservbyport() * routine is available to look up services by their port. */ #define HAS_GETSERVBYNAME /**/ #define HAS_GETSERVBYPORT /**/ /* HAS_GMTIME_R: * This symbol, if defined, indicates that the gmtime_r routine * is available to gmtime re-entrantly. */ /* GMTIME_R_PROTO: * This symbol encodes the prototype of gmtime_r. * It is zero if d_gmtime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gmtime_r * is defined. */ /*#define HAS_GMTIME_R / **/ #define GMTIME_R_PROTO 0 /**/ /* HAS_HTONL: * This symbol, if defined, indicates that the htonl() routine (and * friends htons() ntohl() ntohs()) are available to do network * order byte swapping. */ /* HAS_HTONS: * This symbol, if defined, indicates that the htons() routine (and * friends htonl() ntohl() ntohs()) are available to do network * order byte swapping. */ /* HAS_NTOHL: * This symbol, if defined, indicates that the ntohl() routine (and * friends htonl() htons() ntohs()) are available to do network * order byte swapping. */ /* HAS_NTOHS: * This symbol, if defined, indicates that the ntohs() routine (and * friends htonl() htons() ntohl()) are available to do network * order byte swapping. */ #define HAS_HTONL /**/ #define HAS_HTONS /**/ #define HAS_NTOHL /**/ #define HAS_NTOHS /**/ /* HAS_LOCALTIME_R: * This symbol, if defined, indicates that the localtime_r routine * is available to localtime re-entrantly. */ /* LOCALTIME_R_NEEDS_TZSET: * Many libc's localtime_r implementations do not call tzset, * making them differ from localtime(), and making timezone * changes using \undef{TZ} without explicitly calling tzset * impossible. This symbol makes us call tzset before localtime_r */ /*#define LOCALTIME_R_NEEDS_TZSET / **/ #ifdef LOCALTIME_R_NEEDS_TZSET #define L_R_TZSET tzset(), #else #define L_R_TZSET #endif /* LOCALTIME_R_PROTO: * This symbol encodes the prototype of localtime_r. * It is zero if d_localtime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_localtime_r * is defined. */ /*#define HAS_LOCALTIME_R / **/ #define LOCALTIME_R_PROTO 0 /**/ /* HAS_LONG_DOUBLE: * This symbol will be defined if the C compiler supports long * doubles. */ /* LONG_DOUBLESIZE: * This symbol contains the size of a long double, so that the * C preprocessor can make decisions based on it. It is only * defined if the system supports long doubles. */ #define HAS_LONG_DOUBLE /**/ #ifdef HAS_LONG_DOUBLE # ifndef __GNUC__ # define LONG_DOUBLESIZE 8 /**/ # else # define LONG_DOUBLESIZE 12 /**/ # endif #endif /* HAS_LONG_LONG: * This symbol will be defined if the C compiler supports long long. */ /* LONGLONGSIZE: * This symbol contains the size of a long long, so that the * C preprocessor can make decisions based on it. It is only * defined if the system supports long long. */ /*#define HAS_LONG_LONG / **/ #ifdef HAS_LONG_LONG #define LONGLONGSIZE 8 /**/ #endif /* HAS_LSEEK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the lseek() function. Otherwise, it is up * to the program to supply one. A good guess is * extern off_t lseek(int, off_t, int); */ #define HAS_LSEEK_PROTO /**/ /* HAS_MEMCHR: * This symbol, if defined, indicates that the memchr routine is available * to locate characters within a C string. */ #define HAS_MEMCHR /**/ /* HAS_MKSTEMP: * This symbol, if defined, indicates that the mkstemp routine is * available to exclusively create and open a uniquely named * temporary file. */ /*#define HAS_MKSTEMP / **/ /* HAS_MMAP: * This symbol, if defined, indicates that the mmap system call is * available to map a file into memory. */ /* Mmap_t: * This symbol holds the return type of the mmap() system call * (and simultaneously the type of the first argument). * Usually set to 'void *' or 'caddr_t'. */ /*#define HAS_MMAP / **/ #define Mmap_t void * /**/ /* HAS_MSG: * This symbol, if defined, indicates that the entire msg*(2) library is * supported (IPC mechanism based on message queues). */ /*#define HAS_MSG / **/ /* OLD_PTHREAD_CREATE_JOINABLE: * This symbol, if defined, indicates how to create pthread * in joinable (aka undetached) state. NOTE: not defined * if pthread.h already has defined PTHREAD_CREATE_JOINABLE * (the new version of the constant). * If defined, known values are PTHREAD_CREATE_UNDETACHED * and __UNDETACHED. */ /*#define OLD_PTHREAD_CREATE_JOINABLE / **/ /* HAS_PTHREAD_ATFORK: * This symbol, if defined, indicates that the pthread_atfork routine * is available to setup fork handlers. */ /*#define HAS_PTHREAD_ATFORK / **/ /* HAS_PTHREAD_YIELD: * This symbol, if defined, indicates that the pthread_yield * routine is available to yield the execution of the current * thread. sched_yield is preferable to pthread_yield. */ /* SCHED_YIELD: * This symbol defines the way to yield the execution of * the current thread. Known ways are sched_yield, * pthread_yield, and pthread_yield with NULL. */ /* HAS_SCHED_YIELD: * This symbol, if defined, indicates that the sched_yield * routine is available to yield the execution of the current * thread. sched_yield is preferable to pthread_yield. */ /*#define HAS_PTHREAD_YIELD / **/ #define SCHED_YIELD /**/ /*#define HAS_SCHED_YIELD / **/ /* HAS_RANDOM_R: * This symbol, if defined, indicates that the random_r routine * is available to random re-entrantly. */ /* RANDOM_R_PROTO: * This symbol encodes the prototype of random_r. * It is zero if d_random_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_random_r * is defined. */ /*#define HAS_RANDOM_R / **/ #define RANDOM_R_PROTO 0 /**/ /* HAS_READDIR64_R: * This symbol, if defined, indicates that the readdir64_r routine * is available to readdir64 re-entrantly. */ /* READDIR64_R_PROTO: * This symbol encodes the prototype of readdir64_r. * It is zero if d_readdir64_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_readdir64_r * is defined. */ /*#define HAS_READDIR64_R / **/ #define READDIR64_R_PROTO 0 /**/ /* HAS_READDIR_R: * This symbol, if defined, indicates that the readdir_r routine * is available to readdir re-entrantly. */ /* READDIR_R_PROTO: * This symbol encodes the prototype of readdir_r. * It is zero if d_readdir_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_readdir_r * is defined. */ /*#define HAS_READDIR_R / **/ #define READDIR_R_PROTO 0 /**/ /* HAS_SEM: * This symbol, if defined, indicates that the entire sem*(2) library is * supported. */ /*#define HAS_SEM / **/ /* HAS_SETGRENT: * This symbol, if defined, indicates that the setgrent routine is * available for initializing sequential access of the group database. */ /*#define HAS_SETGRENT / **/ /* HAS_SETGRENT_R: * This symbol, if defined, indicates that the setgrent_r routine * is available to setgrent re-entrantly. */ /* SETGRENT_R_PROTO: * This symbol encodes the prototype of setgrent_r. * It is zero if d_setgrent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setgrent_r * is defined. */ /*#define HAS_SETGRENT_R / **/ #define SETGRENT_R_PROTO 0 /**/ /* HAS_SETHOSTENT: * This symbol, if defined, indicates that the sethostent() routine is * available. */ /*#define HAS_SETHOSTENT / **/ /* HAS_SETHOSTENT_R: * This symbol, if defined, indicates that the sethostent_r routine * is available to sethostent re-entrantly. */ /* SETHOSTENT_R_PROTO: * This symbol encodes the prototype of sethostent_r. * It is zero if d_sethostent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_sethostent_r * is defined. */ /*#define HAS_SETHOSTENT_R / **/ #define SETHOSTENT_R_PROTO 0 /**/ /* HAS_SETLOCALE_R: * This symbol, if defined, indicates that the setlocale_r routine * is available to setlocale re-entrantly. */ /* SETLOCALE_R_PROTO: * This symbol encodes the prototype of setlocale_r. * It is zero if d_setlocale_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setlocale_r * is defined. */ /*#define HAS_SETLOCALE_R / **/ #define SETLOCALE_R_PROTO 0 /**/ /* HAS_SETNETENT: * This symbol, if defined, indicates that the setnetent() routine is * available. */ /*#define HAS_SETNETENT / **/ /* HAS_SETNETENT_R: * This symbol, if defined, indicates that the setnetent_r routine * is available to setnetent re-entrantly. */ /* SETNETENT_R_PROTO: * This symbol encodes the prototype of setnetent_r. * It is zero if d_setnetent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setnetent_r * is defined. */ /*#define HAS_SETNETENT_R / **/ #define SETNETENT_R_PROTO 0 /**/ /* HAS_SETPROTOENT: * This symbol, if defined, indicates that the setprotoent() routine is * available. */ /*#define HAS_SETPROTOENT / **/ /* HAS_SETPGRP: * This symbol, if defined, indicates that the setpgrp routine is * available to set the current process group. */ /* USE_BSD_SETPGRP: * This symbol, if defined, indicates that setpgrp needs two * arguments whereas USG one needs none. See also HAS_SETPGID * for a POSIX interface. */ /*#define HAS_SETPGRP / **/ /*#define USE_BSD_SETPGRP / **/ /* HAS_SETPROTOENT_R: * This symbol, if defined, indicates that the setprotoent_r routine * is available to setprotoent re-entrantly. */ /* SETPROTOENT_R_PROTO: * This symbol encodes the prototype of setprotoent_r. * It is zero if d_setprotoent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setprotoent_r * is defined. */ /*#define HAS_SETPROTOENT_R / **/ #define SETPROTOENT_R_PROTO 0 /**/ /* HAS_SETPWENT: * This symbol, if defined, indicates that the setpwent routine is * available for initializing sequential access of the passwd database. */ /*#define HAS_SETPWENT / **/ /* HAS_SETPWENT_R: * This symbol, if defined, indicates that the setpwent_r routine * is available to setpwent re-entrantly. */ /* SETPWENT_R_PROTO: * This symbol encodes the prototype of setpwent_r. * It is zero if d_setpwent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setpwent_r * is defined. */ /*#define HAS_SETPWENT_R / **/ #define SETPWENT_R_PROTO 0 /**/ /* HAS_SETSERVENT: * This symbol, if defined, indicates that the setservent() routine is * available. */ /*#define HAS_SETSERVENT / **/ /* HAS_SETSERVENT_R: * This symbol, if defined, indicates that the setservent_r routine * is available to setservent re-entrantly. */ /* SETSERVENT_R_PROTO: * This symbol encodes the prototype of setservent_r. * It is zero if d_setservent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setservent_r * is defined. */ /*#define HAS_SETSERVENT_R / **/ #define SETSERVENT_R_PROTO 0 /**/ /* HAS_SETVBUF: * This symbol, if defined, indicates that the setvbuf routine is * available to change buffering on an open stdio stream. * to a line-buffered mode. */ #define HAS_SETVBUF /**/ /* HAS_SHM: * This symbol, if defined, indicates that the entire shm*(2) library is * supported. */ /*#define HAS_SHM / **/ /* Shmat_t: * This symbol holds the return type of the shmat() system call. * Usually set to 'void *' or 'char *'. */ /* HAS_SHMAT_PROTOTYPE: * This symbol, if defined, indicates that the sys/shm.h includes * a prototype for shmat(). Otherwise, it is up to the program to * guess one. Shmat_t shmat(int, Shmat_t, int) is a good guess, * but not always right so it should be emitted by the program only * when HAS_SHMAT_PROTOTYPE is not defined to avoid conflicting defs. */ #define Shmat_t void * /**/ /*#define HAS_SHMAT_PROTOTYPE / **/ /* HAS_SOCKET: * This symbol, if defined, indicates that the BSD socket interface is * supported. */ /* HAS_SOCKETPAIR: * This symbol, if defined, indicates that the BSD socketpair() call is * supported. */ /* HAS_MSG_CTRUNC: * This symbol, if defined, indicates that the MSG_CTRUNC is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_DONTROUTE: * This symbol, if defined, indicates that the MSG_DONTROUTE is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_OOB: * This symbol, if defined, indicates that the MSG_OOB is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_PEEK: * This symbol, if defined, indicates that the MSG_PEEK is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_PROXY: * This symbol, if defined, indicates that the MSG_PROXY is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_SCM_RIGHTS: * This symbol, if defined, indicates that the SCM_RIGHTS is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ #define HAS_SOCKET /**/ /*#define HAS_SOCKETPAIR / **/ /*#define HAS_MSG_CTRUNC / **/ /*#define HAS_MSG_DONTROUTE / **/ /*#define HAS_MSG_OOB / **/ /*#define HAS_MSG_PEEK / **/ /*#define HAS_MSG_PROXY / **/ /*#define HAS_SCM_RIGHTS / **/ /* HAS_SRAND48_R: * This symbol, if defined, indicates that the srand48_r routine * is available to srand48 re-entrantly. */ /* SRAND48_R_PROTO: * This symbol encodes the prototype of srand48_r. * It is zero if d_srand48_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_srand48_r * is defined. */ /*#define HAS_SRAND48_R / **/ #define SRAND48_R_PROTO 0 /**/ /* HAS_SRANDOM_R: * This symbol, if defined, indicates that the srandom_r routine * is available to srandom re-entrantly. */ /* SRANDOM_R_PROTO: * This symbol encodes the prototype of srandom_r. * It is zero if d_srandom_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_srandom_r * is defined. */ /*#define HAS_SRANDOM_R / **/ #define SRANDOM_R_PROTO 0 /**/ /* USE_STAT_BLOCKS: * This symbol is defined if this system has a stat structure declaring * st_blksize and st_blocks. */ #ifndef USE_STAT_BLOCKS /*#define USE_STAT_BLOCKS / **/ #endif /* USE_STRUCT_COPY: * This symbol, if defined, indicates that this C compiler knows how * to copy structures. If undefined, you'll need to use a block copy * routine of some sort instead. */ #define USE_STRUCT_COPY /**/ /* HAS_STRERROR: * This symbol, if defined, indicates that the strerror routine is * available to translate error numbers to strings. See the writeup * of Strerror() in this file before you try to define your own. */ /* HAS_SYS_ERRLIST: * This symbol, if defined, indicates that the sys_errlist array is * available to translate error numbers to strings. The extern int * sys_nerr gives the size of that table. */ /* Strerror: * This preprocessor symbol is defined as a macro if strerror() is * not available to translate error numbers to strings but sys_errlist[] * array is there. */ #define HAS_STRERROR /**/ #define HAS_SYS_ERRLIST /**/ #define Strerror(e) strerror(e) /* HAS_STRERROR_R: * This symbol, if defined, indicates that the strerror_r routine * is available to strerror re-entrantly. */ /* STRERROR_R_PROTO: * This symbol encodes the prototype of strerror_r. * It is zero if d_strerror_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_strerror_r * is defined. */ /*#define HAS_STRERROR_R / **/ #define STRERROR_R_PROTO 0 /**/ /* HAS_STRTOUL: * This symbol, if defined, indicates that the strtoul routine is * available to provide conversion of strings to unsigned long. */ #define HAS_STRTOUL /**/ /* HAS_TIME: * This symbol, if defined, indicates that the time() routine exists. */ /* Time_t: * This symbol holds the type returned by time(). It can be long, * or time_t on BSD sites (in which case should be * included). */ #define HAS_TIME /**/ #define Time_t time_t /* Time type */ /* HAS_TIMES: * This symbol, if defined, indicates that the times() routine exists. * Note that this became obsolete on some systems (SUNOS), which now * use getrusage(). It may be necessary to include . */ #define HAS_TIMES /**/ /* HAS_TMPNAM_R: * This symbol, if defined, indicates that the tmpnam_r routine * is available to tmpnam re-entrantly. */ /* TMPNAM_R_PROTO: * This symbol encodes the prototype of tmpnam_r. * It is zero if d_tmpnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_tmpnam_r * is defined. */ /*#define HAS_TMPNAM_R / **/ #define TMPNAM_R_PROTO 0 /**/ /* HAS_TTYNAME_R: * This symbol, if defined, indicates that the ttyname_r routine * is available to ttyname re-entrantly. */ /* TTYNAME_R_PROTO: * This symbol encodes the prototype of ttyname_r. * It is zero if d_ttyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ttyname_r * is defined. */ /*#define HAS_TTYNAME_R / **/ #define TTYNAME_R_PROTO 0 /**/ /* HAS_UNION_SEMUN: * This symbol, if defined, indicates that the union semun is * defined by including . If not, the user code * probably needs to define it as: * union semun { * int val; * struct semid_ds *buf; * unsigned short *array; * } */ /* USE_SEMCTL_SEMUN: * This symbol, if defined, indicates that union semun is * used for semctl IPC_STAT. */ /* USE_SEMCTL_SEMID_DS: * This symbol, if defined, indicates that struct semid_ds * is * used for semctl IPC_STAT. */ #define HAS_UNION_SEMUN /**/ /*#define USE_SEMCTL_SEMUN / **/ /*#define USE_SEMCTL_SEMID_DS / **/ /* HAS_VFORK: * This symbol, if defined, indicates that vfork() exists. */ /*#define HAS_VFORK / **/ /* HAS_PSEUDOFORK: * This symbol, if defined, indicates that an emulation of the * fork routine is available. */ /*#define HAS_PSEUDOFORK / **/ /* Signal_t: * This symbol's value is either "void" or "int", corresponding to the * appropriate return type of a signal handler. Thus, you can declare * a signal handler using "Signal_t (*handler)()", and define the * handler using "Signal_t handler(sig)". */ #define Signal_t void /* Signal handler's return type */ /* HASVOLATILE: * This symbol, if defined, indicates that this C compiler knows about * the volatile declaration. */ #define HASVOLATILE /**/ #ifndef HASVOLATILE #define volatile #endif /* Fpos_t: * This symbol holds the type used to declare file positions in libc. * It can be fpos_t, long, uint, etc... It may be necessary to include * to get any typedef'ed information. */ #define Fpos_t fpos_t /* File position type */ /* Gid_t_f: * This symbol defines the format string used for printing a Gid_t. */ #define Gid_t_f "ld" /**/ /* Gid_t_sign: * This symbol holds the signedess of a Gid_t. * 1 for unsigned, -1 for signed. */ #define Gid_t_sign -1 /* GID sign */ /* Gid_t_size: * This symbol holds the size of a Gid_t in bytes. */ #define Gid_t_size 4 /* GID size */ /* Gid_t: * This symbol holds the return type of getgid() and the type of * argument to setrgid() and related functions. Typically, * it is the type of group ids in the kernel. It can be int, ushort, * gid_t, etc... It may be necessary to include to get * any typedef'ed information. */ #define Gid_t gid_t /* Type for getgid(), etc... */ /* I_DIRENT: * This symbol, if defined, indicates to the C program that it should * include . Using this symbol also triggers the definition * of the Direntry_t define which ends up being 'struct dirent' or * 'struct direct' depending on the availability of . */ /* DIRNAMLEN: * This symbol, if defined, indicates to the C program that the length * of directory entry names is provided by a d_namlen field. Otherwise * you need to do strlen() on the d_name field. */ /* Direntry_t: * This symbol is set to 'struct direct' or 'struct dirent' depending on * whether dirent is available or not. You should use this pseudo type to * portably declare your directory entries. */ #define I_DIRENT /**/ #define DIRNAMLEN /**/ #define Direntry_t struct direct /* I_GRP: * This symbol, if defined, indicates to the C program that it should * include . */ /* GRPASSWD: * This symbol, if defined, indicates to the C program that struct group * in contains gr_passwd. */ /*#define I_GRP / **/ /*#define GRPASSWD / **/ /* I_MACH_CTHREADS: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_MACH_CTHREADS / **/ /* I_NDBM: * This symbol, if defined, indicates that exists and should * be included. */ /* I_GDBMNDBM: * This symbol, if defined, indicates that exists and should * be included. This was the location of the ndbm.h compatibility file * in RedHat 7.1. */ /* I_GDBM_NDBM: * This symbol, if defined, indicates that exists and should * be included. This is the location of the ndbm.h compatibility file * in Debian 4.0. */ /* NDBM_H_USES_PROTOTYPES: * This symbol, if defined, indicates that uses real ANSI C * prototypes instead of K&R style function declarations without any * parameter information. While ANSI C prototypes are supported in C++, * K&R style function declarations will yield errors. */ /* GDBMNDBM_H_USES_PROTOTYPES: * This symbol, if defined, indicates that uses real ANSI C * prototypes instead of K&R style function declarations without any * parameter information. While ANSI C prototypes are supported in C++, * K&R style function declarations will yield errors. */ /* GDBM_NDBM_H_USES_PROTOTYPES: * This symbol, if defined, indicates that uses real ANSI C * prototypes instead of K&R style function declarations without any * parameter information. While ANSI C prototypes are supported in C++, * K&R style function declarations will yield errors. */ /*#define I_NDBM / **/ /*#define I_GDBMNDBM / **/ /*#define I_GDBM_NDBM / **/ /*#define NDBM_H_USES_PROTOTYPES / **/ /*#define GDBMNDBM_H_USES_PROTOTYPES / **/ /*#define GDBM_NDBM_H_USES_PROTOTYPES / **/ /* I_NETDB: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_NETDB / **/ /* I_NET_ERRNO: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_NET_ERRNO / **/ /* I_PTHREAD: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_PTHREAD / **/ /* I_PWD: * This symbol, if defined, indicates to the C program that it should * include . */ /* PWQUOTA: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_quota. */ /* PWAGE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_age. */ /* PWCHANGE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_change. */ /* PWCLASS: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_class. */ /* PWEXPIRE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_expire. */ /* PWCOMMENT: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_comment. */ /* PWGECOS: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_gecos. */ /* PWPASSWD: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_passwd. */ /*#define I_PWD / **/ /*#define PWQUOTA / **/ /*#define PWAGE / **/ /*#define PWCHANGE / **/ /*#define PWCLASS / **/ /*#define PWEXPIRE / **/ /*#define PWCOMMENT / **/ /*#define PWGECOS / **/ /*#define PWPASSWD / **/ /* I_SYS_ACCESS: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_ACCESS / **/ /* I_SYS_SECURITY: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_SECURITY / **/ /* I_SYSUIO: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSUIO / **/ /* I_STDARG: * This symbol, if defined, indicates that exists and should * be included. */ /* I_VARARGS: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_STDARG /**/ /*#define I_VARARGS / **/ /* PERL_INC_VERSION_LIST: * This variable specifies the list of subdirectories in over * which perl.c:incpush() and lib/lib.pm will automatically * search when adding directories to @INC, in a format suitable * for a C initialization string. See the inc_version_list entry * in Porting/Glossary for more details. */ /*#define PERL_INC_VERSION_LIST 0 / **/ /* INSTALL_USR_BIN_PERL: * This symbol, if defined, indicates that Perl is to be installed * also as /usr/bin/perl. */ /*#define INSTALL_USR_BIN_PERL / **/ /* Off_t: * This symbol holds the type used to declare offsets in the kernel. * It can be int, long, off_t, etc... It may be necessary to include * to get any typedef'ed information. */ /* LSEEKSIZE: * This symbol holds the number of bytes used by the Off_t. */ /* Off_t_size: * This symbol holds the number of bytes used by the Off_t. */ #define Off_t long /* type */ #define LSEEKSIZE 4 /* size */ #define Off_t_size 4 /* size */ /* Free_t: * This variable contains the return type of free(). It is usually * void, but occasionally int. */ /* Malloc_t: * This symbol is the type of pointer returned by malloc and realloc. */ #define Malloc_t void * /**/ #define Free_t void /**/ /* PERL_MALLOC_WRAP: * This symbol, if defined, indicates that we'd like malloc wrap checks. */ #define PERL_MALLOC_WRAP /**/ /* MYMALLOC: * This symbol, if defined, indicates that we're using our own malloc. */ /*#define MYMALLOC / **/ /* Mode_t: * This symbol holds the type used to declare file modes * for systems calls. It is usually mode_t, but may be * int or unsigned short. It may be necessary to include * to get any typedef'ed information. */ #define Mode_t mode_t /* file mode parameter for system calls */ /* Netdb_host_t: * This symbol holds the type used for the 1st argument * to gethostbyaddr(). */ /* Netdb_hlen_t: * This symbol holds the type used for the 2nd argument * to gethostbyaddr(). */ /* Netdb_name_t: * This symbol holds the type used for the argument to * gethostbyname(). */ /* Netdb_net_t: * This symbol holds the type used for the 1st argument to * getnetbyaddr(). */ #define Netdb_host_t char * /**/ #define Netdb_hlen_t int /**/ #define Netdb_name_t char * /**/ #define Netdb_net_t long /**/ /* PERL_OTHERLIBDIRS: * This variable contains a colon-separated set of paths for the perl * binary to search for additional library files or modules. * These directories will be tacked to the end of @INC. * Perl will automatically search below each path for version- * and architecture-specific directories. See PERL_INC_VERSION_LIST * for more details. */ /*#define PERL_OTHERLIBDIRS "" / **/ /* Pid_t: * This symbol holds the type used to declare process ids in the kernel. * It can be int, uint, pid_t, etc... It may be necessary to include * to get any typedef'ed information. */ #define Pid_t int /* PID type */ /* PRIVLIB: * This symbol contains the name of the private library for this package. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. The program * should be prepared to do ~ expansion. */ /* PRIVLIB_EXP: * This symbol contains the ~name expanded version of PRIVLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ #define PRIVLIB "c:\\perl\\lib" /**/ #define PRIVLIB_EXP (win32_get_privlib(PERL_VERSION_STRING, NULL)) /**/ /* CAN_PROTOTYPE: * If defined, this macro indicates that the C compiler can handle * function prototypes. */ /* _: * This macro is used to declare function parameters for folks who want * to make declarations with prototypes using a different style than * the above macros. Use double parentheses. For example: * * int main _((int argc, char *argv[])); */ #define CAN_PROTOTYPE /**/ #ifdef CAN_PROTOTYPE #define _(args) args #else #define _(args) () #endif /* Select_fd_set_t: * This symbol holds the type used for the 2nd, 3rd, and 4th * arguments to select. Usually, this is 'fd_set *', if HAS_FD_SET * is defined, and 'int *' otherwise. This is only useful if you * have select(), of course. */ #define Select_fd_set_t Perl_fd_set * /**/ /* SH_PATH: * This symbol contains the full pathname to the shell used on this * on this system to execute Bourne shell scripts. Usually, this will be * /bin/sh, though it's possible that some systems will have /bin/ksh, * /bin/pdksh, /bin/ash, /bin/bash, or even something such as * D:/bin/sh.exe. */ #define SH_PATH "cmd /x /c" /**/ /* SIG_NAME: * This symbol contains a list of signal names in order of * signal number. This is intended * to be used as a static array initialization, like this: * char *sig_name[] = { SIG_NAME }; * The signals in the list are separated with commas, and each signal * is surrounded by double quotes. There is no leading SIG in the signal * name, i.e. SIGQUIT is known as "QUIT". * Gaps in the signal numbers (up to NSIG) are filled in with NUMnn, * etc., where nn is the actual signal number (e.g. NUM37). * The signal number for sig_name[i] is stored in sig_num[i]. * The last element is 0 to terminate the list with a NULL. This * corresponds to the 0 at the end of the sig_name_init list. * Note that this variable is initialized from the sig_name_init, * not from sig_name (which is unused). */ /* SIG_NUM: * This symbol contains a list of signal numbers, in the same order as the * SIG_NAME list. It is suitable for static array initialization, as in: * int sig_num[] = { SIG_NUM }; * The signals in the list are separated with commas, and the indices * within that list and the SIG_NAME list match, so it's easy to compute * the signal name from a number or vice versa at the price of a small * dynamic linear lookup. * Duplicates are allowed, but are moved to the end of the list. * The signal number corresponding to sig_name[i] is sig_number[i]. * if (i < NSIG) then sig_number[i] == i. * The last element is 0, corresponding to the 0 at the end of * the sig_name_init list. * Note that this variable is initialized from the sig_num_init, * not from sig_num (which is unused). */ /* SIG_SIZE: * This variable contains the number of elements of the SIG_NAME * and SIG_NUM arrays, excluding the final NULL entry. */ #define SIG_NAME "ZERO", "HUP", "INT", "QUIT", "ILL", "NUM05", "NUM06", "NUM07", "FPE", "KILL", "NUM10", "SEGV", "NUM12", "PIPE", "ALRM", "TERM", "NUM16", "NUM17", "NUM18", "NUM19", "CHLD", "BREAK", "ABRT", "STOP", "NUM24", "CONT", "CLD", 0 /**/ #define SIG_NUM 0, 1, 2, 21, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 20, 0 /**/ #define SIG_SIZE 27 /**/ /* SITEARCH: * This symbol contains the name of the private library for this package. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. The program * should be prepared to do ~ expansion. * The standard distribution will put nothing in this directory. * After perl has been installed, users may install their own local * architecture-dependent modules in this directory with * MakeMaker Makefile.PL * or equivalent. See INSTALL for details. */ /* SITEARCH_EXP: * This symbol contains the ~name expanded version of SITEARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ #define SITEARCH "c:\\perl\\site\\lib" /**/ /*#define SITEARCH_EXP "" / **/ /* SITELIB: * This symbol contains the name of the private library for this package. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. The program * should be prepared to do ~ expansion. * The standard distribution will put nothing in this directory. * After perl has been installed, users may install their own local * architecture-independent modules in this directory with * MakeMaker Makefile.PL * or equivalent. See INSTALL for details. */ /* SITELIB_EXP: * This symbol contains the ~name expanded version of SITELIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ /* SITELIB_STEM: * This define is SITELIB_EXP with any trailing version-specific component * removed. The elements in inc_version_list (inc_version_list.U) can * be tacked onto this variable to generate a list of directories to search. */ #define SITELIB "c:\\perl\\site\\lib" /**/ #define SITELIB_EXP (win32_get_sitelib(PERL_VERSION_STRING, NULL)) /**/ #define SITELIB_STEM "" /**/ /* Size_t_size: * This symbol holds the size of a Size_t in bytes. */ #define Size_t_size 4 /**/ /* Size_t: * This symbol holds the type used to declare length parameters * for string functions. It is usually size_t, but may be * unsigned long, int, etc. It may be necessary to include * to get any typedef'ed information. */ #define Size_t size_t /* length paramater for string functions */ /* Sock_size_t: * This symbol holds the type used for the size argument of * various socket calls (just the base type, not the pointer-to). */ #define Sock_size_t int /**/ /* STDCHAR: * This symbol is defined to be the type of char used in stdio.h. * It has the values "unsigned char" or "char". */ #define STDCHAR char /**/ /* Uid_t_f: * This symbol defines the format string used for printing a Uid_t. */ #define Uid_t_f "ld" /**/ /* Uid_t_sign: * This symbol holds the signedess of a Uid_t. * 1 for unsigned, -1 for signed. */ #define Uid_t_sign -1 /* UID sign */ /* Uid_t_size: * This symbol holds the size of a Uid_t in bytes. */ #define Uid_t_size 4 /* UID size */ /* Uid_t: * This symbol holds the type used to declare user ids in the kernel. * It can be int, ushort, uid_t, etc... It may be necessary to include * to get any typedef'ed information. */ #define Uid_t uid_t /* UID type */ /* USE_ITHREADS: * This symbol, if defined, indicates that Perl should be built to * use the interpreter-based threading implementation. */ /* USE_5005THREADS: * This symbol, if defined, indicates that Perl should be built to * use the 5.005-based threading implementation. * Only valid up to 5.8.x. */ /* OLD_PTHREADS_API: * This symbol, if defined, indicates that Perl should * be built to use the old draft POSIX threads API. */ /* USE_REENTRANT_API: * This symbol, if defined, indicates that Perl should * try to use the various _r versions of library functions. * This is extremely experimental. */ /*#define USE_5005THREADS / **/ /*#define USE_ITHREADS / **/ #if defined(USE_5005THREADS) && !defined(USE_ITHREADS) #define USE_THREADS /* until src is revised*/ #endif /*#define OLD_PTHREADS_API / **/ /*#define USE_REENTRANT_API / **/ /* PERL_VENDORARCH: * If defined, this symbol contains the name of a private library. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. * It may have a ~ on the front. * The standard distribution will put nothing in this directory. * Vendors who distribute perl may wish to place their own * architecture-dependent modules and extensions in this directory with * MakeMaker Makefile.PL INSTALLDIRS=vendor * or equivalent. See INSTALL for details. */ /* PERL_VENDORARCH_EXP: * This symbol contains the ~name expanded version of PERL_VENDORARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ /*#define PERL_VENDORARCH "" / **/ /*#define PERL_VENDORARCH_EXP "" / **/ /* PERL_VENDORLIB_EXP: * This symbol contains the ~name expanded version of VENDORLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ /* PERL_VENDORLIB_STEM: * This define is PERL_VENDORLIB_EXP with any trailing version-specific component * removed. The elements in inc_version_list (inc_version_list.U) can * be tacked onto this variable to generate a list of directories to search. */ /*#define PERL_VENDORLIB_EXP "" / **/ /*#define PERL_VENDORLIB_STEM "" / **/ /* VOIDFLAGS: * This symbol indicates how much support of the void type is given by this * compiler. What various bits mean: * * 1 = supports declaration of void * 2 = supports arrays of pointers to functions returning void * 4 = supports comparisons between pointers to void functions and * addresses of void functions * 8 = suports declaration of generic void pointers * * The package designer should define VOIDUSED to indicate the requirements * of the package. This can be done either by #defining VOIDUSED before * including config.h, or by defining defvoidused in Myinit.U. If the * latter approach is taken, only those flags will be tested. If the * level of void support necessary is not present, defines void to int. */ #ifndef VOIDUSED #define VOIDUSED 15 #endif #define VOIDFLAGS 15 #if (VOIDFLAGS & VOIDUSED) != VOIDUSED #define void int /* is void to be avoided? */ #define M_VOID /* Xenix strikes again */ #endif /* USE_CROSS_COMPILE: * This symbol, if defined, indicates that Perl is being cross-compiled. */ /* PERL_TARGETARCH: * This symbol, if defined, indicates the target architecture * Perl has been cross-compiled to. Undefined if not a cross-compile. */ #ifndef USE_CROSS_COMPILE /*#define USE_CROSS_COMPILE / **/ #define PERL_TARGETARCH "" /**/ #endif /* MEM_ALIGNBYTES: * This symbol contains the number of bytes required to align a * double, or a long double when applicable. Usual values are 2, * 4 and 8. The default is eight, for safety. */ #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH) # define MEM_ALIGNBYTES 8 #else #define MEM_ALIGNBYTES 8 #endif /* BYTEORDER: * This symbol holds the hexadecimal constant defined in byteorder, * in a UV, i.e. 0x1234 or 0x4321 or 0x12345678, etc... * If the compiler supports cross-compiling or multiple-architecture * binaries (eg. on NeXT systems), use compiler-defined macros to * determine the byte order. * On NeXT 3.2 (and greater), you can build "Fat" Multiple Architecture * Binaries (MAB) on either big endian or little endian machines. * The endian-ness is available at compile-time. This only matters * for perl, where the config.h can be generated and installed on * one system, and used by a different architecture to build an * extension. Older versions of NeXT that might not have * defined either *_ENDIAN__ were all on Motorola 680x0 series, * so the default case (for NeXT) is big endian to catch them. * This might matter for NeXT 3.0. */ #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH) # ifdef __LITTLE_ENDIAN__ # if LONGSIZE == 4 # define BYTEORDER 0x1234 # else # if LONGSIZE == 8 # define BYTEORDER 0x12345678 # endif # endif # else # ifdef __BIG_ENDIAN__ # if LONGSIZE == 4 # define BYTEORDER 0x4321 # else # if LONGSIZE == 8 # define BYTEORDER 0x87654321 # endif # endif # endif # endif # if !defined(BYTEORDER) && (defined(NeXT) || defined(__NeXT__)) # define BYTEORDER 0x4321 # endif #else #define BYTEORDER 0x1234 /* large digits for MSB */ #endif /* NeXT */ /* CHARBITS: * This symbol contains the size of a char, so that the C preprocessor * can make decisions based on it. */ #define CHARBITS 8 /**/ /* CASTI32: * This symbol is defined if the C compiler can cast negative * or large floating point numbers to 32-bit ints. */ #ifdef __GNUC__ # define CASTI32 /**/ #endif /* CASTNEGFLOAT: * This symbol is defined if the C compiler can cast negative * numbers to unsigned longs, ints and shorts. */ /* CASTFLAGS: * This symbol contains flags that say what difficulties the compiler * has casting odd floating values to unsigned long: * 0 = ok * 1 = couldn't cast < 0 * 2 = couldn't cast >= 0x80000000 * 4 = couldn't cast in argument expression list */ #define CASTNEGFLOAT /**/ #define CASTFLAGS 0 /**/ /* VOID_CLOSEDIR: * This symbol, if defined, indicates that the closedir() routine * does not return a value. */ /*#define VOID_CLOSEDIR / **/ /* HAS_FD_SET: * This symbol, when defined, indicates presence of the fd_set typedef * in */ #define HAS_FD_SET /**/ /* Gconvert: * This preprocessor macro is defined to convert a floating point * number to a string without a trailing decimal point. This * emulates the behavior of sprintf("%g"), but is sometimes much more * efficient. If gconvert() is not available, but gcvt() drops the * trailing decimal point, then gcvt() is used. If all else fails, * a macro using sprintf("%g") is used. Arguments for the Gconvert * macro are: value, number of digits, whether trailing zeros should * be retained, and the output buffer. * The usual values are: * d_Gconvert='gconvert((x),(n),(t),(b))' * d_Gconvert='gcvt((x),(n),(b))' * d_Gconvert='sprintf((b),"%.*g",(n),(x))' * The last two assume trailing zeros should not be kept. */ #define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(x)) /* HAS_GETPAGESIZE: * This symbol, if defined, indicates that the getpagesize system call * is available to get system page size, which is the granularity of * many memory management calls. */ /*#define HAS_GETPAGESIZE / **/ /* HAS_GNULIBC: * This symbol, if defined, indicates to the C program that * the GNU C library is being used. A better check is to use * the __GLIBC__ and __GLIBC_MINOR__ symbols supplied with glibc. */ /*#define HAS_GNULIBC / **/ #if defined(HAS_GNULIBC) && !defined(_GNU_SOURCE) # define _GNU_SOURCE #endif /* HAS_ISASCII: * This manifest constant lets the C program know that isascii * is available. */ #define HAS_ISASCII /**/ /* HAS_LCHOWN: * This symbol, if defined, indicates that the lchown routine is * available to operate on a symbolic link (instead of following the * link). */ /*#define HAS_LCHOWN / **/ /* HAS_OPEN3: * This manifest constant lets the C program know that the three * argument form of open(2) is available. */ /*#define HAS_OPEN3 / **/ /* HAS_SAFE_BCOPY: * This symbol, if defined, indicates that the bcopy routine is available * to copy potentially overlapping memory blocks. Normally, you should * probably use memmove() or memcpy(). If neither is defined, roll your * own version. */ /*#define HAS_SAFE_BCOPY / **/ /* HAS_SAFE_MEMCPY: * This symbol, if defined, indicates that the memcpy routine is available * to copy potentially overlapping memory blocks. If you need to * copy overlapping memory blocks, you should check HAS_MEMMOVE and * use memmove() instead, if available. */ /*#define HAS_SAFE_MEMCPY / **/ /* HAS_SANE_MEMCMP: * This symbol, if defined, indicates that the memcmp routine is available * and can be used to compare relative magnitudes of chars with their high * bits set. If it is not defined, roll your own version. */ #define HAS_SANE_MEMCMP /**/ /* HAS_SIGACTION: * This symbol, if defined, indicates that Vr4's sigaction() routine * is available. */ /*#define HAS_SIGACTION / **/ /* HAS_SIGSETJMP: * This variable indicates to the C program that the sigsetjmp() * routine is available to save the calling process's registers * and stack environment for later use by siglongjmp(), and * to optionally save the process's signal mask. See * Sigjmp_buf, Sigsetjmp, and Siglongjmp. */ /* Sigjmp_buf: * This is the buffer type to be used with Sigsetjmp and Siglongjmp. */ /* Sigsetjmp: * This macro is used in the same way as sigsetjmp(), but will invoke * traditional setjmp() if sigsetjmp isn't available. * See HAS_SIGSETJMP. */ /* Siglongjmp: * This macro is used in the same way as siglongjmp(), but will invoke * traditional longjmp() if siglongjmp isn't available. * See HAS_SIGSETJMP. */ /*#define HAS_SIGSETJMP / **/ #ifdef HAS_SIGSETJMP #define Sigjmp_buf sigjmp_buf #define Sigsetjmp(buf,save_mask) sigsetjmp((buf),(save_mask)) #define Siglongjmp(buf,retval) siglongjmp((buf),(retval)) #else #define Sigjmp_buf jmp_buf #define Sigsetjmp(buf,save_mask) setjmp((buf)) #define Siglongjmp(buf,retval) longjmp((buf),(retval)) #endif /* USE_STDIO_PTR: * This symbol is defined if the _ptr and _cnt fields (or similar) * of the stdio FILE structure can be used to access the stdio buffer * for a file handle. If this is defined, then the FILE_ptr(fp) * and FILE_cnt(fp) macros will also be defined and should be used * to access these fields. */ /* FILE_ptr: * This macro is used to access the _ptr field (or equivalent) of the * FILE structure pointed to by its argument. This macro will always be * defined if USE_STDIO_PTR is defined. */ /* STDIO_PTR_LVALUE: * This symbol is defined if the FILE_ptr macro can be used as an * lvalue. */ /* FILE_cnt: * This macro is used to access the _cnt field (or equivalent) of the * FILE structure pointed to by its argument. This macro will always be * defined if USE_STDIO_PTR is defined. */ /* STDIO_CNT_LVALUE: * This symbol is defined if the FILE_cnt macro can be used as an * lvalue. */ /* STDIO_PTR_LVAL_SETS_CNT: * This symbol is defined if using the FILE_ptr macro as an lvalue * to increase the pointer by n has the side effect of decreasing the * value of File_cnt(fp) by n. */ /* STDIO_PTR_LVAL_NOCHANGE_CNT: * This symbol is defined if using the FILE_ptr macro as an lvalue * to increase the pointer by n leaves File_cnt(fp) unchanged. */ #define USE_STDIO_PTR /**/ #ifdef USE_STDIO_PTR #define FILE_ptr(fp) ((fp)->_ptr) #define STDIO_PTR_LVALUE /**/ #define FILE_cnt(fp) ((fp)->_cnt) #define STDIO_CNT_LVALUE /**/ /*#define STDIO_PTR_LVAL_SETS_CNT / **/ #define STDIO_PTR_LVAL_NOCHANGE_CNT /**/ #endif /* USE_STDIO_BASE: * This symbol is defined if the _base field (or similar) of the * stdio FILE structure can be used to access the stdio buffer for * a file handle. If this is defined, then the FILE_base(fp) macro * will also be defined and should be used to access this field. * Also, the FILE_bufsiz(fp) macro will be defined and should be used * to determine the number of bytes in the buffer. USE_STDIO_BASE * will never be defined unless USE_STDIO_PTR is. */ /* FILE_base: * This macro is used to access the _base field (or equivalent) of the * FILE structure pointed to by its argument. This macro will always be * defined if USE_STDIO_BASE is defined. */ /* FILE_bufsiz: * This macro is used to determine the number of bytes in the I/O * buffer pointed to by _base field (or equivalent) of the FILE * structure pointed to its argument. This macro will always be defined * if USE_STDIO_BASE is defined. */ #define USE_STDIO_BASE /**/ #ifdef USE_STDIO_BASE #define FILE_base(fp) ((fp)->_base) #define FILE_bufsiz(fp) ((fp)->_cnt + (fp)->_ptr - (fp)->_base) #endif /* HAS_VPRINTF: * This symbol, if defined, indicates that the vprintf routine is available * to printf with a pointer to an argument list. If unavailable, you * may need to write your own, probably in terms of _doprnt(). */ /* USE_CHAR_VSPRINTF: * This symbol is defined if this system has vsprintf() returning type * (char*). The trend seems to be to declare it as "int vsprintf()". It * is up to the package author to declare vsprintf correctly based on the * symbol. */ #define HAS_VPRINTF /**/ /*#define USE_CHAR_VSPRINTF / **/ /* DOUBLESIZE: * This symbol contains the size of a double, so that the C preprocessor * can make decisions based on it. */ #define DOUBLESIZE 8 /**/ /* I_TIME: * This symbol, if defined, indicates to the C program that it should * include . */ /* I_SYS_TIME: * This symbol, if defined, indicates to the C program that it should * include . */ /* I_SYS_TIME_KERNEL: * This symbol, if defined, indicates to the C program that it should * include with KERNEL defined. */ /* HAS_TM_TM_ZONE: * This symbol, if defined, indicates to the C program that * the struct tm has a tm_zone field. */ /* HAS_TM_TM_GMTOFF: * This symbol, if defined, indicates to the C program that * the struct tm has a tm_gmtoff field. */ #define I_TIME /**/ /*#define I_SYS_TIME / **/ /*#define I_SYS_TIME_KERNEL / **/ /*#define HAS_TM_TM_ZONE / **/ /*#define HAS_TM_TM_GMTOFF / **/ /* VAL_O_NONBLOCK: * This symbol is to be used during open() or fcntl(F_SETFL) to turn on * non-blocking I/O for the file descriptor. Note that there is no way * back, i.e. you cannot turn it blocking again this way. If you wish to * alternatively switch between blocking and non-blocking, use the * ioctl(FIOSNBIO) call instead, but that is not supported by all devices. */ /* VAL_EAGAIN: * This symbol holds the errno error code set by read() when no data was * present on the non-blocking file descriptor. */ /* RD_NODATA: * This symbol holds the return code from read() when no data is present * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is * not defined, then you can't distinguish between no data and EOF by * issuing a read(). You'll have to find another way to tell for sure! */ /* EOF_NONBLOCK: * This symbol, if defined, indicates to the C program that a read() on * a non-blocking file descriptor will return 0 on EOF, and not the value * held in RD_NODATA (-1 usually, in that case!). */ #define VAL_O_NONBLOCK O_NONBLOCK #define VAL_EAGAIN EAGAIN #define RD_NODATA -1 #define EOF_NONBLOCK /* PTRSIZE: * This symbol contains the size of a pointer, so that the C preprocessor * can make decisions based on it. It will be sizeof(void *) if * the compiler supports (void *); otherwise it will be * sizeof(char *). */ #define PTRSIZE 4 /**/ /* Drand01: * This macro is to be used to generate uniformly distributed * random numbers over the range [0., 1.[. You may have to supply * an 'extern double drand48();' in your program since SunOS 4.1.3 * doesn't provide you with anything relevant in its headers. * See HAS_DRAND48_PROTO. */ /* Rand_seed_t: * This symbol defines the type of the argument of the * random seed function. */ /* seedDrand01: * This symbol defines the macro to be used in seeding the * random number generator (see Drand01). */ /* RANDBITS: * This symbol indicates how many bits are produced by the * function used to generate normalized random numbers. * Values include 15, 16, 31, and 48. */ #define Drand01() (rand()/(double)((unsigned)1< or * to get any typedef'ed information. * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t). */ #define SSize_t int /* signed count of bytes */ /* EBCDIC: * This symbol, if defined, indicates that this system uses * EBCDIC encoding. */ /*#define EBCDIC / **/ /* SETUID_SCRIPTS_ARE_SECURE_NOW: * This symbol, if defined, indicates that the bug that prevents * setuid scripts from being secure is not present in this kernel. */ /* DOSUID: * This symbol, if defined, indicates that the C program should * check the script that it is executing for setuid/setgid bits, and * attempt to emulate setuid/setgid on systems that have disabled * setuid #! scripts because the kernel can't do it securely. * It is up to the package designer to make sure that this emulation * is done securely. Among other things, it should do an fstat on * the script it just opened to make sure it really is a setuid/setgid * script, it should make sure the arguments passed correspond exactly * to the argument on the #! line, and it should not trust any * subprocesses to which it must pass the filename rather than the * file descriptor of the script to be executed. */ /*#define SETUID_SCRIPTS_ARE_SECURE_NOW / **/ /*#define DOSUID / **/ /* PERL_USE_DEVEL: * This symbol, if defined, indicates that Perl was configured with * -Dusedevel, to enable development features. This should not be * done for production builds. */ /*#define PERL_USE_DEVEL / **/ /* HAS_ATOLF: * This symbol, if defined, indicates that the atolf routine is * available to convert strings into long doubles. */ /*#define HAS_ATOLF / **/ /* HAS_ATOLL: * This symbol, if defined, indicates that the atoll routine is * available to convert strings into long longs. */ /*#define HAS_ATOLL / **/ /* HAS__FWALK: * This symbol, if defined, indicates that the _fwalk system call is * available to apply a function to all the file handles. */ /*#define HAS__FWALK / **/ /* HAS_AINTL: * This symbol, if defined, indicates that the aintl routine is * available. If copysignl is also present we can emulate modfl. */ /*#define HAS_AINTL / **/ /* HAS_BUILTIN_CHOOSE_EXPR: * Can we handle GCC builtin for compile-time ternary-like expressions */ /* HAS_BUILTIN_EXPECT: * Can we handle GCC builtin for telling that certain values are more * likely */ /*#define HAS_BUILTIN_EXPECT / **/ /*#define HAS_BUILTIN_CHOOSE_EXPR / **/ /* HAS_C99_VARIADIC_MACROS: * If defined, the compiler supports C99 variadic macros. */ /*#define HAS_C99_VARIADIC_MACROS / **/ /* HAS_CLASS: * This symbol, if defined, indicates that the class routine is * available to classify doubles. Available for example in AIX. * The returned values are defined in and are: * * FP_PLUS_NORM Positive normalized, nonzero * FP_MINUS_NORM Negative normalized, nonzero * FP_PLUS_DENORM Positive denormalized, nonzero * FP_MINUS_DENORM Negative denormalized, nonzero * FP_PLUS_ZERO +0.0 * FP_MINUS_ZERO -0.0 * FP_PLUS_INF +INF * FP_MINUS_INF -INF * FP_NANS Signaling Not a Number (NaNS) * FP_NANQ Quiet Not a Number (NaNQ) */ /*#define HAS_CLASS / **/ /* HAS_CLEARENV: * This symbol, if defined, indicates that the clearenv () routine is * available for use. */ /*#define HAS_CLEARENV / **/ /* HAS_STRUCT_CMSGHDR: * This symbol, if defined, indicates that the struct cmsghdr * is supported. */ /*#define HAS_STRUCT_CMSGHDR / **/ /* HAS_COPYSIGNL: * This symbol, if defined, indicates that the copysignl routine is * available. If aintl is also present we can emulate modfl. */ /*#define HAS_COPYSIGNL / **/ /* USE_CPLUSPLUS: * This symbol, if defined, indicates that a C++ compiler was * used to compiled Perl and will be used to compile extensions. */ /*#define USE_CPLUSPLUS / **/ /* HAS_DBMINIT_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the dbminit() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int dbminit(char *); */ /*#define HAS_DBMINIT_PROTO / **/ /* HAS_DIR_DD_FD: * This symbol, if defined, indicates that the the DIR* dirstream * structure contains a member variable named dd_fd. */ /*#define HAS_DIR_DD_FD / **/ /* HAS_DIRFD: * This manifest constant lets the C program know that dirfd * is available. */ /*#define HAS_DIRFD / **/ /* DLSYM_NEEDS_UNDERSCORE: * This symbol, if defined, indicates that we need to prepend an * underscore to the symbol name before calling dlsym(). This only * makes sense if you *have* dlsym, which we will presume is the * case if you're using dl_dlopen.xs. */ /*#define DLSYM_NEEDS_UNDERSCORE / **/ /* HAS_FAST_STDIO: * This symbol, if defined, indicates that the "fast stdio" * is available to manipulate the stdio buffers directly. */ #define HAS_FAST_STDIO /**/ /* HAS_FCHDIR: * This symbol, if defined, indicates that the fchdir routine is * available to change directory using a file descriptor. */ /*#define HAS_FCHDIR / **/ /* FCNTL_CAN_LOCK: * This symbol, if defined, indicates that fcntl() can be used * for file locking. Normally on Unix systems this is defined. * It may be undefined on VMS. */ /*#define FCNTL_CAN_LOCK / **/ /* HAS_FINITE: * This symbol, if defined, indicates that the finite routine is * available to check whether a double is finite (non-infinity non-NaN). */ /*#define HAS_FINITE / **/ /* HAS_FINITEL: * This symbol, if defined, indicates that the finitel routine is * available to check whether a long double is finite * (non-infinity non-NaN). */ /*#define HAS_FINITEL / **/ /* HAS_FLOCK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the flock() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int flock(int, int); */ #define HAS_FLOCK_PROTO /**/ /* HAS_FP_CLASS: * This symbol, if defined, indicates that the fp_class routine is * available to classify doubles. Available for example in Digital UNIX. * The returned values are defined in and are: * * FP_SNAN Signaling NaN (Not-a-Number) * FP_QNAN Quiet NaN (Not-a-Number) * FP_POS_INF +infinity * FP_NEG_INF -infinity * FP_POS_NORM Positive normalized * FP_NEG_NORM Negative normalized * FP_POS_DENORM Positive denormalized * FP_NEG_DENORM Negative denormalized * FP_POS_ZERO +0.0 (positive zero) * FP_NEG_ZERO -0.0 (negative zero) */ /*#define HAS_FP_CLASS / **/ /* HAS_FPCLASS: * This symbol, if defined, indicates that the fpclass routine is * available to classify doubles. Available for example in Solaris/SVR4. * The returned values are defined in and are: * * FP_SNAN signaling NaN * FP_QNAN quiet NaN * FP_NINF negative infinity * FP_PINF positive infinity * FP_NDENORM negative denormalized non-zero * FP_PDENORM positive denormalized non-zero * FP_NZERO negative zero * FP_PZERO positive zero * FP_NNORM negative normalized non-zero * FP_PNORM positive normalized non-zero */ /*#define HAS_FPCLASS / **/ /* HAS_FPCLASSIFY: * This symbol, if defined, indicates that the fpclassify routine is * available to classify doubles. Available for example in HP-UX. * The returned values are defined in and are * * FP_NORMAL Normalized * FP_ZERO Zero * FP_INFINITE Infinity * FP_SUBNORMAL Denormalized * FP_NAN NaN * */ /*#define HAS_FPCLASSIFY / **/ /* HAS_FPCLASSL: * This symbol, if defined, indicates that the fpclassl routine is * available to classify long doubles. Available for example in IRIX. * The returned values are defined in and are: * * FP_SNAN signaling NaN * FP_QNAN quiet NaN * FP_NINF negative infinity * FP_PINF positive infinity * FP_NDENORM negative denormalized non-zero * FP_PDENORM positive denormalized non-zero * FP_NZERO negative zero * FP_PZERO positive zero * FP_NNORM negative normalized non-zero * FP_PNORM positive normalized non-zero */ /*#define HAS_FPCLASSL / **/ /* HAS_FPOS64_T: * This symbol will be defined if the C compiler supports fpos64_t. */ /*#define HAS_FPOS64_T / **/ /* HAS_FREXPL: * This symbol, if defined, indicates that the frexpl routine is * available to break a long double floating-point number into * a normalized fraction and an integral power of 2. */ /*#define HAS_FREXPL / **/ /* HAS_STRUCT_FS_DATA: * This symbol, if defined, indicates that the struct fs_data * to do statfs() is supported. */ /*#define HAS_STRUCT_FS_DATA / **/ /* HAS_FSEEKO: * This symbol, if defined, indicates that the fseeko routine is * available to fseek beyond 32 bits (useful for ILP32 hosts). */ /*#define HAS_FSEEKO / **/ /* HAS_FSTATFS: * This symbol, if defined, indicates that the fstatfs routine is * available to stat filesystems by file descriptors. */ /*#define HAS_FSTATFS / **/ /* HAS_FSYNC: * This symbol, if defined, indicates that the fsync routine is * available to write a file's modified data and attributes to * permanent storage. */ /*#define HAS_FSYNC / **/ /* HAS_FTELLO: * This symbol, if defined, indicates that the ftello routine is * available to ftell beyond 32 bits (useful for ILP32 hosts). */ /*#define HAS_FTELLO / **/ /* HAS_FUTIMES: * This symbol, if defined, indicates that the futimes routine is * available to change file descriptor time stamps with struct timevals. */ /*#define HAS_FUTIMES / **/ /* HAS_GETADDRINFO: * This symbol, if defined, indicates that the getaddrinfo() function * is available for use. */ /*#define HAS_GETADDRINFO / **/ /* HAS_GETCWD: * This symbol, if defined, indicates that the getcwd routine is * available to get the current working directory. */ #define HAS_GETCWD /**/ /* HAS_GETESPWNAM: * This symbol, if defined, indicates that the getespwnam system call is * available to retrieve enchanced (shadow) password entries by name. */ /*#define HAS_GETESPWNAM / **/ /* HAS_GETFSSTAT: * This symbol, if defined, indicates that the getfsstat routine is * available to stat filesystems in bulk. */ /*#define HAS_GETFSSTAT / **/ /* HAS_GETITIMER: * This symbol, if defined, indicates that the getitimer routine is * available to return interval timers. */ /*#define HAS_GETITIMER / **/ /* HAS_GETMNT: * This symbol, if defined, indicates that the getmnt routine is * available to get filesystem mount info by filename. */ /*#define HAS_GETMNT / **/ /* HAS_GETMNTENT: * This symbol, if defined, indicates that the getmntent routine is * available to iterate through mounted file systems to get their info. */ /*#define HAS_GETMNTENT / **/ /* HAS_GETNAMEINFO: * This symbol, if defined, indicates that the getnameinfo() function * is available for use. */ /*#define HAS_GETNAMEINFO / **/ /* HAS_GETPRPWNAM: * This symbol, if defined, indicates that the getprpwnam system call is * available to retrieve protected (shadow) password entries by name. */ /*#define HAS_GETPRPWNAM / **/ /* HAS_GETSPNAM: * This symbol, if defined, indicates that the getspnam system call is * available to retrieve SysV shadow password entries by name. */ /*#define HAS_GETSPNAM / **/ /* HAS_HASMNTOPT: * This symbol, if defined, indicates that the hasmntopt routine is * available to query the mount options of file systems. */ /*#define HAS_HASMNTOPT / **/ /* HAS_ILOGBL: * This symbol, if defined, indicates that the ilogbl routine is * available. If scalbnl is also present we can emulate frexpl. */ /*#define HAS_ILOGBL / **/ /* HAS_INETNTOP: * This symbol, if defined, indicates that the inet_ntop() function * is available to parse IPv4 and IPv6 strings. */ /*#define HAS_INETNTOP / **/ /* HAS_INETPTON: * This symbol, if defined, indicates that the inet_pton() function * is available to parse IPv4 and IPv6 strings. */ /*#define HAS_INETPTON / **/ /* HAS_INT64_T: * This symbol will defined if the C compiler supports int64_t. * Usually the needs to be included, but sometimes * is enough. */ /*#define HAS_INT64_T / **/ /* HAS_ISFINITE: * This symbol, if defined, indicates that the isfinite routine is * available to check whether a double is finite (non-infinity non-NaN). */ /*#define HAS_ISFINITE / **/ /* HAS_ISINF: * This symbol, if defined, indicates that the isinf routine is * available to check whether a double is an infinity. */ /*#define HAS_ISINF / **/ /* HAS_ISNAN: * This symbol, if defined, indicates that the isnan routine is * available to check whether a double is a NaN. */ #define HAS_ISNAN /**/ /* HAS_ISNANL: * This symbol, if defined, indicates that the isnanl routine is * available to check whether a long double is a NaN. */ /*#define HAS_ISNANL / **/ /* HAS_LDBL_DIG: * This symbol, if defined, indicates that this system's * or defines the symbol LDBL_DIG, which is the number * of significant digits in a long double precision number. Unlike * for DBL_DIG, there's no good guess for LDBL_DIG if it is undefined. */ #define HAS_LDBL_DIG /**/ /* LIBM_LIB_VERSION: * This symbol, if defined, indicates that libm exports _LIB_VERSION * and that math.h defines the enum to manipulate it. */ /*#define LIBM_LIB_VERSION / **/ /* HAS_MADVISE: * This symbol, if defined, indicates that the madvise system call is * available to map a file into memory. */ /*#define HAS_MADVISE / **/ /* HAS_MALLOC_SIZE: * This symbol, if defined, indicates that the malloc_size * routine is available for use. */ /*#define HAS_MALLOC_SIZE / **/ /* HAS_MALLOC_GOOD_SIZE: * This symbol, if defined, indicates that the malloc_good_size * routine is available for use. */ /*#define HAS_MALLOC_GOOD_SIZE / **/ /* HAS_MKDTEMP: * This symbol, if defined, indicates that the mkdtemp routine is * available to exclusively create a uniquely named temporary directory. */ /*#define HAS_MKDTEMP / **/ /* HAS_MKSTEMPS: * This symbol, if defined, indicates that the mkstemps routine is * available to excluslvely create and open a uniquely named * (with a suffix) temporary file. */ /*#define HAS_MKSTEMPS / **/ /* HAS_MODFL: * This symbol, if defined, indicates that the modfl routine is * available to split a long double x into a fractional part f and * an integer part i such that |f| < 1.0 and (f + i) = x. */ /* HAS_MODFL_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the modfl() function. Otherwise, it is up * to the program to supply one. */ /* HAS_MODFL_POW32_BUG: * This symbol, if defined, indicates that the modfl routine is * broken for long doubles >= pow(2, 32). * For example from 4294967303.150000 one would get 4294967302.000000 * and 1.150000. The bug has been seen in certain versions of glibc, * release 2.2.2 is known to be okay. */ /*#define HAS_MODFL / **/ /*#define HAS_MODFL_PROTO / **/ /*#define HAS_MODFL_POW32_BUG / **/ /* HAS_MPROTECT: * This symbol, if defined, indicates that the mprotect system call is * available to modify the access protection of a memory mapped file. */ /*#define HAS_MPROTECT / **/ /* HAS_STRUCT_MSGHDR: * This symbol, if defined, indicates that the struct msghdr * is supported. */ /*#define HAS_STRUCT_MSGHDR / **/ /* HAS_NL_LANGINFO: * This symbol, if defined, indicates that the nl_langinfo routine is * available to return local data. You will also need * and therefore I_LANGINFO. */ /*#define HAS_NL_LANGINFO / **/ /* HAS_OFF64_T: * This symbol will be defined if the C compiler supports off64_t. */ /*#define HAS_OFF64_T / **/ /* HAS_PROCSELFEXE: * This symbol is defined if PROCSELFEXE_PATH is a symlink * to the absolute pathname of the executing program. */ /* PROCSELFEXE_PATH: * If HAS_PROCSELFEXE is defined this symbol is the filename * of the symbolic link pointing to the absolute pathname of * the executing program. */ /*#define HAS_PROCSELFEXE / **/ #if defined(HAS_PROCSELFEXE) && !defined(PROCSELFEXE_PATH) #define PROCSELFEXE_PATH /**/ #endif /* HAS_PTHREAD_ATTR_SETSCOPE: * This symbol, if defined, indicates that the pthread_attr_setscope * system call is available to set the contention scope attribute of * a thread attribute object. */ /*#define HAS_PTHREAD_ATTR_SETSCOPE / **/ /* HAS_READV: * This symbol, if defined, indicates that the readv routine is * available to do gather reads. You will also need * and there I_SYSUIO. */ /*#define HAS_READV / **/ /* HAS_RECVMSG: * This symbol, if defined, indicates that the recvmsg routine is * available to send structured socket messages. */ /*#define HAS_RECVMSG / **/ /* HAS_SBRK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the sbrk() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern void* sbrk(int); * extern void* sbrk(size_t); */ /*#define HAS_SBRK_PROTO / **/ /* HAS_SCALBNL: * This symbol, if defined, indicates that the scalbnl routine is * available. If ilogbl is also present we can emulate frexpl. */ /*#define HAS_SCALBNL / **/ /* HAS_SENDMSG: * This symbol, if defined, indicates that the sendmsg routine is * available to send structured socket messages. */ /*#define HAS_SENDMSG / **/ /* HAS_SETITIMER: * This symbol, if defined, indicates that the setitimer routine is * available to set interval timers. */ /*#define HAS_SETITIMER / **/ /* HAS_SETPROCTITLE: * This symbol, if defined, indicates that the setproctitle routine is * available to set process title. */ /*#define HAS_SETPROCTITLE / **/ /* USE_SFIO: * This symbol, if defined, indicates that sfio should * be used. */ /*#define USE_SFIO / **/ /* HAS_SIGNBIT: * This symbol, if defined, indicates that the signbit routine is * available to check if the given number has the sign bit set. * This should include correct testing of -0.0. This will only be set * if the signbit() routine is safe to use with the NV type used internally * in perl. Users should call Perl_signbit(), which will be #defined to * the system's signbit() function or macro if this symbol is defined. */ /*#define HAS_SIGNBIT / **/ /* HAS_SIGPROCMASK: * This symbol, if defined, indicates that the sigprocmask * system call is available to examine or change the signal mask * of the calling process. */ /*#define HAS_SIGPROCMASK / **/ /* USE_SITECUSTOMIZE: * This symbol, if defined, indicates that sitecustomize should * be used. */ #ifndef USE_SITECUSTOMIZE /*#define USE_SITECUSTOMIZE / **/ #endif /* HAS_SNPRINTF: * This symbol, if defined, indicates that the snprintf () library * function is available for use. */ /* HAS_VSNPRINTF: * This symbol, if defined, indicates that the vsnprintf () library * function is available for use. */ #define HAS_SNPRINTF /**/ #define HAS_VSNPRINTF /**/ /* HAS_SOCKATMARK: * This symbol, if defined, indicates that the sockatmark routine is * available to test whether a socket is at the out-of-band mark. */ /*#define HAS_SOCKATMARK / **/ /* HAS_SOCKATMARK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the sockatmark() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int sockatmark(int); */ /*#define HAS_SOCKATMARK_PROTO / **/ /* HAS_SOCKS5_INIT: * This symbol, if defined, indicates that the socks5_init routine is * available to initialize SOCKS 5. */ /*#define HAS_SOCKS5_INIT / **/ /* SPRINTF_RETURNS_STRLEN: * This variable defines whether sprintf returns the length of the string * (as per the ANSI spec). Some C libraries retain compatibility with * pre-ANSI C and return a pointer to the passed in buffer; for these * this variable will be undef. */ #define SPRINTF_RETURNS_STRLEN /**/ /* HAS_SQRTL: * This symbol, if defined, indicates that the sqrtl routine is * available to do long double square roots. */ /*#define HAS_SQRTL / **/ /* HAS_SETRESGID_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the setresgid() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern int setresgid(uid_t ruid, uid_t euid, uid_t suid); */ /*#define HAS_SETRESGID_PROTO / **/ /* HAS_SETRESUID_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the setresuid() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern int setresuid(uid_t ruid, uid_t euid, uid_t suid); */ /*#define HAS_SETRESUID_PROTO / **/ /* HAS_STRUCT_STATFS_F_FLAGS: * This symbol, if defined, indicates that the struct statfs * does have the f_flags member containing the mount flags of * the filesystem containing the file. * This kind of struct statfs is coming from (BSD 4.3), * not from (SYSV). Older BSDs (like Ultrix) do not * have statfs() and struct statfs, they have ustat() and getmnt() * with struct ustat and struct fs_data. */ /*#define HAS_STRUCT_STATFS_F_FLAGS / **/ /* HAS_STRUCT_STATFS: * This symbol, if defined, indicates that the struct statfs * to do statfs() is supported. */ /*#define HAS_STRUCT_STATFS / **/ /* HAS_FSTATVFS: * This symbol, if defined, indicates that the fstatvfs routine is * available to stat filesystems by file descriptors. */ /*#define HAS_FSTATVFS / **/ /* HAS_STRFTIME: * This symbol, if defined, indicates that the strftime routine is * available to do time formatting. */ #define HAS_STRFTIME /**/ /* HAS_STRLCAT: * This symbol, if defined, indicates that the strlcat () routine is * available to do string concatenation. */ /*#define HAS_STRLCAT / **/ /* HAS_STRLCPY: * This symbol, if defined, indicates that the strlcpy () routine is * available to do string copying. */ /*#define HAS_STRLCPY / **/ /* HAS_STRTOLD: * This symbol, if defined, indicates that the strtold routine is * available to convert strings to long doubles. */ /*#define HAS_STRTOLD / **/ /* HAS_STRTOLL: * This symbol, if defined, indicates that the strtoll routine is * available to convert strings to long longs. */ /*#define HAS_STRTOLL / **/ /* HAS_STRTOQ: * This symbol, if defined, indicates that the strtoq routine is * available to convert strings to long longs (quads). */ /*#define HAS_STRTOQ / **/ /* HAS_STRTOULL: * This symbol, if defined, indicates that the strtoull routine is * available to convert strings to unsigned long longs. */ /*#define HAS_STRTOULL / **/ /* HAS_STRTOUQ: * This symbol, if defined, indicates that the strtouq routine is * available to convert strings to unsigned long longs (quads). */ /*#define HAS_STRTOUQ / **/ /* HAS_SYSCALL_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the syscall() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern int syscall(int, ...); * extern int syscall(long, ...); */ /*#define HAS_SYSCALL_PROTO / **/ /* HAS_TELLDIR_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the telldir() function. Otherwise, it is up * to the program to supply one. A good guess is * extern long telldir(DIR*); */ #define HAS_TELLDIR_PROTO /**/ /* HAS_CTIME64: * This symbol, if defined, indicates that the ctime64 () routine is * available to do the 64bit variant of ctime () */ /* HAS_LOCALTIME64: * This symbol, if defined, indicates that the localtime64 () routine is * available to do the 64bit variant of localtime () */ /* HAS_GMTIME64: * This symbol, if defined, indicates that the gmtime64 () routine is * available to do the 64bit variant of gmtime () */ /* HAS_MKTIME64: * This symbol, if defined, indicates that the mktime64 () routine is * available to do the 64bit variant of mktime () */ /* HAS_DIFFTIME64: * This symbol, if defined, indicates that the difftime64 () routine is * available to do the 64bit variant of difftime () */ /* HAS_ASCTIME64: * This symbol, if defined, indicates that the asctime64 () routine is * available to do the 64bit variant of asctime () */ /*#define HAS_CTIME64 / **/ /*#define HAS_LOCALTIME64 / **/ /*#define HAS_GMTIME64 / **/ /*#define HAS_MKTIME64 / **/ /*#define HAS_DIFFTIME64 / **/ /*#define HAS_ASCTIME64 / **/ /* HAS_TIMEGM: * This symbol, if defined, indicates that the timegm routine is * available to do the opposite of gmtime () */ /*#define HAS_TIMEGM / **/ /* U32_ALIGNMENT_REQUIRED: * This symbol, if defined, indicates that you must access * character data through U32-aligned pointers. */ #ifndef U32_ALIGNMENT_REQUIRED #define U32_ALIGNMENT_REQUIRED /**/ #endif /* HAS_UALARM: * This symbol, if defined, indicates that the ualarm routine is * available to do alarms with microsecond granularity. */ /*#define HAS_UALARM / **/ /* HAS_UNORDERED: * This symbol, if defined, indicates that the unordered routine is * available to check whether two doubles are unordered * (effectively: whether either of them is NaN) */ /*#define HAS_UNORDERED / **/ /* HAS_UNSETENV: * This symbol, if defined, indicates that the unsetenv () routine is * available for use. */ /*#define HAS_UNSETENV / **/ /* HAS_USLEEP_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the usleep() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int usleep(useconds_t); */ /*#define HAS_USLEEP_PROTO / **/ /* HAS_USTAT: * This symbol, if defined, indicates that the ustat system call is * available to query file system statistics by dev_t. */ /*#define HAS_USTAT / **/ /* HAS_WRITEV: * This symbol, if defined, indicates that the writev routine is * available to do scatter writes. */ /*#define HAS_WRITEV / **/ /* USE_DYNAMIC_LOADING: * This symbol, if defined, indicates that dynamic loading of * some sort is available. */ #define USE_DYNAMIC_LOADING /**/ /* FFLUSH_NULL: * This symbol, if defined, tells that fflush(NULL) does flush * all pending stdio output. */ /* FFLUSH_ALL: * This symbol, if defined, tells that to flush * all pending stdio output one must loop through all * the stdio file handles stored in an array and fflush them. * Note that if fflushNULL is defined, fflushall will not * even be probed for and will be left undefined. */ #define FFLUSH_NULL /**/ /*#define FFLUSH_ALL / **/ /* I_ASSERT: * This symbol, if defined, indicates that exists and * could be included by the C program to get the assert() macro. */ #define I_ASSERT /**/ /* I_CRYPT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_CRYPT / **/ /* DB_Prefix_t: * This symbol contains the type of the prefix structure element * in the header file. In older versions of DB, it was * int, while in newer ones it is u_int32_t. */ /* DB_Hash_t: * This symbol contains the type of the prefix structure element * in the header file. In older versions of DB, it was * int, while in newer ones it is size_t. */ /* DB_VERSION_MAJOR_CFG: * This symbol, if defined, defines the major version number of * Berkeley DB found in the header when Perl was configured. */ /* DB_VERSION_MINOR_CFG: * This symbol, if defined, defines the minor version number of * Berkeley DB found in the header when Perl was configured. * For DB version 1 this is always 0. */ /* DB_VERSION_PATCH_CFG: * This symbol, if defined, defines the patch version number of * Berkeley DB found in the header when Perl was configured. * For DB version 1 this is always 0. */ #define DB_Hash_t int /**/ #define DB_Prefix_t int /**/ #define DB_VERSION_MAJOR_CFG 0 /**/ #define DB_VERSION_MINOR_CFG 0 /**/ #define DB_VERSION_PATCH_CFG 0 /**/ /* I_FP: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_FP / **/ /* I_FP_CLASS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_FP_CLASS / **/ /* I_IEEEFP: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_IEEEFP / **/ /* I_INTTYPES: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_INTTYPES / **/ /* I_LANGINFO: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_LANGINFO / **/ /* I_LIBUTIL: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_LIBUTIL / **/ /* I_MALLOCMALLOC: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_MALLOCMALLOC / **/ /* I_MNTENT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_MNTENT / **/ /* I_NETINET_TCP: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_NETINET_TCP / **/ /* I_POLL: * This symbol, if defined, indicates that exists and * should be included. (see also HAS_POLL) */ /*#define I_POLL / **/ /* I_PROT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_PROT / **/ /* I_SHADOW: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SHADOW / **/ /* I_SOCKS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SOCKS / **/ /* I_SUNMATH: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SUNMATH / **/ /* I_SYSLOG: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSLOG / **/ /* I_SYSMODE: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSMODE / **/ /* I_SYS_MOUNT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYS_MOUNT / **/ /* I_SYS_STATFS: * This symbol, if defined, indicates that exists. */ /*#define I_SYS_STATFS / **/ /* I_SYS_STATVFS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYS_STATVFS / **/ /* I_SYSUTSNAME: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSUTSNAME / **/ /* I_SYS_VFS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYS_VFS / **/ /* I_USTAT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_USTAT / **/ /* PERL_PRIfldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'f') for output. */ /* PERL_PRIgldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'g') for output. */ /* PERL_PRIeldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'e') for output. */ /* PERL_SCNfldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'f') for input. */ /*#define PERL_PRIfldbl "f" / **/ /*#define PERL_PRIgldbl "g" / **/ /*#define PERL_PRIeldbl "e" / **/ /*#define PERL_SCNfldbl "f" / **/ /* PERL_MAD: * This symbol, if defined, indicates that the Misc Attribution * Declaration code should be conditionally compiled. */ /*#define PERL_MAD / **/ /* NEED_VA_COPY: * This symbol, if defined, indicates that the system stores * the variable argument list datatype, va_list, in a format * that cannot be copied by simple assignment, so that some * other means must be used when copying is required. * As such systems vary in their provision (or non-provision) * of copying mechanisms, handy.h defines a platform- * independent macro, Perl_va_copy(src, dst), to do the job. */ /*#define NEED_VA_COPY / **/ /* IVTYPE: * This symbol defines the C type used for Perl's IV. */ /* UVTYPE: * This symbol defines the C type used for Perl's UV. */ /* I8TYPE: * This symbol defines the C type used for Perl's I8. */ /* U8TYPE: * This symbol defines the C type used for Perl's U8. */ /* I16TYPE: * This symbol defines the C type used for Perl's I16. */ /* U16TYPE: * This symbol defines the C type used for Perl's U16. */ /* I32TYPE: * This symbol defines the C type used for Perl's I32. */ /* U32TYPE: * This symbol defines the C type used for Perl's U32. */ /* I64TYPE: * This symbol defines the C type used for Perl's I64. */ /* U64TYPE: * This symbol defines the C type used for Perl's U64. */ /* NVTYPE: * This symbol defines the C type used for Perl's NV. */ /* IVSIZE: * This symbol contains the sizeof(IV). */ /* UVSIZE: * This symbol contains the sizeof(UV). */ /* I8SIZE: * This symbol contains the sizeof(I8). */ /* U8SIZE: * This symbol contains the sizeof(U8). */ /* I16SIZE: * This symbol contains the sizeof(I16). */ /* U16SIZE: * This symbol contains the sizeof(U16). */ /* I32SIZE: * This symbol contains the sizeof(I32). */ /* U32SIZE: * This symbol contains the sizeof(U32). */ /* I64SIZE: * This symbol contains the sizeof(I64). */ /* U64SIZE: * This symbol contains the sizeof(U64). */ /* NVSIZE: * This symbol contains the sizeof(NV). */ /* NV_PRESERVES_UV: * This symbol, if defined, indicates that a variable of type NVTYPE * can preserve all the bits of a variable of type UVTYPE. */ /* NV_PRESERVES_UV_BITS: * This symbol contains the number of bits a variable of type NVTYPE * can preserve of a variable of type UVTYPE. */ /* NV_OVERFLOWS_INTEGERS_AT: * This symbol gives the largest integer value that NVs can hold. This * value + 1.0 cannot be stored accurately. It is expressed as constant * floating point expression to reduce the chance of decimale/binary * conversion issues. If it can not be determined, the value 0 is given. */ /* NV_ZERO_IS_ALLBITS_ZERO: * This symbol, if defined, indicates that a variable of type NVTYPE * stores 0.0 in memory as all bits zero. */ #define IVTYPE long /**/ #define UVTYPE unsigned long /**/ #define I8TYPE char /**/ #define U8TYPE unsigned char /**/ #define I16TYPE short /**/ #define U16TYPE unsigned short /**/ #define I32TYPE long /**/ #define U32TYPE unsigned long /**/ #ifdef HAS_QUAD # ifndef __GNUC__ # define I64TYPE __int64 /**/ # define U64TYPE unsigned __int64 /**/ # else # define I64TYPE long long /**/ # define U64TYPE unsigned long long /**/ # endif #endif #define NVTYPE double /**/ #define IVSIZE 4 /**/ #define UVSIZE 4 /**/ #define I8SIZE 1 /**/ #define U8SIZE 1 /**/ #define I16SIZE 2 /**/ #define U16SIZE 2 /**/ #define I32SIZE 4 /**/ #define U32SIZE 4 /**/ #ifdef HAS_QUAD #define I64SIZE 8 /**/ #define U64SIZE 8 /**/ #endif #define NVSIZE 8 /**/ #define NV_PRESERVES_UV #define NV_PRESERVES_UV_BITS 32 #define NV_OVERFLOWS_INTEGERS_AT 256.0*256.0*256.0*256.0*256.0*256.0*2.0*2.0*2.0*2.0*2.0 #define NV_ZERO_IS_ALLBITS_ZERO #if UVSIZE == 8 # ifdef BYTEORDER # if BYTEORDER == 0x1234 # undef BYTEORDER # define BYTEORDER 0x12345678 # else # if BYTEORDER == 0x4321 # undef BYTEORDER # define BYTEORDER 0x87654321 # endif # endif # endif #endif /* IVdf: * This symbol defines the format string used for printing a Perl IV * as a signed decimal integer. */ /* UVuf: * This symbol defines the format string used for printing a Perl UV * as an unsigned decimal integer. */ /* UVof: * This symbol defines the format string used for printing a Perl UV * as an unsigned octal integer. */ /* UVxf: * This symbol defines the format string used for printing a Perl UV * as an unsigned hexadecimal integer in lowercase abcdef. */ /* UVXf: * This symbol defines the format string used for printing a Perl UV * as an unsigned hexadecimal integer in uppercase ABCDEF. */ /* NVef: * This symbol defines the format string used for printing a Perl NV * using %e-ish floating point format. */ /* NVff: * This symbol defines the format string used for printing a Perl NV * using %f-ish floating point format. */ /* NVgf: * This symbol defines the format string used for printing a Perl NV * using %g-ish floating point format. */ #define IVdf "ld" /**/ #define UVuf "lu" /**/ #define UVof "lo" /**/ #define UVxf "lx" /**/ #define UVXf "lX" /**/ #define NVef "e" /**/ #define NVff "f" /**/ #define NVgf "g" /**/ /* SELECT_MIN_BITS: * This symbol holds the minimum number of bits operated by select. * That is, if you do select(n, ...), how many bits at least will be * cleared in the masks if some activity is detected. Usually this * is either n or 32*ceil(n/32), especially many little-endians do * the latter. This is only useful if you have select(), naturally. */ #define SELECT_MIN_BITS 32 /**/ /* STARTPERL: * This variable contains the string to put in front of a perl * script to make sure (one hopes) that it runs with perl and not * some shell. */ #define STARTPERL "#!perl" /**/ /* HAS_STDIO_STREAM_ARRAY: * This symbol, if defined, tells that there is an array * holding the stdio streams. */ /* STDIO_STREAM_ARRAY: * This symbol tells the name of the array holding the stdio streams. * Usual values include _iob, __iob, and __sF. */ /*#define HAS_STDIO_STREAM_ARRAY / **/ #ifdef HAS_STDIO_STREAM_ARRAY #define STDIO_STREAM_ARRAY #endif /* GMTIME_MAX: * This symbol contains the maximum value for the time_t offset that * the system function gmtime () accepts, and defaults to 0 */ /* GMTIME_MIN: * This symbol contains the minimum value for the time_t offset that * the system function gmtime () accepts, and defaults to 0 */ /* LOCALTIME_MAX: * This symbol contains the maximum value for the time_t offset that * the system function localtime () accepts, and defaults to 0 */ /* LOCALTIME_MIN: * This symbol contains the minimum value for the time_t offset that * the system function localtime () accepts, and defaults to 0 */ #define GMTIME_MAX 2147483647 /**/ #define GMTIME_MIN 0 /**/ #define LOCALTIME_MAX 2147483647 /**/ #define LOCALTIME_MIN 0 /**/ /* USE_64_BIT_INT: * This symbol, if defined, indicates that 64-bit integers should * be used when available. If not defined, the native integers * will be employed (be they 32 or 64 bits). The minimal possible * 64-bitness is used, just enough to get 64-bit integers into Perl. * This may mean using for example "long longs", while your memory * may still be limited to 2 gigabytes. */ /* USE_64_BIT_ALL: * This symbol, if defined, indicates that 64-bit integers should * be used when available. If not defined, the native integers * will be used (be they 32 or 64 bits). The maximal possible * 64-bitness is employed: LP64 or ILP64, meaning that you will * be able to use more than 2 gigabytes of memory. This mode is * even more binary incompatible than USE_64_BIT_INT. You may not * be able to run the resulting executable in a 32-bit CPU at all or * you may need at least to reboot your OS to 64-bit mode. */ #ifndef USE_64_BIT_INT /*#define USE_64_BIT_INT / **/ #endif #ifndef USE_64_BIT_ALL /*#define USE_64_BIT_ALL / **/ #endif /* USE_DTRACE: * This symbol, if defined, indicates that Perl should * be built with support for DTrace. */ /*#define USE_DTRACE / **/ /* USE_FAST_STDIO: * This symbol, if defined, indicates that Perl should * be built to use 'fast stdio'. * Defaults to define in Perls 5.8 and earlier, to undef later. */ #ifndef USE_FAST_STDIO /*#define USE_FAST_STDIO / **/ #endif /* USE_LARGE_FILES: * This symbol, if defined, indicates that large file support * should be used when available. */ #ifndef USE_LARGE_FILES /*#define USE_LARGE_FILES / **/ #endif /* USE_LONG_DOUBLE: * This symbol, if defined, indicates that long doubles should * be used when available. */ #ifndef USE_LONG_DOUBLE /*#define USE_LONG_DOUBLE / **/ #endif /* USE_MORE_BITS: * This symbol, if defined, indicates that 64-bit interfaces and * long doubles should be used when available. */ #ifndef USE_MORE_BITS /*#define USE_MORE_BITS / **/ #endif /* MULTIPLICITY: * This symbol, if defined, indicates that Perl should * be built to use multiplicity. */ #ifndef MULTIPLICITY /*#define MULTIPLICITY / **/ #endif /* USE_PERLIO: * This symbol, if defined, indicates that the PerlIO abstraction should * be used throughout. If not defined, stdio should be * used in a fully backward compatible manner. */ #ifndef USE_PERLIO /*#define USE_PERLIO / **/ #endif /* USE_SOCKS: * This symbol, if defined, indicates that Perl should * be built to use socks. */ #ifndef USE_SOCKS /*#define USE_SOCKS / **/ #endif #endif perl-5.12.0-RC0/win32/config_H.ce0000444000175000017500000041337711325125742015135 0ustar jessejesse/* * This file was produced by running the config_h.SH script, which * gets its values from undef, which is generally produced by * running Configure. * * Feel free to modify any of this as the need arises. Note, however, * that running config_h.SH again will wipe out any changes you've made. * For a more permanent change edit undef and rerun config_h.SH. * * $Id: Config_h.U,v 3.0.1.5 1997/02/28 14:57:43 ram Exp $ */ /* * Package name : perl5 * Source directory : * Configuration time: Thu Nov 10 20:47:18 2005 * Configured by : vkon * Target system : */ #ifndef _config_h_ #define _config_h_ /* LOC_SED: * This symbol holds the complete pathname to the sed program. */ #define LOC_SED "" /**/ /* HAS_ALARM: * This symbol, if defined, indicates that the alarm routine is * available. */ /*#define HAS_ALARM /**/ /* HAS_BCMP: * This symbol is defined if the bcmp() routine is available to * compare blocks of memory. */ /*#define HAS_BCMP /**/ /* HAS_BCOPY: * This symbol is defined if the bcopy() routine is available to * copy blocks of memory. */ /*#define HAS_BCOPY /**/ /* HAS_BZERO: * This symbol is defined if the bzero() routine is available to * set a memory block to 0. */ /*#define HAS_BZERO /**/ /* HAS_CHOWN: * This symbol, if defined, indicates that the chown routine is * available. */ /*#define HAS_CHOWN /**/ /* HAS_CHROOT: * This symbol, if defined, indicates that the chroot routine is * available. */ /*#define HAS_CHROOT /**/ /* HAS_CHSIZE: * This symbol, if defined, indicates that the chsize routine is available * to truncate files. You might need a -lx to get this routine. */ #define HAS_CHSIZE /**/ /* HASCONST: * This symbol, if defined, indicates that this C compiler knows about * the const type. There is no need to actually test for that symbol * within your programs. The mere use of the "const" keyword will * trigger the necessary tests. */ #define HASCONST /**/ #ifndef HASCONST #define const #endif /* HAS_CUSERID: * This symbol, if defined, indicates that the cuserid routine is * available to get character login names. */ /*#define HAS_CUSERID /**/ /* HAS_DBL_DIG: * This symbol, if defined, indicates that this system's * or defines the symbol DBL_DIG, which is the number * of significant digits in a double precision number. If this * symbol is not defined, a guess of 15 is usually pretty good. */ #define HAS_DBL_DIG /**/ /* HAS_DIFFTIME: * This symbol, if defined, indicates that the difftime routine is * available. */ #define HAS_DIFFTIME /**/ /* HAS_DLERROR: * This symbol, if defined, indicates that the dlerror routine is * available to return a string describing the last error that * occurred from a call to dlopen(), dlclose() or dlsym(). */ #define HAS_DLERROR /**/ /* HAS_DUP2: * This symbol, if defined, indicates that the dup2 routine is * available to duplicate file descriptors. */ #define HAS_DUP2 /**/ /* HAS_FCHMOD: * This symbol, if defined, indicates that the fchmod routine is available * to change mode of opened files. If unavailable, use chmod(). */ /*#define HAS_FCHMOD /**/ /* HAS_FCHOWN: * This symbol, if defined, indicates that the fchown routine is available * to change ownership of opened files. If unavailable, use chown(). */ /*#define HAS_FCHOWN /**/ /* HAS_FCNTL: * This symbol, if defined, indicates to the C program that * the fcntl() function exists. */ /*#define HAS_FCNTL /**/ /* HAS_FGETPOS: * This symbol, if defined, indicates that the fgetpos routine is * available to get the file position indicator, similar to ftell(). */ #define HAS_FGETPOS /**/ /* HAS_FLOCK: * This symbol, if defined, indicates that the flock routine is * available to do file locking. */ /*#define HAS_FLOCK /**/ /* HAS_FORK: * This symbol, if defined, indicates that the fork routine is * available. */ /*#define HAS_FORK /**/ /* HAS_FSETPOS: * This symbol, if defined, indicates that the fsetpos routine is * available to set the file position indicator, similar to fseek(). */ #define HAS_FSETPOS /**/ /* HAS_GETTIMEOFDAY: * This symbol, if defined, indicates that the gettimeofday() system * call is available for a sub-second accuracy clock. Usually, the file * needs to be included (see I_SYS_RESOURCE). * The type "Timeval" should be used to refer to "struct timeval". */ /*#define HAS_GETTIMEOFDAY /**/ #ifdef HAS_GETTIMEOFDAY #define Timeval struct timeval /* Structure used by gettimeofday() */ #endif /* HAS_GETGROUPS: * This symbol, if defined, indicates that the getgroups() routine is * available to get the list of process groups. If unavailable, multiple * groups are probably not supported. */ /*#define HAS_GETGROUPS /**/ /* HAS_GETLOGIN: * This symbol, if defined, indicates that the getlogin routine is * available to get the login name. */ #define HAS_GETLOGIN /**/ /* HAS_GETPGID: * This symbol, if defined, indicates to the C program that * the getpgid(pid) function is available to get the * process group id. */ /*#define HAS_GETPGID /**/ /* HAS_GETPGRP2: * This symbol, if defined, indicates that the getpgrp2() (as in DG/UX) * routine is available to get the current process group. */ /*#define HAS_GETPGRP2 /**/ /* HAS_GETPPID: * This symbol, if defined, indicates that the getppid routine is * available to get the parent process ID. */ /*#define HAS_GETPPID /**/ /* HAS_GETPRIORITY: * This symbol, if defined, indicates that the getpriority routine is * available to get a process's priority. */ /*#define HAS_GETPRIORITY /**/ /* HAS_INET_ATON: * This symbol, if defined, indicates to the C program that the * inet_aton() function is available to parse IP address "dotted-quad" * strings. */ /*#define HAS_INET_ATON /**/ /* HAS_KILLPG: * This symbol, if defined, indicates that the killpg routine is available * to kill process groups. If unavailable, you probably should use kill * with a negative process number. */ /*#define HAS_KILLPG /**/ /* HAS_LINK: * This symbol, if defined, indicates that the link routine is * available to create hard links. */ #define HAS_LINK /**/ /* HAS_LOCALECONV: * This symbol, if defined, indicates that the localeconv routine is * available for numeric and monetary formatting conventions. */ #define HAS_LOCALECONV /**/ /* HAS_LOCKF: * This symbol, if defined, indicates that the lockf routine is * available to do file locking. */ /*#define HAS_LOCKF /**/ /* HAS_LSTAT: * This symbol, if defined, indicates that the lstat routine is * available to do file stats on symbolic links. */ /*#define HAS_LSTAT /**/ /* HAS_MBLEN: * This symbol, if defined, indicates that the mblen routine is available * to find the number of bytes in a multibye character. */ #define HAS_MBLEN /**/ /* HAS_MBSTOWCS: * This symbol, if defined, indicates that the mbstowcs routine is * available to covert a multibyte string into a wide character string. */ #define HAS_MBSTOWCS /**/ /* HAS_MBTOWC: * This symbol, if defined, indicates that the mbtowc routine is available * to covert a multibyte to a wide character. */ #define HAS_MBTOWC /**/ /* HAS_MEMCMP: * This symbol, if defined, indicates that the memcmp routine is available * to compare blocks of memory. */ #define HAS_MEMCMP /**/ /* HAS_MEMCPY: * This symbol, if defined, indicates that the memcpy routine is available * to copy blocks of memory. */ #define HAS_MEMCPY /**/ /* HAS_MEMMOVE: * This symbol, if defined, indicates that the memmove routine is available * to copy potentially overlapping blocks of memory. This should be used * only when HAS_SAFE_BCOPY is not defined. If neither is there, roll your * own version. */ #define HAS_MEMMOVE /**/ /* HAS_MEMSET: * This symbol, if defined, indicates that the memset routine is available * to set blocks of memory. */ #define HAS_MEMSET /**/ /* HAS_MKDIR: * This symbol, if defined, indicates that the mkdir routine is available * to create directories. Otherwise you should fork off a new process to * exec /bin/mkdir. */ #define HAS_MKDIR /**/ /* HAS_MKFIFO: * This symbol, if defined, indicates that the mkfifo routine is * available to create FIFOs. Otherwise, mknod should be able to * do it for you. However, if mkfifo is there, mknod might require * super-user privileges which mkfifo will not. */ /*#define HAS_MKFIFO /**/ /* HAS_MKTIME: * This symbol, if defined, indicates that the mktime routine is * available. */ #define HAS_MKTIME /**/ /* HAS_MSYNC: * This symbol, if defined, indicates that the msync system call is * available to synchronize a mapped file. */ /*#define HAS_MSYNC /**/ /* HAS_MUNMAP: * This symbol, if defined, indicates that the munmap system call is * available to unmap a region, usually mapped by mmap(). */ /*#define HAS_MUNMAP /**/ /* HAS_NICE: * This symbol, if defined, indicates that the nice routine is * available. */ /*#define HAS_NICE /**/ /* HAS_PATHCONF: * This symbol, if defined, indicates that pathconf() is available * to determine file-system related limits and options associated * with a given filename. */ /* HAS_FPATHCONF: * This symbol, if defined, indicates that pathconf() is available * to determine file-system related limits and options associated * with a given open file descriptor. */ /*#define HAS_PATHCONF /**/ /*#define HAS_FPATHCONF /**/ /* HAS_PAUSE: * This symbol, if defined, indicates that the pause routine is * available to suspend a process until a signal is received. */ #define HAS_PAUSE /**/ /* HAS_PIPE: * This symbol, if defined, indicates that the pipe routine is * available to create an inter-process channel. */ /*#define HAS_PIPE /**/ /* HAS_POLL: * This symbol, if defined, indicates that the poll routine is * available to poll active file descriptors. You may safely * include when this symbol is defined. */ /*#define HAS_POLL /**/ /* HAS_READDIR: * This symbol, if defined, indicates that the readdir routine is * available to read directory entries. You may have to include * . See I_DIRENT. */ #define HAS_READDIR /**/ /* HAS_SEEKDIR: * This symbol, if defined, indicates that the seekdir routine is * available. You may have to include . See I_DIRENT. */ #define HAS_SEEKDIR /**/ /* HAS_TELLDIR: * This symbol, if defined, indicates that the telldir routine is * available. You may have to include . See I_DIRENT. */ #define HAS_TELLDIR /**/ /* HAS_REWINDDIR: * This symbol, if defined, indicates that the rewinddir routine is * available. You may have to include . See I_DIRENT. */ #define HAS_REWINDDIR /**/ /* HAS_READLINK: * This symbol, if defined, indicates that the readlink routine is * available to read the value of a symbolic link. */ /*#define HAS_READLINK /**/ /* HAS_RENAME: * This symbol, if defined, indicates that the rename routine is available * to rename files. Otherwise you should do the unlink(), link(), unlink() * trick. */ #define HAS_RENAME /**/ /* HAS_RMDIR: * This symbol, if defined, indicates that the rmdir routine is * available to remove directories. Otherwise you should fork off a * new process to exec /bin/rmdir. */ #define HAS_RMDIR /**/ /* HAS_SELECT: * This symbol, if defined, indicates that the select routine is * available to select active file descriptors. If the timeout field * is used, may need to be included. */ #define HAS_SELECT /**/ /* HAS_SETEGID: * This symbol, if defined, indicates that the setegid routine is available * to change the effective gid of the current program. */ /*#define HAS_SETEGID /**/ /* HAS_SETEUID: * This symbol, if defined, indicates that the seteuid routine is available * to change the effective uid of the current program. */ /*#define HAS_SETEUID /**/ /* HAS_SETLINEBUF: * This symbol, if defined, indicates that the setlinebuf routine is * available to change stderr or stdout from block-buffered or unbuffered * to a line-buffered mode. */ /*#define HAS_SETLINEBUF /**/ /* HAS_SETLOCALE: * This symbol, if defined, indicates that the setlocale routine is * available to handle locale-specific ctype implementations. */ #define HAS_SETLOCALE /**/ /* HAS_SETPGID: * This symbol, if defined, indicates that the setpgid(pid, gpid) * routine is available to set process group ID. */ /*#define HAS_SETPGID /**/ /* HAS_SETPGRP2: * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX) * routine is available to set the current process group. */ /*#define HAS_SETPGRP2 /**/ /* HAS_SETPRIORITY: * This symbol, if defined, indicates that the setpriority routine is * available to set a process's priority. */ /*#define HAS_SETPRIORITY /**/ /* HAS_SETREGID: * This symbol, if defined, indicates that the setregid routine is * available to change the real and effective gid of the current * process. */ /* HAS_SETRESGID: * This symbol, if defined, indicates that the setresgid routine is * available to change the real, effective and saved gid of the current * process. */ /*#define HAS_SETREGID /**/ /*#define HAS_SETRESGID /**/ /* HAS_SETREUID: * This symbol, if defined, indicates that the setreuid routine is * available to change the real and effective uid of the current * process. */ /* HAS_SETRESUID: * This symbol, if defined, indicates that the setresuid routine is * available to change the real, effective and saved uid of the current * process. */ /*#define HAS_SETREUID /**/ /*#define HAS_SETRESUID /**/ /* HAS_SETRGID: * This symbol, if defined, indicates that the setrgid routine is available * to change the real gid of the current program. */ /*#define HAS_SETRGID /**/ /* HAS_SETRUID: * This symbol, if defined, indicates that the setruid routine is available * to change the real uid of the current program. */ /*#define HAS_SETRUID /**/ /* HAS_SETSID: * This symbol, if defined, indicates that the setsid routine is * available to set the process group ID. */ /*#define HAS_SETSID /**/ /* HAS_STRCHR: * This symbol is defined to indicate that the strchr()/strrchr() * functions are available for string searching. If not, try the * index()/rindex() pair. */ /* HAS_INDEX: * This symbol is defined to indicate that the index()/rindex() * functions are available for string searching. */ #define HAS_STRCHR /**/ /*#define HAS_INDEX /**/ /* HAS_STRCOLL: * This symbol, if defined, indicates that the strcoll routine is * available to compare strings using collating information. */ #define HAS_STRCOLL /**/ /* USE_STRUCT_COPY: * This symbol, if defined, indicates that this C compiler knows how * to copy structures. If undefined, you'll need to use a block copy * routine of some sort instead. */ #define USE_STRUCT_COPY /**/ /* HAS_STRTOD: * This symbol, if defined, indicates that the strtod routine is * available to provide better numeric string conversion than atof(). */ #define HAS_STRTOD /**/ /* HAS_STRTOL: * This symbol, if defined, indicates that the strtol routine is available * to provide better numeric string conversion than atoi() and friends. */ #define HAS_STRTOL /**/ /* HAS_STRXFRM: * This symbol, if defined, indicates that the strxfrm() routine is * available to transform strings. */ /*#define HAS_STRXFRM /**/ /* HAS_SYMLINK: * This symbol, if defined, indicates that the symlink routine is available * to create symbolic links. */ /*#define HAS_SYMLINK /**/ /* HAS_SYSCALL: * This symbol, if defined, indicates that the syscall routine is * available to call arbitrary system calls. If undefined, that's tough. */ /*#define HAS_SYSCALL /**/ /* HAS_SYSCONF: * This symbol, if defined, indicates that sysconf() is available * to determine system related limits and options. */ /*#define HAS_SYSCONF /**/ /* HAS_SYSTEM: * This symbol, if defined, indicates that the system routine is * available to issue a shell command. */ #define HAS_SYSTEM /**/ /* HAS_TCGETPGRP: * This symbol, if defined, indicates that the tcgetpgrp routine is * available to get foreground process group ID. */ /*#define HAS_TCGETPGRP /**/ /* HAS_TCSETPGRP: * This symbol, if defined, indicates that the tcsetpgrp routine is * available to set foreground process group ID. */ /*#define HAS_TCSETPGRP /**/ /* HAS_TRUNCATE: * This symbol, if defined, indicates that the truncate routine is * available to truncate files. */ /*#define HAS_TRUNCATE /**/ /* HAS_TZNAME: * This symbol, if defined, indicates that the tzname[] array is * available to access timezone names. */ #define HAS_TZNAME /**/ /* HAS_UMASK: * This symbol, if defined, indicates that the umask routine is * available to set and get the value of the file creation mask. */ #define HAS_UMASK /**/ /* HAS_USLEEP: * This symbol, if defined, indicates that the usleep routine is * available to let the process sleep on a sub-second accuracy. */ /*#define HAS_USLEEP /**/ /* HASVOLATILE: * This symbol, if defined, indicates that this C compiler knows about * the volatile declaration. */ #define HASVOLATILE /**/ #ifndef HASVOLATILE #define volatile #endif /* HAS_WAIT4: * This symbol, if defined, indicates that wait4() exists. */ /*#define HAS_WAIT4 /**/ /* HAS_WAITPID: * This symbol, if defined, indicates that the waitpid routine is * available to wait for child process. */ #define HAS_WAITPID /**/ /* HAS_WCSTOMBS: * This symbol, if defined, indicates that the wcstombs routine is * available to convert wide character strings to multibyte strings. */ #define HAS_WCSTOMBS /**/ /* HAS_WCTOMB: * This symbol, if defined, indicates that the wctomb routine is available * to covert a wide character to a multibyte. */ #define HAS_WCTOMB /**/ /* I_ARPA_INET: * This symbol, if defined, indicates to the C program that it should * include to get inet_addr and friends declarations. */ #define I_ARPA_INET /**/ /* I_ASSERT: * This symbol, if defined, indicates to the C program that it could * include to get the assert() macro. */ #define I_ASSERT /**/ /* I_DBM: * This symbol, if defined, indicates that exists and should * be included. */ /* I_RPCSVC_DBM: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_DBM /**/ #define I_RPCSVC_DBM /**/ /* I_DIRENT: * This symbol, if defined, indicates to the C program that it should * include . Using this symbol also triggers the definition * of the Direntry_t define which ends up being 'struct dirent' or * 'struct direct' depending on the availability of . */ /* DIRNAMLEN: * This symbol, if defined, indicates to the C program that the length * of directory entry names is provided by a d_namlen field. Otherwise * you need to do strlen() on the d_name field. */ /* Direntry_t: * This symbol is set to 'struct direct' or 'struct dirent' depending on * whether dirent is available or not. You should use this pseudo type to * portably declare your directory entries. */ #define I_DIRENT /**/ #define DIRNAMLEN /**/ #define Direntry_t struct direct /* I_DLFCN: * This symbol, if defined, indicates that exists and should * be included. */ #define I_DLFCN /**/ /* I_FCNTL: * This manifest constant tells the C program to include . */ #define I_FCNTL /**/ /* I_FLOAT: * This symbol, if defined, indicates to the C program that it should * include to get definition of symbols like DBL_MAX or * DBL_MIN, i.e. machine dependent floating point values. */ #define I_FLOAT /**/ /* I_LIMITS: * This symbol, if defined, indicates to the C program that it should * include to get definition of symbols like WORD_BIT or * LONG_MAX, i.e. machine dependant limitations. */ #define I_LIMITS /**/ /* I_LOCALE: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_LOCALE /**/ /* I_MATH: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_MATH /**/ /* I_MEMORY: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_MEMORY /**/ /* I_NET_ERRNO: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_NET_ERRNO /**/ /* I_NETINET_IN: * This symbol, if defined, indicates to the C program that it should * include . Otherwise, you may try . */ /*#define I_NETINET_IN /**/ /* I_SFIO: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SFIO /**/ /* I_STDDEF: * This symbol, if defined, indicates that exists and should * be included. */ #define I_STDDEF /**/ /* I_STDLIB: * This symbol, if defined, indicates that exists and should * be included. */ #define I_STDLIB /**/ /* I_STRING: * This symbol, if defined, indicates to the C program that it should * include (USG systems) instead of (BSD systems). */ #define I_STRING /**/ /* I_SYS_DIR: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_DIR /**/ /* I_SYS_FILE: * This symbol, if defined, indicates to the C program that it should * include to get definition of R_OK and friends. */ /*#define I_SYS_FILE /**/ /* I_SYS_IOCTL: * This symbol, if defined, indicates that exists and should * be included. Otherwise, include or . */ /* I_SYS_SOCKIO: * This symbol, if defined, indicates the should be included * to get socket ioctl options, like SIOCATMARK. */ /*#define I_SYS_IOCTL /**/ /*#define I_SYS_SOCKIO /**/ /* I_SYS_NDIR: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_NDIR /**/ /* I_SYS_PARAM: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_PARAM /**/ /* I_SYS_RESOURCE: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_RESOURCE /**/ /* I_SYS_SELECT: * This symbol, if defined, indicates to the C program that it should * include in order to get definition of struct timeval. */ /*#define I_SYS_SELECT /**/ /* I_SYS_STAT: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_STAT /**/ /* I_SYS_TIMES: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_TIMES /**/ /* I_SYS_TYPES: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_TYPES /**/ /* I_SYS_UN: * This symbol, if defined, indicates to the C program that it should * include to get UNIX domain socket definitions. */ /*#define I_SYS_UN /**/ /* I_SYS_WAIT: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_WAIT /**/ /* I_TERMIO: * This symbol, if defined, indicates that the program should include * rather than . There are also differences in * the ioctl() calls that depend on the value of this symbol. */ /* I_TERMIOS: * This symbol, if defined, indicates that the program should include * the POSIX termios.h rather than sgtty.h or termio.h. * There are also differences in the ioctl() calls that depend on the * value of this symbol. */ /* I_SGTTY: * This symbol, if defined, indicates that the program should include * rather than . There are also differences in * the ioctl() calls that depend on the value of this symbol. */ /*#define I_TERMIO /**/ /*#define I_TERMIOS /**/ /*#define I_SGTTY /**/ /* I_UNISTD: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_UNISTD /**/ /* I_UTIME: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_UTIME /**/ /* I_VALUES: * This symbol, if defined, indicates to the C program that it should * include to get definition of symbols like MINFLOAT or * MAXLONG, i.e. machine dependant limitations. Probably, you * should use instead, if it is available. */ /*#define I_VALUES /**/ /* I_VFORK: * This symbol, if defined, indicates to the C program that it should * include vfork.h. */ /*#define I_VFORK /**/ /* HAS_ACCESSX: * This symbol, if defined, indicates that the accessx routine is * available to do extended access checks. */ /*#define HAS_ACCESSX /**/ /* HAS_EACCESS: * This symbol, if defined, indicates that the eaccess routine is * available to do extended access checks. */ /*#define HAS_EACCESS /**/ /* I_SYS_ACCESS: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_ACCESS /**/ /* I_SYS_SECURITY: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_SECURITY /**/ /* OSNAME: * This symbol contains the name of the operating system, as determined * by Configure. You shouldn't rely on it too much; the specific * feature tests from Configure are generally more reliable. */ /* OSVERS: * This symbol contains the version of the operating system, as determined * by Configure. You shouldn't rely on it too much; the specific * feature tests from Configure are generally more reliable. */ #define OSNAME "MSWin32" /**/ #define OSVERS "4.0" /**/ /* USE_CROSS_COMPILE: * This symbol, if defined, indicates that Perl is being cross-compiled. */ /* PERL_TARGETARCH: * This symbol, if defined, indicates the target architecture * Perl has been cross-compiled to. Undefined if not a cross-compile. */ #ifndef USE_CROSS_COMPILE #define USE_CROSS_COMPILE /**/ #define PERL_TARGETARCH "wince" /**/ #endif /* MULTIARCH: * This symbol, if defined, signifies that the build * process will produce some binary files that are going to be * used in a cross-platform environment. This is the case for * example with the NeXT "fat" binaries that contain executables * for several CPUs. */ /*#define MULTIARCH /**/ /* MEM_ALIGNBYTES: * This symbol contains the number of bytes required to align a * double, or a long double when applicable. Usual values are 2, * 4 and 8. The default is eight, for safety. */ #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH) # define MEM_ALIGNBYTES 8 #else #define MEM_ALIGNBYTES 8 #endif /* ARCHLIB: * This variable, if defined, holds the name of the directory in * which the user wants to put architecture-dependent public * library files for perl5. It is most often a local directory * such as /usr/local/lib. Programs using this variable must be * prepared to deal with filename expansion. If ARCHLIB is the * same as PRIVLIB, it is not defined, since presumably the * program already searches PRIVLIB. */ /* ARCHLIB_EXP: * This symbol contains the ~name expanded version of ARCHLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ #define ARCHLIB "\\Storage Card\\perl58m\\lib" /**/ /*#define ARCHLIB_EXP "" /**/ /* ARCHNAME: * This symbol holds a string representing the architecture name. * It may be used to construct an architecture-dependant pathname * where library files may be held under a private library, for * instance. */ #define ARCHNAME "MS Pocket PC-WCE300-ARM" /**/ /* HAS_ATOLF: * This symbol, if defined, indicates that the atolf routine is * available to convert strings into long doubles. */ /*#define HAS_ATOLF /**/ /* HAS_ATOLL: * This symbol, if defined, indicates that the atoll routine is * available to convert strings into long longs. */ /*#define HAS_ATOLL /**/ /* BIN: * This symbol holds the path of the bin directory where the package will * be installed. Program must be prepared to deal with ~name substitution. */ /* BIN_EXP: * This symbol is the filename expanded version of the BIN symbol, for * programs that do not want to deal with that at run-time. */ #define BIN "\\Storage Card\\perl58m\\bin" /**/ #define BIN_EXP "\\Storage Card\\perl58m\\bin" /**/ /* INTSIZE: * This symbol contains the value of sizeof(int) so that the C * preprocessor can make decisions based on it. */ /* LONGSIZE: * This symbol contains the value of sizeof(long) so that the C * preprocessor can make decisions based on it. */ /* SHORTSIZE: * This symbol contains the value of sizeof(short) so that the C * preprocessor can make decisions based on it. */ #define INTSIZE 4 /**/ #define LONGSIZE 4 /**/ #define SHORTSIZE 2 /**/ /* BYTEORDER: * This symbol holds the hexadecimal constant defined in byteorder, * in a UV, i.e. 0x1234 or 0x4321 or 0x12345678, etc... * If the compiler supports cross-compiling or multiple-architecture * binaries (eg. on NeXT systems), use compiler-defined macros to * determine the byte order. * On NeXT 3.2 (and greater), you can build "Fat" Multiple Architecture * Binaries (MAB) on either big endian or little endian machines. * The endian-ness is available at compile-time. This only matters * for perl, where the config.h can be generated and installed on * one system, and used by a different architecture to build an * extension. Older versions of NeXT that might not have * defined either *_ENDIAN__ were all on Motorola 680x0 series, * so the default case (for NeXT) is big endian to catch them. * This might matter for NeXT 3.0. */ #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH) # ifdef __LITTLE_ENDIAN__ # if LONGSIZE == 4 # define BYTEORDER 0x1234 # else # if LONGSIZE == 8 # define BYTEORDER 0x12345678 # endif # endif # else # ifdef __BIG_ENDIAN__ # if LONGSIZE == 4 # define BYTEORDER 0x4321 # else # if LONGSIZE == 8 # define BYTEORDER 0x87654321 # endif # endif # endif # endif # if !defined(BYTEORDER) && (defined(NeXT) || defined(__NeXT__)) # define BYTEORDER 0x4321 # endif #else #define BYTEORDER 0x1234 /* large digits for MSB */ #endif /* NeXT */ /* CAT2: * This macro concatenates 2 tokens together. */ /* STRINGIFY: * This macro surrounds its token with double quotes. */ #if 42 == 1 #define CAT2(a,b) a/**/b #define STRINGIFY(a) "a" /* If you can get stringification with catify, tell me how! */ #endif #if 42 == 42 #define PeRl_CaTiFy(a, b) a ## b #define PeRl_StGiFy(a) #a /* the additional level of indirection enables these macros to be * used as arguments to other macros. See K&R 2nd ed., page 231. */ #define CAT2(a,b) PeRl_CaTiFy(a,b) #define StGiFy(a) PeRl_StGiFy(a) #define STRINGIFY(a) PeRl_StGiFy(a) #endif #if 42 != 1 && 42 != 42 # include "Bletch: How does this C preprocessor concatenate tokens?" #endif /* CPPSTDIN: * This symbol contains the first part of the string which will invoke * the C preprocessor on the standard input and produce to standard * output. Typical value of "cc -E" or "/lib/cpp", but it can also * call a wrapper. See CPPRUN. */ /* CPPMINUS: * This symbol contains the second part of the string which will invoke * the C preprocessor on the standard input and produce to standard * output. This symbol will have the value "-" if CPPSTDIN needs a minus * to specify standard input, otherwise the value is "". */ /* CPPRUN: * This symbol contains the string which will invoke a C preprocessor on * the standard input and produce to standard output. It needs to end * with CPPLAST, after all other preprocessor flags have been specified. * The main difference with CPPSTDIN is that this program will never be a * pointer to a shell wrapper, i.e. it will be empty if no preprocessor is * available directly to the user. Note that it may well be different from * the preprocessor used to compile the C program. */ /* CPPLAST: * This symbol is intended to be used along with CPPRUN in the same manner * symbol CPPMINUS is used with CPPSTDIN. It contains either "-" or "". */ #define CPPSTDIN "clarm.exe -nologo -E" #define CPPMINUS "" #define CPPRUN "clarm.exe -nologo -E" #define CPPLAST "" /* HAS__FWALK: * This symbol, if defined, indicates that the _fwalk system call is * available to apply a function to all the file handles. */ /*#define HAS__FWALK /**/ /* HAS_ACCESS: * This manifest constant lets the C program know that the access() * system call is available to check for accessibility using real UID/GID. * (always present on UNIX.) */ #define HAS_ACCESS /**/ /* HAS_ASCTIME_R: * This symbol, if defined, indicates that the asctime_r routine * is available to asctime re-entrantly. */ /* ASCTIME_R_PROTO: * This symbol encodes the prototype of asctime_r. * It is zero if d_asctime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_asctime_r * is defined. */ /*#define HAS_ASCTIME_R /**/ #define ASCTIME_R_PROTO 0 /**/ /* CASTI32: * This symbol is defined if the C compiler can cast negative * or large floating point numbers to 32-bit ints. */ /*#define CASTI32 /**/ /* CASTNEGFLOAT: * This symbol is defined if the C compiler can cast negative * numbers to unsigned longs, ints and shorts. */ /* CASTFLAGS: * This symbol contains flags that say what difficulties the compiler * has casting odd floating values to unsigned long: * 0 = ok * 1 = couldn't cast < 0 * 2 = couldn't cast >= 0x80000000 * 4 = couldn't cast in argument expression list */ #define CASTNEGFLOAT /**/ #define CASTFLAGS 0 /**/ /* HAS_CLASS: * This symbol, if defined, indicates that the class routine is * available to classify doubles. Available for example in AIX. * The returned values are defined in and are: * * FP_PLUS_NORM Positive normalized, nonzero * FP_MINUS_NORM Negative normalized, nonzero * FP_PLUS_DENORM Positive denormalized, nonzero * FP_MINUS_DENORM Negative denormalized, nonzero * FP_PLUS_ZERO +0.0 * FP_MINUS_ZERO -0.0 * FP_PLUS_INF +INF * FP_MINUS_INF -INF * FP_NANS Signaling Not a Number (NaNS) * FP_NANQ Quiet Not a Number (NaNQ) */ /*#define HAS_CLASS /**/ /* VOID_CLOSEDIR: * This symbol, if defined, indicates that the closedir() routine * does not return a value. */ /*#define VOID_CLOSEDIR /**/ /* HAS_STRUCT_CMSGHDR: * This symbol, if defined, indicates that the struct cmsghdr * is supported. */ /*#define HAS_STRUCT_CMSGHDR /**/ /* HAS_CRYPT_R: * This symbol, if defined, indicates that the crypt_r routine * is available to crypt re-entrantly. */ /* CRYPT_R_PROTO: * This symbol encodes the prototype of crypt_r. * It is zero if d_crypt_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_crypt_r * is defined. */ /*#define HAS_CRYPT_R /**/ #define CRYPT_R_PROTO 0 /**/ /* HAS_CSH: * This symbol, if defined, indicates that the C-shell exists. */ /* CSH: * This symbol, if defined, contains the full pathname of csh. */ /*#define HAS_CSH /**/ #ifdef HAS_CSH #define CSH "" /**/ #endif /* HAS_CTIME_R: * This symbol, if defined, indicates that the ctime_r routine * is available to ctime re-entrantly. */ /* CTIME_R_PROTO: * This symbol encodes the prototype of ctime_r. * It is zero if d_ctime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ctime_r * is defined. */ /*#define HAS_CTIME_R /**/ #define CTIME_R_PROTO 0 /**/ /* DLSYM_NEEDS_UNDERSCORE: * This symbol, if defined, indicates that we need to prepend an * underscore to the symbol name before calling dlsym(). This only * makes sense if you *have* dlsym, which we will presume is the * case if you're using dl_dlopen.xs. */ /*#define DLSYM_NEEDS_UNDERSCORE /**/ /* HAS_DRAND48_R: * This symbol, if defined, indicates that the drand48_r routine * is available to drand48 re-entrantly. */ /* DRAND48_R_PROTO: * This symbol encodes the prototype of drand48_r. * It is zero if d_drand48_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_drand48_r * is defined. */ /*#define HAS_DRAND48_R /**/ #define DRAND48_R_PROTO 0 /**/ /* HAS_DRAND48_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the drand48() function. Otherwise, it is up * to the program to supply one. A good guess is * extern double drand48(void); */ /*#define HAS_DRAND48_PROTO /**/ /* HAS_ENDGRENT: * This symbol, if defined, indicates that the getgrent routine is * available for finalizing sequential access of the group database. */ /*#define HAS_ENDGRENT /**/ /* HAS_ENDGRENT_R: * This symbol, if defined, indicates that the endgrent_r routine * is available to endgrent re-entrantly. */ /* ENDGRENT_R_PROTO: * This symbol encodes the prototype of endgrent_r. * It is zero if d_endgrent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endgrent_r * is defined. */ /*#define HAS_ENDGRENT_R /**/ #define ENDGRENT_R_PROTO 0 /**/ /* HAS_ENDHOSTENT: * This symbol, if defined, indicates that the endhostent() routine is * available to close whatever was being used for host queries. */ /*#define HAS_ENDHOSTENT /**/ /* HAS_ENDNETENT: * This symbol, if defined, indicates that the endnetent() routine is * available to close whatever was being used for network queries. */ /*#define HAS_ENDNETENT /**/ /* HAS_ENDPROTOENT: * This symbol, if defined, indicates that the endprotoent() routine is * available to close whatever was being used for protocol queries. */ /*#define HAS_ENDPROTOENT /**/ /* HAS_ENDPWENT: * This symbol, if defined, indicates that the getgrent routine is * available for finalizing sequential access of the passwd database. */ /*#define HAS_ENDPWENT /**/ /* HAS_ENDPWENT_R: * This symbol, if defined, indicates that the endpwent_r routine * is available to endpwent re-entrantly. */ /* ENDPWENT_R_PROTO: * This symbol encodes the prototype of endpwent_r. * It is zero if d_endpwent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endpwent_r * is defined. */ /*#define HAS_ENDPWENT_R /**/ #define ENDPWENT_R_PROTO 0 /**/ /* HAS_ENDSERVENT: * This symbol, if defined, indicates that the endservent() routine is * available to close whatever was being used for service queries. */ /*#define HAS_ENDSERVENT /**/ /* HAS_FCHDIR: * This symbol, if defined, indicates that the fchdir routine is * available to change directory using a file descriptor. */ /*#define HAS_FCHDIR /**/ /* FCNTL_CAN_LOCK: * This symbol, if defined, indicates that fcntl() can be used * for file locking. Normally on Unix systems this is defined. * It may be undefined on VMS. */ /*#define FCNTL_CAN_LOCK /**/ /* HAS_FD_SET: * This symbol, when defined, indicates presence of the fd_set typedef * in */ #define HAS_FD_SET /**/ /* HAS_FINITE: * This symbol, if defined, indicates that the finite routine is * available to check whether a double is finite (non-infinity non-NaN). */ /*#define HAS_FINITE /**/ /* HAS_FINITEL: * This symbol, if defined, indicates that the finitel routine is * available to check whether a long double is finite * (non-infinity non-NaN). */ /*#define HAS_FINITEL /**/ /* FLEXFILENAMES: * This symbol, if defined, indicates that the system supports filenames * longer than 14 characters. */ #define FLEXFILENAMES /**/ /* HAS_FP_CLASS: * This symbol, if defined, indicates that the fp_class routine is * available to classify doubles. Available for example in Digital UNIX. * The returned values are defined in and are: * * FP_SNAN Signaling NaN (Not-a-Number) * FP_QNAN Quiet NaN (Not-a-Number) * FP_POS_INF +infinity * FP_NEG_INF -infinity * FP_POS_NORM Positive normalized * FP_NEG_NORM Negative normalized * FP_POS_DENORM Positive denormalized * FP_NEG_DENORM Negative denormalized * FP_POS_ZERO +0.0 (positive zero) * FP_NEG_ZERO -0.0 (negative zero) */ /*#define HAS_FP_CLASS /**/ /* HAS_FPCLASS: * This symbol, if defined, indicates that the fpclass routine is * available to classify doubles. Available for example in Solaris/SVR4. * The returned values are defined in and are: * * FP_SNAN signaling NaN * FP_QNAN quiet NaN * FP_NINF negative infinity * FP_PINF positive infinity * FP_NDENORM negative denormalized non-zero * FP_PDENORM positive denormalized non-zero * FP_NZERO negative zero * FP_PZERO positive zero * FP_NNORM negative normalized non-zero * FP_PNORM positive normalized non-zero */ /*#define HAS_FPCLASS /**/ /* HAS_FPCLASSIFY: * This symbol, if defined, indicates that the fpclassify routine is * available to classify doubles. Available for example in HP-UX. * The returned values are defined in and are * * FP_NORMAL Normalized * FP_ZERO Zero * FP_INFINITE Infinity * FP_SUBNORMAL Denormalized * FP_NAN NaN * */ /*#define HAS_FPCLASSIFY /**/ /* HAS_FPOS64_T: * This symbol will be defined if the C compiler supports fpos64_t. */ /*#define HAS_FPOS64_T /**/ /* HAS_FREXPL: * This symbol, if defined, indicates that the frexpl routine is * available to break a long double floating-point number into * a normalized fraction and an integral power of 2. */ /*#define HAS_FREXPL /**/ /* HAS_STRUCT_FS_DATA: * This symbol, if defined, indicates that the struct fs_data * to do statfs() is supported. */ /*#define HAS_STRUCT_FS_DATA /**/ /* HAS_FSEEKO: * This symbol, if defined, indicates that the fseeko routine is * available to fseek beyond 32 bits (useful for ILP32 hosts). */ /*#define HAS_FSEEKO /**/ /* HAS_FSTATFS: * This symbol, if defined, indicates that the fstatfs routine is * available to stat filesystems by file descriptors. */ /*#define HAS_FSTATFS /**/ /* HAS_FSYNC: * This symbol, if defined, indicates that the fsync routine is * available to write a file's modified data and attributes to * permanent storage. */ /*#define HAS_FSYNC /**/ /* HAS_FTELLO: * This symbol, if defined, indicates that the ftello routine is * available to ftell beyond 32 bits (useful for ILP32 hosts). */ /*#define HAS_FTELLO /**/ /* HAS_FUTIMES: * This symbol, if defined, indicates that the futimes routine is * available to change file descriptor time stamps with struct timevals. */ /*#define HAS_FUTIMES /**/ /* Gconvert: * This preprocessor macro is defined to convert a floating point * number to a string without a trailing decimal point. This * emulates the behavior of sprintf("%g"), but is sometimes much more * efficient. If gconvert() is not available, but gcvt() drops the * trailing decimal point, then gcvt() is used. If all else fails, * a macro using sprintf("%g") is used. Arguments for the Gconvert * macro are: value, number of digits, whether trailing zeros should * be retained, and the output buffer. * The usual values are: * d_Gconvert='gconvert((x),(n),(t),(b))' * d_Gconvert='gcvt((x),(n),(b))' * d_Gconvert='sprintf((b),"%.*g",(n),(x))' * The last two assume trailing zeros should not be kept. */ #define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(x)) /* HAS_GETCWD: * This symbol, if defined, indicates that the getcwd routine is * available to get the current working directory. */ #define HAS_GETCWD /**/ /* HAS_GETESPWNAM: * This symbol, if defined, indicates that the getespwnam system call is * available to retrieve enchanced (shadow) password entries by name. */ /*#define HAS_GETESPWNAM /**/ /* HAS_GETFSSTAT: * This symbol, if defined, indicates that the getfsstat routine is * available to stat filesystems in bulk. */ /*#define HAS_GETFSSTAT /**/ /* HAS_GETGRENT: * This symbol, if defined, indicates that the getgrent routine is * available for sequential access of the group database. */ /*#define HAS_GETGRENT /**/ /* HAS_GETGRENT_R: * This symbol, if defined, indicates that the getgrent_r routine * is available to getgrent re-entrantly. */ /* GETGRENT_R_PROTO: * This symbol encodes the prototype of getgrent_r. * It is zero if d_getgrent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrent_r * is defined. */ /*#define HAS_GETGRENT_R /**/ #define GETGRENT_R_PROTO 0 /**/ /* HAS_GETGRGID_R: * This symbol, if defined, indicates that the getgrgid_r routine * is available to getgrgid re-entrantly. */ /* GETGRGID_R_PROTO: * This symbol encodes the prototype of getgrgid_r. * It is zero if d_getgrgid_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrgid_r * is defined. */ /*#define HAS_GETGRGID_R /**/ #define GETGRGID_R_PROTO 0 /**/ /* HAS_GETGRNAM_R: * This symbol, if defined, indicates that the getgrnam_r routine * is available to getgrnam re-entrantly. */ /* GETGRNAM_R_PROTO: * This symbol encodes the prototype of getgrnam_r. * It is zero if d_getgrnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrnam_r * is defined. */ /*#define HAS_GETGRNAM_R /**/ #define GETGRNAM_R_PROTO 0 /**/ /* HAS_GETHOSTBYADDR: * This symbol, if defined, indicates that the gethostbyaddr() routine is * available to look up hosts by their IP addresses. */ #define HAS_GETHOSTBYADDR /**/ /* HAS_GETHOSTBYNAME: * This symbol, if defined, indicates that the gethostbyname() routine is * available to look up host names in some data base or other. */ #define HAS_GETHOSTBYNAME /**/ /* HAS_GETHOSTENT: * This symbol, if defined, indicates that the gethostent() routine is * available to look up host names in some data base or another. */ /*#define HAS_GETHOSTENT /**/ /* HAS_GETHOSTNAME: * This symbol, if defined, indicates that the C program may use the * gethostname() routine to derive the host name. See also HAS_UNAME * and PHOSTNAME. */ /* HAS_UNAME: * This symbol, if defined, indicates that the C program may use the * uname() routine to derive the host name. See also HAS_GETHOSTNAME * and PHOSTNAME. */ /* PHOSTNAME: * This symbol, if defined, indicates the command to feed to the * popen() routine to derive the host name. See also HAS_GETHOSTNAME * and HAS_UNAME. Note that the command uses a fully qualified path, * so that it is safe even if used by a process with super-user * privileges. */ /* HAS_PHOSTNAME: * This symbol, if defined, indicates that the C program may use the * contents of PHOSTNAME as a command to feed to the popen() routine * to derive the host name. */ #define HAS_GETHOSTNAME /**/ #define HAS_UNAME /**/ /*#define HAS_PHOSTNAME /**/ #ifdef HAS_PHOSTNAME #define PHOSTNAME "" /* How to get the host name */ #endif /* HAS_GETHOST_PROTOS: * This symbol, if defined, indicates that includes * prototypes for gethostent(), gethostbyname(), and * gethostbyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ #define HAS_GETHOST_PROTOS /**/ /* HAS_GETITIMER: * This symbol, if defined, indicates that the getitimer routine is * available to return interval timers. */ /*#define HAS_GETITIMER /**/ /* HAS_GETLOGIN_R: * This symbol, if defined, indicates that the getlogin_r routine * is available to getlogin re-entrantly. */ /* GETLOGIN_R_PROTO: * This symbol encodes the prototype of getlogin_r. * It is zero if d_getlogin_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getlogin_r * is defined. */ /*#define HAS_GETLOGIN_R /**/ #define GETLOGIN_R_PROTO 0 /**/ /* HAS_GETMNT: * This symbol, if defined, indicates that the getmnt routine is * available to get filesystem mount info by filename. */ /*#define HAS_GETMNT /**/ /* HAS_GETMNTENT: * This symbol, if defined, indicates that the getmntent routine is * available to iterate through mounted file systems to get their info. */ /*#define HAS_GETMNTENT /**/ /* HAS_GETNETBYADDR: * This symbol, if defined, indicates that the getnetbyaddr() routine is * available to look up networks by their IP addresses. */ /*#define HAS_GETNETBYADDR /**/ /* HAS_GETNETBYNAME: * This symbol, if defined, indicates that the getnetbyname() routine is * available to look up networks by their names. */ /*#define HAS_GETNETBYNAME /**/ /* HAS_GETNETENT: * This symbol, if defined, indicates that the getnetent() routine is * available to look up network names in some data base or another. */ /*#define HAS_GETNETENT /**/ /* HAS_GETNET_PROTOS: * This symbol, if defined, indicates that includes * prototypes for getnetent(), getnetbyname(), and * getnetbyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ /*#define HAS_GETNET_PROTOS /**/ /* HAS_GETPAGESIZE: * This symbol, if defined, indicates that the getpagesize system call * is available to get system page size, which is the granularity of * many memory management calls. */ /*#define HAS_GETPAGESIZE /**/ /* HAS_GETPROTOENT: * This symbol, if defined, indicates that the getprotoent() routine is * available to look up protocols in some data base or another. */ /*#define HAS_GETPROTOENT /**/ /* HAS_GETPGRP: * This symbol, if defined, indicates that the getpgrp routine is * available to get the current process group. */ /* USE_BSD_GETPGRP: * This symbol, if defined, indicates that getpgrp needs one * arguments whereas USG one needs none. */ /*#define HAS_GETPGRP /**/ /*#define USE_BSD_GETPGRP /**/ /* HAS_GETPROTOBYNAME: * This symbol, if defined, indicates that the getprotobyname() * routine is available to look up protocols by their name. */ /* HAS_GETPROTOBYNUMBER: * This symbol, if defined, indicates that the getprotobynumber() * routine is available to look up protocols by their number. */ #define HAS_GETPROTOBYNAME /**/ #define HAS_GETPROTOBYNUMBER /**/ /* HAS_GETPROTO_PROTOS: * This symbol, if defined, indicates that includes * prototypes for getprotoent(), getprotobyname(), and * getprotobyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ #define HAS_GETPROTO_PROTOS /**/ /* HAS_GETPRPWNAM: * This symbol, if defined, indicates that the getprpwnam system call is * available to retrieve protected (shadow) password entries by name. */ /*#define HAS_GETPRPWNAM /**/ /* HAS_GETPWENT: * This symbol, if defined, indicates that the getpwent routine is * available for sequential access of the passwd database. * If this is not available, the older getpw() function may be available. */ /*#define HAS_GETPWENT /**/ /* HAS_GETPWENT_R: * This symbol, if defined, indicates that the getpwent_r routine * is available to getpwent re-entrantly. */ /* GETPWENT_R_PROTO: * This symbol encodes the prototype of getpwent_r. * It is zero if d_getpwent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwent_r * is defined. */ /*#define HAS_GETPWENT_R /**/ #define GETPWENT_R_PROTO 0 /**/ /* HAS_GETPWNAM_R: * This symbol, if defined, indicates that the getpwnam_r routine * is available to getpwnam re-entrantly. */ /* GETPWNAM_R_PROTO: * This symbol encodes the prototype of getpwnam_r. * It is zero if d_getpwnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwnam_r * is defined. */ /*#define HAS_GETPWNAM_R /**/ #define GETPWNAM_R_PROTO 0 /**/ /* HAS_GETPWUID_R: * This symbol, if defined, indicates that the getpwuid_r routine * is available to getpwuid re-entrantly. */ /* GETPWUID_R_PROTO: * This symbol encodes the prototype of getpwuid_r. * It is zero if d_getpwuid_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwuid_r * is defined. */ /*#define HAS_GETPWUID_R /**/ #define GETPWUID_R_PROTO 0 /**/ /* HAS_GETSERVENT: * This symbol, if defined, indicates that the getservent() routine is * available to look up network services in some data base or another. */ /*#define HAS_GETSERVENT /**/ /* HAS_GETSERV_PROTOS: * This symbol, if defined, indicates that includes * prototypes for getservent(), getservbyname(), and * getservbyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ #define HAS_GETSERV_PROTOS /**/ /* HAS_GETSPNAM: * This symbol, if defined, indicates that the getspnam system call is * available to retrieve SysV shadow password entries by name. */ /*#define HAS_GETSPNAM /**/ /* HAS_GETSPNAM_R: * This symbol, if defined, indicates that the getspnam_r routine * is available to getspnam re-entrantly. */ /* GETSPNAM_R_PROTO: * This symbol encodes the prototype of getspnam_r. * It is zero if d_getspnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getspnam_r * is defined. */ /*#define HAS_GETSPNAM_R /**/ #define GETSPNAM_R_PROTO 0 /**/ /* HAS_GETSERVBYNAME: * This symbol, if defined, indicates that the getservbyname() * routine is available to look up services by their name. */ /* HAS_GETSERVBYPORT: * This symbol, if defined, indicates that the getservbyport() * routine is available to look up services by their port. */ #define HAS_GETSERVBYNAME /**/ #define HAS_GETSERVBYPORT /**/ /* HAS_GMTIME_R: * This symbol, if defined, indicates that the gmtime_r routine * is available to gmtime re-entrantly. */ /* GMTIME_R_PROTO: * This symbol encodes the prototype of gmtime_r. * It is zero if d_gmtime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gmtime_r * is defined. */ /*#define HAS_GMTIME_R /**/ #define GMTIME_R_PROTO 0 /**/ /* HAS_GNULIBC: * This symbol, if defined, indicates to the C program that * the GNU C library is being used. A better check is to use * the __GLIBC__ and __GLIBC_MINOR__ symbols supplied with glibc. */ /*#define HAS_GNULIBC /**/ #if defined(HAS_GNULIBC) && !defined(_GNU_SOURCE) # define _GNU_SOURCE #endif /* HAS_HASMNTOPT: * This symbol, if defined, indicates that the hasmntopt routine is * available to query the mount options of file systems. */ /*#define HAS_HASMNTOPT /**/ /* HAS_HTONL: * This symbol, if defined, indicates that the htonl() routine (and * friends htons() ntohl() ntohs()) are available to do network * order byte swapping. */ /* HAS_HTONS: * This symbol, if defined, indicates that the htons() routine (and * friends htonl() ntohl() ntohs()) are available to do network * order byte swapping. */ /* HAS_NTOHL: * This symbol, if defined, indicates that the ntohl() routine (and * friends htonl() htons() ntohs()) are available to do network * order byte swapping. */ /* HAS_NTOHS: * This symbol, if defined, indicates that the ntohs() routine (and * friends htonl() htons() ntohl()) are available to do network * order byte swapping. */ #define HAS_HTONL /**/ #define HAS_HTONS /**/ #define HAS_NTOHL /**/ #define HAS_NTOHS /**/ /* HAS_INT64_T: * This symbol will defined if the C compiler supports int64_t. * Usually the needs to be included, but sometimes * is enough. */ /*#define HAS_INT64_T /**/ /* HAS_ISASCII: * This manifest constant lets the C program know that isascii * is available. */ #define HAS_ISASCII /**/ /* HAS_ISFINITE: * This symbol, if defined, indicates that the isfinite routine is * available to check whether a double is finite (non-infinity non-NaN). */ /*#define HAS_ISFINITE /**/ /* HAS_ISINF: * This symbol, if defined, indicates that the isinf routine is * available to check whether a double is an infinity. */ /*#define HAS_ISINF /**/ /* HAS_ISNAN: * This symbol, if defined, indicates that the isnan routine is * available to check whether a double is a NaN. */ #define HAS_ISNAN /**/ /* HAS_ISNANL: * This symbol, if defined, indicates that the isnanl routine is * available to check whether a long double is a NaN. */ /*#define HAS_ISNANL /**/ /* HAS_LCHOWN: * This symbol, if defined, indicates that the lchown routine is * available to operate on a symbolic link (instead of following the * link). */ /*#define HAS_LCHOWN /**/ /* HAS_LDBL_DIG: * This symbol, if defined, indicates that this system's * or defines the symbol LDBL_DIG, which is the number * of significant digits in a long double precision number. Unlike * for DBL_DIG, there's no good guess for LDBL_DIG if it is undefined. */ #define HAS_LDBL_DIG /**/ /* HAS_LOCALTIME_R: * This symbol, if defined, indicates that the localtime_r routine * is available to localtime re-entrantly. */ /* LOCALTIME_R_NEEDS_TZSET: * Many libc's localtime_r implementations do not call tzset, * making them differ from localtime(), and making timezone * changes using $ENV{TZ} without explicitly calling tzset * impossible. This symbol makes us call tzset before localtime_r */ /* LOCALTIME_R_PROTO: * This symbol encodes the prototype of localtime_r. * It is zero if d_localtime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_localtime_r * is defined. */ /*#define HAS_LOCALTIME_R /**/ /*#define LOCALTIME_R_NEEDS_TZSET /**/ #define LOCALTIME_R_PROTO 0 /**/ /* HAS_LONG_DOUBLE: * This symbol will be defined if the C compiler supports long * doubles. */ /* LONG_DOUBLESIZE: * This symbol contains the size of a long double, so that the * C preprocessor can make decisions based on it. It is only * defined if the system supports long doubles. */ /*#define HAS_LONG_DOUBLE /**/ #ifdef HAS_LONG_DOUBLE #define LONG_DOUBLESIZE 10 /**/ #endif /* HAS_LONG_LONG: * This symbol will be defined if the C compiler supports long long. */ /* LONGLONGSIZE: * This symbol contains the size of a long long, so that the * C preprocessor can make decisions based on it. It is only * defined if the system supports long long. */ /*#define HAS_LONG_LONG /**/ #ifdef HAS_LONG_LONG #define LONGLONGSIZE 8 /**/ #endif /* HAS_LSEEK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the lseek() function. Otherwise, it is up * to the program to supply one. A good guess is * extern off_t lseek(int, off_t, int); */ #define HAS_LSEEK_PROTO /**/ /* HAS_MADVISE: * This symbol, if defined, indicates that the madvise system call is * available to map a file into memory. */ /*#define HAS_MADVISE /**/ /* HAS_MALLOC_SIZE: * This symbol, if defined, indicates that the malloc_size * routine is available for use. */ /*#define HAS_MALLOC_SIZE /**/ /* HAS_MALLOC_GOOD_SIZE: * This symbol, if defined, indicates that the malloc_good_size * routine is available for use. */ /*#define HAS_MALLOC_GOOD_SIZE /**/ /* HAS_MEMCHR: * This symbol, if defined, indicates that the memchr routine is available * to locate characters within a C string. */ #define HAS_MEMCHR /**/ /* HAS_MKDTEMP: * This symbol, if defined, indicates that the mkdtemp routine is * available to exclusively create a uniquely named temporary directory. */ /*#define HAS_MKDTEMP /**/ /* HAS_MKSTEMP: * This symbol, if defined, indicates that the mkstemp routine is * available to exclusively create and open a uniquely named * temporary file. */ /*#define HAS_MKSTEMP /**/ /* HAS_MKSTEMPS: * This symbol, if defined, indicates that the mkstemps routine is * available to excluslvely create and open a uniquely named * (with a suffix) temporary file. */ /*#define HAS_MKSTEMPS /**/ /* HAS_MMAP: * This symbol, if defined, indicates that the mmap system call is * available to map a file into memory. */ /* Mmap_t: * This symbol holds the return type of the mmap() system call * (and simultaneously the type of the first argument). * Usually set to 'void *' or 'cadd_t'. */ /*#define HAS_MMAP /**/ #define Mmap_t void * /**/ /* HAS_MODFL: * This symbol, if defined, indicates that the modfl routine is * available to split a long double x into a fractional part f and * an integer part i such that |f| < 1.0 and (f + i) = x. */ /* HAS_MODFL_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the modfl() function. Otherwise, it is up * to the program to supply one. */ /* HAS_MODFL_POW32_BUG: * This symbol, if defined, indicates that the modfl routine is * broken for long doubles >= pow(2, 32). * For example from 4294967303.150000 one would get 4294967302.000000 * and 1.150000. The bug has been seen in certain versions of glibc, * release 2.2.2 is known to be okay. */ /*#define HAS_MODFL /**/ /*#define HAS_MODFL_PROTO /**/ /*#define HAS_MODFL_POW32_BUG /**/ /* HAS_MPROTECT: * This symbol, if defined, indicates that the mprotect system call is * available to modify the access protection of a memory mapped file. */ /*#define HAS_MPROTECT /**/ /* HAS_MSG: * This symbol, if defined, indicates that the entire msg*(2) library is * supported (IPC mechanism based on message queues). */ /*#define HAS_MSG /**/ /* HAS_STRUCT_MSGHDR: * This symbol, if defined, indicates that the struct msghdr * is supported. */ /*#define HAS_STRUCT_MSGHDR /**/ /* HAS_OFF64_T: * This symbol will be defined if the C compiler supports off64_t. */ /*#define HAS_OFF64_T /**/ /* HAS_OPEN3: * This manifest constant lets the C program know that the three * argument form of open(2) is available. */ /*#define HAS_OPEN3 /**/ /* OLD_PTHREAD_CREATE_JOINABLE: * This symbol, if defined, indicates how to create pthread * in joinable (aka undetached) state. NOTE: not defined * if pthread.h already has defined PTHREAD_CREATE_JOINABLE * (the new version of the constant). * If defined, known values are PTHREAD_CREATE_UNDETACHED * and __UNDETACHED. */ /*#define OLD_PTHREAD_CREATE_JOINABLE /**/ /* HAS_PTHREAD_YIELD: * This symbol, if defined, indicates that the pthread_yield * routine is available to yield the execution of the current * thread. sched_yield is preferable to pthread_yield. */ /* SCHED_YIELD: * This symbol defines the way to yield the execution of * the current thread. Known ways are sched_yield, * pthread_yield, and pthread_yield with NULL. */ /* HAS_SCHED_YIELD: * This symbol, if defined, indicates that the sched_yield * routine is available to yield the execution of the current * thread. sched_yield is preferable to pthread_yield. */ /*#define HAS_PTHREAD_YIELD /**/ #define SCHED_YIELD /**/ /*#define HAS_SCHED_YIELD /**/ /* HAS_RANDOM_R: * This symbol, if defined, indicates that the random_r routine * is available to random re-entrantly. */ /* RANDOM_R_PROTO: * This symbol encodes the prototype of random_r. * It is zero if d_random_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_random_r * is defined. */ /*#define HAS_RANDOM_R /**/ #define RANDOM_R_PROTO 0 /**/ /* HAS_READDIR_R: * This symbol, if defined, indicates that the readdir_r routine * is available to readdir re-entrantly. */ /* READDIR_R_PROTO: * This symbol encodes the prototype of readdir_r. * It is zero if d_readdir_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_readdir_r * is defined. */ /*#define HAS_READDIR_R /**/ #define READDIR_R_PROTO 0 /**/ /* HAS_READV: * This symbol, if defined, indicates that the readv routine is * available to do gather reads. You will also need * and there I_SYSUIO. */ /*#define HAS_READV /**/ /* HAS_RECVMSG: * This symbol, if defined, indicates that the recvmsg routine is * available to send structured socket messages. */ /*#define HAS_RECVMSG /**/ /* HAS_SAFE_BCOPY: * This symbol, if defined, indicates that the bcopy routine is available * to copy potentially overlapping memory blocks. Normally, you should * probably use memmove() or memcpy(). If neither is defined, roll your * own version. */ /*#define HAS_SAFE_BCOPY /**/ /* HAS_SAFE_MEMCPY: * This symbol, if defined, indicates that the memcpy routine is available * to copy potentially overlapping memory blocks. If you need to * copy overlapping memory blocks, you should check HAS_MEMMOVE and * use memmove() instead, if available. */ /*#define HAS_SAFE_MEMCPY /**/ /* HAS_SANE_MEMCMP: * This symbol, if defined, indicates that the memcmp routine is available * and can be used to compare relative magnitudes of chars with their high * bits set. If it is not defined, roll your own version. */ #define HAS_SANE_MEMCMP /**/ /* HAS_SBRK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the sbrk() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern void* sbrk(int); * extern void* sbrk(size_t); */ /*#define HAS_SBRK_PROTO /**/ /* HAS_SEM: * This symbol, if defined, indicates that the entire sem*(2) library is * supported. */ /*#define HAS_SEM /**/ /* HAS_SENDMSG: * This symbol, if defined, indicates that the sendmsg routine is * available to send structured socket messages. */ /*#define HAS_SENDMSG /**/ /* HAS_SETGRENT: * This symbol, if defined, indicates that the setgrent routine is * available for initializing sequential access of the group database. */ /*#define HAS_SETGRENT /**/ /* HAS_SETGRENT_R: * This symbol, if defined, indicates that the setgrent_r routine * is available to setgrent re-entrantly. */ /* SETGRENT_R_PROTO: * This symbol encodes the prototype of setgrent_r. * It is zero if d_setgrent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setgrent_r * is defined. */ /*#define HAS_SETGRENT_R /**/ #define SETGRENT_R_PROTO 0 /**/ /* HAS_SETGROUPS: * This symbol, if defined, indicates that the setgroups() routine is * available to set the list of process groups. If unavailable, multiple * groups are probably not supported. */ /*#define HAS_SETGROUPS /**/ /* HAS_SETHOSTENT: * This symbol, if defined, indicates that the sethostent() routine is * available. */ /*#define HAS_SETHOSTENT /**/ /* HAS_SETITIMER: * This symbol, if defined, indicates that the setitimer routine is * available to set interval timers. */ /*#define HAS_SETITIMER /**/ /* HAS_SETNETENT: * This symbol, if defined, indicates that the setnetent() routine is * available. */ /*#define HAS_SETNETENT /**/ /* HAS_SETPROTOENT: * This symbol, if defined, indicates that the setprotoent() routine is * available. */ /*#define HAS_SETPROTOENT /**/ /* HAS_SETPGRP: * This symbol, if defined, indicates that the setpgrp routine is * available to set the current process group. */ /* USE_BSD_SETPGRP: * This symbol, if defined, indicates that setpgrp needs two * arguments whereas USG one needs none. See also HAS_SETPGID * for a POSIX interface. */ /*#define HAS_SETPGRP /**/ /*#define USE_BSD_SETPGRP /**/ /* HAS_SETPROCTITLE: * This symbol, if defined, indicates that the setproctitle routine is * available to set process title. */ /*#define HAS_SETPROCTITLE /**/ /* HAS_SETPWENT: * This symbol, if defined, indicates that the setpwent routine is * available for initializing sequential access of the passwd database. */ /*#define HAS_SETPWENT /**/ /* HAS_SETPWENT_R: * This symbol, if defined, indicates that the setpwent_r routine * is available to setpwent re-entrantly. */ /* SETPWENT_R_PROTO: * This symbol encodes the prototype of setpwent_r. * It is zero if d_setpwent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setpwent_r * is defined. */ /*#define HAS_SETPWENT_R /**/ #define SETPWENT_R_PROTO 0 /**/ /* HAS_SETSERVENT: * This symbol, if defined, indicates that the setservent() routine is * available. */ /*#define HAS_SETSERVENT /**/ /* HAS_SETVBUF: * This symbol, if defined, indicates that the setvbuf routine is * available to change buffering on an open stdio stream. * to a line-buffered mode. */ /*#define HAS_SETVBUF /**/ /* USE_SFIO: * This symbol, if defined, indicates that sfio should * be used. */ /*#define USE_SFIO /**/ /* HAS_SHM: * This symbol, if defined, indicates that the entire shm*(2) library is * supported. */ /*#define HAS_SHM /**/ /* HAS_SIGACTION: * This symbol, if defined, indicates that Vr4's sigaction() routine * is available. */ /*#define HAS_SIGACTION /**/ /* HAS_SIGSETJMP: * This variable indicates to the C program that the sigsetjmp() * routine is available to save the calling process's registers * and stack environment for later use by siglongjmp(), and * to optionally save the process's signal mask. See * Sigjmp_buf, Sigsetjmp, and Siglongjmp. */ /* Sigjmp_buf: * This is the buffer type to be used with Sigsetjmp and Siglongjmp. */ /* Sigsetjmp: * This macro is used in the same way as sigsetjmp(), but will invoke * traditional setjmp() if sigsetjmp isn't available. * See HAS_SIGSETJMP. */ /* Siglongjmp: * This macro is used in the same way as siglongjmp(), but will invoke * traditional longjmp() if siglongjmp isn't available. * See HAS_SIGSETJMP. */ /*#define HAS_SIGSETJMP /**/ #ifdef HAS_SIGSETJMP #define Sigjmp_buf sigjmp_buf #define Sigsetjmp(buf,save_mask) sigsetjmp((buf),(save_mask)) #define Siglongjmp(buf,retval) siglongjmp((buf),(retval)) #else #define Sigjmp_buf jmp_buf #define Sigsetjmp(buf,save_mask) setjmp((buf)) #define Siglongjmp(buf,retval) longjmp((buf),(retval)) #endif /* USE_SITECUSTOMIZE: * This symbol, if defined, indicates that sitecustomize should * be used. */ /*#define USE_SITECUSTOMIZE /**/ /* HAS_SOCKET: * This symbol, if defined, indicates that the BSD socket interface is * supported. */ /* HAS_SOCKETPAIR: * This symbol, if defined, indicates that the BSD socketpair() call is * supported. */ /* HAS_MSG_CTRUNC: * This symbol, if defined, indicates that the MSG_CTRUNC is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_DONTROUTE: * This symbol, if defined, indicates that the MSG_DONTROUTE is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_OOB: * This symbol, if defined, indicates that the MSG_OOB is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_PEEK: * This symbol, if defined, indicates that the MSG_PEEK is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_PROXY: * This symbol, if defined, indicates that the MSG_PROXY is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_SCM_RIGHTS: * This symbol, if defined, indicates that the SCM_RIGHTS is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ #define HAS_SOCKET /**/ /*#define HAS_SOCKETPAIR /**/ /*#define HAS_MSG_CTRUNC /**/ /*#define HAS_MSG_DONTROUTE /**/ /*#define HAS_MSG_OOB /**/ /*#define HAS_MSG_PEEK /**/ /*#define HAS_MSG_PROXY /**/ /*#define HAS_SCM_RIGHTS /**/ /* HAS_SOCKS5_INIT: * This symbol, if defined, indicates that the socks5_init routine is * available to initialize SOCKS 5. */ /*#define HAS_SOCKS5_INIT /**/ /* HAS_SQRTL: * This symbol, if defined, indicates that the sqrtl routine is * available to do long double square roots. */ /*#define HAS_SQRTL /**/ /* HAS_SRAND48_R: * This symbol, if defined, indicates that the srand48_r routine * is available to srand48 re-entrantly. */ /* SRAND48_R_PROTO: * This symbol encodes the prototype of srand48_r. * It is zero if d_srand48_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_srand48_r * is defined. */ /*#define HAS_SRAND48_R /**/ #define SRAND48_R_PROTO 0 /**/ /* HAS_SRANDOM_R: * This symbol, if defined, indicates that the srandom_r routine * is available to srandom re-entrantly. */ /* SRANDOM_R_PROTO: * This symbol encodes the prototype of srandom_r. * It is zero if d_srandom_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_srandom_r * is defined. */ /*#define HAS_SRANDOM_R /**/ #define SRANDOM_R_PROTO 0 /**/ /* USE_STAT_BLOCKS: * This symbol is defined if this system has a stat structure declaring * st_blksize and st_blocks. */ #ifndef USE_STAT_BLOCKS /*#define USE_STAT_BLOCKS /**/ #endif /* HAS_STRUCT_STATFS_F_FLAGS: * This symbol, if defined, indicates that the struct statfs * does have the f_flags member containing the mount flags of * the filesystem containing the file. * This kind of struct statfs is coming from (BSD 4.3), * not from (SYSV). Older BSDs (like Ultrix) do not * have statfs() and struct statfs, they have ustat() and getmnt() * with struct ustat and struct fs_data. */ /*#define HAS_STRUCT_STATFS_F_FLAGS /**/ /* HAS_STRUCT_STATFS: * This symbol, if defined, indicates that the struct statfs * to do statfs() is supported. */ /*#define HAS_STRUCT_STATFS /**/ /* HAS_FSTATVFS: * This symbol, if defined, indicates that the fstatvfs routine is * available to stat filesystems by file descriptors. */ /*#define HAS_FSTATVFS /**/ /* USE_STDIO_PTR: * This symbol is defined if the _ptr and _cnt fields (or similar) * of the stdio FILE structure can be used to access the stdio buffer * for a file handle. If this is defined, then the FILE_ptr(fp) * and FILE_cnt(fp) macros will also be defined and should be used * to access these fields. */ /* FILE_ptr: * This macro is used to access the _ptr field (or equivalent) of the * FILE structure pointed to by its argument. This macro will always be * defined if USE_STDIO_PTR is defined. */ /* STDIO_PTR_LVALUE: * This symbol is defined if the FILE_ptr macro can be used as an * lvalue. */ /* FILE_cnt: * This macro is used to access the _cnt field (or equivalent) of the * FILE structure pointed to by its argument. This macro will always be * defined if USE_STDIO_PTR is defined. */ /* STDIO_CNT_LVALUE: * This symbol is defined if the FILE_cnt macro can be used as an * lvalue. */ /* STDIO_PTR_LVAL_SETS_CNT: * This symbol is defined if using the FILE_ptr macro as an lvalue * to increase the pointer by n has the side effect of decreasing the * value of File_cnt(fp) by n. */ /* STDIO_PTR_LVAL_NOCHANGE_CNT: * This symbol is defined if using the FILE_ptr macro as an lvalue * to increase the pointer by n leaves File_cnt(fp) unchanged. */ /*#define USE_STDIO_PTR /**/ #ifdef USE_STDIO_PTR #define FILE_ptr(fp) /*#define STDIO_PTR_LVALUE /**/ #define FILE_cnt(fp) /*#define STDIO_CNT_LVALUE /**/ /*#define STDIO_PTR_LVAL_SETS_CNT /**/ /*#define STDIO_PTR_LVAL_NOCHANGE_CNT /**/ #endif /* USE_STDIO_BASE: * This symbol is defined if the _base field (or similar) of the * stdio FILE structure can be used to access the stdio buffer for * a file handle. If this is defined, then the FILE_base(fp) macro * will also be defined and should be used to access this field. * Also, the FILE_bufsiz(fp) macro will be defined and should be used * to determine the number of bytes in the buffer. USE_STDIO_BASE * will never be defined unless USE_STDIO_PTR is. */ /* FILE_base: * This macro is used to access the _base field (or equivalent) of the * FILE structure pointed to by its argument. This macro will always be * defined if USE_STDIO_BASE is defined. */ /* FILE_bufsiz: * This macro is used to determine the number of bytes in the I/O * buffer pointed to by _base field (or equivalent) of the FILE * structure pointed to its argument. This macro will always be defined * if USE_STDIO_BASE is defined. */ /*#define USE_STDIO_BASE /**/ #ifdef USE_STDIO_BASE #define FILE_base(fp) #define FILE_bufsiz(fp) #endif /* HAS_STRERROR: * This symbol, if defined, indicates that the strerror routine is * available to translate error numbers to strings. See the writeup * of Strerror() in this file before you try to define your own. */ /* HAS_SYS_ERRLIST: * This symbol, if defined, indicates that the sys_errlist array is * available to translate error numbers to strings. The extern int * sys_nerr gives the size of that table. */ /* Strerror: * This preprocessor symbol is defined as a macro if strerror() is * not available to translate error numbers to strings but sys_errlist[] * array is there. */ #define HAS_STRERROR /**/ #define HAS_SYS_ERRLIST /**/ #define Strerror(e) strerror(e) /* HAS_STRERROR_R: * This symbol, if defined, indicates that the strerror_r routine * is available to strerror re-entrantly. */ /* STRERROR_R_PROTO: * This symbol encodes the prototype of strerror_r. * It is zero if d_strerror_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_strerror_r * is defined. */ /*#define HAS_STRERROR_R /**/ #define STRERROR_R_PROTO 0 /**/ /* HAS_STRTOLD: * This symbol, if defined, indicates that the strtold routine is * available to convert strings to long doubles. */ /*#define HAS_STRTOLD /**/ /* HAS_STRTOLL: * This symbol, if defined, indicates that the strtoll routine is * available to convert strings to long longs. */ /*#define HAS_STRTOLL /**/ /* HAS_STRTOQ: * This symbol, if defined, indicates that the strtoq routine is * available to convert strings to long longs (quads). */ /*#define HAS_STRTOQ /**/ /* HAS_STRTOUL: * This symbol, if defined, indicates that the strtoul routine is * available to provide conversion of strings to unsigned long. */ #define HAS_STRTOUL /**/ /* HAS_STRTOULL: * This symbol, if defined, indicates that the strtoull routine is * available to convert strings to unsigned long longs. */ /*#define HAS_STRTOULL /**/ /* HAS_STRTOUQ: * This symbol, if defined, indicates that the strtouq routine is * available to convert strings to unsigned long longs (quads). */ /*#define HAS_STRTOUQ /**/ /* HAS_TELLDIR_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the telldir() function. Otherwise, it is up * to the program to supply one. A good guess is * extern long telldir(DIR*); */ #define HAS_TELLDIR_PROTO /**/ /* HAS_TIME: * This symbol, if defined, indicates that the time() routine exists. */ /* Time_t: * This symbol holds the type returned by time(). It can be long, * or time_t on BSD sites (in which case should be * included). */ #define HAS_TIME /**/ #define Time_t time_t /* Time type */ /* HAS_TIMES: * This symbol, if defined, indicates that the times() routine exists. * Note that this became obsolete on some systems (SUNOS), which now * use getrusage(). It may be necessary to include . */ #define HAS_TIMES /**/ /* HAS_TMPNAM_R: * This symbol, if defined, indicates that the tmpnam_r routine * is available to tmpnam re-entrantly. */ /* TMPNAM_R_PROTO: * This symbol encodes the prototype of tmpnam_r. * It is zero if d_tmpnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_tmpnam_r * is defined. */ /*#define HAS_TMPNAM_R /**/ #define TMPNAM_R_PROTO 0 /**/ /* HAS_UALARM: * This symbol, if defined, indicates that the ualarm routine is * available to do alarms with microsecond granularity. */ /*#define HAS_UALARM /**/ /* HAS_UNION_SEMUN: * This symbol, if defined, indicates that the union semun is * defined by including . If not, the user code * probably needs to define it as: * union semun { * int val; * struct semid_ds *buf; * unsigned short *array; * } */ /* USE_SEMCTL_SEMUN: * This symbol, if defined, indicates that union semun is * used for semctl IPC_STAT. */ /* USE_SEMCTL_SEMID_DS: * This symbol, if defined, indicates that struct semid_ds * is * used for semctl IPC_STAT. */ #define HAS_UNION_SEMUN /**/ /*#define USE_SEMCTL_SEMUN /**/ /*#define USE_SEMCTL_SEMID_DS /**/ /* HAS_UNORDERED: * This symbol, if defined, indicates that the unordered routine is * available to check whether two doubles are unordered * (effectively: whether either of them is NaN) */ /*#define HAS_UNORDERED /**/ /* HAS_UNSETENV: * This symbol, if defined, indicates that the unsetenv () routine is * available for use. */ /*#define HAS_UNSETENV /**/ /* HAS_USTAT: * This symbol, if defined, indicates that the ustat system call is * available to query file system statistics by dev_t. */ /*#define HAS_USTAT /**/ /* HAS_VFORK: * This symbol, if defined, indicates that vfork() exists. */ /*#define HAS_VFORK /**/ /* Signal_t: * This symbol's value is either "void" or "int", corresponding to the * appropriate return type of a signal handler. Thus, you can declare * a signal handler using "Signal_t (*handler)()", and define the * handler using "Signal_t handler(sig)". */ #define Signal_t void /* Signal handler's return type */ /* HAS_VPRINTF: * This symbol, if defined, indicates that the vprintf routine is available * to printf with a pointer to an argument list. If unavailable, you * may need to write your own, probably in terms of _doprnt(). */ /* USE_CHAR_VSPRINTF: * This symbol is defined if this system has vsprintf() returning type * (char*). The trend seems to be to declare it as "int vsprintf()". It * is up to the package author to declare vsprintf correctly based on the * symbol. */ #define HAS_VPRINTF /**/ /*#define USE_CHAR_VSPRINTF /**/ /* HAS_WRITEV: * This symbol, if defined, indicates that the writev routine is * available to do scatter writes. */ /*#define HAS_WRITEV /**/ /* USE_DYNAMIC_LOADING: * This symbol, if defined, indicates that dynamic loading of * some sort is available. */ #define USE_DYNAMIC_LOADING /**/ /* DOUBLESIZE: * This symbol contains the size of a double, so that the C preprocessor * can make decisions based on it. */ #define DOUBLESIZE 8 /**/ /* EBCDIC: * This symbol, if defined, indicates that this system uses * EBCDIC encoding. */ /*#define EBCDIC /**/ /* FFLUSH_NULL: * This symbol, if defined, tells that fflush(NULL) does flush * all pending stdio output. */ /* FFLUSH_ALL: * This symbol, if defined, tells that to flush * all pending stdio output one must loop through all * the stdio file handles stored in an array and fflush them. * Note that if fflushNULL is defined, fflushall will not * even be probed for and will be left undefined. */ #define FFLUSH_NULL /**/ /*#define FFLUSH_ALL /**/ /* Fpos_t: * This symbol holds the type used to declare file positions in libc. * It can be fpos_t, long, uint, etc... It may be necessary to include * to get any typedef'ed information. */ #define Fpos_t fpos_t /* File position type */ /* Gid_t_f: * This symbol defines the format string used for printing a Gid_t. */ #define Gid_t_f "ld" /**/ /* Gid_t_sign: * This symbol holds the signedess of a Gid_t. * 1 for unsigned, -1 for signed. */ #define Gid_t_sign -1 /* GID sign */ /* Gid_t_size: * This symbol holds the size of a Gid_t in bytes. */ #define Gid_t_size 4 /* GID size */ /* Gid_t: * This symbol holds the return type of getgid() and the type of * argument to setrgid() and related functions. Typically, * it is the type of group ids in the kernel. It can be int, ushort, * gid_t, etc... It may be necessary to include to get * any typedef'ed information. */ #define Gid_t gid_t /* Type for getgid(), etc... */ /* Groups_t: * This symbol holds the type used for the second argument to * getgroups() and setgroups(). Usually, this is the same as * gidtype (gid_t) , but sometimes it isn't. * It can be int, ushort, gid_t, etc... * It may be necessary to include to get any * typedef'ed information. This is only required if you have * getgroups() or setgroups().. */ #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS) #define Groups_t gid_t /* Type for 2nd arg to [sg]etgroups() */ #endif /* DB_Prefix_t: * This symbol contains the type of the prefix structure element * in the header file. In older versions of DB, it was * int, while in newer ones it is u_int32_t. */ /* DB_Hash_t: * This symbol contains the type of the prefix structure element * in the header file. In older versions of DB, it was * int, while in newer ones it is size_t. */ /* DB_VERSION_MAJOR_CFG: * This symbol, if defined, defines the major version number of * Berkeley DB found in the header when Perl was configured. */ /* DB_VERSION_MINOR_CFG: * This symbol, if defined, defines the minor version number of * Berkeley DB found in the header when Perl was configured. * For DB version 1 this is always 0. */ /* DB_VERSION_PATCH_CFG: * This symbol, if defined, defines the patch version number of * Berkeley DB found in the header when Perl was configured. * For DB version 1 this is always 0. */ #define DB_Hash_t int /**/ #define DB_Prefix_t int /**/ #define DB_VERSION_MAJOR_CFG undef /**/ #define DB_VERSION_MINOR_CFG undef /**/ #define DB_VERSION_PATCH_CFG undef /**/ /* I_FP_CLASS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_FP_CLASS /**/ /* I_GRP: * This symbol, if defined, indicates to the C program that it should * include . */ /* GRPASSWD: * This symbol, if defined, indicates to the C program that struct group * in contains gr_passwd. */ /*#define I_GRP /**/ /*#define GRPASSWD /**/ /* I_IEEEFP: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_IEEEFP /**/ /* I_INTTYPES: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_INTTYPES /**/ /* I_LIBUTIL: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_LIBUTIL /**/ /* I_MACH_CTHREADS: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_MACH_CTHREADS /**/ /* I_MNTENT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_MNTENT /**/ /* I_NETDB: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_NETDB /**/ /* I_NETINET_TCP: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_NETINET_TCP /**/ /* I_POLL: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_POLL /**/ /* I_PROT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_PROT /**/ /* I_PTHREAD: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_PTHREAD /**/ /* I_PWD: * This symbol, if defined, indicates to the C program that it should * include . */ /* PWQUOTA: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_quota. */ /* PWAGE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_age. */ /* PWCHANGE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_change. */ /* PWCLASS: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_class. */ /* PWEXPIRE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_expire. */ /* PWCOMMENT: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_comment. */ /* PWGECOS: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_gecos. */ /* PWPASSWD: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_passwd. */ /*#define I_PWD /**/ /*#define PWQUOTA /**/ /*#define PWAGE /**/ /*#define PWCHANGE /**/ /*#define PWCLASS /**/ /*#define PWEXPIRE /**/ /*#define PWCOMMENT /**/ /*#define PWGECOS /**/ /*#define PWPASSWD /**/ /* I_SHADOW: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SHADOW /**/ /* I_SOCKS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SOCKS /**/ /* I_SUNMATH: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SUNMATH /**/ /* I_SYSLOG: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSLOG /**/ /* I_SYSMODE: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSMODE /**/ /* I_SYS_MOUNT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYS_MOUNT /**/ /* I_SYS_STATFS: * This symbol, if defined, indicates that exists. */ /*#define I_SYS_STATFS /**/ /* I_SYS_STATVFS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYS_STATVFS /**/ /* I_SYSUIO: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSUIO /**/ /* I_SYSUTSNAME: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSUTSNAME /**/ /* I_SYS_VFS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYS_VFS /**/ /* I_TIME: * This symbol, if defined, indicates to the C program that it should * include . */ /* I_SYS_TIME: * This symbol, if defined, indicates to the C program that it should * include . */ /* I_SYS_TIME_KERNEL: * This symbol, if defined, indicates to the C program that it should * include with KERNEL defined. */ /* HAS_TM_TM_ZONE: * This symbol, if defined, indicates to the C program that * the struct tm has a tm_zone field. */ /* HAS_TM_TM_GMTOFF: * This symbol, if defined, indicates to the C program that * the struct tm has a tm_gmtoff field. */ /*#define I_TIME /**/ /*#define I_SYS_TIME /**/ /*#define I_SYS_TIME_KERNEL /**/ /*#define HAS_TM_TM_ZONE /**/ /*#define HAS_TM_TM_GMTOFF /**/ /* I_USTAT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_USTAT /**/ /* PERL_INC_VERSION_LIST: * This variable specifies the list of subdirectories in over * which perl.c:incpush() and lib/lib.pm will automatically * search when adding directories to @INC, in a format suitable * for a C initialization string. See the inc_version_list entry * in Porting/Glossary for more details. */ #define PERL_INC_VERSION_LIST 0 /**/ /* INSTALL_USR_BIN_PERL: * This symbol, if defined, indicates that Perl is to be installed * also as /usr/bin/perl. */ /*#define INSTALL_USR_BIN_PERL /**/ /* PERL_PRIfldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'f') for output. */ /* PERL_PRIgldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'g') for output. */ /* PERL_PRIeldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'e') for output. */ /* PERL_SCNfldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'f') for input. */ /*#define PERL_PRIfldbl "f" /**/ /*#define PERL_PRIgldbl "g" /**/ /*#define PERL_PRIeldbl "e" /**/ /*#define PERL_SCNfldbl undef /**/ /* Off_t: * This symbol holds the type used to declare offsets in the kernel. * It can be int, long, off_t, etc... It may be necessary to include * to get any typedef'ed information. */ /* LSEEKSIZE: * This symbol holds the number of bytes used by the Off_t. */ /* Off_t_size: * This symbol holds the number of bytes used by the Off_t. */ #define Off_t long /* type */ #define LSEEKSIZE 4 /* size */ #define Off_t_size 4 /* size */ /* Free_t: * This variable contains the return type of free(). It is usually * void, but occasionally int. */ /* Malloc_t: * This symbol is the type of pointer returned by malloc and realloc. */ #define Malloc_t void * /**/ #define Free_t void /**/ /* PERL_MALLOC_WRAP: * This symbol, if defined, indicates that we'd like malloc wrap checks. */ #define PERL_MALLOC_WRAP /**/ /* MYMALLOC: * This symbol, if defined, indicates that we're using our own malloc. */ #define MYMALLOC /**/ /* Mode_t: * This symbol holds the type used to declare file modes * for systems calls. It is usually mode_t, but may be * int or unsigned short. It may be necessary to include * to get any typedef'ed information. */ #define Mode_t mode_t /* file mode parameter for system calls */ /* VAL_O_NONBLOCK: * This symbol is to be used during open() or fcntl(F_SETFL) to turn on * non-blocking I/O for the file descriptor. Note that there is no way * back, i.e. you cannot turn it blocking again this way. If you wish to * alternatively switch between blocking and non-blocking, use the * ioctl(FIOSNBIO) call instead, but that is not supported by all devices. */ /* VAL_EAGAIN: * This symbol holds the errno error code set by read() when no data was * present on the non-blocking file descriptor. */ /* RD_NODATA: * This symbol holds the return code from read() when no data is present * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is * not defined, then you can't distinguish between no data and EOF by * issuing a read(). You'll have to find another way to tell for sure! */ /* EOF_NONBLOCK: * This symbol, if defined, indicates to the C program that a read() on * a non-blocking file descriptor will return 0 on EOF, and not the value * held in RD_NODATA (-1 usually, in that case!). */ #define VAL_O_NONBLOCK O_NONBLOCK #define VAL_EAGAIN EAGAIN #define RD_NODATA -1 #define EOF_NONBLOCK /* NEED_VA_COPY: * This symbol, if defined, indicates that the system stores * the variable argument list datatype, va_list, in a format * that cannot be copied by simple assignment, so that some * other means must be used when copying is required. * As such systems vary in their provision (or non-provision) * of copying mechanisms, handy.h defines a platform- * independent macro, Perl_va_copy(src, dst), to do the job. */ /*#define NEED_VA_COPY /**/ /* Netdb_host_t: * This symbol holds the type used for the 1st argument * to gethostbyaddr(). */ /* Netdb_hlen_t: * This symbol holds the type used for the 2nd argument * to gethostbyaddr(). */ /* Netdb_name_t: * This symbol holds the type used for the argument to * gethostbyname(). */ /* Netdb_net_t: * This symbol holds the type used for the 1st argument to * getnetbyaddr(). */ #define Netdb_host_t char * /**/ #define Netdb_hlen_t int /**/ #define Netdb_name_t char * /**/ #define Netdb_net_t long /**/ /* PERL_OTHERLIBDIRS: * This variable contains a colon-separated set of paths for the perl * binary to search for additional library files or modules. * These directories will be tacked to the end of @INC. * Perl will automatically search below each path for version- * and architecture-specific directories. See PERL_INC_VERSION_LIST * for more details. */ /*#define PERL_OTHERLIBDIRS "" /**/ /* HAS_QUAD: * This symbol, if defined, tells that there's a 64-bit integer type, * Quad_t, and its unsigned counterpar, Uquad_t. QUADKIND will be one * of QUAD_IS_INT, QUAD_IS_LONG, QUAD_IS_LONG_LONG, or QUAD_IS_INT64_T. */ /*#define HAS_QUAD /**/ #ifdef HAS_QUAD # define Quad_t __int64 /**/ # define Uquad_t unsigned __int64 /**/ # define QUADKIND 5 /**/ # define QUAD_IS_INT 1 # define QUAD_IS_LONG 2 # define QUAD_IS_LONG_LONG 3 # define QUAD_IS_INT64_T 4 #endif /* IVTYPE: * This symbol defines the C type used for Perl's IV. */ /* UVTYPE: * This symbol defines the C type used for Perl's UV. */ /* I8TYPE: * This symbol defines the C type used for Perl's I8. */ /* U8TYPE: * This symbol defines the C type used for Perl's U8. */ /* I16TYPE: * This symbol defines the C type used for Perl's I16. */ /* U16TYPE: * This symbol defines the C type used for Perl's U16. */ /* I32TYPE: * This symbol defines the C type used for Perl's I32. */ /* U32TYPE: * This symbol defines the C type used for Perl's U32. */ /* I64TYPE: * This symbol defines the C type used for Perl's I64. */ /* U64TYPE: * This symbol defines the C type used for Perl's U64. */ /* NVTYPE: * This symbol defines the C type used for Perl's NV. */ /* IVSIZE: * This symbol contains the sizeof(IV). */ /* UVSIZE: * This symbol contains the sizeof(UV). */ /* I8SIZE: * This symbol contains the sizeof(I8). */ /* U8SIZE: * This symbol contains the sizeof(U8). */ /* I16SIZE: * This symbol contains the sizeof(I16). */ /* U16SIZE: * This symbol contains the sizeof(U16). */ /* I32SIZE: * This symbol contains the sizeof(I32). */ /* U32SIZE: * This symbol contains the sizeof(U32). */ /* I64SIZE: * This symbol contains the sizeof(I64). */ /* U64SIZE: * This symbol contains the sizeof(U64). */ /* NVSIZE: * This symbol contains the sizeof(NV). */ /* NV_PRESERVES_UV: * This symbol, if defined, indicates that a variable of type NVTYPE * can preserve all the bits of a variable of type UVTYPE. */ /* NV_PRESERVES_UV_BITS: * This symbol contains the number of bits a variable of type NVTYPE * can preserve of a variable of type UVTYPE. */ /* NV_OVERFLOWS_INTEGERS_AT * This symbol gives the largest integer value that NVs can hold. This * value + 1.0 cannot be stored accurately. It is expressed as constant * floating point expression to reduce the chance of decimale/binary * conversion issues. If it can not be determined, the value 0 is given. */ /* NV_ZERO_IS_ALLBITS_ZERO * This symbol, if defined, indicates that a variable of type NVTYPE * stores 0.0 in memory as all bits zero. */ #define IVTYPE long /**/ #define UVTYPE unsigned long /**/ #define I8TYPE char /**/ #define U8TYPE unsigned char /**/ #define I16TYPE short /**/ #define U16TYPE unsigned short /**/ #define I32TYPE long /**/ #define U32TYPE unsigned long /**/ #ifdef HAS_QUAD #define I64TYPE __int64 /**/ #define U64TYPE unsigned __int64 /**/ #endif #define NVTYPE double /**/ #define IVSIZE 4 /**/ #define UVSIZE 4 /**/ #define I8SIZE 1 /**/ #define U8SIZE 1 /**/ #define I16SIZE 2 /**/ #define U16SIZE 2 /**/ #define I32SIZE 4 /**/ #define U32SIZE 4 /**/ #ifdef HAS_QUAD #define I64SIZE 8 /**/ #define U64SIZE 8 /**/ #endif #define NVSIZE 8 /**/ #define NV_PRESERVES_UV #define NV_PRESERVES_UV_BITS undef #define NV_OVERFLOWS_INTEGERS_AT 256.0*256.0*256.0*256.0*256.0*256.0*2.0*2.0*2.0*2.0*2.0 #undef NV_ZERO_IS_ALLBITS_ZERO #if UVSIZE == 8 # ifdef BYTEORDER # if BYTEORDER == 0x1234 # undef BYTEORDER # define BYTEORDER 0x12345678 # else # if BYTEORDER == 0x4321 # undef BYTEORDER # define BYTEORDER 0x87654321 # endif # endif # endif #endif /* IVdf: * This symbol defines the format string used for printing a Perl IV * as a signed decimal integer. */ /* UVuf: * This symbol defines the format string used for printing a Perl UV * as an unsigned decimal integer. */ /* UVof: * This symbol defines the format string used for printing a Perl UV * as an unsigned octal integer. */ /* UVxf: * This symbol defines the format string used for printing a Perl UV * as an unsigned hexadecimal integer in lowercase abcdef. */ /* UVXf: * This symbol defines the format string used for printing a Perl UV * as an unsigned hexadecimal integer in uppercase ABCDEF. */ /* NVef: * This symbol defines the format string used for printing a Perl NV * using %e-ish floating point format. */ /* NVff: * This symbol defines the format string used for printing a Perl NV * using %f-ish floating point format. */ /* NVgf: * This symbol defines the format string used for printing a Perl NV * using %g-ish floating point format. */ #define IVdf "ld" /**/ #define UVuf "lu" /**/ #define UVof "lo" /**/ #define UVxf "lx" /**/ #define UVXf "lX" /**/ #define NVef "e" /**/ #define NVff "f" /**/ #define NVgf "g" /**/ /* Pid_t: * This symbol holds the type used to declare process ids in the kernel. * It can be int, uint, pid_t, etc... It may be necessary to include * to get any typedef'ed information. */ #define Pid_t int /* PID type */ /* PRIVLIB: * This symbol contains the name of the private library for this package. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. The program * should be prepared to do ~ expansion. */ /* PRIVLIB_EXP: * This symbol contains the ~name expanded version of PRIVLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ #define PRIVLIB "\\Storage Card\\perl58m\\lib" /**/ #define PRIVLIB_EXP (win32_get_privlib(PERL_VERSION_STRING, NULL)) /**/ /* PTRSIZE: * This symbol contains the size of a pointer, so that the C preprocessor * can make decisions based on it. It will be sizeof(void *) if * the compiler supports (void *); otherwise it will be * sizeof(char *). */ #define PTRSIZE 4 /**/ /* Drand01: * This macro is to be used to generate uniformly distributed * random numbers over the range [0., 1.[. You may have to supply * an 'extern double drand48();' in your program since SunOS 4.1.3 * doesn't provide you with anything relevant in its headers. * See HAS_DRAND48_PROTO. */ /* Rand_seed_t: * This symbol defines the type of the argument of the * random seed function. */ /* seedDrand01: * This symbol defines the macro to be used in seeding the * random number generator (see Drand01). */ /* RANDBITS: * This symbol indicates how many bits are produced by the * function used to generate normalized random numbers. * Values include 15, 16, 31, and 48. */ #define Drand01() (rand()/(double)((unsigned)1< to get any typedef'ed information. */ #define Size_t size_t /* length paramater for string functions */ /* Sock_size_t: * This symbol holds the type used for the size argument of * various socket calls (just the base type, not the pointer-to). */ #define Sock_size_t int /**/ /* SSize_t: * This symbol holds the type used by functions that return * a count of bytes or an error condition. It must be a signed type. * It is usually ssize_t, but may be long or int, etc. * It may be necessary to include or * to get any typedef'ed information. * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t). */ #define SSize_t int /* signed count of bytes */ /* STARTPERL: * This variable contains the string to put in front of a perl * script to make sure (one hopes) that it runs with perl and not * some shell. */ #define STARTPERL "#!perl" /**/ /* STDCHAR: * This symbol is defined to be the type of char used in stdio.h. * It has the values "unsigned char" or "char". */ #define STDCHAR char /**/ /* HAS_STDIO_STREAM_ARRAY: * This symbol, if defined, tells that there is an array * holding the stdio streams. */ /* STDIO_STREAM_ARRAY: * This symbol tells the name of the array holding the stdio streams. * Usual values include _iob, __iob, and __sF. */ /*#define HAS_STDIO_STREAM_ARRAY /**/ #define STDIO_STREAM_ARRAY /* Uid_t_f: * This symbol defines the format string used for printing a Uid_t. */ #define Uid_t_f "ld" /**/ /* Uid_t_sign: * This symbol holds the signedess of a Uid_t. * 1 for unsigned, -1 for signed. */ #define Uid_t_sign -1 /* UID sign */ /* Uid_t_size: * This symbol holds the size of a Uid_t in bytes. */ #define Uid_t_size 4 /* UID size */ /* Uid_t: * This symbol holds the type used to declare user ids in the kernel. * It can be int, ushort, uid_t, etc... It may be necessary to include * to get any typedef'ed information. */ #define Uid_t uid_t /* UID type */ /* USE_64_BIT_INT: * This symbol, if defined, indicates that 64-bit integers should * be used when available. If not defined, the native integers * will be employed (be they 32 or 64 bits). The minimal possible * 64-bitness is used, just enough to get 64-bit integers into Perl. * This may mean using for example "long longs", while your memory * may still be limited to 2 gigabytes. */ /* USE_64_BIT_ALL: * This symbol, if defined, indicates that 64-bit integers should * be used when available. If not defined, the native integers * will be used (be they 32 or 64 bits). The maximal possible * 64-bitness is employed: LP64 or ILP64, meaning that you will * be able to use more than 2 gigabytes of memory. This mode is * even more binary incompatible than USE_64_BIT_INT. You may not * be able to run the resulting executable in a 32-bit CPU at all or * you may need at least to reboot your OS to 64-bit mode. */ #ifndef USE_64_BIT_INT /*#define USE_64_BIT_INT /**/ #endif #ifndef USE_64_BIT_ALL /*#define USE_64_BIT_ALL /**/ #endif /* USE_LARGE_FILES: * This symbol, if defined, indicates that large file support * should be used when available. */ #ifndef USE_LARGE_FILES /*#define USE_LARGE_FILES /**/ #endif /* USE_LONG_DOUBLE: * This symbol, if defined, indicates that long doubles should * be used when available. */ #ifndef USE_LONG_DOUBLE /*#define USE_LONG_DOUBLE /**/ #endif /* USE_MORE_BITS: * This symbol, if defined, indicates that 64-bit interfaces and * long doubles should be used when available. */ #ifndef USE_MORE_BITS /*#define USE_MORE_BITS /**/ #endif /* MULTIPLICITY: * This symbol, if defined, indicates that Perl should * be built to use multiplicity. */ #ifndef MULTIPLICITY /*#define MULTIPLICITY /**/ #endif /* USE_PERLIO: * This symbol, if defined, indicates that the PerlIO abstraction should * be used throughout. If not defined, stdio should be * used in a fully backward compatible manner. */ #ifndef USE_PERLIO #define USE_PERLIO /**/ #endif /* USE_SOCKS: * This symbol, if defined, indicates that Perl should * be built to use socks. */ #ifndef USE_SOCKS /*#define USE_SOCKS /**/ #endif /* USE_ITHREADS: * This symbol, if defined, indicates that Perl should be built to * use the interpreter-based threading implementation. */ /* USE_5005THREADS: * This symbol, if defined, indicates that Perl should be built to * use the 5.005-based threading implementation. */ /* OLD_PTHREADS_API: * This symbol, if defined, indicates that Perl should * be built to use the old draft POSIX threads API. */ /* USE_REENTRANT_API: * This symbol, if defined, indicates that Perl should * try to use the various _r versions of library functions. * This is extremely experimental. */ /*#define USE_5005THREADS /**/ /*#define USE_ITHREADS /**/ #if defined(USE_5005THREADS) && !defined(USE_ITHREADS) #define USE_THREADS /* until src is revised*/ #endif /*#define OLD_PTHREADS_API /**/ /*#define USE_REENTRANT_API /**/ /* USE_DTRACE * This symbol, if defined, indicates that Perl should * be built with support for DTrace. */ /*#define USE_DTRACE / **/ /* PERL_VENDORARCH: * If defined, this symbol contains the name of a private library. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. * It may have a ~ on the front. * The standard distribution will put nothing in this directory. * Vendors who distribute perl may wish to place their own * architecture-dependent modules and extensions in this directory with * MakeMaker Makefile.PL INSTALLDIRS=vendor * or equivalent. See INSTALL for details. */ /* PERL_VENDORARCH_EXP: * This symbol contains the ~name expanded version of PERL_VENDORARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ /*#define PERL_VENDORARCH "" /**/ /*#define PERL_VENDORARCH_EXP "" /**/ /* PERL_VENDORLIB_EXP: * This symbol contains the ~name expanded version of VENDORLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ /* PERL_VENDORLIB_STEM: * This define is PERL_VENDORLIB_EXP with any trailing version-specific component * removed. The elements in inc_version_list (inc_version_list.U) can * be tacked onto this variable to generate a list of directories to search. */ /*#define PERL_VENDORLIB_EXP "" /**/ /*#define PERL_VENDORLIB_STEM "" /**/ /* VOIDFLAGS: * This symbol indicates how much support of the void type is given by this * compiler. What various bits mean: * * 1 = supports declaration of void * 2 = supports arrays of pointers to functions returning void * 4 = supports comparisons between pointers to void functions and * addresses of void functions * 8 = suports declaration of generic void pointers * * The package designer should define VOIDUSED to indicate the requirements * of the package. This can be done either by #defining VOIDUSED before * including config.h, or by defining defvoidused in Myinit.U. If the * latter approach is taken, only those flags will be tested. If the * level of void support necessary is not present, defines void to int. */ #ifndef VOIDUSED #define VOIDUSED 15 #endif #define VOIDFLAGS 15 #if (VOIDFLAGS & VOIDUSED) != VOIDUSED #define void int /* is void to be avoided? */ #define M_VOID /* Xenix strikes again */ #endif /* HASATTRIBUTE_FORMAT: * Can we handle GCC attribute for checking printf-style formats */ /* HASATTRIBUTE_MALLOC: * Can we handle GCC attribute for malloc-style functions. */ /* HASATTRIBUTE_NONNULL: * Can we handle GCC attribute for nonnull function parms. */ /* HASATTRIBUTE_NORETURN: * Can we handle GCC attribute for functions that do not return */ /* HASATTRIBUTE_PURE: * Can we handle GCC attribute for pure functions */ /* HASATTRIBUTE_UNUSED: * Can we handle GCC attribute for unused variables and arguments */ /* HASATTRIBUTE_WARN_UNUSED_RESULT: * Can we handle GCC attribute for warning on unused results */ /*#define HASATTRIBUTE_FORMAT /**/ /*#define HASATTRIBUTE_NORETURN /**/ /*#define HASATTRIBUTE_MALLOC /**/ /*#define HASATTRIBUTE_NONNULL /**/ /*#define HASATTRIBUTE_PURE /**/ /*#define HASATTRIBUTE_UNUSED /**/ /*#define HASATTRIBUTE_WARN_UNUSED_RESULT /**/ /* HAS_CRYPT: * This symbol, if defined, indicates that the crypt routine is available * to encrypt passwords and the like. */ /*#define HAS_CRYPT /**/ /* SETUID_SCRIPTS_ARE_SECURE_NOW: * This symbol, if defined, indicates that the bug that prevents * setuid scripts from being secure is not present in this kernel. */ /* DOSUID: * This symbol, if defined, indicates that the C program should * check the script that it is executing for setuid/setgid bits, and * attempt to emulate setuid/setgid on systems that have disabled * setuid #! scripts because the kernel can't do it securely. * It is up to the package designer to make sure that this emulation * is done securely. Among other things, it should do an fstat on * the script it just opened to make sure it really is a setuid/setgid * script, it should make sure the arguments passed correspond exactly * to the argument on the #! line, and it should not trust any * subprocesses to which it must pass the filename rather than the * file descriptor of the script to be executed. */ /*#define SETUID_SCRIPTS_ARE_SECURE_NOW /**/ /*#define DOSUID /**/ /* Shmat_t: * This symbol holds the return type of the shmat() system call. * Usually set to 'void *' or 'char *'. */ /* HAS_SHMAT_PROTOTYPE: * This symbol, if defined, indicates that the sys/shm.h includes * a prototype for shmat(). Otherwise, it is up to the program to * guess one. Shmat_t shmat(int, Shmat_t, int) is a good guess, * but not always right so it should be emitted by the program only * when HAS_SHMAT_PROTOTYPE is not defined to avoid conflicting defs. */ #define Shmat_t void * /**/ /*#define HAS_SHMAT_PROTOTYPE /**/ /* I_NDBM: * This symbol, if defined, indicates that exists and should * be included. */ /*#define I_NDBM /**/ /* I_STDARG: * This symbol, if defined, indicates that exists and should * be included. */ /* I_VARARGS: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_STDARG /**/ /*#define I_VARARGS /**/ /* CAN_PROTOTYPE: * If defined, this macro indicates that the C compiler can handle * function prototypes. */ /* _: * This macro is used to declare function parameters for folks who want * to make declarations with prototypes using a different style than * the above macros. Use double parentheses. For example: * * int main _((int argc, char *argv[])); */ #define CAN_PROTOTYPE /**/ #ifdef CAN_PROTOTYPE #define _(args) args #else #define _(args) () #endif /* SH_PATH: * This symbol contains the full pathname to the shell used on this * on this system to execute Bourne shell scripts. Usually, this will be * /bin/sh, though it's possible that some systems will have /bin/ksh, * /bin/pdksh, /bin/ash, /bin/bash, or even something such as * D:/bin/sh.exe. */ #define SH_PATH "cmd /x /c" /**/ /* HAS_AINTL: * This symbol, if defined, indicates that the aintl routine is * available. If copysignl is also present we can emulate modfl. */ /*#define HAS_AINTL /**/ /* HAS_CLEARENV: * This symbol, if defined, indicates that the clearenv () routine is * available for use. */ /*#define HAS_CLEARENV /**/ /* HAS_COPYSIGNL: * This symbol, if defined, indicates that the copysignl routine is * available. If aintl is also present we can emulate modfl. */ /*#define HAS_COPYSIGNL /**/ /* USE_CPLUSPLUS: * This symbol, if defined, indicates that a C++ compiler was * used to compiled Perl and will be used to compile extensions. */ /*#define USE_CPLUSPLUS /**/ /* HAS_DBMINIT_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the dbminit() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int dbminit(char *); */ /*#define HAS_DBMINIT_PROTO /**/ /* HAS_DIRFD: * This manifest constant lets the C program know that dirfd * is available. */ /*#define HAS_DIRFD /**/ /* HAS_FAST_STDIO: * This symbol, if defined, indicates that the "fast stdio" * is available to manipulate the stdio buffers directly. */ /*#define HAS_FAST_STDIO /**/ /* HAS_FLOCK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the flock() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int flock(int, int); */ /*#define HAS_FLOCK_PROTO /**/ /* HAS_FPCLASSL: * This symbol, if defined, indicates that the fpclassl routine is * available to classify long doubles. Available for example in IRIX. * The returned values are defined in and are: * * FP_SNAN signaling NaN * FP_QNAN quiet NaN * FP_NINF negative infinity * FP_PINF positive infinity * FP_NDENORM negative denormalized non-zero * FP_PDENORM positive denormalized non-zero * FP_NZERO negative zero * FP_PZERO positive zero * FP_NNORM negative normalized non-zero * FP_PNORM positive normalized non-zero */ /*#define HAS_FPCLASSL /**/ /* HAS_ILOGBL: * This symbol, if defined, indicates that the ilogbl routine is * available. If scalbnl is also present we can emulate frexpl. */ /*#define HAS_ILOGBL /**/ /* LIBM_LIB_VERSION: * This symbol, if defined, indicates that libm exports _LIB_VERSION * and that math.h defines the enum to manipulate it. */ /*#define LIBM_LIB_VERSION /**/ /* HAS_NL_LANGINFO: * This symbol, if defined, indicates that the nl_langinfo routine is * available to return local data. You will also need * and therefore I_LANGINFO. */ /*#define HAS_NL_LANGINFO /**/ /* HAS_PROCSELFEXE: * This symbol is defined if PROCSELFEXE_PATH is a symlink * to the absolute pathname of the executing program. */ /* PROCSELFEXE_PATH: * If HAS_PROCSELFEXE is defined this symbol is the filename * of the symbolic link pointing to the absolute pathname of * the executing program. */ /*#define HAS_PROCSELFEXE /**/ #if defined(HAS_PROCSELFEXE) && !defined(PROCSELFEXE_PATH) #define PROCSELFEXE_PATH /**/ #endif /* HAS_PTHREAD_ATTR_SETSCOPE: * This symbol, if defined, indicates that the pthread_attr_setscope * system call is available to set the contention scope attribute of * a thread attribute object. */ /*#define HAS_PTHREAD_ATTR_SETSCOPE /**/ /* HAS_SCALBNL: * This symbol, if defined, indicates that the scalbnl routine is * available. If ilogbl is also present we can emulate frexpl. */ /*#define HAS_SCALBNL /**/ /* HAS_SIGPROCMASK: * This symbol, if defined, indicates that the sigprocmask * system call is available to examine or change the signal mask * of the calling process. */ /*#define HAS_SIGPROCMASK /**/ /* HAS_SOCKATMARK: * This symbol, if defined, indicates that the sockatmark routine is * available to test whether a socket is at the out-of-band mark. */ /*#define HAS_SOCKATMARK /**/ /* HAS_SOCKATMARK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the sockatmark() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int sockatmark(int); */ /*#define HAS_SOCKATMARK_PROTO /**/ /* SPRINTF_RETURNS_STRLEN: * This variable defines whether sprintf returns the length of the string * (as per the ANSI spec). Some C libraries retain compatibility with * pre-ANSI C and return a pointer to the passed in buffer; for these * this variable will be undef. */ #define SPRINTF_RETURNS_STRLEN /**/ /* HAS_SETRESGID_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the setresgid() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern int setresgid(uid_t ruid, uid_t euid, uid_t suid); */ /*#define HAS_SETRESGID_PROTO /**/ /* HAS_SETRESUID_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the setresuid() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern int setresuid(uid_t ruid, uid_t euid, uid_t suid); */ /*#define HAS_SETRESUID_PROTO /**/ /* HAS_STRFTIME: * This symbol, if defined, indicates that the strftime routine is * available to do time formatting. */ /*#define HAS_STRFTIME /**/ /* HAS_STRLCAT: * This symbol, if defined, indicates that the strlcat () routine is * available to do string concatenation. */ /*#define HAS_STRLCAT /**/ /* HAS_STRLCPY: * This symbol, if defined, indicates that the strlcpy () routine is * available to do string copying. */ /*#define HAS_STRLCPY /**/ /* HAS_SYSCALL_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the syscall() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern int syscall(int, ...); * extern int syscall(long, ...); */ /*#define HAS_SYSCALL_PROTO /**/ /* U32_ALIGNMENT_REQUIRED: * This symbol, if defined, indicates that you must access * character data through U32-aligned pointers. */ #ifndef U32_ALIGNMENT_REQUIRED /*#define U32_ALIGNMENT_REQUIRED /**/ #endif /* HAS_USLEEP_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the usleep() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int usleep(useconds_t); */ /*#define HAS_USLEEP_PROTO /**/ /* I_CRYPT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_CRYPT /**/ /* I_FP: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_FP /**/ /* I_LANGINFO: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_LANGINFO /**/ /* USE_FAST_STDIO: * This symbol, if defined, indicates that Perl should * be built to use 'fast stdio'. * Defaults to define in Perls 5.8 and earlier, to undef later. */ #ifndef USE_FAST_STDIO /*#define USE_FAST_STDIO /**/ #endif /* PERL_RELOCATABLE_INC: * This symbol, if defined, indicates that we'd like to relocate entries * in @INC at run time based on the location of the perl binary. */ #define PERL_RELOCATABLE_INC "undef" /**/ /* HAS_CTERMID_R: * This symbol, if defined, indicates that the ctermid_r routine * is available to ctermid re-entrantly. */ /* CTERMID_R_PROTO: * This symbol encodes the prototype of ctermid_r. * It is zero if d_ctermid_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ctermid_r * is defined. */ /*#define HAS_CTERMID_R /**/ #define CTERMID_R_PROTO 0 /**/ /* HAS_ENDHOSTENT_R: * This symbol, if defined, indicates that the endhostent_r routine * is available to endhostent re-entrantly. */ /* ENDHOSTENT_R_PROTO: * This symbol encodes the prototype of endhostent_r. * It is zero if d_endhostent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endhostent_r * is defined. */ /*#define HAS_ENDHOSTENT_R /**/ #define ENDHOSTENT_R_PROTO 0 /**/ /* HAS_ENDNETENT_R: * This symbol, if defined, indicates that the endnetent_r routine * is available to endnetent re-entrantly. */ /* ENDNETENT_R_PROTO: * This symbol encodes the prototype of endnetent_r. * It is zero if d_endnetent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endnetent_r * is defined. */ /*#define HAS_ENDNETENT_R /**/ #define ENDNETENT_R_PROTO 0 /**/ /* HAS_ENDPROTOENT_R: * This symbol, if defined, indicates that the endprotoent_r routine * is available to endprotoent re-entrantly. */ /* ENDPROTOENT_R_PROTO: * This symbol encodes the prototype of endprotoent_r. * It is zero if d_endprotoent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endprotoent_r * is defined. */ /*#define HAS_ENDPROTOENT_R /**/ #define ENDPROTOENT_R_PROTO 0 /**/ /* HAS_ENDSERVENT_R: * This symbol, if defined, indicates that the endservent_r routine * is available to endservent re-entrantly. */ /* ENDSERVENT_R_PROTO: * This symbol encodes the prototype of endservent_r. * It is zero if d_endservent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endservent_r * is defined. */ /*#define HAS_ENDSERVENT_R /**/ #define ENDSERVENT_R_PROTO 0 /**/ /* HAS_GETHOSTBYADDR_R: * This symbol, if defined, indicates that the gethostbyaddr_r routine * is available to gethostbyaddr re-entrantly. */ /* GETHOSTBYADDR_R_PROTO: * This symbol encodes the prototype of gethostbyaddr_r. * It is zero if d_gethostbyaddr_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostbyaddr_r * is defined. */ /*#define HAS_GETHOSTBYADDR_R /**/ #define GETHOSTBYADDR_R_PROTO 0 /**/ /* HAS_GETHOSTBYNAME_R: * This symbol, if defined, indicates that the gethostbyname_r routine * is available to gethostbyname re-entrantly. */ /* GETHOSTBYNAME_R_PROTO: * This symbol encodes the prototype of gethostbyname_r. * It is zero if d_gethostbyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostbyname_r * is defined. */ /*#define HAS_GETHOSTBYNAME_R /**/ #define GETHOSTBYNAME_R_PROTO 0 /**/ /* HAS_GETHOSTENT_R: * This symbol, if defined, indicates that the gethostent_r routine * is available to gethostent re-entrantly. */ /* GETHOSTENT_R_PROTO: * This symbol encodes the prototype of gethostent_r. * It is zero if d_gethostent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostent_r * is defined. */ /*#define HAS_GETHOSTENT_R /**/ #define GETHOSTENT_R_PROTO 0 /**/ /* HAS_GETNETBYADDR_R: * This symbol, if defined, indicates that the getnetbyaddr_r routine * is available to getnetbyaddr re-entrantly. */ /* GETNETBYADDR_R_PROTO: * This symbol encodes the prototype of getnetbyaddr_r. * It is zero if d_getnetbyaddr_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetbyaddr_r * is defined. */ /*#define HAS_GETNETBYADDR_R /**/ #define GETNETBYADDR_R_PROTO 0 /**/ /* HAS_GETNETBYNAME_R: * This symbol, if defined, indicates that the getnetbyname_r routine * is available to getnetbyname re-entrantly. */ /* GETNETBYNAME_R_PROTO: * This symbol encodes the prototype of getnetbyname_r. * It is zero if d_getnetbyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetbyname_r * is defined. */ /*#define HAS_GETNETBYNAME_R /**/ #define GETNETBYNAME_R_PROTO 0 /**/ /* HAS_GETNETENT_R: * This symbol, if defined, indicates that the getnetent_r routine * is available to getnetent re-entrantly. */ /* GETNETENT_R_PROTO: * This symbol encodes the prototype of getnetent_r. * It is zero if d_getnetent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetent_r * is defined. */ /*#define HAS_GETNETENT_R /**/ #define GETNETENT_R_PROTO 0 /**/ /* HAS_GETPROTOBYNAME_R: * This symbol, if defined, indicates that the getprotobyname_r routine * is available to getprotobyname re-entrantly. */ /* GETPROTOBYNAME_R_PROTO: * This symbol encodes the prototype of getprotobyname_r. * It is zero if d_getprotobyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotobyname_r * is defined. */ /*#define HAS_GETPROTOBYNAME_R /**/ #define GETPROTOBYNAME_R_PROTO 0 /**/ /* HAS_GETPROTOBYNUMBER_R: * This symbol, if defined, indicates that the getprotobynumber_r routine * is available to getprotobynumber re-entrantly. */ /* GETPROTOBYNUMBER_R_PROTO: * This symbol encodes the prototype of getprotobynumber_r. * It is zero if d_getprotobynumber_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotobynumber_r * is defined. */ /*#define HAS_GETPROTOBYNUMBER_R /**/ #define GETPROTOBYNUMBER_R_PROTO 0 /**/ /* HAS_GETPROTOENT_R: * This symbol, if defined, indicates that the getprotoent_r routine * is available to getprotoent re-entrantly. */ /* GETPROTOENT_R_PROTO: * This symbol encodes the prototype of getprotoent_r. * It is zero if d_getprotoent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotoent_r * is defined. */ /*#define HAS_GETPROTOENT_R /**/ #define GETPROTOENT_R_PROTO 0 /**/ /* HAS_GETSERVBYNAME_R: * This symbol, if defined, indicates that the getservbyname_r routine * is available to getservbyname re-entrantly. */ /* GETSERVBYNAME_R_PROTO: * This symbol encodes the prototype of getservbyname_r. * It is zero if d_getservbyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservbyname_r * is defined. */ /*#define HAS_GETSERVBYNAME_R /**/ #define GETSERVBYNAME_R_PROTO 0 /**/ /* HAS_GETSERVBYPORT_R: * This symbol, if defined, indicates that the getservbyport_r routine * is available to getservbyport re-entrantly. */ /* GETSERVBYPORT_R_PROTO: * This symbol encodes the prototype of getservbyport_r. * It is zero if d_getservbyport_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservbyport_r * is defined. */ /*#define HAS_GETSERVBYPORT_R /**/ #define GETSERVBYPORT_R_PROTO 0 /**/ /* HAS_GETSERVENT_R: * This symbol, if defined, indicates that the getservent_r routine * is available to getservent re-entrantly. */ /* GETSERVENT_R_PROTO: * This symbol encodes the prototype of getservent_r. * It is zero if d_getservent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservent_r * is defined. */ /*#define HAS_GETSERVENT_R /**/ #define GETSERVENT_R_PROTO 0 /**/ /* HAS_PTHREAD_ATFORK: * This symbol, if defined, indicates that the pthread_atfork routine * is available to setup fork handlers. */ /*#define HAS_PTHREAD_ATFORK /**/ /* HAS_READDIR64_R: * This symbol, if defined, indicates that the readdir64_r routine * is available to readdir64 re-entrantly. */ /* READDIR64_R_PROTO: * This symbol encodes the prototype of readdir64_r. * It is zero if d_readdir64_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_readdir64_r * is defined. */ /*#define HAS_READDIR64_R /**/ #define READDIR64_R_PROTO 0 /**/ /* HAS_SETHOSTENT_R: * This symbol, if defined, indicates that the sethostent_r routine * is available to sethostent re-entrantly. */ /* SETHOSTENT_R_PROTO: * This symbol encodes the prototype of sethostent_r. * It is zero if d_sethostent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_sethostent_r * is defined. */ /*#define HAS_SETHOSTENT_R /**/ #define SETHOSTENT_R_PROTO 0 /**/ /* HAS_SETLOCALE_R: * This symbol, if defined, indicates that the setlocale_r routine * is available to setlocale re-entrantly. */ /* SETLOCALE_R_PROTO: * This symbol encodes the prototype of setlocale_r. * It is zero if d_setlocale_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setlocale_r * is defined. */ /*#define HAS_SETLOCALE_R /**/ #define SETLOCALE_R_PROTO 0 /**/ /* HAS_SETNETENT_R: * This symbol, if defined, indicates that the setnetent_r routine * is available to setnetent re-entrantly. */ /* SETNETENT_R_PROTO: * This symbol encodes the prototype of setnetent_r. * It is zero if d_setnetent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setnetent_r * is defined. */ /*#define HAS_SETNETENT_R /**/ #define SETNETENT_R_PROTO 0 /**/ /* HAS_SETPROTOENT_R: * This symbol, if defined, indicates that the setprotoent_r routine * is available to setprotoent re-entrantly. */ /* SETPROTOENT_R_PROTO: * This symbol encodes the prototype of setprotoent_r. * It is zero if d_setprotoent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setprotoent_r * is defined. */ /*#define HAS_SETPROTOENT_R /**/ #define SETPROTOENT_R_PROTO 0 /**/ /* HAS_SETSERVENT_R: * This symbol, if defined, indicates that the setservent_r routine * is available to setservent re-entrantly. */ /* SETSERVENT_R_PROTO: * This symbol encodes the prototype of setservent_r. * It is zero if d_setservent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setservent_r * is defined. */ /*#define HAS_SETSERVENT_R /**/ #define SETSERVENT_R_PROTO 0 /**/ /* HAS_TTYNAME_R: * This symbol, if defined, indicates that the ttyname_r routine * is available to ttyname re-entrantly. */ /* TTYNAME_R_PROTO: * This symbol encodes the prototype of ttyname_r. * It is zero if d_ttyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ttyname_r * is defined. */ /*#define HAS_TTYNAME_R /**/ #define TTYNAME_R_PROTO 0 /**/ #endif perl-5.12.0-RC0/win32/wince.h0000444000175000017500000000724311325125742014355 0ustar jessejesse/* wince.h */ /* Time-stamp: <01/08/01 20:48:08 keuchel@w2k> */ /* This file includes extracts from the celib-headers, because */ /* the celib-headers produces macro conflicts with defines in */ /* win32iop.h etc */ #ifndef WINCE_H #define WINCE_H 1 #include "celib_defs.h" /* include local copies of celib headers... */ #include "errno.h" #include "sys/stat.h" #include "time.h" #include "cectype.h" #ifndef START_EXTERN_C #undef EXTERN_C #ifdef __cplusplus # define START_EXTERN_C extern "C" { # define END_EXTERN_C } # define EXTERN_C extern "C" #else # define START_EXTERN_C # define END_EXTERN_C # define EXTERN_C #endif #endif START_EXTERN_C #ifndef _IOFBF #define _IOFBF 0x0000 #endif #ifndef _IOLBF #define _IOLBF 0x0040 #endif #ifndef _IONBF #define _IONBF 0x0004 #endif #if UNDER_CE <= 200 XCE_EXPORT double xceatof(const char *); XCE_EXPORT int xcetoupper(int c); XCE_EXPORT int xcetolower(int c); #define atof xceatof #define toupper xcetoupper #define tolower xcetolower #else XCE_EXPORT double atof(const char *); #endif XCE_EXPORT void XCEShowMessageA(const char *fmt, ...); #define time xcetime #define gmtime xcegmtime #define localtime xcelocaltime #define asctime xceasctime /* #define utime xceutime */ #define futime xcefutime #define ftime xceftime #define ctime xcectime #define gettimeofday xcegettimeofday #define GetSystemTimeAsFileTime XCEGetSystemTimeAsFileTime #define setuid xcesetuid #define getuid xcegetuid #define geteuid xcegeteuid #define seteuid xceseteuid #define setgid xcesetgid #define getgid xcegetgid #define getegid xcegetegid #define setegid xcesetegid XCE_EXPORT int xcechown(const char *filename, int owner, int group); #define chown xcechown XCE_EXPORT char *xcestrrchr(const char * string, int ch); #define strrchr xcestrrchr XCE_EXPORT void (*xcesignal(int, void (*)(int)))(int); XCE_EXPORT int xceraise(int); #define signal xcesignal #define raise xceraise XCE_EXPORT int xcecreat(const char *filename, int pmode); XCE_EXPORT int xceopen(const char *fname, int mode, ...); XCE_EXPORT int xceread(int fd, void *buf, int size); XCE_EXPORT int xcewrite(int fd, void *buf, int size); XCE_EXPORT int xceclose(int fd); XCE_EXPORT off_t xcelseek(int fd, int off, int whence); XCE_EXPORT char *xcestrupr(char *string); XCE_EXPORT char *xcestrlwr(char *string); #define strupr xcestrupr #define strlwr xcestrlwr XCE_EXPORT double xcestrtod(const char *s, char **errorptr); XCE_EXPORT long xcestrtol(const char *s, char **errorptr, int base); XCE_EXPORT unsigned long xcestrtoul(const char *s, char **errorptr, int base); #define strtod xcestrtod #define strtol xcestrtol #define strtoul xcestrtoul XCE_EXPORT int xcestrnicmp(const char *first, const char *last, size_t count); #define strnicmp xcestrnicmp XCE_EXPORT int xceumask(int mask); #define umask xceumask XCE_EXPORT int xceisatty(int fd); #define isatty xceisatty XCE_EXPORT int xcechsize(int fd, unsigned long size); #define chsize xcechsize XCE_EXPORT char *xcegetlogin(); #define getlogin xcegetlogin XCE_EXPORT DWORD XCEAPI XCEGetModuleFileNameA(HMODULE hModule, LPTSTR lpName, DWORD nSize); XCE_EXPORT HMODULE XCEAPI XCEGetModuleHandleA(const char *lpName); XCE_EXPORT FARPROC XCEAPI XCEGetProcAddressA(HMODULE hMod, const char *name); /* //////////////////////////////////////////////////////////////////// */ #define getgid xcegetgid #define getegid xcegetegid #define geteuid xcegeteuid #define setgid xcesetgid #define strupr xcestrupr #define time xcetime XCE_EXPORT BOOL XCEFreeEnvironmentStrings(LPCSTR buf); #define GetEnvironmentStrings XCEGetEnvironmentStrings #define FreeEnvironmentStrings XCEFreeEnvironmentStrings void wce_hitreturn(); END_EXTERN_C #endif perl-5.12.0-RC0/win32/FindExt.pm0000444000175000017500000000464311325127002014766 0ustar jessejessepackage FindExt; our $VERSION = '1.02'; use strict; use warnings; my $no = join('|',qw(GDBM_File ODBM_File NDBM_File DB_File VMS VMS-DCLsym VMS-Stdio Sys-Syslog IPC-SysV I18N-Langinfo)); $no = qr/^(?:$no)$/i; my %ext; my %static; sub set_static_extensions { # adjust results of scan_ext, and also save # statics in case scan_ext hasn't been called yet. # if '*' is passed then all XS extensions are static # (with possible exclusions) %static = (); my @list = @_; if ($_[0] eq '*') { my %excl = map {$_=>1} map {m/^!(.*)$/} @_[1 .. $#_]; @list = grep {!exists $excl{$_}} keys %ext; } for (@list) { $static{$_} = 1; $ext{$_} = 'static' if $ext{$_} && $ext{$_} eq 'dynamic'; } } sub scan_ext { my $dir = shift; find_ext("$dir/"); extensions(); } sub _ext_eq { my $key = shift; sub { sort grep $ext{$_} eq $key, keys %ext; } } *dynamic_ext = _ext_eq('dynamic'); *static_ext = _ext_eq('static'); *nonxs_ext = _ext_eq('nonxs'); sub _ext_ne { my $key = shift; sub { sort grep $ext{$_} ne $key, keys %ext; } } *extensions = _ext_ne('known'); # faithfully copy Configure in not including nonxs extensions for the nonce *known_extensions = _ext_ne('nonxs'); sub is_static { return $ext{$_[0]} eq 'static' } sub has_xs_or_c { my $dir = shift; opendir my $dh, $dir or die "opendir $dir: $!"; while (defined (my $item = readdir $dh)) { return 1 if $item =~ /\.xs$/; return 1 if $item =~ /\.c$/; } return 0; } # Function to find available extensions, ignoring DynaLoader sub find_ext { my $ext_dir = shift; opendir my $dh, "$ext_dir"; while (defined (my $item = readdir $dh)) { next if $item =~ /^\.\.?$/; next if $item eq "DynaLoader"; next unless -d "$ext_dir$item"; my $this_ext = $item; my $leaf = $item; $this_ext =~ s!-!/!g; $leaf =~ s/.*-//; # Temporary hack to cope with smokers that are not clearing directories: next if $ext{$this_ext}; if (has_xs_or_c("$ext_dir$item")) { $ext{$this_ext} = $static{$this_ext} ? 'static' : 'dynamic'; } else { $ext{$this_ext} = 'nonxs'; } $ext{$this_ext} = 'known' if $ext{$this_ext} && $item =~ $no; } } 1; # Local variables: # cperl-indent-level: 4 # indent-tabs-mode: nil # End: # # ex: set ts=8 sts=4 sw=4 et: perl-5.12.0-RC0/win32/config.gc640000444000175000017500000005321411325127002015017 0ustar jessejesse## Configured by: ~cf_email~ ## Target system: WIN32 Author='' Date='$Date' Header='' Id='$Id' Locker='' Log='$Log' RCSfile='$RCSfile' Revision='$Revision' Source='' State='' _a='.a' _exe='.exe' _o='.o' afs='false' afsroot='/afs' alignbytes='8' ansi2knr='' aphostname='' api_revision='~PERL_API_REVISION~' api_subversion='~PERL_API_SUBVERSION~' api_version='~PERL_API_VERSION~' api_versionstring='~PERL_API_REVISION~.~PERL_API_VERSION~.~PERL_API_SUBVERSION~' ar='x86_64-w64-mingw32-ar' archlib='~INST_TOP~~INST_VER~\lib~INST_ARCH~' archlibexp='~INST_TOP~~INST_VER~\lib~INST_ARCH~' archname64='' archname='MSWin32' archobjs='' asctime_r_proto='0' awk='awk' baserev='5' bash='' bin='~INST_TOP~~INST_VER~\bin~INST_ARCH~' binexp='~INST_TOP~~INST_VER~\bin~INST_ARCH~' bison='' byacc='byacc' byteorder='1234' c='' castflags='0' cat='type' cc='x86_64-w64-mingw32-gcc' cccdlflags=' ' ccdlflags=' ' ccflags='-MD -DWIN32' ccflags_uselargefiles='' ccname='~cc~' ccsymbols='' ccversion='' cf_by='nobody' cf_email='nobody@no.where.net' cf_time='' chgrp='' chmod='' chown='' clocktype='clock_t' comm='' compress='' contains='grep' cp='copy' cpio='' cpp='~cc~ -E' cpp_stuff='42' cppccsymbols='' cppflags='-DWIN32' cpplast='' cppminus='-' cpprun='~cc~ -E' cppstdin='~cc~ -E' cppsymbols='' crypt_r_proto='0' cryptlib='' csh='undef' ctermid_r_proto='0' ctime_r_proto='0' d_Gconvert='sprintf((b),"%.*g",(n),(x))' d_PRIEUldbl='undef' d_PRIFUldbl='undef' d_PRIGUldbl='undef' d_PRIXU64='undef' d_PRId64='undef' d_PRIeldbl='undef' d_PRIfldbl='undef' d_PRIgldbl='undef' d_PRIi64='undef' d_PRIo64='undef' d_PRIu64='undef' d_PRIx64='undef' d_SCNfldbl='undef' d__fwalk='undef' d_access='define' d_accessx='undef' d_aintl='undef' d_alarm='define' d_archlib='define' d_asctime64='undef' d_asctime_r='undef' d_atolf='undef' d_atoll='define' d_attribute_deprecated='undef' d_attribute_format='undef' d_attribute_malloc='undef' d_attribute_nonnull='undef' d_attribute_noreturn='undef' d_attribute_pure='undef' d_attribute_unused='undef' d_attribute_warn_unused_result='undef' d_bcmp='undef' d_bcopy='undef' d_bsd='define' d_bsdgetpgrp='undef' d_bsdsetpgrp='undef' d_builtin_choose_expr='undef' d_builtin_expect='undef' d_bzero='undef' d_c99_variadic_macros='undef' d_casti32='define' d_castneg='define' d_charvspr='undef' d_chown='undef' d_chroot='undef' d_chsize='define' d_class='undef' d_clearenv='undef' d_closedir='define' d_cmsghdr_s='undef' d_const='define' d_copysignl='undef' d_cplusplus='undef' d_crypt='undef' d_crypt_r='undef' d_csh='undef' d_ctermid='undef' d_ctermid_r='undef' d_ctime64='undef' d_ctime_r='undef' d_cuserid='undef' d_dbl_dig='define' d_dbminitproto='undef' d_difftime64='undef' d_difftime='define' d_dir_dd_fd='undef' d_dirfd='undef' d_dirnamlen='define' d_dlerror='define' d_dlopen='define' d_dlsymun='undef' d_dosuid='undef' d_drand48_r='undef' d_drand48proto='undef' d_dup2='define' d_eaccess='undef' d_endgrent='undef' d_endgrent_r='undef' d_endhent='undef' d_endhostent_r='undef' d_endnent='undef' d_endnetent_r='undef' d_endpent='undef' d_endprotoent_r='undef' d_endpwent='undef' d_endpwent_r='undef' d_endsent='undef' d_endservent_r='undef' d_eofnblk='define' d_eunice='undef' d_faststdio='define' d_fchdir='undef' d_fchmod='undef' d_fchown='undef' d_fcntl_can_lock='undef' d_fcntl='undef' d_fd_macros='define' d_fd_set='define' d_fds_bits='define' d_fgetpos='define' d_finitel='undef' d_finite='undef' d_flexfnam='define' d_flock='define' d_flockproto='define' d_fork='undef' d_fp_class='undef' d_fpathconf='undef' d_fpclass='undef' d_fpclassify='undef' d_fpclassl='undef' d_fpos64_t='undef' d_frexpl='undef' d_fs_data_s='undef' d_fseeko='undef' d_fsetpos='define' d_fstatfs='undef' d_fstatvfs='undef' d_fsync='undef' d_ftello='undef' d_ftime='define' d_futimes='undef' d_gdbm_ndbm_h_uses_prototypes='undef' d_gdbmndbm_h_uses_prototypes='undef' d_getaddrinfo='undef' d_getcwd='define' d_getespwnam='undef' d_getfsstat='undef' d_getgrent='undef' d_getgrent_r='undef' d_getgrgid_r='undef' d_getgrnam_r='undef' d_getgrps='undef' d_gethbyaddr='define' d_gethbyname='define' d_gethent='undef' d_gethname='define' d_gethostbyaddr_r='undef' d_gethostbyname_r='undef' d_gethostent_r='undef' d_gethostprotos='define' d_getitimer='undef' d_getlogin='define' d_getlogin_r='undef' d_getmnt='undef' d_getmntent='undef' d_getnameinfo='undef' d_getnbyaddr='undef' d_getnbyname='undef' d_getnent='undef' d_getnetbyaddr_r='undef' d_getnetbyname_r='undef' d_getnetent_r='undef' d_getnetprotos='undef' d_getpagsz='undef' d_getpbyname='define' d_getpbynumber='define' d_getpent='undef' d_getpgid='undef' d_getpgrp2='undef' d_getpgrp='undef' d_getppid='undef' d_getprior='undef' d_getprotobyname_r='undef' d_getprotobynumber_r='undef' d_getprotoent_r='undef' d_getprotoprotos='define' d_getprpwnam='undef' d_getpwent='undef' d_getpwent_r='undef' d_getpwnam_r='undef' d_getpwuid_r='undef' d_getsbyname='define' d_getsbyport='define' d_getsent='undef' d_getservbyname_r='undef' d_getservbyport_r='undef' d_getservent_r='undef' d_getservprotos='define' d_getspnam='undef' d_getspnam_r='undef' d_gettimeod='define' d_gmtime64='undef' d_gmtime_r='undef' d_gnulibc='undef' d_grpasswd='undef' d_hasmntopt='undef' d_htonl='define' d_ilogbl='undef' d_inc_version_list='undef' d_index='undef' d_inetaton='undef' d_inetntop='undef' d_inetpton='undef' d_int64_t='undef' d_isascii='define' d_isfinite='undef' d_isinf='undef' d_isnan='define' d_isnanl='undef' d_killpg='define' d_lchown='undef' d_ldbl_dig='define' d_libm_lib_version='undef' d_link='define' d_localtime64='undef' d_localtime_r='undef' d_localtime_r_needs_tzset='undef' d_locconv='define' d_lockf='undef' d_longdbl='define' d_longlong='define' d_lseekproto='define' d_lstat='undef' d_madvise='undef' d_malloc_good_size='undef' d_malloc_size='undef' d_mblen='define' d_mbstowcs='define' d_mbtowc='define' d_memchr='define' d_memcmp='define' d_memcpy='define' d_memmove='define' d_memset='define' d_mkdir='define' d_mkdtemp='undef' d_mkfifo='undef' d_mkstemp='undef' d_mkstemps='undef' d_mktime64='undef' d_mktime='define' d_mmap='undef' d_modfl='undef' d_modfl_pow32_bug='undef' d_modflproto='undef' d_mprotect='undef' d_msgctl='undef' d_msg_ctrunc='undef' d_msg_dontroute='undef' d_msgget='undef' d_msghdr_s='undef' d_msg_oob='undef' d_msg_peek='undef' d_msg_proxy='undef' d_msgrcv='undef' d_msgsnd='undef' d_msg='undef' d_msync='undef' d_munmap='undef' d_mymalloc='undef' d_ndbm='undef' d_ndbm_h_uses_prototypes='undef' d_nice='undef' d_nl_langinfo='undef' d_nv_preserves_uv='undef' d_nv_zero_is_allbits_zero='define' d_off64_t='undef' d_old_pthread_create_joinable='undef' d_oldpthreads='undef' d_oldsock='undef' d_open3='undef' d_pathconf='undef' d_pause='define' d_perl_otherlibdirs='undef' d_phostname='undef' d_pipe='define' d_poll='undef' d_portable='define' d_printf_format_null='undef' d_procselfexe='undef' d_pseudofork='undef' d_pthread_atfork='undef' d_pthread_attr_setscope='undef' d_pthread_yield='undef' d_pwage='undef' d_pwchange='undef' d_pwclass='undef' d_pwcomment='undef' d_pwexpire='undef' d_pwgecos='undef' d_pwpasswd='undef' d_pwquota='undef' d_qgcvt='undef' d_quad='define' d_random_r='undef' d_readdir64_r='undef' d_readdir='define' d_readdir_r='undef' d_readlink='undef' d_readv='undef' d_recvmsg='undef' d_rename='define' d_rewinddir='define' d_rmdir='define' d_safebcpy='undef' d_safemcpy='undef' d_sanemcmp='define' d_sbrkproto='undef' d_scalbnl='undef' d_sched_yield='undef' d_scm_rights='undef' d_seekdir='define' d_select='define' d_sem='undef' d_semctl='undef' d_semctl_semid_ds='undef' d_semctl_semun='undef' d_semget='undef' d_semop='undef' d_sendmsg='undef' d_setegid='undef' d_seteuid='undef' d_setgrent='undef' d_setgrent_r='undef' d_setgrps='undef' d_sethent='undef' d_sethostent_r='undef' d_setitimer='undef' d_setlinebuf='undef' d_setlocale='define' d_setlocale_r='undef' d_setnent='undef' d_setnetent_r='undef' d_setpent='undef' d_setpgid='undef' d_setpgrp2='undef' d_setpgrp='undef' d_setprior='undef' d_setproctitle='undef' d_setprotoent_r='undef' d_setpwent='undef' d_setpwent_r='undef' d_setregid='undef' d_setresgid='undef' d_setresuid='undef' d_setreuid='undef' d_setrgid='undef' d_setruid='undef' d_setsent='undef' d_setservent_r='undef' d_setsid='undef' d_setvbuf='define' d_sfio='undef' d_shm='undef' d_shmat='undef' d_shmatprototype='undef' d_shmctl='undef' d_shmdt='undef' d_shmget='undef' d_sigaction='undef' d_signbit='undef' d_sigprocmask='undef' d_sigsetjmp='undef' d_sitearch='define' d_snprintf='define' d_sockatmark='undef' d_sockatmarkproto='undef' d_socket='define' d_socklen_t='undef' d_sockpair='undef' d_socks5_init='undef' d_sprintf_returns_strlen='define' d_sqrtl='undef' d_srand48_r='undef' d_srandom_r='undef' d_sresgproto='undef' d_sresuproto='undef' d_statblks='undef' d_statfs_f_flags='undef' d_statfs_s='undef' d_statvfs='undef' d_stdio_cnt_lval='define' d_stdio_ptr_lval='define' d_stdio_ptr_lval_nochange_cnt='define' d_stdio_ptr_lval_sets_cnt='undef' d_stdio_stream_array='undef' d_stdiobase='define' d_stdstdio='define' d_strchr='define' d_strcoll='define' d_strctcpy='define' d_strerrm='strerror(e)' d_strerror='define' d_strerror_r='undef' d_strftime='define' d_strlcat='undef' d_strlcpy='undef' d_strtod='define' d_strtol='define' d_strtold='undef' d_strtoll='define' d_strtoq='undef' d_strtoul='define' d_strtoull='define' d_strtouq='undef' d_strxfrm='define' d_suidsafe='undef' d_symlink='undef' d_syscall='undef' d_syscallproto='undef' d_sysconf='undef' d_sysernlst='' d_syserrlst='define' d_system='define' d_tcgetpgrp='undef' d_tcsetpgrp='undef' d_telldir='define' d_telldirproto='define' d_time='define' d_timegm='undef' d_times='define' d_tm_tm_gmtoff='undef' d_tm_tm_zone='undef' d_tmpnam_r='undef' d_truncate='undef' d_ttyname_r='undef' d_tzname='define' d_u32align='define' d_ualarm='undef' d_umask='define' d_uname='define' d_union_semun='define' d_unordered='undef' d_unsetenv='undef' d_usleep='undef' d_usleepproto='undef' d_ustat='undef' d_vendorarch='undef' d_vendorbin='undef' d_vendorlib='undef' d_vendorscript='undef' d_vfork='undef' d_void_closedir='undef' d_voidsig='define' d_voidtty='' d_volatile='define' d_vprintf='define' d_vsnprintf='define' d_wait4='undef' d_waitpid='define' d_wcstombs='define' d_wctomb='define' d_writev='undef' d_xenix='undef' date='date' db_hashtype='int' db_prefixtype='int' db_version_major='0' db_version_minor='0' db_version_patch='0' defvoidused='15' direntrytype='struct direct' dlext='dll' dlltool='x86_64-w64-mingw32-dlltool' dlsrc='dl_win32.xs' doublesize='8' drand01='(rand()/(double)((unsigned)1< #endif /* PERL_IMPLICIT_SYS */ /* Register any extra external extensions */ char *staticlinkmodules[] = { "DynaLoader", /* other similar records will be included from "perllibst.h" */ #define STATIC1 #include "perllibst.h" NULL, }; EXTERN_C void boot_DynaLoader (pTHX_ CV* cv); /* other similar records will be included from "perllibst.h" */ #define STATIC2 #include "perllibst.h" static void xs_init(pTHX) { char *file = __FILE__; dXSUB_SYS; newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); /* other similar records will be included from "perllibst.h" */ #define STATIC3 #include "perllibst.h" } #ifdef PERL_IMPLICIT_SYS /* WINCE: include replaced by: extern "C" void win32_checkTLS(PerlInterpreter *host_perl); */ #include "perlhost.h" void win32_checkTLS(PerlInterpreter *host_perl) { dTHX; if (host_perl != my_perl) { int *nowhere = NULL; #ifdef UNDER_CE printf(" ... bad in win32_checkTLS\n"); printf(" %08X ne %08X\n",host_perl,my_perl); #endif abort(); } } #ifdef UNDER_CE int GetLogicalDrives() { return 0; /* no logical drives on CE */ } int GetLogicalDriveStrings(int size, char addr[]) { return 0; /* no logical drives on CE */ } /* TBD */ DWORD GetFullPathNameA(LPCSTR fn, DWORD blen, LPTSTR buf, LPSTR *pfile) { return 0; } /* TBD */ DWORD GetFullPathNameW(CONST WCHAR *fn, DWORD blen, WCHAR * buf, WCHAR **pfile) { return 0; } /* TBD */ DWORD SetCurrentDirectoryA(LPSTR pPath) { return 0; } /* TBD */ DWORD SetCurrentDirectoryW(CONST WCHAR *pPath) { return 0; } int xcesetuid(uid_t id){return 0;} int xceseteuid(uid_t id){ return 0;} int xcegetuid() {return 0;} int xcegeteuid(){ return 0;} #endif /* WINCE??: include "perlhost.h" */ 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) { if (perlMemInfo) { 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*)); } if (perlMemParseInfo) { 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*)); } if (perlStdIOInfo) { 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*)); } if (perlDirInfo) { 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*)); } if (perlProcInfo) { 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) { PerlInterpreter *my_perl = NULL; CPerlHost* pHost = new CPerlHost(ppMem, ppMemShared, ppMemParse, ppEnv, 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; } } return my_perl; } EXTERN_C PerlInterpreter* 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; pHost->host_perl = my_perl; } } return my_perl; } EXTERN_C void win32_delete_internal_host(void *h) { CPerlHost *host = (CPerlHost*)h; delete host; } #endif /* PERL_IMPLICIT_SYS */ EXTERN_C HANDLE w32_perldll_handle; EXTERN_C DllExport int RunPerl(int argc, char **argv, char **env) { int exitstatus; PerlInterpreter *my_perl, *new_perl = NULL; OSVERSIONINFO osver; char szModuleName[MAX_PATH]; char *arg0 = argv[0]; char *ansi = NULL; bool use_environ = (env == environ); osver.dwOSVersionInfoSize = sizeof(osver); GetVersionEx(&osver); if (osver.dwMajorVersion > 4) { WCHAR widename[MAX_PATH]; GetModuleFileNameW(NULL, widename, sizeof(widename)/sizeof(WCHAR)); argv[0] = ansi = win32_ansipath(widename); } else { Win_GetModuleFileName(NULL, szModuleName, sizeof(szModuleName)); (void)win32_longpath(szModuleName); argv[0] = szModuleName; } #ifdef PERL_GLOBAL_STRUCT #define PERLVAR(var,type) /**/ #define PERLVARA(var,type) /**/ #define PERLVARI(var,type,init) PL_Vars.var = init; #define PERLVARIC(var,type,init) PL_Vars.var = init; #include "perlvars.h" #undef PERLVAR #undef PERLVARA #undef PERLVARI #undef PERLVARIC #endif PERL_SYS_INIT(&argc,&argv); if (!(my_perl = perl_alloc())) return (1); perl_construct(my_perl); PL_perl_destruct_level = 0; /* PERL_SYS_INIT() may update the environment, e.g. via ansify_path(). * This may reallocate the RTL environment block. Therefore we need * to make sure that `env` continues to have the same value as `environ` * if we have been called this way. If we have been called with any * other value for `env` then all environment munging by PERL_SYS_INIT() * will be lost again. */ if (use_environ) env = environ; exitstatus = perl_parse(my_perl, xs_init, argc, argv, env); if (!exitstatus) { #if defined(TOP_CLONE) && defined(USE_ITHREADS) /* XXXXXX testing */ new_perl = perl_clone(my_perl, 1); exitstatus = perl_run(new_perl); PERL_SET_THX(my_perl); #else exitstatus = perl_run(my_perl); #endif } perl_destruct(my_perl); perl_free(my_perl); #ifdef USE_ITHREADS if (new_perl) { PERL_SET_THX(new_perl); perl_destruct(new_perl); perl_free(new_perl); } #endif /* At least the Borland RTL wants to free argv[] after main() returns. */ argv[0] = arg0; if (ansi) win32_free(ansi); PERL_SYS_TERM(); return (exitstatus); } EXTERN_C void set_w32_module_name(void); EXTERN_C void EndSockets(void); #ifdef __MINGW32__ EXTERN_C /* GCC in C++ mode mangles the name, otherwise */ #endif BOOL APIENTRY DllMain(HANDLE hModule, /* DLL module handle */ 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. */ case DLL_PROCESS_ATTACH: /* #define DEFAULT_BINMODE */ #ifdef DEFAULT_BINMODE setmode( fileno( stdin ), O_BINARY ); setmode( fileno( stdout ), O_BINARY ); setmode( fileno( stderr ), O_BINARY ); _fmode = O_BINARY; #endif #ifndef UNDER_CE DisableThreadLibraryCalls((HMODULE)hModule); #endif w32_perldll_handle = hModule; set_w32_module_name(); break; /* 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: A. Not called at all. B. Called after memory allocation for Heap has been forcibly removed by OS. PerlIO_cleanup() was done here but fails (B). */ EndSockets(); #if defined(USE_ITHREADS) if (PL_curinterp) FREE_THREAD_KEY; #endif break; /* The attached process creates a new thread. */ case DLL_THREAD_ATTACH: break; /* The thread of the attached process terminates. */ case DLL_THREAD_DETACH: break; default: break; } return TRUE; } #if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) EXTERN_C PerlInterpreter * perl_clone_host(PerlInterpreter* proto_perl, UV flags) { dTHX; CPerlHost *h; h = new CPerlHost(*(CPerlHost*)PL_sys_intern.internal_host); proto_perl = perl_clone_using(proto_perl, flags, 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 ); proto_perl->Isys_intern.internal_host = h; h->host_perl = proto_perl; return proto_perl; } #endif perl-5.12.0-RC0/win32/Makefile.ce0000644000175000017500000006332711347250766015145 0ustar jessejesse# # perl makefile for wince # During the cross-compilation, it first uses Makefile file to build # miniperl on HOST and then build required platform # SRCDIR = .. PV = 59 INST_VER = 5.12.0 # INSTALL_ROOT specifies a path where this perl will be installed on CE device INSTALL_ROOT=/netzwerk/sprache/perl INST_TOP=$(INSTALL_ROOT) INST_VER= # PERLCEDIR shoud be set to current directory PERLCEDIR = H:\src\wince\perl\win32 # WCEROOT is a directory where Windows CE Tools was installed WCEROOT = D:\Windows CE Tools # HPERL stands for host perl, which is perl on local desktop machine # which is usually ..\miniperl.exe #HPERL = N:\Programme\perl\bin\perl.exe HPERL = $(MAKEDIR)\..\miniperl.exe CEPATH = D:\Programme\Microsoft eMbedded Tools\EVC\WCE211\BIN CELIBDLLDIR = h:\src\wince\celib-palm-3.0 CECONSOLEDIR = h:\src\wince\w32console # specify following options to build perl on local machine, by MSVC MSVCDIR = D:\MSVStudio\VC98 CCHOME = $(MSVCDIR) CCINCDIR = $(CCHOME)\include CCLIBDIR = $(CCHOME)\lib # Only for WIN2000 #YES = /y COPY = copy $(YES) XCOPY = xcopy $(YES) /f /r /i /d RCOPY = xcopy $(YES) /f /r /i /e /d # cecopy program. Make shure it is in your path, as well as cemkdir, cedel CECOPY = cecopy # # Comment out next assign to disable perl's I/O subsystem and use compiler's # stdio for IO - depending on your compiler vendor and run time library you may # then get a number of fails from make test i.e. bugs - complain to them not us ;-). # You will also be unable to take full advantage of perl5.8's support for multiple # encodings and may see lower IO performance. You have been warned. USE_PERLIO = define # # set this if you wish to use perl's malloc # This will make perl run few times faster # WARNING: Turning this on/off WILL break binary compatibility with extensions # you may have compiled with/without it. # PERL_MALLOC = define NOOP = @echo # keep this untouched! NULL = #CFG=DEBUG CFG=RELEASE !if "$(MACHINE)" == "" MACHINE=wince-arm-hpc-wce300 #MACHINE=wince-arm-hpc-wce211 #MACHINE=wince-sh3-hpc-wce211 #MACHINE=wince-mips-hpc-wce211 #MACHINE=wince-sh3-hpc-wce200 #MACHINE=wince-mips-hpc-wce200 #MACHINE=wince-arm-pocket-wce300 #MACHINE=wince-mips-pocket-wce300 #MACHINE=wince-sh3-pocket-wce300 #MACHINE=wince-x86em-pocket-wce300 #MACHINE=wince-mips-palm-wce211 #MACHINE=wince-sh3-palm-wce211 #MACHINE=wince-x86em-palm-wce211 !endif # set this to your email address # #EMAIL = ##################### CHANGE THESE ONLY IF YOU MUST ##################### ###################################################################### # machines !if "$(MACHINE)" == "wince-sh3-hpc-wce211" CC = shcl.exe ARCH = SH3 CPU = SH3 TARGETCPU = SH3 CEVersion = 211 OSVERSION = WCE211 PLATFORM = MS HPC Pro MCFLAGS = -MDd -DSH3 -D_SH3_ -DSHx -DPROCESSOR_SH3 -DPALM_SIZE \ -I $(CELIBDLLDIR)\inc SUBSYS = -subsystem:windowsce,2.11 CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release LDLIBPATH = -libpath:$(CELIBPATH) STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \ $(CECONSOLEDIR)/$(MACHINE)/w32console.obj !endif !if "$(MACHINE)" == "wince-mips-hpc-wce211" CC = clmips.exe ARCH = MIPS CPU = MIPS TARGETCPU = MIPS CEVersion = 211 OSVERSION = WCE211 PLATFORM = MS HPC Pro MCFLAGS = -D _MT -D _DLL \ -D MIPS -D mips -D _MIPS_ -D _mips_ -DPROCESSOR_MIPS \ -D PALM_SIZE \ -I $(CELIBDLLDIR)\inc SUBSYS = -subsystem:windowsce,2.11 CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release LDLIBPATH = -libpath:$(CELIBPATH) STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \ $(CECONSOLEDIR)/$(MACHINE)/w32console.obj !endif !if "$(MACHINE)" == "wince-mips-hpc-wce200" CC = clmips.exe ARCH = MIPS CPU = MIPS TARGETCPU = MIPS CEVersion = 200 OSVERSION = WCE200 PLATFORM = MS HPC # MUST USE -MD to get the right FPE stuff... MCFLAGS = -D _MT -D _DLL -MD \ -D MIPS -D mips -D _MIPS_ -D _mips_ -DPROCESSOR_MIPS \ -D PALM_SIZE \ -I $(CELIBDLLDIR)\inc SUBSYS = -subsystem:windowsce,2.00 CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release LDLIBPATH = -libpath:$(CELIBPATH) STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \ $(CECONSOLEDIR)/$(MACHINE)/w32console.obj !endif !if "$(MACHINE)" == "wince-sh3-hpc-wce200" CC = shcl.exe ARCH = SH3 CPU = SH3 TARGETCPU = SH3 CEVersion = 200 OSVERSION = WCE200 PLATFORM = MS HPC # MUST USE -MD to get the right FPE stuff... MCFLAGS = -D _MT -D _DLL -MD \ -D SH3 -D sh3 -D _SH3_ -D _sh3_ -D SHx -DPROCESSOR_SH3 \ -D PALM_SIZE \ -I $(CELIBDLLDIR)\inc SUBSYS = -subsystem:windowsce,2.00 CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release LDLIBPATH = -libpath:$(CELIBPATH) STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \ $(CECONSOLEDIR)/$(MACHINE)/w32console.obj !endif !if "$(MACHINE)" == "wince-arm-hpc-wce211" CC = clarm.exe ARCH = ARM CPU = ARM TARGETCPU = ARM CEVersion = 211 OSVERSION = WCE211 PLATFORM = MS HPC Pro MCFLAGS = -D _MT -D _DLL -D ARM -D arm -D _arm_ -D _ARM_ \ -DPROCESSOR_ARM -DPALM_SIZE \ -I $(CELIBDLLDIR)\inc SUBSYS = -subsystem:windowsce,2.11 CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release LDLIBPATH = -libpath:$(CELIBPATH) STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \ $(CECONSOLEDIR)/$(MACHINE)/w32console.obj !endif !if "$(MACHINE)" == "wince-arm-hpc-wce300" CC = clarm.exe ARCH = ARM CPU = ARM TARGETCPU = ARM CEVersion = 300 OSVERSION = WCE300 #PLATFORM = HPC2000 MCFLAGS = -D _MT -D _DLL -D ARM -D arm -D _arm_ -D _ARM_ \ -DPROCESSOR_ARM -DPALM_SIZE \ -I $(CELIBDLLDIR)\inc SUBSYS = -subsystem:windowsce,3.00 CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release LDLIBPATH = -libpath:$(CELIBPATH) STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \ $(CECONSOLEDIR)/$(MACHINE)/w32console.obj !endif !if "$(MACHINE)" == "wince-mips-palm-wce211" CC = clmips.exe ARCH = MIPS CPU = MIPS TARGETCPU = MIPS CEVersion = 211 OSVERSION = WCE211 PLATFORM = MS Palm Size PC MCFLAGS = -DMIPS -D_MIPS_ -DPROCESSOR_MIPS -D PALM_SIZE -D _DLL -D _MT \ -I $(CELIBDLLDIR)\inc SUBSYS = -subsystem:windowsce,2.11 CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release LDLIBPATH = -libpath:$(CELIBPATH) STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \ $(CECONSOLEDIR)/$(MACHINE)/w32console.obj !endif !if "$(MACHINE)" == "wince-sh3-palm-wce211" CC = shcl.exe ARCH = SH3 CPU = SH3 TARGETCPU = SH3 CEVersion = 211 OSVERSION = WCE211 PLATFORM = MS Palm Size PC MCFLAGS = -D _MT -D _DLL -DSH3 -D_SH3_ -DSHx -DPROCESSOR_SH3 -DPALM_SIZE \ -I $(CELIBDLLDIR)\inc SUBSYS = -subsystem:windowsce,2.11 CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release LDLIBPATH = -libpath:$(CELIBPATH) STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \ $(CECONSOLEDIR)/$(MACHINE)/w32console.obj !endif !if "$(MACHINE)" == "wince-x86em-palm-wce211" CC = cl.exe ARCH = X86EM CPU = X86 TARGETCPU = X86 CEVersion = 211 OSVERSION = WCE211 PLATFORM = MS Palm Size PC MCFLAGS = -MDd -DX86 -D_X86_ -DPROCESSOR_X86 \ -D_WIN32_WCE_EMULATION -DPALM_SIZE \ -I $(CELIBDLLDIR)\inc MACH = -machine:x86 SUBSYS = -subsystem:windows CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release LDLIBPATH = -libpath:$(CELIBPATH) STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \ $(CECONSOLEDIR)/$(MACHINE)/w32console.obj !endif !if "$(MACHINE)" == "wince-x86em-pocket-wce300" CC = cl.exe ARCH = X86EM CPU = X86 TARGETCPU = X86 CEVersion = 300 OSVERSION = WCE300 PLATFORM = MS Pocket PC MCFLAGS = -DX86 -D_X86_ -DPROCESSOR_X86 -D _MT -D _DLL \ -D_WIN32_WCE_EMULATION -DPALM_SIZE -DPOCKET_SIZE \ -I $(CELIBDLLDIR)\inc MACH = -machine:x86 SUBSYS = -subsystem:windows CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release LDLIBPATH = -libpath:$(CELIBPATH) STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \ $(CECONSOLEDIR)/$(MACHINE)/w32console.obj !endif !if "$(MACHINE)" == "wince-mips-pocket-wce300" CC = clmips.exe ARCH = MIPS CPU = MIPS TARGETCPU = MIPS CEVersion = 300 OSVERSION = WCE300 PLATFORM = MS Pocket PC MCFLAGS = -D MIPS -D mips -D _MIPS_ -D _mips_ -DPROCESSOR_MIPS \ -D _MT -D _DLL -DPALM_SIZE -DPOCKET_SIZE \ -I $(CELIBDLLDIR)\inc MACH = -machine:mips SUBSYS = -subsystem:windowsce,3.00 CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release #STDLIBPATH = $(WCEROOT)\$(OSVERSION)\$(PLATFORM)\lib\$(CPU) LDLIBPATH = -libpath:$(CELIBPATH) #"-libpath:$(STDLIBPATH)" STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \ $(CECONSOLEDIR)/$(MACHINE)/w32console.obj !endif !if "$(MACHINE)" == "wince-sh3-pocket-wce300" CC = shcl.exe ARCH = SH3 CPU = SH3 TARGETCPU = SH3 CEVersion = 300 OSVERSION = WCE300 PLATFORM = MS Pocket PC MCFLAGS = -D _MT -D _DLL -DSH3 -D_SH3_ -DSHx -DPROCESSOR_SH3 \ -DPALM_SIZE -DPOCKET_SIZE \ -I $(CELIBDLLDIR)\inc MACH = -machine:sh3 SUBSYS = -subsystem:windowsce,3.00 CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release LDLIBPATH = -libpath:$(CELIBPATH) STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \ $(CECONSOLEDIR)/$(MACHINE)/w32console.obj !endif !if "$(MACHINE)" == "wince-arm-pocket-wce300" CC = clarm.exe ARCH = ARM CPU = ARM TARGETCPU = ARM CEVersion = 300 OSVERSION = WCE300 PLATFORM = MS Pocket PC MCFLAGS = -D ARM -D arm -D _ARM_ -D _arm_ -DPROCESSOR_ARM \ -D _MT -D _DLL -DPALM_SIZE -DPOCKET_SIZE \ -I $(CELIBDLLDIR)\inc MACH = -machine:arm SUBSYS = -subsystem:windowsce,3.00 CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release LDLIBPATH = -libpath:$(CELIBPATH) STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \ $(CECONSOLEDIR)/$(MACHINE)/w32console.obj !endif ###################################################################### # common section CEDEFS = -D_WINDOWS -D_WIN32_WCE=$(CEVersion) -DUNDER_CE=$(CEVersion) \ $(MCFLAGS) -D PERL CECFLAGS = $(CEDEFS) !if "$(CFG)" == "DEBUG" CECFLAGS = $(CECFLAGS) -Zi -Od !endif !if "$(CFG)" == "RELEASE" # -O2 and -Ot give internal compiler error in perl.c and lexer. # Also the dll cannot be loaded by perl.exe... !if "$(CPU)" == "SH3" !else CECFLAGS = $(CECFLAGS) -O2 -Ot !endif !endif RCDEFS = /l 0x407 /r /d "UNICODE" /d UNDER_CE=$(CEVersion) \ /d _WIN32_WCE=$(CEVersion) PATH=$(CEPATH);$(PATH) INCLUDE=$(WCEROOT)\$(OSVERSION)\$(PLATFORM)\include LIB=$(WCEROOT)\$(OSVERSION)\$(PLATFORM)\lib\$(ARCH) ###################################################################### !message !message Compiling for $(MACHINE) !message LIB=$(LIB) !message INCLUDE=$(INCLUDE) !message PATH=$(CEPATH) !message ###################################################################### # # Additional compiler flags can be specified here. # BUILDOPT = $(BUILDOPT) $(CECFLAGS) -DUSE_CROSS_COMPILE !IF "$(CRYPT_SRC)$(CRYPT_LIB)" == "" D_CRYPT = undef !ELSE D_CRYPT = define CRYPT_FLAG = -DHAVE_DES_FCRYPT !ENDIF !IF "$(PERL_MALLOC)" == "" PERL_MALLOC = undef !ENDIF !IF "$(USE_MULTI)" == "" USE_MULTI = undef !ENDIF !IF "$(USE_ITHREADS)" == "" USE_ITHREADS = undef !ENDIF !IF "$(USE_IMP_SYS)" == "" USE_IMP_SYS = undef !ENDIF !IF "$(USE_PERLIO)" == "" USE_PERLIO = undef !ENDIF !IF "$(USE_PERLCRT)" == "" USE_PERLCRT = undef !ENDIF !IF "$(USE_IMP_SYS)$(USE_MULTI)" == "defineundef" USE_MULTI = define !ENDIF !IF "$(USE_ITHREADS)$(USE_MULTI)" == "defineundef" USE_MULTI = define !ENDIF !IF "$(USE_MULTI)" != "undef" BUILDOPT = $(BUILDOPT) -DPERL_IMPLICIT_CONTEXT !ENDIF !IF "$(USE_IMP_SYS)" != "undef" BUILDOPT = $(BUILDOPT) -DPERL_IMPLICIT_SYS !ENDIF !IF "$(USE_PERLIO)" == "define" BUILDOPT = $(BUILDOPT) -DUSE_PERLIO !ENDIF !IF "$(CROSS_NAME)" == "" CROSS_NAME = $(MACHINE) !ENDIF # new option - automatically defined in perl.h... #BUILDOPT = $(BUILDOPT) -DUSE_ENVIRON_ARRAY PROCESSOR_ARCHITECTURE = $(TARGETCPU) ARCHNAME = $(PLATFORM)-$(OSVERSION)-$(PROCESSOR_ARCHITECTURE) ARCHDIR = ..\lib\$(ARCHNAME) COREDIR = ..\lib\CORE XCOREDIR = ..\xlib\$(CROSS_NAME)\CORE AUTODIR = ..\lib\auto LIBDIR = ..\lib EXTDIR = ..\ext PODDIR = ..\pod EXTUTILSDIR = $(LIBDIR)\ExtUtils LINK32 = link LIB32 = $(LINK32) -lib RSC = rc INCLUDES = -I.\include -I. -I.. DEFINES = -DWIN32 -D_CONSOLE -DNO_STRICT $(CRYPT_FLAG) $(CECFLAGS) LOCDEFS = -DPERLDLL -DPERL_CORE CXX_FLAG = -TP PERLEXE_RES = perl.res PERLDLL_RES = !if "$(CFG)" == "RELEASE" CELIB = celib.lib !endif !if "$(CFG)" == "DEBUG" CELIB = celib.lib !endif CELIBS = -nodefaultlib \ winsock.lib $(CELIB) coredll.lib !if $(CEVersion) > 200 CELIBS = $(CELIBS) corelibc.lib !else CELIBS = $(CELIBS) msvcrt.lib !endif LIBBASEFILES = $(CRYPT_LIB) $(CELIBS) LIBFILES = $(LIBBASEFILES) $(LIBC) CFLAGS = -nologo -Gf -W3 $(INCLUDES) $(DEFINES) $(LOCDEFS) \ $(PCHFLAGS) $(OPTIMIZE) LINK_FLAGS = -nologo -machine:$(PROCESSOR_ARCHITECTURE) !if "$(CFG)" == "DEBUG" LINK_FLAGS = $(LINK_FLAGS) -debug:full -pdb:none !else LINK_FLAGS = $(LINK_FLAGS) -release !endif OBJOUT_FLAG = -Fo EXEOUT_FLAG = -Fe CFLAGS_O = $(CFLAGS) $(BUILDOPT) o = .obj # # Rules # .SUFFIXES : .c $(o) .dll .lib .exe .rc .res .c$(o): $(CC) -c -I$( ..\config.sh $(MINIMOD) : ..\minimod.pl cd .. && $(HPERL) minimod.pl > lib\ExtUtils\Miniperl.pm $(DYNALOADER).c: $(EXTDIR)\DynaLoader\dl_win32.xs $(CONFIGPM) if not exist $(AUTODIR) mkdir $(AUTODIR) cd $(EXTDIR)\$(*B) $(HPERL) -I..\..\lib -MCross=$(CROSS_NAME) $(*B)_pm.PL $(HPERL) -I..\..\lib -MCross=$(CROSS_NAME) XSLoader_pm.PL cd ..\..\win32 $(XCOPY) $(EXTDIR)\$(*B)\$(*B).pm $(LIBDIR)\$(NULL) $(XCOPY) $(EXTDIR)\$(*B)\XSLoader.pm $(LIBDIR)\$(NULL) cd $(EXTDIR)\$(*B) $(XSUBPP) dl_win32.xs > $(*B).c cd ..\..\win32 $(EXTDIR)\DynaLoader\dl_win32.xs: dl_win32.xs $(COPY) dl_win32.xs $(EXTDIR)\DynaLoader\dl_win32.xs MakePPPort: $(MINIPERL) $(CONFIGPM) $(HPERL) -I..\lib -MCross=$(CROSS_NAME) ..\mkppport MakePPPort_clean: -if exist $(HPERL) $(HPERL) -I..\lib ..\mkppport --clean #---------------------------------------------------------------------------------- NOT_COMPILE_EXT = !if "$(MACHINE)" == "wince-sh3-palm-wce211" NOT_COMPILE_EXT = $(NOT_COMPILE_EXT) !XS/Typemap !endif !if "$(MACHINE)" == "wince-mips-palm-wce211" NOT_COMPILE_EXT = $(NOT_COMPILE_EXT) !XS/Typemap !endif Extensions: ..\make_ext.pl $(PERLDEP) $(CONFIGPM) $(HPERL) -I..\lib -I. -MCross=$(CROSS_NAME) ..\make_ext.pl "MAKE=$(MAKE)" --dir=$(EXTDIR) --all \ !POSIX $(NOT_COMPILE_EXT) Extensions_clean: -if exist $(MINIPERL) $(MINIPERL) -I..\lib ..\make_ext.pl "MAKE=$(MAKE)" --dir=$(EXTDIR) --all --target=clean #---------------------------------------------------------------------------------- $(PERLEXE_RES): perl.rc perl.ico rc $(RCDEFS) perl.rc clean: -rm -f $(MACHINE)/dll/* -rm -f $(MACHINE)/*.obj -rm -f $(MACHINE)/*.exe -rm -f $(MACHINE)/*.dll -rm -f $(MACHINE)/*.lib -rm -f ../config.sh ../lib/Config.pm -rm -f config.h xconfig.h perl.res -rm -f ../t/test_state XDLLOBJS = \ $(DLLDIR)\av.obj \ $(DLLDIR)\deb.obj \ $(DLLDIR)\doio.obj \ $(DLLDIR)\doop.obj \ $(DLLDIR)\dump.obj \ $(DLLDIR)\globals.obj \ $(DLLDIR)\gv.obj \ $(DLLDIR)\mro.obj \ $(DLLDIR)\hv.obj \ $(DLLDIR)\locale.obj \ $(DLLDIR)\mathoms.obj \ $(DLLDIR)\mg.obj \ $(DLLDIR)\numeric.obj \ $(DLLDIR)\op.obj \ $(DLLDIR)\pad.obj \ $(DLLDIR)\perl.obj \ $(DLLDIR)\perlapi.obj \ $(DLLDIR)\perlio.obj \ $(DLLDIR)\perly.obj \ $(DLLDIR)\pp.obj \ $(DLLDIR)\pp_ctl.obj \ $(DLLDIR)\pp_hot.obj \ $(DLLDIR)\pp_pack.obj \ $(DLLDIR)\pp_sort.obj \ $(DLLDIR)\pp_sys.obj \ $(DLLDIR)\reentr.obj \ $(DLLDIR)\regcomp.obj \ $(DLLDIR)\regexec.obj \ $(DLLDIR)\run.obj \ $(DLLDIR)\scope.obj \ $(DLLDIR)\sv.obj \ $(DLLDIR)\taint.obj \ $(DLLDIR)\toke.obj \ $(DLLDIR)\universal.obj \ $(DLLDIR)\utf8.obj \ $(DLLDIR)\util.obj \ $(DLLDIR)\win32thread.obj \ $(DLLDIR)\wince.obj \ $(DLLDIR)\win32io.obj \ $(DLLDIR)\wincesck.obj \ $(DLLDIR)\perllib.obj \ $(DLLDIR)\DynaLoader.obj !IF "$(PERL_MALLOC)" == "define" XDLLOBJS = $(XDLLOBJS) $(DLLDIR)\malloc.obj !ENDIF !IF "$(CRYPT_SRC)" != "" XDLLOBJS = $(XDLLOBJS) $(DLLDIR)\fcrypt.obj !ENDIF {$(SRCDIR)}.c{$(DLLDIR)}.obj: $(CC) -c $(CFLAGS_O) -DPERL_EXTERNAL_GLOB -Fo$(DLLDIR)\ $< # compiler explains that it will optimize toke.c if we'll give it an # option -QMOb with num>=4178 $(DLLDIR)\toke.obj: $(CC) -c $(CFLAGS_O) -QMOb9000 -DPERL_EXTERNAL_GLOB -Fo$(DLLDIR)\ ..\toke.c {$(SRCDIR)/win32}.c{$(DLLDIR)}.obj: $(CC) -c $(CFLAGS_O) -DPERL_EXTERNAL_GLOB -Fo$(DLLDIR)\ $< # -DPERL_IMPLICIT_SYS needs C++ for perllib.c # This is the only file that depends on perlhost.h, vmem.h, and vdir.h !IF "$(USE_IMP_SYS)" == "define" $(DLLDIR)\perllib$(o) : perllib.c .\perlhost.h .\vdir.h .\vmem.h $(CC) -c -I. $(CFLAGS_O) $(CXX_FLAG) $(OBJOUT_FLAG)$@ perllib.c rem (frustrated) mv perllib.obj $(DLLDIR) !ENDIF perldll.def : $(HPERL) $(CONFIGPM) ..\global.sym ..\pp.sym ..\makedef.pl create_perllibst_h.pl $(HPERL) -MCross -I..\lib create_perllibst_h.pl $(HPERL) -w ..\makedef.pl PLATFORM=wince $(OPTIMIZE) $(DEFINES) $(BUILDOPT) \ CCTYPE=$(CCTYPE) -DPERL_DLL=$(PERLDLL) > perldll.def $(PERLDLL) : $(DLLDIR) perldll.def $(XDLLOBJS) $(PERLDLL_RES) $(LINK32) -dll -def:perldll.def -out:$@ \ $(SUBSYS) $(LDLIBPATH) \ $(LINK_FLAGS) $(LIBFILES) \ $(XDLLOBJS) $(PERLDLL_RES) $(DLLDIR) : if not exist "$(DLLDIR)" mkdir "$(DLLDIR)" $(DLLDIR)\DynaLoader.obj: $(EXTDIR)\DynaLoader\DynaLoader.c $(CC) -c $(CFLAGS_O) -DPERL_EXTERNAL_GLOB -Fo$(DLLDIR)\ \ $(EXTDIR)\DynaLoader\DynaLoader.c XPERLEXEOBJS = \ $(MACHINE)\perlmaince.obj $(PERLEXE) : $(PERLDLL) $(CONFIGPM) $(XPERLEXEOBJS) $(PERLEXE_RES) $(STARTOBJS) $(XCOPY) $(MACHINE)\*.lib $(XCOREDIR) $(LINK32) $(SUBSYS) $(LDLIBPATH) \ -entry:wWinMainCRTStartup \ -out:$(MACHINE)\perl.exe \ -stack:0x100000 $(LINK_FLAGS) $(STARTOBJS) $(XPERLEXEOBJS) \ $(PERLIMPLIB) $(PERLEXE_RES) $(LIBFILES) $(MACHINE)\perlmaince.obj : perlmaince.c $(CC) $(CFLAGS_O) -UPERLDLL -Fo$(MACHINE)\ -c perlmaince.c iodll: $(IO_DLL) socketdll: $(SOCKET_DLL) dumperdll: $(DUMPER_DLL) dlls: socketdll iodll dumperdll -xmkdir -p $(MACHINE)/lib/auto/IO cp ../lib/auto/IO/IO.bs $(MACHINE)/lib/auto/IO cp ../lib/auto/IO/IO.dll $(MACHINE)/lib/auto/IO -xmkdir $(MACHINE)/lib/auto/Socket cp ../lib/auto/Socket/Socket.bs $(MACHINE)/lib/auto/Socket cp ../lib/auto/Socket/Socket.dll $(MACHINE)/lib/auto/Socket -xmkdir -p $(MACHINE)/lib/auto/Data/Dumper cp ../lib/auto/Data/Dumper/Dumper.bs $(MACHINE)/lib/auto/Data/Dumper cp ../lib/auto/Data/Dumper/Dumper.dll $(MACHINE)/lib/auto/Data/Dumper makedist: all dlls $(COPY) $(CELIBPATH)\celib.dll $(MACHINE) cp perl.txt $(MACHINE) cp registry.bat $(MACHINE) cp ../lib/Config.pm $(MACHINE)/lib cd $(MACHINE) rm -f perl-$(MACHINE).tar.gz sh -c "tar cf perl-$(MACHINE).tar *.exe *.dll *.txt *.bat lib" gzip -9 perl-$(MACHINE).tar mv perl-$(MACHINE).tar.gz h:/freenet/new cd .. install: all -cemkdir "$(INSTALL_ROOT)" -cemkdir "$(INSTALL_ROOT)\bin" -cemkdir "$(INSTALL_ROOT)\lib" $(CECOPY) "pc:$(MACHINE)/perl.exe" "ce:$(INSTALL_ROOT)/bin" $(CECOPY) "pc:$(MACHINE)/perl$(PV).dll" "ce:$(INSTALL_ROOT)/bin" $(CECOPY) "pc:../xlib/$(CROSS_NAME)/Config.pm" "ce:$(INSTALL_ROOT)/lib" $(UNIDATAFILES) : $(HPERL) $(CONFIGPM) ..\lib\unicore\mktables cd ..\lib\unicore && \ $(HPERL) -I.. mktables -P ..\..\pod -maketest -makelist -p dist: all $(HPERL) -I..\lib -MCross=$(CROSS_NAME) ce-helpers\makedist.pl --distdir=dist-$(CROSS_NAME) --cross-name=$(CROSS_NAME) zipdist: all $(HPERL) -I..\lib -MCross=$(CROSS_NAME) ce-helpers\makedist.pl --distdir=dist-$(CROSS_NAME) --cross-name=$(CROSS_NAME) $(HPERL) -I..\lib -MCross=$(CROSS_NAME) ce-helpers\makedist.pl --distdir=dist-$(CROSS_NAME) --cross-name=$(CROSS_NAME) --zip zip: $(HPERL) -I..\lib -MCross=$(CROSS_NAME) ce-helpers\makedist.pl --distdir=dist-$(CROSS_NAME) --cross-name=$(CROSS_NAME) --zip hostminiperl: ..\miniperl.exe ..\miniperl.exe: set PATH=$(CCHOME)\bin;$(PATH) $(MAKE) -f Makefile "CCHOME=$(MSVCDIR)" "CCINCDIR=$(CCHOME)\include" "CCLIBDIR=$(CCHOME)\lib" "INCLUDE=$(CCHOME)\include" "LIB=$(CCHOME)\lib" "LINK_FLAGS=" .\config.h ..\miniperl.exe host-install: perl -MConfig -MExtUtils::Install -we "install({'../lib/CORE', qq#$$Config{installprefixexp}/xlib/$(CROSS_NAME)/CORE#},1)" perl -MConfig -MExtUtils::Install -we "install({'../xlib/$(CROSS_NAME)', qq#$$Config{installprefixexp}/xlib/$(CROSS_NAME)#},1)" perl -MConfig -MFile::Copy -we "copy qq#./$(MACHINE)/perl$(PV).lib#, qq#$$Config{installprefixexp}/xlib/$(CROSS_NAME)/CORE#" perl -MConfig -MFile::Copy -we "copy qq#../lib/Cross.pm#, qq#$$Config{installprefixexp}/lib#" perl -MConfig -we "system qq#perl -pi.bak -we \"s{((arch^|priv)libexp)='.*'}{\$$1='# . \ quotemeta($$Config{installprefixexp}) . \ qq#/xlib/$(CROSS_NAME)'}\" $$Config{installprefixexp}/xlib/$(CROSS_NAME)/Config.pm#" perl-5.12.0-RC0/win32/config.vc640000444000175000017500000005306611325127002015043 0ustar jessejesse## Configured by: ~cf_email~ ## Target system: WIN32 Author='' Date='$Date' Header='' Id='$Id' Locker='' Log='$Log' RCSfile='$RCSfile' Revision='$Revision' Source='' State='' _a='.lib' _exe='.exe' _o='.obj' afs='false' afsroot='/afs' alignbytes='8' ansi2knr='' aphostname='' api_revision='~PERL_API_REVISION~' api_subversion='~PERL_API_SUBVERSION~' api_version='~PERL_API_VERSION~' api_versionstring='~PERL_API_REVISION~.~PERL_API_VERSION~.~PERL_API_SUBVERSION~' ar='lib' archlib='~INST_TOP~~INST_VER~\lib~INST_ARCH~' archlibexp='~INST_TOP~~INST_VER~\lib~INST_ARCH~' archname64='' archname='MSWin32' archobjs='' asctime_r_proto='0' awk='awk' baserev='5' bash='' bin='~INST_TOP~~INST_VER~\bin~INST_ARCH~' binexp='~INST_TOP~~INST_VER~\bin~INST_ARCH~' bison='' byacc='byacc' byteorder='1234' c='' castflags='0' cat='type' cc='cl' cccdlflags=' ' ccdlflags=' ' ccflags='-MD -DWIN32' ccflags_uselargefiles='' ccname='~cc~' ccsymbols='' ccversion='' cf_by='nobody' cf_email='nobody@no.where.net' cf_time='' charbits='8' chgrp='' chmod='' chown='' clocktype='clock_t' comm='' compress='' contains='grep' cp='copy' cpio='' cpp='~cc~ -nologo -E' cpp_stuff='42' cppccsymbols='' cppflags='-DWIN32' cpplast='' cppminus='' cpprun='~cc~ -nologo -E' cppstdin='cppstdin' cppsymbols='' crypt_r_proto='0' cryptlib='' csh='undef' ctermid_r_proto='0' ctime_r_proto='0' d_Gconvert='sprintf((b),"%.*g",(n),(x))' d_PRIEUldbl='undef' d_PRIFUldbl='undef' d_PRIGUldbl='undef' d_PRIXU64='undef' d_PRId64='undef' d_PRIeldbl='undef' d_PRIfldbl='undef' d_PRIgldbl='undef' d_PRIi64='undef' d_PRIo64='undef' d_PRIu64='undef' d_PRIx64='undef' d_SCNfldbl='undef' d__fwalk='undef' d_access='define' d_accessx='undef' d_aintl='undef' d_alarm='define' d_archlib='define' d_asctime64='undef' d_asctime_r='undef' d_atolf='undef' d_atoll='define' d_attribute_deprecated='undef' d_attribute_format='undef' d_attribute_malloc='undef' d_attribute_nonnull='undef' d_attribute_noreturn='undef' d_attribute_pure='undef' d_attribute_unused='undef' d_attribute_warn_unused_result='undef' d_bcmp='undef' d_bcopy='undef' d_bsd='define' d_bsdgetpgrp='undef' d_bsdsetpgrp='undef' d_builtin_choose_expr='undef' d_builtin_expect='undef' d_bzero='undef' d_c99_variadic_macros='undef' d_casti32='undef' d_castneg='define' d_charvspr='undef' d_chown='undef' d_chroot='undef' d_chsize='define' d_class='undef' d_clearenv='undef' d_closedir='define' d_cmsghdr_s='undef' d_const='define' d_copysignl='undef' d_cplusplus='undef' d_crypt='undef' d_crypt_r='undef' d_csh='undef' d_ctermid='undef' d_ctermid_r='undef' d_ctime64='undef' d_ctime_r='undef' d_cuserid='undef' d_dbl_dig='define' d_dbminitproto='undef' d_difftime64='undef' d_difftime='define' d_dir_dd_fd='undef' d_dirfd='undef' d_dirnamlen='define' d_dlerror='define' d_dlopen='define' d_dlsymun='undef' d_dosuid='undef' d_drand48_r='undef' d_drand48proto='undef' d_dup2='define' d_eaccess='undef' d_endgrent='undef' d_endgrent_r='undef' d_endhent='undef' d_endhostent_r='undef' d_endnent='undef' d_endnetent_r='undef' d_endpent='undef' d_endprotoent_r='undef' d_endpwent='undef' d_endpwent_r='undef' d_endsent='undef' d_endservent_r='undef' d_eofnblk='define' d_eunice='undef' d_faststdio='define' d_fchdir='undef' d_fchmod='undef' d_fchown='undef' d_fcntl_can_lock='undef' d_fcntl='undef' d_fd_macros='define' d_fd_set='define' d_fds_bits='define' d_fgetpos='define' d_finitel='undef' d_finite='undef' d_flexfnam='define' d_flock='define' d_flockproto='define' d_fork='undef' d_fp_class='undef' d_fpathconf='undef' d_fpclass='undef' d_fpclassify='undef' d_fpclassl='undef' d_fpos64_t='undef' d_frexpl='undef' d_fs_data_s='undef' d_fseeko='undef' d_fsetpos='define' d_fstatfs='undef' d_fstatvfs='undef' d_fsync='undef' d_ftello='undef' d_ftime='define' d_futimes='undef' d_gdbm_ndbm_h_uses_prototypes='undef' d_gdbmndbm_h_uses_prototypes='undef' d_getaddrinfo='undef' d_getcwd='define' d_getespwnam='undef' d_getfsstat='undef' d_getgrent='undef' d_getgrent_r='undef' d_getgrgid_r='undef' d_getgrnam_r='undef' d_getgrps='undef' d_gethbyaddr='define' d_gethbyname='define' d_gethent='undef' d_gethname='define' d_gethostbyaddr_r='undef' d_gethostbyname_r='undef' d_gethostent_r='undef' d_gethostprotos='define' d_getitimer='undef' d_getlogin='define' d_getlogin_r='undef' d_getmnt='undef' d_getmntent='undef' d_getnameinfo='undef' d_getnbyaddr='undef' d_getnbyname='undef' d_getnent='undef' d_getnetbyaddr_r='undef' d_getnetbyname_r='undef' d_getnetent_r='undef' d_getnetprotos='undef' d_getpagsz='undef' d_getpbyname='define' d_getpbynumber='define' d_getpent='undef' d_getpgid='undef' d_getpgrp2='undef' d_getpgrp='undef' d_getppid='undef' d_getprior='undef' d_getprotobyname_r='undef' d_getprotobynumber_r='undef' d_getprotoent_r='undef' d_getprotoprotos='define' d_getprpwnam='undef' d_getpwent='undef' d_getpwent_r='undef' d_getpwnam_r='undef' d_getpwuid_r='undef' d_getsbyname='define' d_getsbyport='define' d_getsent='undef' d_getservbyname_r='undef' d_getservbyport_r='undef' d_getservent_r='undef' d_getservprotos='define' d_getspnam='undef' d_getspnam_r='undef' d_gettimeod='define' d_gmtime64='undef' d_gmtime_r='undef' d_gnulibc='undef' d_grpasswd='undef' d_hasmntopt='undef' d_htonl='define' d_ilogbl='undef' d_inc_version_list='undef' d_index='undef' d_inetaton='undef' d_inetntop='undef' d_inetpton='undef' d_int64_t='undef' d_isascii='define' d_isfinite='undef' d_isinf='undef' d_isnan='define' d_isnanl='undef' d_killpg='define' d_lchown='undef' d_ldbl_dig='define' d_libm_lib_version='undef' d_link='define' d_localtime64='undef' d_localtime_r='undef' d_localtime_r_needs_tzset='undef' d_locconv='define' d_lockf='undef' d_longdbl='define' d_longlong='undef' d_lseekproto='define' d_lstat='undef' d_madvise='undef' d_malloc_good_size='undef' d_malloc_size='undef' d_mblen='define' d_mbstowcs='define' d_mbtowc='define' d_memchr='define' d_memcmp='define' d_memcpy='define' d_memmove='define' d_memset='define' d_mkdir='define' d_mkdtemp='undef' d_mkfifo='undef' d_mkstemp='undef' d_mkstemps='undef' d_mktime64='undef' d_mktime='define' d_mmap='undef' d_modfl='undef' d_modfl_pow32_bug='undef' d_modflproto='undef' d_mprotect='undef' d_msgctl='undef' d_msg_ctrunc='undef' d_msg_dontroute='undef' d_msgget='undef' d_msghdr_s='undef' d_msg_oob='undef' d_msg_peek='undef' d_msg_proxy='undef' d_msgrcv='undef' d_msgsnd='undef' d_msg='undef' d_msync='undef' d_munmap='undef' d_mymalloc='undef' d_ndbm='undef' d_ndbm_h_uses_prototypes='undef' d_nice='undef' d_nl_langinfo='undef' d_nv_preserves_uv='undef' d_nv_zero_is_allbits_zero='define' d_off64_t='undef' d_old_pthread_create_joinable='undef' d_oldpthreads='undef' d_oldsock='undef' d_open3='undef' d_pathconf='undef' d_pause='define' d_perl_otherlibdirs='undef' d_phostname='undef' d_pipe='define' d_poll='undef' d_portable='define' d_printf_format_null='undef' d_procselfexe='undef' d_pseudofork='undef' d_pthread_atfork='undef' d_pthread_attr_setscope='undef' d_pthread_yield='undef' d_pwage='undef' d_pwchange='undef' d_pwclass='undef' d_pwcomment='undef' d_pwexpire='undef' d_pwgecos='undef' d_pwpasswd='undef' d_pwquota='undef' d_qgcvt='undef' d_quad='define' d_random_r='undef' d_readdir64_r='undef' d_readdir='define' d_readdir_r='undef' d_readlink='undef' d_readv='undef' d_recvmsg='undef' d_rename='define' d_rewinddir='define' d_rmdir='define' d_safebcpy='undef' d_safemcpy='undef' d_sanemcmp='define' d_sbrkproto='undef' d_scalbnl='undef' d_sched_yield='undef' d_scm_rights='undef' d_seekdir='define' d_select='define' d_sem='undef' d_semctl='undef' d_semctl_semid_ds='undef' d_semctl_semun='undef' d_semget='undef' d_semop='undef' d_sendmsg='undef' d_setegid='undef' d_seteuid='undef' d_setgrent='undef' d_setgrent_r='undef' d_setgrps='undef' d_sethent='undef' d_sethostent_r='undef' d_setitimer='undef' d_setlinebuf='undef' d_setlocale='define' d_setlocale_r='undef' d_setnent='undef' d_setnetent_r='undef' d_setpent='undef' d_setpgid='undef' d_setpgrp2='undef' d_setpgrp='undef' d_setprior='undef' d_setproctitle='undef' d_setprotoent_r='undef' d_setpwent='undef' d_setpwent_r='undef' d_setregid='undef' d_setresgid='undef' d_setresuid='undef' d_setreuid='undef' d_setrgid='undef' d_setruid='undef' d_setsent='undef' d_setservent_r='undef' d_setsid='undef' d_setvbuf='define' d_sfio='undef' d_shm='undef' d_shmat='undef' d_shmatprototype='undef' d_shmctl='undef' d_shmdt='undef' d_shmget='undef' d_sigaction='undef' d_signbit='undef' d_sigprocmask='undef' d_sigsetjmp='undef' d_sitearch='define' d_snprintf='define' d_sockatmark='undef' d_sockatmarkproto='undef' d_socket='define' d_socklen_t='undef' d_sockpair='undef' d_socks5_init='undef' d_sprintf_returns_strlen='define' d_sqrtl='undef' d_srand48_r='undef' d_srandom_r='undef' d_sresgproto='undef' d_sresuproto='undef' d_statblks='undef' d_statfs_f_flags='undef' d_statfs_s='undef' d_statvfs='undef' d_stdio_cnt_lval='define' d_stdio_ptr_lval='define' d_stdio_ptr_lval_nochange_cnt='define' d_stdio_ptr_lval_sets_cnt='undef' d_stdio_stream_array='undef' d_stdiobase='define' d_stdstdio='define' d_strchr='define' d_strcoll='define' d_strctcpy='define' d_strerrm='strerror(e)' d_strerror='define' d_strerror_r='undef' d_strftime='define' d_strlcat='undef' d_strlcpy='undef' d_strtod='define' d_strtol='define' d_strtold='undef' d_strtoll='define' d_strtoq='undef' d_strtoul='define' d_strtoull='define' d_strtouq='undef' d_strxfrm='define' d_suidsafe='undef' d_symlink='undef' d_syscall='undef' d_syscallproto='undef' d_sysconf='undef' d_sysernlst='' d_syserrlst='define' d_system='define' d_tcgetpgrp='undef' d_tcsetpgrp='undef' d_telldir='define' d_telldirproto='define' d_time='define' d_timegm='undef' d_times='define' d_tm_tm_gmtoff='undef' d_tm_tm_zone='undef' d_tmpnam_r='undef' d_truncate='undef' d_ttyname_r='undef' d_tzname='define' d_u32align='define' d_ualarm='undef' d_umask='define' d_uname='define' d_union_semun='define' d_unordered='undef' d_unsetenv='undef' d_usleep='undef' d_usleepproto='undef' d_ustat='undef' d_vendorarch='undef' d_vendorbin='undef' d_vendorlib='undef' d_vendorscript='undef' d_vfork='undef' d_void_closedir='undef' d_voidsig='define' d_voidtty='' d_volatile='define' d_vprintf='define' d_vsnprintf='define' d_wait4='undef' d_waitpid='define' d_wcstombs='define' d_wctomb='define' d_writev='undef' d_xenix='undef' date='date' db_hashtype='int' db_prefixtype='int' db_version_major='0' db_version_minor='0' db_version_patch='0' defvoidused='15' direntrytype='struct direct' dlext='dll' dlsrc='dl_win32.xs' doublesize='8' drand01='(rand()/(double)((unsigned)1<GetDirW(index), index); } nDefault = pDir->GetDefault(); } else { int bSave = bManageDirectory; DWORD driveBits = GetLogicalDrives(); OSVERSIONINFO osver; memset(&osver, 0, sizeof(osver)); osver.dwOSVersionInfoSize = sizeof(osver); GetVersionEx(&osver); bManageDirectory = 0; if (osver.dwMajorVersion < 5) { char szBuffer[MAX_PATH*driveCount]; if (GetLogicalDriveStringsA(sizeof(szBuffer), szBuffer)) { char* pEnv = (char*)GetEnvironmentStringsA(); char* ptr = szBuffer; for (index = 0; index < driveCount; ++index) { if (driveBits & (1<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); return length; } 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)) { 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)) { SetDirW(&pEnv[4], index); break; } else pEnv += wcslen(pEnv)+1; } } void VDir::SetDefaultA(char const *pDefault) { char szBuffer[MAX_PATH+1]; char *pPtr; if (GetFullPathNameA(pDefault, sizeof(szBuffer), szBuffer, &pPtr)) { if (*pDefault != '.' && pPtr != NULL) *pPtr = '\0'; SetDefaultDirA(szBuffer, DriveIndex(szBuffer[0])); } } 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) { char *ansi; 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); } win32_free(ansi); } } if(bManageDirectory) ::SetCurrentDirectoryW(pPath); return length; } void VDir::SetDefaultW(WCHAR const *pDefault) { WCHAR szBuffer[MAX_PATH+1]; WCHAR *pPtr; if (GetFullPathNameW(pDefault, (sizeof(szBuffer)/sizeof(WCHAR)), szBuffer, &pPtr)) { if (*pDefault != '.' && pPtr != NULL) *pPtr = '\0'; SetDefaultDirW(szBuffer, DriveIndex((char)szBuffer[0])); } } inline BOOL IsPathSep(char ch) { return (ch == '\\' || ch == '/'); } inline void DoGetFullPathNameA(char* lpBuffer, DWORD dwSize, char* Dest) { char *pPtr; /* * On WinNT GetFullPathName does not fail, (or at least always * succeeds when the drive is valid) WinNT does set *Dest to NULL * On Win98 GetFullPathName will set last error if it fails, but * does not touch *Dest */ *Dest = '\0'; GetFullPathNameA(lpBuffer, dwSize, Dest, &pPtr); } inline bool IsSpecialFileName(const char* pName) { /* specical file names are devices that the system can open * these include AUX, CON, NUL, PRN, COMx, LPTx, CLOCK$, CONIN$, CONOUT$ * (x is a single digit, and names are case-insensitive) */ 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 ((pName[3] >= '1') && (pName[3] <= '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') && (pName[3] >= '1') && (pName[3] <= '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; } char *VDir::MapPathA(const char *pInName) { /* * possiblities -- relative path or absolute path with or without drive letter * OR UNC name */ char szBuffer[(MAX_PATH+1)*2]; char szlBuf[MAX_PATH+1]; int length = strlen(pInName); if (!length) 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; } /* strlen(pInName) is now <= MAX_PATH */ if (pInName[1] == ':') { /* has drive letter */ if (IsPathSep(pInName[2])) { /* absolute with drive letter */ DoGetFullPathNameA((char*)pInName, sizeof(szLocalBufferA), szLocalBufferA); } else { /* relative path with drive letter */ strcpy(szBuffer, GetDirA(DriveIndex(*pInName))); strcat(szBuffer, &pInName[2]); if(strlen(szBuffer) > MAX_PATH) szBuffer[MAX_PATH] = '\0'; DoGetFullPathNameA(szBuffer, sizeof(szLocalBufferA), szLocalBufferA); } } else { /* no drive letter */ if (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; } int VDir::SetCurrentDirectoryA(char *lpBuffer) { char *pPtr; int length, nRet = -1; 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'; } 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; } return nRet; } DWORD VDir::CalculateEnvironmentSpace(void) { /* the current directory environment strings are stored as '=D:=d:\path' */ 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:=' */ } } return dwSize; } LPSTR VDir::BuildEnvironmentSpace(LPSTR lpStr) { /* store the current directory environment strings as '=D:=d:\path' */ 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; } } } return lpStr; } inline BOOL IsPathSep(WCHAR ch) { return (ch == '\\' || ch == '/'); } inline void DoGetFullPathNameW(WCHAR* lpBuffer, DWORD dwSize, WCHAR* Dest) { WCHAR *pPtr; /* * On WinNT GetFullPathName does not fail, (or at least always * succeeds when the drive is valid) WinNT does set *Dest to NULL * On Win98 GetFullPathName will set last error if it fails, but * does not touch *Dest */ *Dest = '\0'; GetFullPathNameW(lpBuffer, dwSize, Dest, &pPtr); } inline bool IsSpecialFileName(const WCHAR* pName) { /* specical file names are devices that the system can open * these include AUX, CON, NUL, PRN, COMx, LPTx, CLOCK$, CONIN$, CONOUT$ * (x is a single digit, and names are case-insensitive) */ 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 ((pName[3] >= '1') && (pName[3] <= '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') && (pName[3] >= '1') && (pName[3] <= '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; } WCHAR* VDir::MapPathW(const WCHAR *pInName) { /* * possiblities -- relative path or absolute path with or without drive letter * OR UNC name */ WCHAR szBuffer[(MAX_PATH+1)*2]; WCHAR szlBuf[MAX_PATH+1]; int length = wcslen(pInName); if (!length) 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; } /* strlen(pInName) is now <= MAX_PATH */ if (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 */ wcscpy(szBuffer, GetDirW(DriveIndex((char)*pInName))); wcscat(szBuffer, &pInName[2]); if(wcslen(szBuffer) > MAX_PATH) szBuffer[MAX_PATH] = '\0'; DoGetFullPathNameW(szBuffer, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW); } } else { /* no drive letter */ if (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; } int VDir::SetCurrentDirectoryW(WCHAR *lpBuffer) { WCHAR *pPtr; int length, nRet = -1; 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'; } 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; } return nRet; } #endif /* ___VDir_H___ */ perl-5.12.0-RC0/win32/genmk95.pl0000444000175000017500000000454611143650501014710 0ustar jessejesse# genmk95.pl - uses miniperl to generate a makefile that command.com will # understand given one that cmd.exe will understand # Author: Benjamin K. Stuhl # Date: 10-16-1999 # how it works: # dmake supports an alternative form for its recipes, called "group # recipes", in which all elements of a recipe are run with only one shell. # This program converts the standard dmake makefile.mk to one using group # recipes. This is done so that lines using && or || (which command.com # doesn't understand) may be split into two lines that will still be run # with one shell. my ($filein, $fileout) = @ARGV; open my $in, $filein or die "Error opening input file: $!\n"; open my $out, "> $fileout" or die "Error opening output file: $!\n"; print $out <<_EOH_; # *** Warning: this file is autogenerated from $filein by $0 *** # *** Do not edit this file - edit $filein instead *** _HOME_DIR := \$(PWD) _EOH_ my $inrec = 0; while (<$in>) { chomp; if (/^[^#.\t][^#=]*?:(?:[^=]|$)/) { if (! $inrec) { print $out "$_\n"; while (/\\\s*$/) { chomp($_ = <$in>); print $out "$_\n"; } print $out "@[\n"; $inrec = 1; next; } else { if (!/^\t/) { seek ($out, -4, 2); # no recipe, so back up and undo grouping # should be -3, but MS has its CR/LF thing... $inrec = 0; } print $out "$_\n"; next; } } if ((/^\s*$/ || /^[^#.\t][^#=]*?:/) && $inrec) { print $out "]\n"; print $out "$_\n"; $inrec = 0; next; } if (/^(.*?)(&&|\|\|)(.*)$/) # two commands separated by && or || { my ($one, $sep, $two) = ($1, $2, $3); $one =~ s/^\t(?:-(?!-))?\@?(.*?)$/\t$1/; # no -,@ in group recipes LINE_CONT: if ($two =~ /\\\s*$/) { chomp ($two .= "\n" . scalar <$in>); goto LINE_CONT; } s/^\s*// for ($one, $two); print $out "\t$one\n\t$two\n" if ($sep eq "&&"); print $out "\t$one\n\tif errorlevel 1 $two\n" if ($sep eq "||"); print $out "\tcd \$(_HOME_DIR)\n"; next; } # fall through - no need for special handling s/^\t(?:-(?!-))?\@?(.*?)$/\t$1/; # no -,@ in group recipes print $out "$_\n"; } print $out "]\n" if ($inrec); close $in or warn "Error closing \$in: $!\n"; close $out or warn "Error closing \$out: $!\n"; perl-5.12.0-RC0/win32/config_H.bc0000644000175000017500000043312711325127002015116 0ustar jessejesse/* * This file was produced by running the config_h.SH script, which * gets its values from undef, which is generally produced by * running Configure. * * Feel free to modify any of this as the need arises. Note, however, * that running config_h.SH again will wipe out any changes you've made. * For a more permanent change edit undef and rerun config_h.SH. * * $Id: Config_h.U 1 2006-08-24 12:32:52Z rmanfredi $ */ /* * Package name : perl5 * Source directory : * Configuration time: Mon Jan 11 00:09:46 2010 * Configured by : Steve * Target system : */ #ifndef _config_h_ #define _config_h_ /* LOC_SED: * This symbol holds the complete pathname to the sed program. */ #define LOC_SED "" /**/ /* HAS_ALARM: * This symbol, if defined, indicates that the alarm routine is * available. */ #define HAS_ALARM /**/ /* HAS_BCMP: * This symbol is defined if the bcmp() routine is available to * compare blocks of memory. */ /*#define HAS_BCMP / **/ /* HAS_BCOPY: * This symbol is defined if the bcopy() routine is available to * copy blocks of memory. */ /*#define HAS_BCOPY / **/ /* HAS_BZERO: * This symbol is defined if the bzero() routine is available to * set a memory block to 0. */ /*#define HAS_BZERO / **/ /* HAS_CHOWN: * This symbol, if defined, indicates that the chown routine is * available. */ /*#define HAS_CHOWN / **/ /* HAS_CHROOT: * This symbol, if defined, indicates that the chroot routine is * available. */ /*#define HAS_CHROOT / **/ /* HAS_CHSIZE: * This symbol, if defined, indicates that the chsize routine is available * to truncate files. You might need a -lx to get this routine. */ #define HAS_CHSIZE /**/ /* HAS_CRYPT: * This symbol, if defined, indicates that the crypt routine is available * to encrypt passwords and the like. */ /*#define HAS_CRYPT / **/ /* HAS_CTERMID: * This symbol, if defined, indicates that the ctermid routine is * available to generate filename for terminal. */ /*#define HAS_CTERMID / **/ /* HAS_CUSERID: * This symbol, if defined, indicates that the cuserid routine is * available to get character login names. */ /*#define HAS_CUSERID / **/ /* HAS_DBL_DIG: * This symbol, if defined, indicates that this system's * or defines the symbol DBL_DIG, which is the number * of significant digits in a double precision number. If this * symbol is not defined, a guess of 15 is usually pretty good. */ #define HAS_DBL_DIG /**/ /* HAS_DIFFTIME: * This symbol, if defined, indicates that the difftime routine is * available. */ #define HAS_DIFFTIME /**/ /* HAS_DLERROR: * This symbol, if defined, indicates that the dlerror routine is * available to return a string describing the last error that * occurred from a call to dlopen(), dlclose() or dlsym(). */ #define HAS_DLERROR /**/ /* HAS_DUP2: * This symbol, if defined, indicates that the dup2 routine is * available to duplicate file descriptors. */ #define HAS_DUP2 /**/ /* HAS_FCHMOD: * This symbol, if defined, indicates that the fchmod routine is available * to change mode of opened files. If unavailable, use chmod(). */ /*#define HAS_FCHMOD / **/ /* HAS_FCHOWN: * This symbol, if defined, indicates that the fchown routine is available * to change ownership of opened files. If unavailable, use chown(). */ /*#define HAS_FCHOWN / **/ /* HAS_FCNTL: * This symbol, if defined, indicates to the C program that * the fcntl() function exists. */ /*#define HAS_FCNTL / **/ /* HAS_FGETPOS: * This symbol, if defined, indicates that the fgetpos routine is * available to get the file position indicator, similar to ftell(). */ #define HAS_FGETPOS /**/ /* HAS_FLOCK: * This symbol, if defined, indicates that the flock routine is * available to do file locking. */ #define HAS_FLOCK /**/ /* HAS_FORK: * This symbol, if defined, indicates that the fork routine is * available. */ /*#define HAS_FORK / **/ /* HAS_FSETPOS: * This symbol, if defined, indicates that the fsetpos routine is * available to set the file position indicator, similar to fseek(). */ #define HAS_FSETPOS /**/ /* HAS_GETTIMEOFDAY: * This symbol, if defined, indicates that the gettimeofday() system * call is available for a sub-second accuracy clock. Usually, the file * needs to be included (see I_SYS_RESOURCE). * The type "Timeval" should be used to refer to "struct timeval". */ #define HAS_GETTIMEOFDAY /**/ #ifdef HAS_GETTIMEOFDAY #define Timeval struct timeval /* Structure used by gettimeofday() */ #endif /* HAS_GETGROUPS: * This symbol, if defined, indicates that the getgroups() routine is * available to get the list of process groups. If unavailable, multiple * groups are probably not supported. */ /*#define HAS_GETGROUPS / **/ /* HAS_GETLOGIN: * This symbol, if defined, indicates that the getlogin routine is * available to get the login name. */ #define HAS_GETLOGIN /**/ /* HAS_GETPGID: * This symbol, if defined, indicates to the C program that * the getpgid(pid) function is available to get the * process group id. */ /*#define HAS_GETPGID / **/ /* HAS_GETPGRP2: * This symbol, if defined, indicates that the getpgrp2() (as in DG/UX) * routine is available to get the current process group. */ /*#define HAS_GETPGRP2 / **/ /* HAS_GETPPID: * This symbol, if defined, indicates that the getppid routine is * available to get the parent process ID. */ /*#define HAS_GETPPID / **/ /* HAS_GETPRIORITY: * This symbol, if defined, indicates that the getpriority routine is * available to get a process's priority. */ /*#define HAS_GETPRIORITY / **/ /* HAS_INET_ATON: * This symbol, if defined, indicates to the C program that the * inet_aton() function is available to parse IP address "dotted-quad" * strings. */ /*#define HAS_INET_ATON / **/ /* HAS_KILLPG: * This symbol, if defined, indicates that the killpg routine is available * to kill process groups. If unavailable, you probably should use kill * with a negative process number. */ #define HAS_KILLPG /**/ /* HAS_LINK: * This symbol, if defined, indicates that the link routine is * available to create hard links. */ #define HAS_LINK /**/ /* HAS_LOCALECONV: * This symbol, if defined, indicates that the localeconv routine is * available for numeric and monetary formatting conventions. */ #define HAS_LOCALECONV /**/ /* HAS_LOCKF: * This symbol, if defined, indicates that the lockf routine is * available to do file locking. */ /*#define HAS_LOCKF / **/ /* HAS_LSTAT: * This symbol, if defined, indicates that the lstat routine is * available to do file stats on symbolic links. */ /*#define HAS_LSTAT / **/ /* HAS_MBLEN: * This symbol, if defined, indicates that the mblen routine is available * to find the number of bytes in a multibye character. */ #define HAS_MBLEN /**/ /* HAS_MBSTOWCS: * This symbol, if defined, indicates that the mbstowcs routine is * available to covert a multibyte string into a wide character string. */ #define HAS_MBSTOWCS /**/ /* HAS_MBTOWC: * This symbol, if defined, indicates that the mbtowc routine is available * to covert a multibyte to a wide character. */ #define HAS_MBTOWC /**/ /* HAS_MEMCMP: * This symbol, if defined, indicates that the memcmp routine is available * to compare blocks of memory. */ #define HAS_MEMCMP /**/ /* HAS_MEMCPY: * This symbol, if defined, indicates that the memcpy routine is available * to copy blocks of memory. */ #define HAS_MEMCPY /**/ /* HAS_MEMMOVE: * This symbol, if defined, indicates that the memmove routine is available * to copy potentially overlapping blocks of memory. This should be used * only when HAS_SAFE_BCOPY is not defined. If neither is there, roll your * own version. */ #define HAS_MEMMOVE /**/ /* HAS_MEMSET: * This symbol, if defined, indicates that the memset routine is available * to set blocks of memory. */ #define HAS_MEMSET /**/ /* HAS_MKDIR: * This symbol, if defined, indicates that the mkdir routine is available * to create directories. Otherwise you should fork off a new process to * exec /bin/mkdir. */ #define HAS_MKDIR /**/ /* HAS_MKFIFO: * This symbol, if defined, indicates that the mkfifo routine is * available to create FIFOs. Otherwise, mknod should be able to * do it for you. However, if mkfifo is there, mknod might require * super-user privileges which mkfifo will not. */ /*#define HAS_MKFIFO / **/ /* HAS_MKTIME: * This symbol, if defined, indicates that the mktime routine is * available. */ #define HAS_MKTIME /**/ /* HAS_MSYNC: * This symbol, if defined, indicates that the msync system call is * available to synchronize a mapped file. */ /*#define HAS_MSYNC / **/ /* HAS_MUNMAP: * This symbol, if defined, indicates that the munmap system call is * available to unmap a region, usually mapped by mmap(). */ /*#define HAS_MUNMAP / **/ /* HAS_NICE: * This symbol, if defined, indicates that the nice routine is * available. */ /*#define HAS_NICE / **/ /* HAS_PATHCONF: * This symbol, if defined, indicates that pathconf() is available * to determine file-system related limits and options associated * with a given filename. */ /* HAS_FPATHCONF: * This symbol, if defined, indicates that pathconf() is available * to determine file-system related limits and options associated * with a given open file descriptor. */ /*#define HAS_PATHCONF / **/ /*#define HAS_FPATHCONF / **/ /* HAS_PAUSE: * This symbol, if defined, indicates that the pause routine is * available to suspend a process until a signal is received. */ #define HAS_PAUSE /**/ /* HAS_PIPE: * This symbol, if defined, indicates that the pipe routine is * available to create an inter-process channel. */ #define HAS_PIPE /**/ /* HAS_POLL: * This symbol, if defined, indicates that the poll routine is * available to poll active file descriptors. Please check I_POLL and * I_SYS_POLL to know which header should be included as well. */ /*#define HAS_POLL / **/ /* HAS_READDIR: * This symbol, if defined, indicates that the readdir routine is * available to read directory entries. You may have to include * . See I_DIRENT. */ #define HAS_READDIR /**/ /* HAS_SEEKDIR: * This symbol, if defined, indicates that the seekdir routine is * available. You may have to include . See I_DIRENT. */ #define HAS_SEEKDIR /**/ /* HAS_TELLDIR: * This symbol, if defined, indicates that the telldir routine is * available. You may have to include . See I_DIRENT. */ #define HAS_TELLDIR /**/ /* HAS_REWINDDIR: * This symbol, if defined, indicates that the rewinddir routine is * available. You may have to include . See I_DIRENT. */ #define HAS_REWINDDIR /**/ /* HAS_READLINK: * This symbol, if defined, indicates that the readlink routine is * available to read the value of a symbolic link. */ /*#define HAS_READLINK / **/ /* HAS_RENAME: * This symbol, if defined, indicates that the rename routine is available * to rename files. Otherwise you should do the unlink(), link(), unlink() * trick. */ #define HAS_RENAME /**/ /* HAS_RMDIR: * This symbol, if defined, indicates that the rmdir routine is * available to remove directories. Otherwise you should fork off a * new process to exec /bin/rmdir. */ #define HAS_RMDIR /**/ /* HAS_SELECT: * This symbol, if defined, indicates that the select routine is * available to select active file descriptors. If the timeout field * is used, may need to be included. */ #define HAS_SELECT /**/ /* HAS_SETEGID: * This symbol, if defined, indicates that the setegid routine is available * to change the effective gid of the current program. */ /*#define HAS_SETEGID / **/ /* HAS_SETEUID: * This symbol, if defined, indicates that the seteuid routine is available * to change the effective uid of the current program. */ /*#define HAS_SETEUID / **/ /* HAS_SETGROUPS: * This symbol, if defined, indicates that the setgroups() routine is * available to set the list of process groups. If unavailable, multiple * groups are probably not supported. */ /*#define HAS_SETGROUPS / **/ /* HAS_SETLINEBUF: * This symbol, if defined, indicates that the setlinebuf routine is * available to change stderr or stdout from block-buffered or unbuffered * to a line-buffered mode. */ /*#define HAS_SETLINEBUF / **/ /* HAS_SETLOCALE: * This symbol, if defined, indicates that the setlocale routine is * available to handle locale-specific ctype implementations. */ #define HAS_SETLOCALE /**/ /* HAS_SETPGID: * This symbol, if defined, indicates that the setpgid(pid, gpid) * routine is available to set process group ID. */ /*#define HAS_SETPGID / **/ /* HAS_SETPGRP2: * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX) * routine is available to set the current process group. */ /*#define HAS_SETPGRP2 / **/ /* HAS_SETPRIORITY: * This symbol, if defined, indicates that the setpriority routine is * available to set a process's priority. */ /*#define HAS_SETPRIORITY / **/ /* HAS_SETREGID: * This symbol, if defined, indicates that the setregid routine is * available to change the real and effective gid of the current * process. */ /* HAS_SETRESGID: * This symbol, if defined, indicates that the setresgid routine is * available to change the real, effective and saved gid of the current * process. */ /*#define HAS_SETREGID / **/ /*#define HAS_SETRESGID / **/ /* HAS_SETREUID: * This symbol, if defined, indicates that the setreuid routine is * available to change the real and effective uid of the current * process. */ /* HAS_SETRESUID: * This symbol, if defined, indicates that the setresuid routine is * available to change the real, effective and saved uid of the current * process. */ /*#define HAS_SETREUID / **/ /*#define HAS_SETRESUID / **/ /* HAS_SETRGID: * This symbol, if defined, indicates that the setrgid routine is available * to change the real gid of the current program. */ /*#define HAS_SETRGID / **/ /* HAS_SETRUID: * This symbol, if defined, indicates that the setruid routine is available * to change the real uid of the current program. */ /*#define HAS_SETRUID / **/ /* HAS_SETSID: * This symbol, if defined, indicates that the setsid routine is * available to set the process group ID. */ /*#define HAS_SETSID / **/ /* HAS_STRCHR: * This symbol is defined to indicate that the strchr()/strrchr() * functions are available for string searching. If not, try the * index()/rindex() pair. */ /* HAS_INDEX: * This symbol is defined to indicate that the index()/rindex() * functions are available for string searching. */ #define HAS_STRCHR /**/ /*#define HAS_INDEX / **/ /* HAS_STRCOLL: * This symbol, if defined, indicates that the strcoll routine is * available to compare strings using collating information. */ #define HAS_STRCOLL /**/ /* HAS_STRTOD: * This symbol, if defined, indicates that the strtod routine is * available to provide better numeric string conversion than atof(). */ #define HAS_STRTOD /**/ /* HAS_STRTOL: * This symbol, if defined, indicates that the strtol routine is available * to provide better numeric string conversion than atoi() and friends. */ #define HAS_STRTOL /**/ /* HAS_STRXFRM: * This symbol, if defined, indicates that the strxfrm() routine is * available to transform strings. */ #define HAS_STRXFRM /**/ /* HAS_SYMLINK: * This symbol, if defined, indicates that the symlink routine is available * to create symbolic links. */ /*#define HAS_SYMLINK / **/ /* HAS_SYSCALL: * This symbol, if defined, indicates that the syscall routine is * available to call arbitrary system calls. If undefined, that's tough. */ /*#define HAS_SYSCALL / **/ /* HAS_SYSCONF: * This symbol, if defined, indicates that sysconf() is available * to determine system related limits and options. */ /*#define HAS_SYSCONF / **/ /* HAS_SYSTEM: * This symbol, if defined, indicates that the system routine is * available to issue a shell command. */ #define HAS_SYSTEM /**/ /* HAS_TCGETPGRP: * This symbol, if defined, indicates that the tcgetpgrp routine is * available to get foreground process group ID. */ /*#define HAS_TCGETPGRP / **/ /* HAS_TCSETPGRP: * This symbol, if defined, indicates that the tcsetpgrp routine is * available to set foreground process group ID. */ /*#define HAS_TCSETPGRP / **/ /* HAS_TRUNCATE: * This symbol, if defined, indicates that the truncate routine is * available to truncate files. */ /*#define HAS_TRUNCATE / **/ /* HAS_TZNAME: * This symbol, if defined, indicates that the tzname[] array is * available to access timezone names. */ #define HAS_TZNAME /**/ /* HAS_UMASK: * This symbol, if defined, indicates that the umask routine is * available to set and get the value of the file creation mask. */ #define HAS_UMASK /**/ /* HAS_USLEEP: * This symbol, if defined, indicates that the usleep routine is * available to let the process sleep on a sub-second accuracy. */ /*#define HAS_USLEEP / **/ /* HAS_WAIT4: * This symbol, if defined, indicates that wait4() exists. */ /*#define HAS_WAIT4 / **/ /* HAS_WAITPID: * This symbol, if defined, indicates that the waitpid routine is * available to wait for child process. */ #define HAS_WAITPID /**/ /* HAS_WCSTOMBS: * This symbol, if defined, indicates that the wcstombs routine is * available to convert wide character strings to multibyte strings. */ #define HAS_WCSTOMBS /**/ /* HAS_WCTOMB: * This symbol, if defined, indicates that the wctomb routine is available * to covert a wide character to a multibyte. */ #define HAS_WCTOMB /**/ /* Groups_t: * This symbol holds the type used for the second argument to * getgroups() and setgroups(). Usually, this is the same as * gidtype (gid_t) , but sometimes it isn't. * It can be int, ushort, gid_t, etc... * It may be necessary to include to get any * typedef'ed information. This is only required if you have * getgroups() or setgroups().. */ #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS) #define Groups_t gid_t /* Type for 2nd arg to [sg]etgroups() */ #endif /* I_ARPA_INET: * This symbol, if defined, indicates to the C program that it should * include to get inet_addr and friends declarations. */ #define I_ARPA_INET /**/ /* I_DBM: * This symbol, if defined, indicates that exists and should * be included. */ /* I_RPCSVC_DBM: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_DBM / **/ #define I_RPCSVC_DBM /**/ /* I_DLFCN: * This symbol, if defined, indicates that exists and should * be included. */ #define I_DLFCN /**/ /* I_FCNTL: * This manifest constant tells the C program to include . */ #define I_FCNTL /**/ /* I_FLOAT: * This symbol, if defined, indicates to the C program that it should * include to get definition of symbols like DBL_MAX or * DBL_MIN, i.e. machine dependent floating point values. */ #define I_FLOAT /**/ /* I_GDBM: * This symbol, if defined, indicates that exists and should * be included. */ /*#define I_GDBM / **/ /* I_LIMITS: * This symbol, if defined, indicates to the C program that it should * include to get definition of symbols like WORD_BIT or * LONG_MAX, i.e. machine dependant limitations. */ #define I_LIMITS /**/ /* I_LOCALE: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_LOCALE /**/ /* I_MATH: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_MATH /**/ /* I_MEMORY: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_MEMORY / **/ /* I_NETINET_IN: * This symbol, if defined, indicates to the C program that it should * include . Otherwise, you may try . */ /*#define I_NETINET_IN / **/ /* I_SFIO: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SFIO / **/ /* I_STDDEF: * This symbol, if defined, indicates that exists and should * be included. */ #define I_STDDEF /**/ /* I_STDLIB: * This symbol, if defined, indicates that exists and should * be included. */ #define I_STDLIB /**/ /* I_STRING: * This symbol, if defined, indicates to the C program that it should * include (USG systems) instead of (BSD systems). */ #define I_STRING /**/ /* I_SYS_DIR: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_DIR / **/ /* I_SYS_FILE: * This symbol, if defined, indicates to the C program that it should * include to get definition of R_OK and friends. */ /*#define I_SYS_FILE / **/ /* I_SYS_IOCTL: * This symbol, if defined, indicates that exists and should * be included. Otherwise, include or . */ /* I_SYS_SOCKIO: * This symbol, if defined, indicates the should be included * to get socket ioctl options, like SIOCATMARK. */ /*#define I_SYS_IOCTL / **/ /*#define I_SYS_SOCKIO / **/ /* I_SYS_NDIR: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_NDIR / **/ /* I_SYS_PARAM: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_PARAM / **/ /* I_SYS_POLL: * This symbol, if defined, indicates that the program may include * . When I_POLL is also defined, it's probably safest * to only include . */ /*#define I_SYS_POLL / **/ /* I_SYS_RESOURCE: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_RESOURCE / **/ /* I_SYS_SELECT: * This symbol, if defined, indicates to the C program that it should * include in order to get definition of struct timeval. */ /*#define I_SYS_SELECT / **/ /* I_SYS_STAT: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_STAT /**/ /* I_SYS_TIMES: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_TIMES / **/ /* I_SYS_TYPES: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_TYPES /**/ /* I_SYS_UN: * This symbol, if defined, indicates to the C program that it should * include to get UNIX domain socket definitions. */ /*#define I_SYS_UN / **/ /* I_SYS_WAIT: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_WAIT / **/ /* I_TERMIO: * This symbol, if defined, indicates that the program should include * rather than . There are also differences in * the ioctl() calls that depend on the value of this symbol. */ /* I_TERMIOS: * This symbol, if defined, indicates that the program should include * the POSIX termios.h rather than sgtty.h or termio.h. * There are also differences in the ioctl() calls that depend on the * value of this symbol. */ /* I_SGTTY: * This symbol, if defined, indicates that the program should include * rather than . There are also differences in * the ioctl() calls that depend on the value of this symbol. */ /*#define I_TERMIO / **/ /*#define I_TERMIOS / **/ /*#define I_SGTTY / **/ /* I_UNISTD: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_UNISTD / **/ /* I_UTIME: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_UTIME /**/ /* I_VALUES: * This symbol, if defined, indicates to the C program that it should * include to get definition of symbols like MINFLOAT or * MAXLONG, i.e. machine dependant limitations. Probably, you * should use instead, if it is available. */ /*#define I_VALUES / **/ /* I_VFORK: * This symbol, if defined, indicates to the C program that it should * include vfork.h. */ /*#define I_VFORK / **/ /* CAN_VAPROTO: * This variable is defined on systems supporting prototype declaration * of functions with a variable number of arguments. */ /* _V: * This macro is used to declare function parameters in prototypes for * functions with a variable number of parameters. Use double parentheses. * For example: * * int printf _V((char *fmt, ...)); * * Remember to use the plain simple _() macro when declaring a function * with no variable number of arguments, since it might be possible to * have a non-effect _V() macro and still get prototypes via _(). */ /*#define CAN_VAPROTO / **/ #ifdef CAN_VAPROTO #define _V(args) args #else #define _V(args) () #endif /* INTSIZE: * This symbol contains the value of sizeof(int) so that the C * preprocessor can make decisions based on it. */ /* LONGSIZE: * This symbol contains the value of sizeof(long) so that the C * preprocessor can make decisions based on it. */ /* SHORTSIZE: * This symbol contains the value of sizeof(short) so that the C * preprocessor can make decisions based on it. */ #define INTSIZE 4 /**/ #define LONGSIZE 4 /**/ #define SHORTSIZE 2 /**/ /* MULTIARCH: * This symbol, if defined, signifies that the build * process will produce some binary files that are going to be * used in a cross-platform environment. This is the case for * example with the NeXT "fat" binaries that contain executables * for several CPUs. */ /*#define MULTIARCH / **/ /* HAS_QUAD: * This symbol, if defined, tells that there's a 64-bit integer type, * Quad_t, and its unsigned counterpar, Uquad_t. QUADKIND will be one * of QUAD_IS_INT, QUAD_IS_LONG, QUAD_IS_LONG_LONG, QUAD_IS_INT64_T, * or QUAD_IS___INT64. */ #define HAS_QUAD /**/ #ifdef HAS_QUAD # define Quad_t __int64 /**/ # define Uquad_t unsigned __int64 /**/ # define QUADKIND 5 /**/ # define QUAD_IS_INT 1 # define QUAD_IS_LONG 2 # define QUAD_IS_LONG_LONG 3 # define QUAD_IS_INT64_T 4 # define QUAD_IS___INT64 5 #endif /* OSNAME: * This symbol contains the name of the operating system, as determined * by Configure. You shouldn't rely on it too much; the specific * feature tests from Configure are generally more reliable. */ /* OSVERS: * This symbol contains the version of the operating system, as determined * by Configure. You shouldn't rely on it too much; the specific * feature tests from Configure are generally more reliable. */ #define OSNAME "MSWin32" /**/ #define OSVERS "5.1" /**/ /* ARCHLIB: * This variable, if defined, holds the name of the directory in * which the user wants to put architecture-dependent public * library files for perl5. It is most often a local directory * such as /usr/local/lib. Programs using this variable must be * prepared to deal with filename expansion. If ARCHLIB is the * same as PRIVLIB, it is not defined, since presumably the * program already searches PRIVLIB. */ /* ARCHLIB_EXP: * This symbol contains the ~name expanded version of ARCHLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ #define ARCHLIB "c:\\perl\\lib" /**/ /*#define ARCHLIB_EXP "" / **/ /* ARCHNAME: * This symbol holds a string representing the architecture name. * It may be used to construct an architecture-dependant pathname * where library files may be held under a private library, for * instance. */ #define ARCHNAME "MSWin32-x86" /**/ /* BIN: * This symbol holds the path of the bin directory where the package will * be installed. Program must be prepared to deal with ~name substitution. */ /* BIN_EXP: * This symbol is the filename expanded version of the BIN symbol, for * programs that do not want to deal with that at run-time. */ /* PERL_RELOCATABLE_INC: * This symbol, if defined, indicates that we'd like to relocate entries * in @INC at run time based on the location of the perl binary. */ #define BIN "c:\\perl\\bin" /**/ #define BIN_EXP "c:\\perl\\bin" /**/ #define PERL_RELOCATABLE_INC "undef" /**/ /* CAT2: * This macro concatenates 2 tokens together. */ /* STRINGIFY: * This macro surrounds its token with double quotes. */ #if 42 == 1 #define CAT2(a,b) a/**/b #define STRINGIFY(a) "a" #endif #if 42 == 42 #define PeRl_CaTiFy(a, b) a ## b #define PeRl_StGiFy(a) #a #define CAT2(a,b) PeRl_CaTiFy(a,b) #define StGiFy(a) PeRl_StGiFy(a) #define STRINGIFY(a) PeRl_StGiFy(a) #endif #if 42 != 1 && 42 != 42 #include "Bletch: How does this C preprocessor concatenate tokens?" #endif /* CPPSTDIN: * This symbol contains the first part of the string which will invoke * the C preprocessor on the standard input and produce to standard * output. Typical value of "cc -E" or "/lib/cpp", but it can also * call a wrapper. See CPPRUN. */ /* CPPMINUS: * This symbol contains the second part of the string which will invoke * the C preprocessor on the standard input and produce to standard * output. This symbol will have the value "-" if CPPSTDIN needs a minus * to specify standard input, otherwise the value is "". */ /* CPPRUN: * This symbol contains the string which will invoke a C preprocessor on * the standard input and produce to standard output. It needs to end * with CPPLAST, after all other preprocessor flags have been specified. * The main difference with CPPSTDIN is that this program will never be a * pointer to a shell wrapper, i.e. it will be empty if no preprocessor is * available directly to the user. Note that it may well be different from * the preprocessor used to compile the C program. */ /* CPPLAST: * This symbol is intended to be used along with CPPRUN in the same manner * symbol CPPMINUS is used with CPPSTDIN. It contains either "-" or "". */ #define CPPSTDIN "cppstdin" #define CPPMINUS "" #define CPPRUN "cpp32 -oCON" #define CPPLAST "" /* HAS_ACCESS: * This manifest constant lets the C program know that the access() * system call is available to check for accessibility using real UID/GID. * (always present on UNIX.) */ #define HAS_ACCESS /**/ /* HAS_ACCESSX: * This symbol, if defined, indicates that the accessx routine is * available to do extended access checks. */ /*#define HAS_ACCESSX / **/ /* HAS_ASCTIME_R: * This symbol, if defined, indicates that the asctime_r routine * is available to asctime re-entrantly. */ /* ASCTIME_R_PROTO: * This symbol encodes the prototype of asctime_r. * It is zero if d_asctime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_asctime_r * is defined. */ /*#define HAS_ASCTIME_R / **/ #define ASCTIME_R_PROTO 0 /**/ /* HASATTRIBUTE_FORMAT: * Can we handle GCC attribute for checking printf-style formats */ /* PRINTF_FORMAT_NULL_OK: * Allows __printf__ format to be null when checking printf-style */ /* HASATTRIBUTE_MALLOC: * Can we handle GCC attribute for malloc-style functions. */ /* HASATTRIBUTE_NONNULL: * Can we handle GCC attribute for nonnull function parms. */ /* HASATTRIBUTE_NORETURN: * Can we handle GCC attribute for functions that do not return */ /* HASATTRIBUTE_PURE: * Can we handle GCC attribute for pure functions */ /* HASATTRIBUTE_UNUSED: * Can we handle GCC attribute for unused variables and arguments */ /* HASATTRIBUTE_DEPRECATED: * Can we handle GCC attribute for marking deprecated APIs */ /* HASATTRIBUTE_WARN_UNUSED_RESULT: * Can we handle GCC attribute for warning on unused results */ /*#define HASATTRIBUTE_DEPRECATED / **/ /*#define HASATTRIBUTE_FORMAT / **/ /*#define PRINTF_FORMAT_NULL_OK / **/ /*#define HASATTRIBUTE_NORETURN / **/ /*#define HASATTRIBUTE_MALLOC / **/ /*#define HASATTRIBUTE_NONNULL / **/ /*#define HASATTRIBUTE_PURE / **/ /*#define HASATTRIBUTE_UNUSED / **/ /*#define HASATTRIBUTE_WARN_UNUSED_RESULT / **/ /* HASCONST: * This symbol, if defined, indicates that this C compiler knows about * the const type. There is no need to actually test for that symbol * within your programs. The mere use of the "const" keyword will * trigger the necessary tests. */ #define HASCONST /**/ #ifndef HASCONST #define const #endif /* HAS_CRYPT_R: * This symbol, if defined, indicates that the crypt_r routine * is available to crypt re-entrantly. */ /* CRYPT_R_PROTO: * This symbol encodes the prototype of crypt_r. * It is zero if d_crypt_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_crypt_r * is defined. */ /*#define HAS_CRYPT_R / **/ #define CRYPT_R_PROTO 0 /**/ /* HAS_CSH: * This symbol, if defined, indicates that the C-shell exists. */ /* CSH: * This symbol, if defined, contains the full pathname of csh. */ /*#define HAS_CSH / **/ #ifdef HAS_CSH #define CSH "" /**/ #endif /* HAS_CTERMID_R: * This symbol, if defined, indicates that the ctermid_r routine * is available to ctermid re-entrantly. */ /* CTERMID_R_PROTO: * This symbol encodes the prototype of ctermid_r. * It is zero if d_ctermid_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ctermid_r * is defined. */ /*#define HAS_CTERMID_R / **/ #define CTERMID_R_PROTO 0 /**/ /* HAS_CTIME_R: * This symbol, if defined, indicates that the ctime_r routine * is available to ctime re-entrantly. */ /* CTIME_R_PROTO: * This symbol encodes the prototype of ctime_r. * It is zero if d_ctime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ctime_r * is defined. */ /*#define HAS_CTIME_R / **/ #define CTIME_R_PROTO 0 /**/ /* HAS_DRAND48_R: * This symbol, if defined, indicates that the drand48_r routine * is available to drand48 re-entrantly. */ /* DRAND48_R_PROTO: * This symbol encodes the prototype of drand48_r. * It is zero if d_drand48_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_drand48_r * is defined. */ /*#define HAS_DRAND48_R / **/ #define DRAND48_R_PROTO 0 /**/ /* HAS_DRAND48_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the drand48() function. Otherwise, it is up * to the program to supply one. A good guess is * extern double drand48(void); */ /*#define HAS_DRAND48_PROTO / **/ /* HAS_EACCESS: * This symbol, if defined, indicates that the eaccess routine is * available to do extended access checks. */ /*#define HAS_EACCESS / **/ /* HAS_ENDGRENT: * This symbol, if defined, indicates that the getgrent routine is * available for finalizing sequential access of the group database. */ /*#define HAS_ENDGRENT / **/ /* HAS_ENDGRENT_R: * This symbol, if defined, indicates that the endgrent_r routine * is available to endgrent re-entrantly. */ /* ENDGRENT_R_PROTO: * This symbol encodes the prototype of endgrent_r. * It is zero if d_endgrent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endgrent_r * is defined. */ /*#define HAS_ENDGRENT_R / **/ #define ENDGRENT_R_PROTO 0 /**/ /* HAS_ENDHOSTENT: * This symbol, if defined, indicates that the endhostent() routine is * available to close whatever was being used for host queries. */ /*#define HAS_ENDHOSTENT / **/ /* HAS_ENDHOSTENT_R: * This symbol, if defined, indicates that the endhostent_r routine * is available to endhostent re-entrantly. */ /* ENDHOSTENT_R_PROTO: * This symbol encodes the prototype of endhostent_r. * It is zero if d_endhostent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endhostent_r * is defined. */ /*#define HAS_ENDHOSTENT_R / **/ #define ENDHOSTENT_R_PROTO 0 /**/ /* HAS_ENDNETENT: * This symbol, if defined, indicates that the endnetent() routine is * available to close whatever was being used for network queries. */ /*#define HAS_ENDNETENT / **/ /* HAS_ENDNETENT_R: * This symbol, if defined, indicates that the endnetent_r routine * is available to endnetent re-entrantly. */ /* ENDNETENT_R_PROTO: * This symbol encodes the prototype of endnetent_r. * It is zero if d_endnetent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endnetent_r * is defined. */ /*#define HAS_ENDNETENT_R / **/ #define ENDNETENT_R_PROTO 0 /**/ /* HAS_ENDPROTOENT: * This symbol, if defined, indicates that the endprotoent() routine is * available to close whatever was being used for protocol queries. */ /*#define HAS_ENDPROTOENT / **/ /* HAS_ENDPROTOENT_R: * This symbol, if defined, indicates that the endprotoent_r routine * is available to endprotoent re-entrantly. */ /* ENDPROTOENT_R_PROTO: * This symbol encodes the prototype of endprotoent_r. * It is zero if d_endprotoent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endprotoent_r * is defined. */ /*#define HAS_ENDPROTOENT_R / **/ #define ENDPROTOENT_R_PROTO 0 /**/ /* HAS_ENDPWENT: * This symbol, if defined, indicates that the getgrent routine is * available for finalizing sequential access of the passwd database. */ /*#define HAS_ENDPWENT / **/ /* HAS_ENDPWENT_R: * This symbol, if defined, indicates that the endpwent_r routine * is available to endpwent re-entrantly. */ /* ENDPWENT_R_PROTO: * This symbol encodes the prototype of endpwent_r. * It is zero if d_endpwent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endpwent_r * is defined. */ /*#define HAS_ENDPWENT_R / **/ #define ENDPWENT_R_PROTO 0 /**/ /* HAS_ENDSERVENT: * This symbol, if defined, indicates that the endservent() routine is * available to close whatever was being used for service queries. */ /*#define HAS_ENDSERVENT / **/ /* HAS_ENDSERVENT_R: * This symbol, if defined, indicates that the endservent_r routine * is available to endservent re-entrantly. */ /* ENDSERVENT_R_PROTO: * This symbol encodes the prototype of endservent_r. * It is zero if d_endservent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endservent_r * is defined. */ /*#define HAS_ENDSERVENT_R / **/ #define ENDSERVENT_R_PROTO 0 /**/ /* FLEXFILENAMES: * This symbol, if defined, indicates that the system supports filenames * longer than 14 characters. */ #define FLEXFILENAMES /**/ /* HAS_GETGRENT: * This symbol, if defined, indicates that the getgrent routine is * available for sequential access of the group database. */ /*#define HAS_GETGRENT / **/ /* HAS_GETGRENT_R: * This symbol, if defined, indicates that the getgrent_r routine * is available to getgrent re-entrantly. */ /* GETGRENT_R_PROTO: * This symbol encodes the prototype of getgrent_r. * It is zero if d_getgrent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrent_r * is defined. */ /*#define HAS_GETGRENT_R / **/ #define GETGRENT_R_PROTO 0 /**/ /* HAS_GETGRGID_R: * This symbol, if defined, indicates that the getgrgid_r routine * is available to getgrgid re-entrantly. */ /* GETGRGID_R_PROTO: * This symbol encodes the prototype of getgrgid_r. * It is zero if d_getgrgid_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrgid_r * is defined. */ /*#define HAS_GETGRGID_R / **/ #define GETGRGID_R_PROTO 0 /**/ /* HAS_GETGRNAM_R: * This symbol, if defined, indicates that the getgrnam_r routine * is available to getgrnam re-entrantly. */ /* GETGRNAM_R_PROTO: * This symbol encodes the prototype of getgrnam_r. * It is zero if d_getgrnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrnam_r * is defined. */ /*#define HAS_GETGRNAM_R / **/ #define GETGRNAM_R_PROTO 0 /**/ /* HAS_GETHOSTBYADDR: * This symbol, if defined, indicates that the gethostbyaddr() routine is * available to look up hosts by their IP addresses. */ #define HAS_GETHOSTBYADDR /**/ /* HAS_GETHOSTBYNAME: * This symbol, if defined, indicates that the gethostbyname() routine is * available to look up host names in some data base or other. */ #define HAS_GETHOSTBYNAME /**/ /* HAS_GETHOSTENT: * This symbol, if defined, indicates that the gethostent() routine is * available to look up host names in some data base or another. */ /*#define HAS_GETHOSTENT / **/ /* HAS_GETHOSTNAME: * This symbol, if defined, indicates that the C program may use the * gethostname() routine to derive the host name. See also HAS_UNAME * and PHOSTNAME. */ /* HAS_UNAME: * This symbol, if defined, indicates that the C program may use the * uname() routine to derive the host name. See also HAS_GETHOSTNAME * and PHOSTNAME. */ /* PHOSTNAME: * This symbol, if defined, indicates the command to feed to the * popen() routine to derive the host name. See also HAS_GETHOSTNAME * and HAS_UNAME. Note that the command uses a fully qualified path, * so that it is safe even if used by a process with super-user * privileges. */ /* HAS_PHOSTNAME: * This symbol, if defined, indicates that the C program may use the * contents of PHOSTNAME as a command to feed to the popen() routine * to derive the host name. */ #define HAS_GETHOSTNAME /**/ #define HAS_UNAME /**/ /*#define HAS_PHOSTNAME / **/ #ifdef HAS_PHOSTNAME #define PHOSTNAME "" /* How to get the host name */ #endif /* HAS_GETHOSTBYADDR_R: * This symbol, if defined, indicates that the gethostbyaddr_r routine * is available to gethostbyaddr re-entrantly. */ /* GETHOSTBYADDR_R_PROTO: * This symbol encodes the prototype of gethostbyaddr_r. * It is zero if d_gethostbyaddr_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostbyaddr_r * is defined. */ /*#define HAS_GETHOSTBYADDR_R / **/ #define GETHOSTBYADDR_R_PROTO 0 /**/ /* HAS_GETHOSTBYNAME_R: * This symbol, if defined, indicates that the gethostbyname_r routine * is available to gethostbyname re-entrantly. */ /* GETHOSTBYNAME_R_PROTO: * This symbol encodes the prototype of gethostbyname_r. * It is zero if d_gethostbyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostbyname_r * is defined. */ /*#define HAS_GETHOSTBYNAME_R / **/ #define GETHOSTBYNAME_R_PROTO 0 /**/ /* HAS_GETHOSTENT_R: * This symbol, if defined, indicates that the gethostent_r routine * is available to gethostent re-entrantly. */ /* GETHOSTENT_R_PROTO: * This symbol encodes the prototype of gethostent_r. * It is zero if d_gethostent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostent_r * is defined. */ /*#define HAS_GETHOSTENT_R / **/ #define GETHOSTENT_R_PROTO 0 /**/ /* HAS_GETHOST_PROTOS: * This symbol, if defined, indicates that includes * prototypes for gethostent(), gethostbyname(), and * gethostbyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ #define HAS_GETHOST_PROTOS /**/ /* HAS_GETLOGIN_R: * This symbol, if defined, indicates that the getlogin_r routine * is available to getlogin re-entrantly. */ /* GETLOGIN_R_PROTO: * This symbol encodes the prototype of getlogin_r. * It is zero if d_getlogin_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getlogin_r * is defined. */ /*#define HAS_GETLOGIN_R / **/ #define GETLOGIN_R_PROTO 0 /**/ /* HAS_GETNETBYADDR: * This symbol, if defined, indicates that the getnetbyaddr() routine is * available to look up networks by their IP addresses. */ /*#define HAS_GETNETBYADDR / **/ /* HAS_GETNETBYNAME: * This symbol, if defined, indicates that the getnetbyname() routine is * available to look up networks by their names. */ /*#define HAS_GETNETBYNAME / **/ /* HAS_GETNETENT: * This symbol, if defined, indicates that the getnetent() routine is * available to look up network names in some data base or another. */ /*#define HAS_GETNETENT / **/ /* HAS_GETNETBYADDR_R: * This symbol, if defined, indicates that the getnetbyaddr_r routine * is available to getnetbyaddr re-entrantly. */ /* GETNETBYADDR_R_PROTO: * This symbol encodes the prototype of getnetbyaddr_r. * It is zero if d_getnetbyaddr_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetbyaddr_r * is defined. */ /*#define HAS_GETNETBYADDR_R / **/ #define GETNETBYADDR_R_PROTO 0 /**/ /* HAS_GETNETBYNAME_R: * This symbol, if defined, indicates that the getnetbyname_r routine * is available to getnetbyname re-entrantly. */ /* GETNETBYNAME_R_PROTO: * This symbol encodes the prototype of getnetbyname_r. * It is zero if d_getnetbyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetbyname_r * is defined. */ /*#define HAS_GETNETBYNAME_R / **/ #define GETNETBYNAME_R_PROTO 0 /**/ /* HAS_GETNETENT_R: * This symbol, if defined, indicates that the getnetent_r routine * is available to getnetent re-entrantly. */ /* GETNETENT_R_PROTO: * This symbol encodes the prototype of getnetent_r. * It is zero if d_getnetent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetent_r * is defined. */ /*#define HAS_GETNETENT_R / **/ #define GETNETENT_R_PROTO 0 /**/ /* HAS_GETNET_PROTOS: * This symbol, if defined, indicates that includes * prototypes for getnetent(), getnetbyname(), and * getnetbyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ /*#define HAS_GETNET_PROTOS / **/ /* HAS_GETPROTOENT: * This symbol, if defined, indicates that the getprotoent() routine is * available to look up protocols in some data base or another. */ /*#define HAS_GETPROTOENT / **/ /* HAS_GETPGRP: * This symbol, if defined, indicates that the getpgrp routine is * available to get the current process group. */ /* USE_BSD_GETPGRP: * This symbol, if defined, indicates that getpgrp needs one * arguments whereas USG one needs none. */ /*#define HAS_GETPGRP / **/ /*#define USE_BSD_GETPGRP / **/ /* HAS_GETPROTOBYNAME: * This symbol, if defined, indicates that the getprotobyname() * routine is available to look up protocols by their name. */ /* HAS_GETPROTOBYNUMBER: * This symbol, if defined, indicates that the getprotobynumber() * routine is available to look up protocols by their number. */ #define HAS_GETPROTOBYNAME /**/ #define HAS_GETPROTOBYNUMBER /**/ /* HAS_GETPROTOBYNAME_R: * This symbol, if defined, indicates that the getprotobyname_r routine * is available to getprotobyname re-entrantly. */ /* GETPROTOBYNAME_R_PROTO: * This symbol encodes the prototype of getprotobyname_r. * It is zero if d_getprotobyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotobyname_r * is defined. */ /*#define HAS_GETPROTOBYNAME_R / **/ #define GETPROTOBYNAME_R_PROTO 0 /**/ /* HAS_GETPROTOBYNUMBER_R: * This symbol, if defined, indicates that the getprotobynumber_r routine * is available to getprotobynumber re-entrantly. */ /* GETPROTOBYNUMBER_R_PROTO: * This symbol encodes the prototype of getprotobynumber_r. * It is zero if d_getprotobynumber_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotobynumber_r * is defined. */ /*#define HAS_GETPROTOBYNUMBER_R / **/ #define GETPROTOBYNUMBER_R_PROTO 0 /**/ /* HAS_GETPROTOENT_R: * This symbol, if defined, indicates that the getprotoent_r routine * is available to getprotoent re-entrantly. */ /* GETPROTOENT_R_PROTO: * This symbol encodes the prototype of getprotoent_r. * It is zero if d_getprotoent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotoent_r * is defined. */ /*#define HAS_GETPROTOENT_R / **/ #define GETPROTOENT_R_PROTO 0 /**/ /* HAS_GETPROTO_PROTOS: * This symbol, if defined, indicates that includes * prototypes for getprotoent(), getprotobyname(), and * getprotobyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ #define HAS_GETPROTO_PROTOS /**/ /* HAS_GETPWENT: * This symbol, if defined, indicates that the getpwent routine is * available for sequential access of the passwd database. * If this is not available, the older getpw() function may be available. */ /*#define HAS_GETPWENT / **/ /* HAS_GETPWENT_R: * This symbol, if defined, indicates that the getpwent_r routine * is available to getpwent re-entrantly. */ /* GETPWENT_R_PROTO: * This symbol encodes the prototype of getpwent_r. * It is zero if d_getpwent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwent_r * is defined. */ /*#define HAS_GETPWENT_R / **/ #define GETPWENT_R_PROTO 0 /**/ /* HAS_GETPWNAM_R: * This symbol, if defined, indicates that the getpwnam_r routine * is available to getpwnam re-entrantly. */ /* GETPWNAM_R_PROTO: * This symbol encodes the prototype of getpwnam_r. * It is zero if d_getpwnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwnam_r * is defined. */ /*#define HAS_GETPWNAM_R / **/ #define GETPWNAM_R_PROTO 0 /**/ /* HAS_GETPWUID_R: * This symbol, if defined, indicates that the getpwuid_r routine * is available to getpwuid re-entrantly. */ /* GETPWUID_R_PROTO: * This symbol encodes the prototype of getpwuid_r. * It is zero if d_getpwuid_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwuid_r * is defined. */ /*#define HAS_GETPWUID_R / **/ #define GETPWUID_R_PROTO 0 /**/ /* HAS_GETSERVENT: * This symbol, if defined, indicates that the getservent() routine is * available to look up network services in some data base or another. */ /*#define HAS_GETSERVENT / **/ /* HAS_GETSERVBYNAME_R: * This symbol, if defined, indicates that the getservbyname_r routine * is available to getservbyname re-entrantly. */ /* GETSERVBYNAME_R_PROTO: * This symbol encodes the prototype of getservbyname_r. * It is zero if d_getservbyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservbyname_r * is defined. */ /*#define HAS_GETSERVBYNAME_R / **/ #define GETSERVBYNAME_R_PROTO 0 /**/ /* HAS_GETSERVBYPORT_R: * This symbol, if defined, indicates that the getservbyport_r routine * is available to getservbyport re-entrantly. */ /* GETSERVBYPORT_R_PROTO: * This symbol encodes the prototype of getservbyport_r. * It is zero if d_getservbyport_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservbyport_r * is defined. */ /*#define HAS_GETSERVBYPORT_R / **/ #define GETSERVBYPORT_R_PROTO 0 /**/ /* HAS_GETSERVENT_R: * This symbol, if defined, indicates that the getservent_r routine * is available to getservent re-entrantly. */ /* GETSERVENT_R_PROTO: * This symbol encodes the prototype of getservent_r. * It is zero if d_getservent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservent_r * is defined. */ /*#define HAS_GETSERVENT_R / **/ #define GETSERVENT_R_PROTO 0 /**/ /* HAS_GETSERV_PROTOS: * This symbol, if defined, indicates that includes * prototypes for getservent(), getservbyname(), and * getservbyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ #define HAS_GETSERV_PROTOS /**/ /* HAS_GETSPNAM_R: * This symbol, if defined, indicates that the getspnam_r routine * is available to getspnam re-entrantly. */ /* GETSPNAM_R_PROTO: * This symbol encodes the prototype of getspnam_r. * It is zero if d_getspnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getspnam_r * is defined. */ /*#define HAS_GETSPNAM_R / **/ #define GETSPNAM_R_PROTO 0 /**/ /* HAS_GETSERVBYNAME: * This symbol, if defined, indicates that the getservbyname() * routine is available to look up services by their name. */ /* HAS_GETSERVBYPORT: * This symbol, if defined, indicates that the getservbyport() * routine is available to look up services by their port. */ #define HAS_GETSERVBYNAME /**/ #define HAS_GETSERVBYPORT /**/ /* HAS_GMTIME_R: * This symbol, if defined, indicates that the gmtime_r routine * is available to gmtime re-entrantly. */ /* GMTIME_R_PROTO: * This symbol encodes the prototype of gmtime_r. * It is zero if d_gmtime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gmtime_r * is defined. */ /*#define HAS_GMTIME_R / **/ #define GMTIME_R_PROTO 0 /**/ /* HAS_HTONL: * This symbol, if defined, indicates that the htonl() routine (and * friends htons() ntohl() ntohs()) are available to do network * order byte swapping. */ /* HAS_HTONS: * This symbol, if defined, indicates that the htons() routine (and * friends htonl() ntohl() ntohs()) are available to do network * order byte swapping. */ /* HAS_NTOHL: * This symbol, if defined, indicates that the ntohl() routine (and * friends htonl() htons() ntohs()) are available to do network * order byte swapping. */ /* HAS_NTOHS: * This symbol, if defined, indicates that the ntohs() routine (and * friends htonl() htons() ntohl()) are available to do network * order byte swapping. */ #define HAS_HTONL /**/ #define HAS_HTONS /**/ #define HAS_NTOHL /**/ #define HAS_NTOHS /**/ /* HAS_LOCALTIME_R: * This symbol, if defined, indicates that the localtime_r routine * is available to localtime re-entrantly. */ /* LOCALTIME_R_NEEDS_TZSET: * Many libc's localtime_r implementations do not call tzset, * making them differ from localtime(), and making timezone * changes using \undef{TZ} without explicitly calling tzset * impossible. This symbol makes us call tzset before localtime_r */ /*#define LOCALTIME_R_NEEDS_TZSET / **/ #ifdef LOCALTIME_R_NEEDS_TZSET #define L_R_TZSET tzset(), #else #define L_R_TZSET #endif /* LOCALTIME_R_PROTO: * This symbol encodes the prototype of localtime_r. * It is zero if d_localtime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_localtime_r * is defined. */ /*#define HAS_LOCALTIME_R / **/ #define LOCALTIME_R_PROTO 0 /**/ /* HAS_LONG_DOUBLE: * This symbol will be defined if the C compiler supports long * doubles. */ /* LONG_DOUBLESIZE: * This symbol contains the size of a long double, so that the * C preprocessor can make decisions based on it. It is only * defined if the system supports long doubles. */ #define HAS_LONG_DOUBLE /**/ #ifdef HAS_LONG_DOUBLE #define LONG_DOUBLESIZE 10 /**/ #endif /* HAS_LONG_LONG: * This symbol will be defined if the C compiler supports long long. */ /* LONGLONGSIZE: * This symbol contains the size of a long long, so that the * C preprocessor can make decisions based on it. It is only * defined if the system supports long long. */ /*#define HAS_LONG_LONG / **/ #ifdef HAS_LONG_LONG #define LONGLONGSIZE 8 /**/ #endif /* HAS_LSEEK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the lseek() function. Otherwise, it is up * to the program to supply one. A good guess is * extern off_t lseek(int, off_t, int); */ #define HAS_LSEEK_PROTO /**/ /* HAS_MEMCHR: * This symbol, if defined, indicates that the memchr routine is available * to locate characters within a C string. */ #define HAS_MEMCHR /**/ /* HAS_MKSTEMP: * This symbol, if defined, indicates that the mkstemp routine is * available to exclusively create and open a uniquely named * temporary file. */ /*#define HAS_MKSTEMP / **/ /* HAS_MMAP: * This symbol, if defined, indicates that the mmap system call is * available to map a file into memory. */ /* Mmap_t: * This symbol holds the return type of the mmap() system call * (and simultaneously the type of the first argument). * Usually set to 'void *' or 'caddr_t'. */ /*#define HAS_MMAP / **/ #define Mmap_t void * /**/ /* HAS_MSG: * This symbol, if defined, indicates that the entire msg*(2) library is * supported (IPC mechanism based on message queues). */ /*#define HAS_MSG / **/ /* OLD_PTHREAD_CREATE_JOINABLE: * This symbol, if defined, indicates how to create pthread * in joinable (aka undetached) state. NOTE: not defined * if pthread.h already has defined PTHREAD_CREATE_JOINABLE * (the new version of the constant). * If defined, known values are PTHREAD_CREATE_UNDETACHED * and __UNDETACHED. */ /*#define OLD_PTHREAD_CREATE_JOINABLE / **/ /* HAS_PTHREAD_ATFORK: * This symbol, if defined, indicates that the pthread_atfork routine * is available to setup fork handlers. */ /*#define HAS_PTHREAD_ATFORK / **/ /* HAS_PTHREAD_YIELD: * This symbol, if defined, indicates that the pthread_yield * routine is available to yield the execution of the current * thread. sched_yield is preferable to pthread_yield. */ /* SCHED_YIELD: * This symbol defines the way to yield the execution of * the current thread. Known ways are sched_yield, * pthread_yield, and pthread_yield with NULL. */ /* HAS_SCHED_YIELD: * This symbol, if defined, indicates that the sched_yield * routine is available to yield the execution of the current * thread. sched_yield is preferable to pthread_yield. */ /*#define HAS_PTHREAD_YIELD / **/ #define SCHED_YIELD /**/ /*#define HAS_SCHED_YIELD / **/ /* HAS_RANDOM_R: * This symbol, if defined, indicates that the random_r routine * is available to random re-entrantly. */ /* RANDOM_R_PROTO: * This symbol encodes the prototype of random_r. * It is zero if d_random_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_random_r * is defined. */ /*#define HAS_RANDOM_R / **/ #define RANDOM_R_PROTO 0 /**/ /* HAS_READDIR64_R: * This symbol, if defined, indicates that the readdir64_r routine * is available to readdir64 re-entrantly. */ /* READDIR64_R_PROTO: * This symbol encodes the prototype of readdir64_r. * It is zero if d_readdir64_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_readdir64_r * is defined. */ /*#define HAS_READDIR64_R / **/ #define READDIR64_R_PROTO 0 /**/ /* HAS_READDIR_R: * This symbol, if defined, indicates that the readdir_r routine * is available to readdir re-entrantly. */ /* READDIR_R_PROTO: * This symbol encodes the prototype of readdir_r. * It is zero if d_readdir_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_readdir_r * is defined. */ /*#define HAS_READDIR_R / **/ #define READDIR_R_PROTO 0 /**/ /* HAS_SEM: * This symbol, if defined, indicates that the entire sem*(2) library is * supported. */ /*#define HAS_SEM / **/ /* HAS_SETGRENT: * This symbol, if defined, indicates that the setgrent routine is * available for initializing sequential access of the group database. */ /*#define HAS_SETGRENT / **/ /* HAS_SETGRENT_R: * This symbol, if defined, indicates that the setgrent_r routine * is available to setgrent re-entrantly. */ /* SETGRENT_R_PROTO: * This symbol encodes the prototype of setgrent_r. * It is zero if d_setgrent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setgrent_r * is defined. */ /*#define HAS_SETGRENT_R / **/ #define SETGRENT_R_PROTO 0 /**/ /* HAS_SETHOSTENT: * This symbol, if defined, indicates that the sethostent() routine is * available. */ /*#define HAS_SETHOSTENT / **/ /* HAS_SETHOSTENT_R: * This symbol, if defined, indicates that the sethostent_r routine * is available to sethostent re-entrantly. */ /* SETHOSTENT_R_PROTO: * This symbol encodes the prototype of sethostent_r. * It is zero if d_sethostent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_sethostent_r * is defined. */ /*#define HAS_SETHOSTENT_R / **/ #define SETHOSTENT_R_PROTO 0 /**/ /* HAS_SETLOCALE_R: * This symbol, if defined, indicates that the setlocale_r routine * is available to setlocale re-entrantly. */ /* SETLOCALE_R_PROTO: * This symbol encodes the prototype of setlocale_r. * It is zero if d_setlocale_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setlocale_r * is defined. */ /*#define HAS_SETLOCALE_R / **/ #define SETLOCALE_R_PROTO 0 /**/ /* HAS_SETNETENT: * This symbol, if defined, indicates that the setnetent() routine is * available. */ /*#define HAS_SETNETENT / **/ /* HAS_SETNETENT_R: * This symbol, if defined, indicates that the setnetent_r routine * is available to setnetent re-entrantly. */ /* SETNETENT_R_PROTO: * This symbol encodes the prototype of setnetent_r. * It is zero if d_setnetent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setnetent_r * is defined. */ /*#define HAS_SETNETENT_R / **/ #define SETNETENT_R_PROTO 0 /**/ /* HAS_SETPROTOENT: * This symbol, if defined, indicates that the setprotoent() routine is * available. */ /*#define HAS_SETPROTOENT / **/ /* HAS_SETPGRP: * This symbol, if defined, indicates that the setpgrp routine is * available to set the current process group. */ /* USE_BSD_SETPGRP: * This symbol, if defined, indicates that setpgrp needs two * arguments whereas USG one needs none. See also HAS_SETPGID * for a POSIX interface. */ /*#define HAS_SETPGRP / **/ /*#define USE_BSD_SETPGRP / **/ /* HAS_SETPROTOENT_R: * This symbol, if defined, indicates that the setprotoent_r routine * is available to setprotoent re-entrantly. */ /* SETPROTOENT_R_PROTO: * This symbol encodes the prototype of setprotoent_r. * It is zero if d_setprotoent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setprotoent_r * is defined. */ /*#define HAS_SETPROTOENT_R / **/ #define SETPROTOENT_R_PROTO 0 /**/ /* HAS_SETPWENT: * This symbol, if defined, indicates that the setpwent routine is * available for initializing sequential access of the passwd database. */ /*#define HAS_SETPWENT / **/ /* HAS_SETPWENT_R: * This symbol, if defined, indicates that the setpwent_r routine * is available to setpwent re-entrantly. */ /* SETPWENT_R_PROTO: * This symbol encodes the prototype of setpwent_r. * It is zero if d_setpwent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setpwent_r * is defined. */ /*#define HAS_SETPWENT_R / **/ #define SETPWENT_R_PROTO 0 /**/ /* HAS_SETSERVENT: * This symbol, if defined, indicates that the setservent() routine is * available. */ /*#define HAS_SETSERVENT / **/ /* HAS_SETSERVENT_R: * This symbol, if defined, indicates that the setservent_r routine * is available to setservent re-entrantly. */ /* SETSERVENT_R_PROTO: * This symbol encodes the prototype of setservent_r. * It is zero if d_setservent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setservent_r * is defined. */ /*#define HAS_SETSERVENT_R / **/ #define SETSERVENT_R_PROTO 0 /**/ /* HAS_SETVBUF: * This symbol, if defined, indicates that the setvbuf routine is * available to change buffering on an open stdio stream. * to a line-buffered mode. */ #define HAS_SETVBUF /**/ /* HAS_SHM: * This symbol, if defined, indicates that the entire shm*(2) library is * supported. */ /*#define HAS_SHM / **/ /* Shmat_t: * This symbol holds the return type of the shmat() system call. * Usually set to 'void *' or 'char *'. */ /* HAS_SHMAT_PROTOTYPE: * This symbol, if defined, indicates that the sys/shm.h includes * a prototype for shmat(). Otherwise, it is up to the program to * guess one. Shmat_t shmat(int, Shmat_t, int) is a good guess, * but not always right so it should be emitted by the program only * when HAS_SHMAT_PROTOTYPE is not defined to avoid conflicting defs. */ #define Shmat_t void * /**/ /*#define HAS_SHMAT_PROTOTYPE / **/ /* HAS_SOCKET: * This symbol, if defined, indicates that the BSD socket interface is * supported. */ /* HAS_SOCKETPAIR: * This symbol, if defined, indicates that the BSD socketpair() call is * supported. */ /* HAS_MSG_CTRUNC: * This symbol, if defined, indicates that the MSG_CTRUNC is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_DONTROUTE: * This symbol, if defined, indicates that the MSG_DONTROUTE is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_OOB: * This symbol, if defined, indicates that the MSG_OOB is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_PEEK: * This symbol, if defined, indicates that the MSG_PEEK is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_PROXY: * This symbol, if defined, indicates that the MSG_PROXY is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_SCM_RIGHTS: * This symbol, if defined, indicates that the SCM_RIGHTS is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ #define HAS_SOCKET /**/ /*#define HAS_SOCKETPAIR / **/ /*#define HAS_MSG_CTRUNC / **/ /*#define HAS_MSG_DONTROUTE / **/ /*#define HAS_MSG_OOB / **/ /*#define HAS_MSG_PEEK / **/ /*#define HAS_MSG_PROXY / **/ /*#define HAS_SCM_RIGHTS / **/ /* HAS_SRAND48_R: * This symbol, if defined, indicates that the srand48_r routine * is available to srand48 re-entrantly. */ /* SRAND48_R_PROTO: * This symbol encodes the prototype of srand48_r. * It is zero if d_srand48_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_srand48_r * is defined. */ /*#define HAS_SRAND48_R / **/ #define SRAND48_R_PROTO 0 /**/ /* HAS_SRANDOM_R: * This symbol, if defined, indicates that the srandom_r routine * is available to srandom re-entrantly. */ /* SRANDOM_R_PROTO: * This symbol encodes the prototype of srandom_r. * It is zero if d_srandom_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_srandom_r * is defined. */ /*#define HAS_SRANDOM_R / **/ #define SRANDOM_R_PROTO 0 /**/ /* USE_STAT_BLOCKS: * This symbol is defined if this system has a stat structure declaring * st_blksize and st_blocks. */ #ifndef USE_STAT_BLOCKS /*#define USE_STAT_BLOCKS / **/ #endif /* USE_STRUCT_COPY: * This symbol, if defined, indicates that this C compiler knows how * to copy structures. If undefined, you'll need to use a block copy * routine of some sort instead. */ #define USE_STRUCT_COPY /**/ /* HAS_STRERROR: * This symbol, if defined, indicates that the strerror routine is * available to translate error numbers to strings. See the writeup * of Strerror() in this file before you try to define your own. */ /* HAS_SYS_ERRLIST: * This symbol, if defined, indicates that the sys_errlist array is * available to translate error numbers to strings. The extern int * sys_nerr gives the size of that table. */ /* Strerror: * This preprocessor symbol is defined as a macro if strerror() is * not available to translate error numbers to strings but sys_errlist[] * array is there. */ #define HAS_STRERROR /**/ #define HAS_SYS_ERRLIST /**/ #define Strerror(e) strerror(e) /* HAS_STRERROR_R: * This symbol, if defined, indicates that the strerror_r routine * is available to strerror re-entrantly. */ /* STRERROR_R_PROTO: * This symbol encodes the prototype of strerror_r. * It is zero if d_strerror_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_strerror_r * is defined. */ /*#define HAS_STRERROR_R / **/ #define STRERROR_R_PROTO 0 /**/ /* HAS_STRTOUL: * This symbol, if defined, indicates that the strtoul routine is * available to provide conversion of strings to unsigned long. */ #define HAS_STRTOUL /**/ /* HAS_TIME: * This symbol, if defined, indicates that the time() routine exists. */ /* Time_t: * This symbol holds the type returned by time(). It can be long, * or time_t on BSD sites (in which case should be * included). */ #define HAS_TIME /**/ #define Time_t time_t /* Time type */ /* HAS_TIMES: * This symbol, if defined, indicates that the times() routine exists. * Note that this became obsolete on some systems (SUNOS), which now * use getrusage(). It may be necessary to include . */ #define HAS_TIMES /**/ /* HAS_TMPNAM_R: * This symbol, if defined, indicates that the tmpnam_r routine * is available to tmpnam re-entrantly. */ /* TMPNAM_R_PROTO: * This symbol encodes the prototype of tmpnam_r. * It is zero if d_tmpnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_tmpnam_r * is defined. */ /*#define HAS_TMPNAM_R / **/ #define TMPNAM_R_PROTO 0 /**/ /* HAS_TTYNAME_R: * This symbol, if defined, indicates that the ttyname_r routine * is available to ttyname re-entrantly. */ /* TTYNAME_R_PROTO: * This symbol encodes the prototype of ttyname_r. * It is zero if d_ttyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ttyname_r * is defined. */ /*#define HAS_TTYNAME_R / **/ #define TTYNAME_R_PROTO 0 /**/ /* HAS_UNION_SEMUN: * This symbol, if defined, indicates that the union semun is * defined by including . If not, the user code * probably needs to define it as: * union semun { * int val; * struct semid_ds *buf; * unsigned short *array; * } */ /* USE_SEMCTL_SEMUN: * This symbol, if defined, indicates that union semun is * used for semctl IPC_STAT. */ /* USE_SEMCTL_SEMID_DS: * This symbol, if defined, indicates that struct semid_ds * is * used for semctl IPC_STAT. */ #define HAS_UNION_SEMUN /**/ /*#define USE_SEMCTL_SEMUN / **/ /*#define USE_SEMCTL_SEMID_DS / **/ /* HAS_VFORK: * This symbol, if defined, indicates that vfork() exists. */ /*#define HAS_VFORK / **/ /* HAS_PSEUDOFORK: * This symbol, if defined, indicates that an emulation of the * fork routine is available. */ /*#define HAS_PSEUDOFORK / **/ /* Signal_t: * This symbol's value is either "void" or "int", corresponding to the * appropriate return type of a signal handler. Thus, you can declare * a signal handler using "Signal_t (*handler)()", and define the * handler using "Signal_t handler(sig)". */ #define Signal_t void /* Signal handler's return type */ /* HASVOLATILE: * This symbol, if defined, indicates that this C compiler knows about * the volatile declaration. */ #define HASVOLATILE /**/ #ifndef HASVOLATILE #define volatile #endif /* Fpos_t: * This symbol holds the type used to declare file positions in libc. * It can be fpos_t, long, uint, etc... It may be necessary to include * to get any typedef'ed information. */ #define Fpos_t fpos_t /* File position type */ /* Gid_t_f: * This symbol defines the format string used for printing a Gid_t. */ #define Gid_t_f "d" /**/ /* Gid_t_sign: * This symbol holds the signedess of a Gid_t. * 1 for unsigned, -1 for signed. */ #define Gid_t_sign -1 /* GID sign */ /* Gid_t_size: * This symbol holds the size of a Gid_t in bytes. */ #define Gid_t_size 4 /* GID size */ /* Gid_t: * This symbol holds the return type of getgid() and the type of * argument to setrgid() and related functions. Typically, * it is the type of group ids in the kernel. It can be int, ushort, * gid_t, etc... It may be necessary to include to get * any typedef'ed information. */ #define Gid_t gid_t /* Type for getgid(), etc... */ /* I_DIRENT: * This symbol, if defined, indicates to the C program that it should * include . Using this symbol also triggers the definition * of the Direntry_t define which ends up being 'struct dirent' or * 'struct direct' depending on the availability of . */ /* DIRNAMLEN: * This symbol, if defined, indicates to the C program that the length * of directory entry names is provided by a d_namlen field. Otherwise * you need to do strlen() on the d_name field. */ /* Direntry_t: * This symbol is set to 'struct direct' or 'struct dirent' depending on * whether dirent is available or not. You should use this pseudo type to * portably declare your directory entries. */ #define I_DIRENT /**/ #define DIRNAMLEN /**/ #define Direntry_t struct direct /* I_GRP: * This symbol, if defined, indicates to the C program that it should * include . */ /* GRPASSWD: * This symbol, if defined, indicates to the C program that struct group * in contains gr_passwd. */ /*#define I_GRP / **/ /*#define GRPASSWD / **/ /* I_MACH_CTHREADS: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_MACH_CTHREADS / **/ /* I_NDBM: * This symbol, if defined, indicates that exists and should * be included. */ /* I_GDBMNDBM: * This symbol, if defined, indicates that exists and should * be included. This was the location of the ndbm.h compatibility file * in RedHat 7.1. */ /* I_GDBM_NDBM: * This symbol, if defined, indicates that exists and should * be included. This is the location of the ndbm.h compatibility file * in Debian 4.0. */ /* NDBM_H_USES_PROTOTYPES: * This symbol, if defined, indicates that uses real ANSI C * prototypes instead of K&R style function declarations without any * parameter information. While ANSI C prototypes are supported in C++, * K&R style function declarations will yield errors. */ /* GDBMNDBM_H_USES_PROTOTYPES: * This symbol, if defined, indicates that uses real ANSI C * prototypes instead of K&R style function declarations without any * parameter information. While ANSI C prototypes are supported in C++, * K&R style function declarations will yield errors. */ /* GDBM_NDBM_H_USES_PROTOTYPES: * This symbol, if defined, indicates that uses real ANSI C * prototypes instead of K&R style function declarations without any * parameter information. While ANSI C prototypes are supported in C++, * K&R style function declarations will yield errors. */ /*#define I_NDBM / **/ /*#define I_GDBMNDBM / **/ /*#define I_GDBM_NDBM / **/ /*#define NDBM_H_USES_PROTOTYPES / **/ /*#define GDBMNDBM_H_USES_PROTOTYPES / **/ /*#define GDBM_NDBM_H_USES_PROTOTYPES / **/ /* I_NETDB: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_NETDB / **/ /* I_NET_ERRNO: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_NET_ERRNO / **/ /* I_PTHREAD: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_PTHREAD / **/ /* I_PWD: * This symbol, if defined, indicates to the C program that it should * include . */ /* PWQUOTA: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_quota. */ /* PWAGE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_age. */ /* PWCHANGE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_change. */ /* PWCLASS: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_class. */ /* PWEXPIRE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_expire. */ /* PWCOMMENT: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_comment. */ /* PWGECOS: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_gecos. */ /* PWPASSWD: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_passwd. */ /*#define I_PWD / **/ /*#define PWQUOTA / **/ /*#define PWAGE / **/ /*#define PWCHANGE / **/ /*#define PWCLASS / **/ /*#define PWEXPIRE / **/ /*#define PWCOMMENT / **/ /*#define PWGECOS / **/ /*#define PWPASSWD / **/ /* I_SYS_ACCESS: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_ACCESS / **/ /* I_SYS_SECURITY: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_SECURITY / **/ /* I_SYSUIO: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSUIO / **/ /* I_STDARG: * This symbol, if defined, indicates that exists and should * be included. */ /* I_VARARGS: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_STDARG /**/ /*#define I_VARARGS / **/ /* PERL_INC_VERSION_LIST: * This variable specifies the list of subdirectories in over * which perl.c:incpush() and lib/lib.pm will automatically * search when adding directories to @INC, in a format suitable * for a C initialization string. See the inc_version_list entry * in Porting/Glossary for more details. */ /*#define PERL_INC_VERSION_LIST 0 / **/ /* INSTALL_USR_BIN_PERL: * This symbol, if defined, indicates that Perl is to be installed * also as /usr/bin/perl. */ /*#define INSTALL_USR_BIN_PERL / **/ /* Off_t: * This symbol holds the type used to declare offsets in the kernel. * It can be int, long, off_t, etc... It may be necessary to include * to get any typedef'ed information. */ /* LSEEKSIZE: * This symbol holds the number of bytes used by the Off_t. */ /* Off_t_size: * This symbol holds the number of bytes used by the Off_t. */ #define Off_t long /* type */ #define LSEEKSIZE 4 /* size */ #define Off_t_size 4 /* size */ /* Free_t: * This variable contains the return type of free(). It is usually * void, but occasionally int. */ /* Malloc_t: * This symbol is the type of pointer returned by malloc and realloc. */ #define Malloc_t void * /**/ #define Free_t void /**/ /* PERL_MALLOC_WRAP: * This symbol, if defined, indicates that we'd like malloc wrap checks. */ #define PERL_MALLOC_WRAP /**/ /* MYMALLOC: * This symbol, if defined, indicates that we're using our own malloc. */ /*#define MYMALLOC / **/ /* Mode_t: * This symbol holds the type used to declare file modes * for systems calls. It is usually mode_t, but may be * int or unsigned short. It may be necessary to include * to get any typedef'ed information. */ #define Mode_t mode_t /* file mode parameter for system calls */ /* Netdb_host_t: * This symbol holds the type used for the 1st argument * to gethostbyaddr(). */ /* Netdb_hlen_t: * This symbol holds the type used for the 2nd argument * to gethostbyaddr(). */ /* Netdb_name_t: * This symbol holds the type used for the argument to * gethostbyname(). */ /* Netdb_net_t: * This symbol holds the type used for the 1st argument to * getnetbyaddr(). */ #define Netdb_host_t char * /**/ #define Netdb_hlen_t int /**/ #define Netdb_name_t char * /**/ #define Netdb_net_t long /**/ /* PERL_OTHERLIBDIRS: * This variable contains a colon-separated set of paths for the perl * binary to search for additional library files or modules. * These directories will be tacked to the end of @INC. * Perl will automatically search below each path for version- * and architecture-specific directories. See PERL_INC_VERSION_LIST * for more details. */ /*#define PERL_OTHERLIBDIRS "" / **/ /* Pid_t: * This symbol holds the type used to declare process ids in the kernel. * It can be int, uint, pid_t, etc... It may be necessary to include * to get any typedef'ed information. */ #define Pid_t int /* PID type */ /* PRIVLIB: * This symbol contains the name of the private library for this package. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. The program * should be prepared to do ~ expansion. */ /* PRIVLIB_EXP: * This symbol contains the ~name expanded version of PRIVLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ #define PRIVLIB "c:\\perl\\lib" /**/ #define PRIVLIB_EXP (win32_get_privlib(PERL_VERSION_STRING, NULL)) /**/ /* CAN_PROTOTYPE: * If defined, this macro indicates that the C compiler can handle * function prototypes. */ /* _: * This macro is used to declare function parameters for folks who want * to make declarations with prototypes using a different style than * the above macros. Use double parentheses. For example: * * int main _((int argc, char *argv[])); */ #define CAN_PROTOTYPE /**/ #ifdef CAN_PROTOTYPE #define _(args) args #else #define _(args) () #endif /* Select_fd_set_t: * This symbol holds the type used for the 2nd, 3rd, and 4th * arguments to select. Usually, this is 'fd_set *', if HAS_FD_SET * is defined, and 'int *' otherwise. This is only useful if you * have select(), of course. */ #define Select_fd_set_t Perl_fd_set * /**/ /* SH_PATH: * This symbol contains the full pathname to the shell used on this * on this system to execute Bourne shell scripts. Usually, this will be * /bin/sh, though it's possible that some systems will have /bin/ksh, * /bin/pdksh, /bin/ash, /bin/bash, or even something such as * D:/bin/sh.exe. */ #define SH_PATH "cmd /x /c" /**/ /* SIG_NAME: * This symbol contains a list of signal names in order of * signal number. This is intended * to be used as a static array initialization, like this: * char *sig_name[] = { SIG_NAME }; * The signals in the list are separated with commas, and each signal * is surrounded by double quotes. There is no leading SIG in the signal * name, i.e. SIGQUIT is known as "QUIT". * Gaps in the signal numbers (up to NSIG) are filled in with NUMnn, * etc., where nn is the actual signal number (e.g. NUM37). * The signal number for sig_name[i] is stored in sig_num[i]. * The last element is 0 to terminate the list with a NULL. This * corresponds to the 0 at the end of the sig_name_init list. * Note that this variable is initialized from the sig_name_init, * not from sig_name (which is unused). */ /* SIG_NUM: * This symbol contains a list of signal numbers, in the same order as the * SIG_NAME list. It is suitable for static array initialization, as in: * int sig_num[] = { SIG_NUM }; * The signals in the list are separated with commas, and the indices * within that list and the SIG_NAME list match, so it's easy to compute * the signal name from a number or vice versa at the price of a small * dynamic linear lookup. * Duplicates are allowed, but are moved to the end of the list. * The signal number corresponding to sig_name[i] is sig_number[i]. * if (i < NSIG) then sig_number[i] == i. * The last element is 0, corresponding to the 0 at the end of * the sig_name_init list. * Note that this variable is initialized from the sig_num_init, * not from sig_num (which is unused). */ /* SIG_SIZE: * This variable contains the number of elements of the SIG_NAME * and SIG_NUM arrays, excluding the final NULL entry. */ #define SIG_NAME "ZERO", "HUP", "INT", "QUIT", "ILL", "NUM05", "NUM06", "NUM07", "FPE", "KILL", "NUM10", "SEGV", "NUM12", "PIPE", "ALRM", "TERM", "USR1", "USR2", "CHLD", "NUM19", "USR3", "BREAK", "ABRT", "STOP", "NUM24", "CONT", "CLD", 0 /**/ #define SIG_NUM 0, 1, 2, 21, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 18, 0 /**/ #define SIG_SIZE 27 /**/ /* SITEARCH: * This symbol contains the name of the private library for this package. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. The program * should be prepared to do ~ expansion. * The standard distribution will put nothing in this directory. * After perl has been installed, users may install their own local * architecture-dependent modules in this directory with * MakeMaker Makefile.PL * or equivalent. See INSTALL for details. */ /* SITEARCH_EXP: * This symbol contains the ~name expanded version of SITEARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ #define SITEARCH "c:\\perl\\site\\lib" /**/ /*#define SITEARCH_EXP "" / **/ /* SITELIB: * This symbol contains the name of the private library for this package. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. The program * should be prepared to do ~ expansion. * The standard distribution will put nothing in this directory. * After perl has been installed, users may install their own local * architecture-independent modules in this directory with * MakeMaker Makefile.PL * or equivalent. See INSTALL for details. */ /* SITELIB_EXP: * This symbol contains the ~name expanded version of SITELIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ /* SITELIB_STEM: * This define is SITELIB_EXP with any trailing version-specific component * removed. The elements in inc_version_list (inc_version_list.U) can * be tacked onto this variable to generate a list of directories to search. */ #define SITELIB "c:\\perl\\site\\lib" /**/ #define SITELIB_EXP (win32_get_sitelib(PERL_VERSION_STRING, NULL)) /**/ #define SITELIB_STEM "" /**/ /* Size_t_size: * This symbol holds the size of a Size_t in bytes. */ #define Size_t_size 4 /**/ /* Size_t: * This symbol holds the type used to declare length parameters * for string functions. It is usually size_t, but may be * unsigned long, int, etc. It may be necessary to include * to get any typedef'ed information. */ #define Size_t size_t /* length paramater for string functions */ /* Sock_size_t: * This symbol holds the type used for the size argument of * various socket calls (just the base type, not the pointer-to). */ #define Sock_size_t int /**/ /* STDCHAR: * This symbol is defined to be the type of char used in stdio.h. * It has the values "unsigned char" or "char". */ #define STDCHAR unsigned char /**/ /* Uid_t_f: * This symbol defines the format string used for printing a Uid_t. */ #define Uid_t_f "d" /**/ /* Uid_t_sign: * This symbol holds the signedess of a Uid_t. * 1 for unsigned, -1 for signed. */ #define Uid_t_sign -1 /* UID sign */ /* Uid_t_size: * This symbol holds the size of a Uid_t in bytes. */ #define Uid_t_size 4 /* UID size */ /* Uid_t: * This symbol holds the type used to declare user ids in the kernel. * It can be int, ushort, uid_t, etc... It may be necessary to include * to get any typedef'ed information. */ #define Uid_t uid_t /* UID type */ /* USE_ITHREADS: * This symbol, if defined, indicates that Perl should be built to * use the interpreter-based threading implementation. */ /* USE_5005THREADS: * This symbol, if defined, indicates that Perl should be built to * use the 5.005-based threading implementation. * Only valid up to 5.8.x. */ /* OLD_PTHREADS_API: * This symbol, if defined, indicates that Perl should * be built to use the old draft POSIX threads API. */ /* USE_REENTRANT_API: * This symbol, if defined, indicates that Perl should * try to use the various _r versions of library functions. * This is extremely experimental. */ /*#define USE_5005THREADS / **/ /*#define USE_ITHREADS / **/ #if defined(USE_5005THREADS) && !defined(USE_ITHREADS) #define USE_THREADS /* until src is revised*/ #endif /*#define OLD_PTHREADS_API / **/ /*#define USE_REENTRANT_API / **/ /* PERL_VENDORARCH: * If defined, this symbol contains the name of a private library. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. * It may have a ~ on the front. * The standard distribution will put nothing in this directory. * Vendors who distribute perl may wish to place their own * architecture-dependent modules and extensions in this directory with * MakeMaker Makefile.PL INSTALLDIRS=vendor * or equivalent. See INSTALL for details. */ /* PERL_VENDORARCH_EXP: * This symbol contains the ~name expanded version of PERL_VENDORARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ /*#define PERL_VENDORARCH "" / **/ /*#define PERL_VENDORARCH_EXP "" / **/ /* PERL_VENDORLIB_EXP: * This symbol contains the ~name expanded version of VENDORLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ /* PERL_VENDORLIB_STEM: * This define is PERL_VENDORLIB_EXP with any trailing version-specific component * removed. The elements in inc_version_list (inc_version_list.U) can * be tacked onto this variable to generate a list of directories to search. */ /*#define PERL_VENDORLIB_EXP "" / **/ /*#define PERL_VENDORLIB_STEM "" / **/ /* VOIDFLAGS: * This symbol indicates how much support of the void type is given by this * compiler. What various bits mean: * * 1 = supports declaration of void * 2 = supports arrays of pointers to functions returning void * 4 = supports comparisons between pointers to void functions and * addresses of void functions * 8 = suports declaration of generic void pointers * * The package designer should define VOIDUSED to indicate the requirements * of the package. This can be done either by #defining VOIDUSED before * including config.h, or by defining defvoidused in Myinit.U. If the * latter approach is taken, only those flags will be tested. If the * level of void support necessary is not present, defines void to int. */ #ifndef VOIDUSED #define VOIDUSED 15 #endif #define VOIDFLAGS 15 #if (VOIDFLAGS & VOIDUSED) != VOIDUSED #define void int /* is void to be avoided? */ #define M_VOID /* Xenix strikes again */ #endif /* USE_CROSS_COMPILE: * This symbol, if defined, indicates that Perl is being cross-compiled. */ /* PERL_TARGETARCH: * This symbol, if defined, indicates the target architecture * Perl has been cross-compiled to. Undefined if not a cross-compile. */ #ifndef USE_CROSS_COMPILE /*#define USE_CROSS_COMPILE / **/ #define PERL_TARGETARCH "" /**/ #endif /* MEM_ALIGNBYTES: * This symbol contains the number of bytes required to align a * double, or a long double when applicable. Usual values are 2, * 4 and 8. The default is eight, for safety. */ #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH) # define MEM_ALIGNBYTES 8 #else #define MEM_ALIGNBYTES 8 #endif /* BYTEORDER: * This symbol holds the hexadecimal constant defined in byteorder, * in a UV, i.e. 0x1234 or 0x4321 or 0x12345678, etc... * If the compiler supports cross-compiling or multiple-architecture * binaries (eg. on NeXT systems), use compiler-defined macros to * determine the byte order. * On NeXT 3.2 (and greater), you can build "Fat" Multiple Architecture * Binaries (MAB) on either big endian or little endian machines. * The endian-ness is available at compile-time. This only matters * for perl, where the config.h can be generated and installed on * one system, and used by a different architecture to build an * extension. Older versions of NeXT that might not have * defined either *_ENDIAN__ were all on Motorola 680x0 series, * so the default case (for NeXT) is big endian to catch them. * This might matter for NeXT 3.0. */ #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH) # ifdef __LITTLE_ENDIAN__ # if LONGSIZE == 4 # define BYTEORDER 0x1234 # else # if LONGSIZE == 8 # define BYTEORDER 0x12345678 # endif # endif # else # ifdef __BIG_ENDIAN__ # if LONGSIZE == 4 # define BYTEORDER 0x4321 # else # if LONGSIZE == 8 # define BYTEORDER 0x87654321 # endif # endif # endif # endif # if !defined(BYTEORDER) && (defined(NeXT) || defined(__NeXT__)) # define BYTEORDER 0x4321 # endif #else #define BYTEORDER 0x1234 /* large digits for MSB */ #endif /* NeXT */ /* CHARBITS: * This symbol contains the size of a char, so that the C preprocessor * can make decisions based on it. */ #define CHARBITS 8 /**/ /* CASTI32: * This symbol is defined if the C compiler can cast negative * or large floating point numbers to 32-bit ints. */ #define CASTI32 /**/ /* CASTNEGFLOAT: * This symbol is defined if the C compiler can cast negative * numbers to unsigned longs, ints and shorts. */ /* CASTFLAGS: * This symbol contains flags that say what difficulties the compiler * has casting odd floating values to unsigned long: * 0 = ok * 1 = couldn't cast < 0 * 2 = couldn't cast >= 0x80000000 * 4 = couldn't cast in argument expression list */ #define CASTNEGFLOAT /**/ #define CASTFLAGS 0 /**/ /* VOID_CLOSEDIR: * This symbol, if defined, indicates that the closedir() routine * does not return a value. */ /*#define VOID_CLOSEDIR / **/ /* HAS_FD_SET: * This symbol, when defined, indicates presence of the fd_set typedef * in */ #define HAS_FD_SET /**/ /* Gconvert: * This preprocessor macro is defined to convert a floating point * number to a string without a trailing decimal point. This * emulates the behavior of sprintf("%g"), but is sometimes much more * efficient. If gconvert() is not available, but gcvt() drops the * trailing decimal point, then gcvt() is used. If all else fails, * a macro using sprintf("%g") is used. Arguments for the Gconvert * macro are: value, number of digits, whether trailing zeros should * be retained, and the output buffer. * The usual values are: * d_Gconvert='gconvert((x),(n),(t),(b))' * d_Gconvert='gcvt((x),(n),(b))' * d_Gconvert='sprintf((b),"%.*g",(n),(x))' * The last two assume trailing zeros should not be kept. */ #define Gconvert(x,n,t,b) gcvt((x),(n),(b)) /* HAS_GETPAGESIZE: * This symbol, if defined, indicates that the getpagesize system call * is available to get system page size, which is the granularity of * many memory management calls. */ /*#define HAS_GETPAGESIZE / **/ /* HAS_GNULIBC: * This symbol, if defined, indicates to the C program that * the GNU C library is being used. A better check is to use * the __GLIBC__ and __GLIBC_MINOR__ symbols supplied with glibc. */ /*#define HAS_GNULIBC / **/ #if defined(HAS_GNULIBC) && !defined(_GNU_SOURCE) # define _GNU_SOURCE #endif /* HAS_ISASCII: * This manifest constant lets the C program know that isascii * is available. */ #define HAS_ISASCII /**/ /* HAS_LCHOWN: * This symbol, if defined, indicates that the lchown routine is * available to operate on a symbolic link (instead of following the * link). */ /*#define HAS_LCHOWN / **/ /* HAS_OPEN3: * This manifest constant lets the C program know that the three * argument form of open(2) is available. */ /*#define HAS_OPEN3 / **/ /* HAS_SAFE_BCOPY: * This symbol, if defined, indicates that the bcopy routine is available * to copy potentially overlapping memory blocks. Normally, you should * probably use memmove() or memcpy(). If neither is defined, roll your * own version. */ /*#define HAS_SAFE_BCOPY / **/ /* HAS_SAFE_MEMCPY: * This symbol, if defined, indicates that the memcpy routine is available * to copy potentially overlapping memory blocks. If you need to * copy overlapping memory blocks, you should check HAS_MEMMOVE and * use memmove() instead, if available. */ /*#define HAS_SAFE_MEMCPY / **/ /* HAS_SANE_MEMCMP: * This symbol, if defined, indicates that the memcmp routine is available * and can be used to compare relative magnitudes of chars with their high * bits set. If it is not defined, roll your own version. */ #define HAS_SANE_MEMCMP /**/ /* HAS_SIGACTION: * This symbol, if defined, indicates that Vr4's sigaction() routine * is available. */ /*#define HAS_SIGACTION / **/ /* HAS_SIGSETJMP: * This variable indicates to the C program that the sigsetjmp() * routine is available to save the calling process's registers * and stack environment for later use by siglongjmp(), and * to optionally save the process's signal mask. See * Sigjmp_buf, Sigsetjmp, and Siglongjmp. */ /* Sigjmp_buf: * This is the buffer type to be used with Sigsetjmp and Siglongjmp. */ /* Sigsetjmp: * This macro is used in the same way as sigsetjmp(), but will invoke * traditional setjmp() if sigsetjmp isn't available. * See HAS_SIGSETJMP. */ /* Siglongjmp: * This macro is used in the same way as siglongjmp(), but will invoke * traditional longjmp() if siglongjmp isn't available. * See HAS_SIGSETJMP. */ /*#define HAS_SIGSETJMP / **/ #ifdef HAS_SIGSETJMP #define Sigjmp_buf sigjmp_buf #define Sigsetjmp(buf,save_mask) sigsetjmp((buf),(save_mask)) #define Siglongjmp(buf,retval) siglongjmp((buf),(retval)) #else #define Sigjmp_buf jmp_buf #define Sigsetjmp(buf,save_mask) setjmp((buf)) #define Siglongjmp(buf,retval) longjmp((buf),(retval)) #endif /* USE_STDIO_PTR: * This symbol is defined if the _ptr and _cnt fields (or similar) * of the stdio FILE structure can be used to access the stdio buffer * for a file handle. If this is defined, then the FILE_ptr(fp) * and FILE_cnt(fp) macros will also be defined and should be used * to access these fields. */ /* FILE_ptr: * This macro is used to access the _ptr field (or equivalent) of the * FILE structure pointed to by its argument. This macro will always be * defined if USE_STDIO_PTR is defined. */ /* STDIO_PTR_LVALUE: * This symbol is defined if the FILE_ptr macro can be used as an * lvalue. */ /* FILE_cnt: * This macro is used to access the _cnt field (or equivalent) of the * FILE structure pointed to by its argument. This macro will always be * defined if USE_STDIO_PTR is defined. */ /* STDIO_CNT_LVALUE: * This symbol is defined if the FILE_cnt macro can be used as an * lvalue. */ /* STDIO_PTR_LVAL_SETS_CNT: * This symbol is defined if using the FILE_ptr macro as an lvalue * to increase the pointer by n has the side effect of decreasing the * value of File_cnt(fp) by n. */ /* STDIO_PTR_LVAL_NOCHANGE_CNT: * This symbol is defined if using the FILE_ptr macro as an lvalue * to increase the pointer by n leaves File_cnt(fp) unchanged. */ #define USE_STDIO_PTR /**/ #ifdef USE_STDIO_PTR #define FILE_ptr(fp) ((fp)->curp) #define STDIO_PTR_LVALUE /**/ #define FILE_cnt(fp) ((fp)->level) #define STDIO_CNT_LVALUE /**/ /*#define STDIO_PTR_LVAL_SETS_CNT / **/ #define STDIO_PTR_LVAL_NOCHANGE_CNT /**/ #endif /* USE_STDIO_BASE: * This symbol is defined if the _base field (or similar) of the * stdio FILE structure can be used to access the stdio buffer for * a file handle. If this is defined, then the FILE_base(fp) macro * will also be defined and should be used to access this field. * Also, the FILE_bufsiz(fp) macro will be defined and should be used * to determine the number of bytes in the buffer. USE_STDIO_BASE * will never be defined unless USE_STDIO_PTR is. */ /* FILE_base: * This macro is used to access the _base field (or equivalent) of the * FILE structure pointed to by its argument. This macro will always be * defined if USE_STDIO_BASE is defined. */ /* FILE_bufsiz: * This macro is used to determine the number of bytes in the I/O * buffer pointed to by _base field (or equivalent) of the FILE * structure pointed to its argument. This macro will always be defined * if USE_STDIO_BASE is defined. */ #define USE_STDIO_BASE /**/ #ifdef USE_STDIO_BASE #define FILE_base(fp) ((fp)->buffer) #define FILE_bufsiz(fp) ((fp)->level + (fp)->curp - (fp)->buffer) #endif /* HAS_VPRINTF: * This symbol, if defined, indicates that the vprintf routine is available * to printf with a pointer to an argument list. If unavailable, you * may need to write your own, probably in terms of _doprnt(). */ /* USE_CHAR_VSPRINTF: * This symbol is defined if this system has vsprintf() returning type * (char*). The trend seems to be to declare it as "int vsprintf()". It * is up to the package author to declare vsprintf correctly based on the * symbol. */ #define HAS_VPRINTF /**/ /*#define USE_CHAR_VSPRINTF / **/ /* DOUBLESIZE: * This symbol contains the size of a double, so that the C preprocessor * can make decisions based on it. */ #define DOUBLESIZE 8 /**/ /* I_TIME: * This symbol, if defined, indicates to the C program that it should * include . */ /* I_SYS_TIME: * This symbol, if defined, indicates to the C program that it should * include . */ /* I_SYS_TIME_KERNEL: * This symbol, if defined, indicates to the C program that it should * include with KERNEL defined. */ /* HAS_TM_TM_ZONE: * This symbol, if defined, indicates to the C program that * the struct tm has a tm_zone field. */ /* HAS_TM_TM_GMTOFF: * This symbol, if defined, indicates to the C program that * the struct tm has a tm_gmtoff field. */ #define I_TIME /**/ /*#define I_SYS_TIME / **/ /*#define I_SYS_TIME_KERNEL / **/ /*#define HAS_TM_TM_ZONE / **/ /*#define HAS_TM_TM_GMTOFF / **/ /* VAL_O_NONBLOCK: * This symbol is to be used during open() or fcntl(F_SETFL) to turn on * non-blocking I/O for the file descriptor. Note that there is no way * back, i.e. you cannot turn it blocking again this way. If you wish to * alternatively switch between blocking and non-blocking, use the * ioctl(FIOSNBIO) call instead, but that is not supported by all devices. */ /* VAL_EAGAIN: * This symbol holds the errno error code set by read() when no data was * present on the non-blocking file descriptor. */ /* RD_NODATA: * This symbol holds the return code from read() when no data is present * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is * not defined, then you can't distinguish between no data and EOF by * issuing a read(). You'll have to find another way to tell for sure! */ /* EOF_NONBLOCK: * This symbol, if defined, indicates to the C program that a read() on * a non-blocking file descriptor will return 0 on EOF, and not the value * held in RD_NODATA (-1 usually, in that case!). */ #define VAL_O_NONBLOCK O_NONBLOCK #define VAL_EAGAIN EAGAIN #define RD_NODATA -1 #define EOF_NONBLOCK /* PTRSIZE: * This symbol contains the size of a pointer, so that the C preprocessor * can make decisions based on it. It will be sizeof(void *) if * the compiler supports (void *); otherwise it will be * sizeof(char *). */ #define PTRSIZE 4 /**/ /* Drand01: * This macro is to be used to generate uniformly distributed * random numbers over the range [0., 1.[. You may have to supply * an 'extern double drand48();' in your program since SunOS 4.1.3 * doesn't provide you with anything relevant in its headers. * See HAS_DRAND48_PROTO. */ /* Rand_seed_t: * This symbol defines the type of the argument of the * random seed function. */ /* seedDrand01: * This symbol defines the macro to be used in seeding the * random number generator (see Drand01). */ /* RANDBITS: * This symbol indicates how many bits are produced by the * function used to generate normalized random numbers. * Values include 15, 16, 31, and 48. */ #define Drand01() (rand()/(double)((unsigned)1< or * to get any typedef'ed information. * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t). */ #define SSize_t int /* signed count of bytes */ /* EBCDIC: * This symbol, if defined, indicates that this system uses * EBCDIC encoding. */ /*#define EBCDIC / **/ /* SETUID_SCRIPTS_ARE_SECURE_NOW: * This symbol, if defined, indicates that the bug that prevents * setuid scripts from being secure is not present in this kernel. */ /* DOSUID: * This symbol, if defined, indicates that the C program should * check the script that it is executing for setuid/setgid bits, and * attempt to emulate setuid/setgid on systems that have disabled * setuid #! scripts because the kernel can't do it securely. * It is up to the package designer to make sure that this emulation * is done securely. Among other things, it should do an fstat on * the script it just opened to make sure it really is a setuid/setgid * script, it should make sure the arguments passed correspond exactly * to the argument on the #! line, and it should not trust any * subprocesses to which it must pass the filename rather than the * file descriptor of the script to be executed. */ /*#define SETUID_SCRIPTS_ARE_SECURE_NOW / **/ /*#define DOSUID / **/ /* PERL_USE_DEVEL: * This symbol, if defined, indicates that Perl was configured with * -Dusedevel, to enable development features. This should not be * done for production builds. */ /*#define PERL_USE_DEVEL / **/ /* HAS_ATOLF: * This symbol, if defined, indicates that the atolf routine is * available to convert strings into long doubles. */ /*#define HAS_ATOLF / **/ /* HAS_ATOLL: * This symbol, if defined, indicates that the atoll routine is * available to convert strings into long longs. */ /*#define HAS_ATOLL / **/ /* HAS__FWALK: * This symbol, if defined, indicates that the _fwalk system call is * available to apply a function to all the file handles. */ /*#define HAS__FWALK / **/ /* HAS_AINTL: * This symbol, if defined, indicates that the aintl routine is * available. If copysignl is also present we can emulate modfl. */ /*#define HAS_AINTL / **/ /* HAS_BUILTIN_CHOOSE_EXPR: * Can we handle GCC builtin for compile-time ternary-like expressions */ /* HAS_BUILTIN_EXPECT: * Can we handle GCC builtin for telling that certain values are more * likely */ /*#define HAS_BUILTIN_EXPECT / **/ /*#define HAS_BUILTIN_CHOOSE_EXPR / **/ /* HAS_C99_VARIADIC_MACROS: * If defined, the compiler supports C99 variadic macros. */ /*#define HAS_C99_VARIADIC_MACROS / **/ /* HAS_CLASS: * This symbol, if defined, indicates that the class routine is * available to classify doubles. Available for example in AIX. * The returned values are defined in and are: * * FP_PLUS_NORM Positive normalized, nonzero * FP_MINUS_NORM Negative normalized, nonzero * FP_PLUS_DENORM Positive denormalized, nonzero * FP_MINUS_DENORM Negative denormalized, nonzero * FP_PLUS_ZERO +0.0 * FP_MINUS_ZERO -0.0 * FP_PLUS_INF +INF * FP_MINUS_INF -INF * FP_NANS Signaling Not a Number (NaNS) * FP_NANQ Quiet Not a Number (NaNQ) */ /*#define HAS_CLASS / **/ /* HAS_CLEARENV: * This symbol, if defined, indicates that the clearenv () routine is * available for use. */ /*#define HAS_CLEARENV / **/ /* HAS_STRUCT_CMSGHDR: * This symbol, if defined, indicates that the struct cmsghdr * is supported. */ /*#define HAS_STRUCT_CMSGHDR / **/ /* HAS_COPYSIGNL: * This symbol, if defined, indicates that the copysignl routine is * available. If aintl is also present we can emulate modfl. */ /*#define HAS_COPYSIGNL / **/ /* USE_CPLUSPLUS: * This symbol, if defined, indicates that a C++ compiler was * used to compiled Perl and will be used to compile extensions. */ /*#define USE_CPLUSPLUS / **/ /* HAS_DBMINIT_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the dbminit() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int dbminit(char *); */ /*#define HAS_DBMINIT_PROTO / **/ /* HAS_DIR_DD_FD: * This symbol, if defined, indicates that the the DIR* dirstream * structure contains a member variable named dd_fd. */ /*#define HAS_DIR_DD_FD / **/ /* HAS_DIRFD: * This manifest constant lets the C program know that dirfd * is available. */ /*#define HAS_DIRFD / **/ /* DLSYM_NEEDS_UNDERSCORE: * This symbol, if defined, indicates that we need to prepend an * underscore to the symbol name before calling dlsym(). This only * makes sense if you *have* dlsym, which we will presume is the * case if you're using dl_dlopen.xs. */ /*#define DLSYM_NEEDS_UNDERSCORE / **/ /* HAS_FAST_STDIO: * This symbol, if defined, indicates that the "fast stdio" * is available to manipulate the stdio buffers directly. */ #define HAS_FAST_STDIO /**/ /* HAS_FCHDIR: * This symbol, if defined, indicates that the fchdir routine is * available to change directory using a file descriptor. */ /*#define HAS_FCHDIR / **/ /* FCNTL_CAN_LOCK: * This symbol, if defined, indicates that fcntl() can be used * for file locking. Normally on Unix systems this is defined. * It may be undefined on VMS. */ /*#define FCNTL_CAN_LOCK / **/ /* HAS_FINITE: * This symbol, if defined, indicates that the finite routine is * available to check whether a double is finite (non-infinity non-NaN). */ /*#define HAS_FINITE / **/ /* HAS_FINITEL: * This symbol, if defined, indicates that the finitel routine is * available to check whether a long double is finite * (non-infinity non-NaN). */ /*#define HAS_FINITEL / **/ /* HAS_FLOCK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the flock() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int flock(int, int); */ #define HAS_FLOCK_PROTO /**/ /* HAS_FP_CLASS: * This symbol, if defined, indicates that the fp_class routine is * available to classify doubles. Available for example in Digital UNIX. * The returned values are defined in and are: * * FP_SNAN Signaling NaN (Not-a-Number) * FP_QNAN Quiet NaN (Not-a-Number) * FP_POS_INF +infinity * FP_NEG_INF -infinity * FP_POS_NORM Positive normalized * FP_NEG_NORM Negative normalized * FP_POS_DENORM Positive denormalized * FP_NEG_DENORM Negative denormalized * FP_POS_ZERO +0.0 (positive zero) * FP_NEG_ZERO -0.0 (negative zero) */ /*#define HAS_FP_CLASS / **/ /* HAS_FPCLASS: * This symbol, if defined, indicates that the fpclass routine is * available to classify doubles. Available for example in Solaris/SVR4. * The returned values are defined in and are: * * FP_SNAN signaling NaN * FP_QNAN quiet NaN * FP_NINF negative infinity * FP_PINF positive infinity * FP_NDENORM negative denormalized non-zero * FP_PDENORM positive denormalized non-zero * FP_NZERO negative zero * FP_PZERO positive zero * FP_NNORM negative normalized non-zero * FP_PNORM positive normalized non-zero */ /*#define HAS_FPCLASS / **/ /* HAS_FPCLASSIFY: * This symbol, if defined, indicates that the fpclassify routine is * available to classify doubles. Available for example in HP-UX. * The returned values are defined in and are * * FP_NORMAL Normalized * FP_ZERO Zero * FP_INFINITE Infinity * FP_SUBNORMAL Denormalized * FP_NAN NaN * */ /*#define HAS_FPCLASSIFY / **/ /* HAS_FPCLASSL: * This symbol, if defined, indicates that the fpclassl routine is * available to classify long doubles. Available for example in IRIX. * The returned values are defined in and are: * * FP_SNAN signaling NaN * FP_QNAN quiet NaN * FP_NINF negative infinity * FP_PINF positive infinity * FP_NDENORM negative denormalized non-zero * FP_PDENORM positive denormalized non-zero * FP_NZERO negative zero * FP_PZERO positive zero * FP_NNORM negative normalized non-zero * FP_PNORM positive normalized non-zero */ /*#define HAS_FPCLASSL / **/ /* HAS_FPOS64_T: * This symbol will be defined if the C compiler supports fpos64_t. */ /*#define HAS_FPOS64_T / **/ /* HAS_FREXPL: * This symbol, if defined, indicates that the frexpl routine is * available to break a long double floating-point number into * a normalized fraction and an integral power of 2. */ /*#define HAS_FREXPL / **/ /* HAS_STRUCT_FS_DATA: * This symbol, if defined, indicates that the struct fs_data * to do statfs() is supported. */ /*#define HAS_STRUCT_FS_DATA / **/ /* HAS_FSEEKO: * This symbol, if defined, indicates that the fseeko routine is * available to fseek beyond 32 bits (useful for ILP32 hosts). */ /*#define HAS_FSEEKO / **/ /* HAS_FSTATFS: * This symbol, if defined, indicates that the fstatfs routine is * available to stat filesystems by file descriptors. */ /*#define HAS_FSTATFS / **/ /* HAS_FSYNC: * This symbol, if defined, indicates that the fsync routine is * available to write a file's modified data and attributes to * permanent storage. */ /*#define HAS_FSYNC / **/ /* HAS_FTELLO: * This symbol, if defined, indicates that the ftello routine is * available to ftell beyond 32 bits (useful for ILP32 hosts). */ /*#define HAS_FTELLO / **/ /* HAS_FUTIMES: * This symbol, if defined, indicates that the futimes routine is * available to change file descriptor time stamps with struct timevals. */ /*#define HAS_FUTIMES / **/ /* HAS_GETADDRINFO: * This symbol, if defined, indicates that the getaddrinfo() function * is available for use. */ /*#define HAS_GETADDRINFO / **/ /* HAS_GETCWD: * This symbol, if defined, indicates that the getcwd routine is * available to get the current working directory. */ #define HAS_GETCWD /**/ /* HAS_GETESPWNAM: * This symbol, if defined, indicates that the getespwnam system call is * available to retrieve enchanced (shadow) password entries by name. */ /*#define HAS_GETESPWNAM / **/ /* HAS_GETFSSTAT: * This symbol, if defined, indicates that the getfsstat routine is * available to stat filesystems in bulk. */ /*#define HAS_GETFSSTAT / **/ /* HAS_GETITIMER: * This symbol, if defined, indicates that the getitimer routine is * available to return interval timers. */ /*#define HAS_GETITIMER / **/ /* HAS_GETMNT: * This symbol, if defined, indicates that the getmnt routine is * available to get filesystem mount info by filename. */ /*#define HAS_GETMNT / **/ /* HAS_GETMNTENT: * This symbol, if defined, indicates that the getmntent routine is * available to iterate through mounted file systems to get their info. */ /*#define HAS_GETMNTENT / **/ /* HAS_GETNAMEINFO: * This symbol, if defined, indicates that the getnameinfo() function * is available for use. */ /*#define HAS_GETNAMEINFO / **/ /* HAS_GETPRPWNAM: * This symbol, if defined, indicates that the getprpwnam system call is * available to retrieve protected (shadow) password entries by name. */ /*#define HAS_GETPRPWNAM / **/ /* HAS_GETSPNAM: * This symbol, if defined, indicates that the getspnam system call is * available to retrieve SysV shadow password entries by name. */ /*#define HAS_GETSPNAM / **/ /* HAS_HASMNTOPT: * This symbol, if defined, indicates that the hasmntopt routine is * available to query the mount options of file systems. */ /*#define HAS_HASMNTOPT / **/ /* HAS_ILOGBL: * This symbol, if defined, indicates that the ilogbl routine is * available. If scalbnl is also present we can emulate frexpl. */ /*#define HAS_ILOGBL / **/ /* HAS_INETNTOP: * This symbol, if defined, indicates that the inet_ntop() function * is available to parse IPv4 and IPv6 strings. */ /*#define HAS_INETNTOP / **/ /* HAS_INETPTON: * This symbol, if defined, indicates that the inet_pton() function * is available to parse IPv4 and IPv6 strings. */ /*#define HAS_INETPTON / **/ /* HAS_INT64_T: * This symbol will defined if the C compiler supports int64_t. * Usually the needs to be included, but sometimes * is enough. */ /*#define HAS_INT64_T / **/ /* HAS_ISFINITE: * This symbol, if defined, indicates that the isfinite routine is * available to check whether a double is finite (non-infinity non-NaN). */ /*#define HAS_ISFINITE / **/ /* HAS_ISINF: * This symbol, if defined, indicates that the isinf routine is * available to check whether a double is an infinity. */ /*#define HAS_ISINF / **/ /* HAS_ISNAN: * This symbol, if defined, indicates that the isnan routine is * available to check whether a double is a NaN. */ #define HAS_ISNAN /**/ /* HAS_ISNANL: * This symbol, if defined, indicates that the isnanl routine is * available to check whether a long double is a NaN. */ /*#define HAS_ISNANL / **/ /* HAS_LDBL_DIG: * This symbol, if defined, indicates that this system's * or defines the symbol LDBL_DIG, which is the number * of significant digits in a long double precision number. Unlike * for DBL_DIG, there's no good guess for LDBL_DIG if it is undefined. */ #define HAS_LDBL_DIG /**/ /* LIBM_LIB_VERSION: * This symbol, if defined, indicates that libm exports _LIB_VERSION * and that math.h defines the enum to manipulate it. */ /*#define LIBM_LIB_VERSION / **/ /* HAS_MADVISE: * This symbol, if defined, indicates that the madvise system call is * available to map a file into memory. */ /*#define HAS_MADVISE / **/ /* HAS_MALLOC_SIZE: * This symbol, if defined, indicates that the malloc_size * routine is available for use. */ /*#define HAS_MALLOC_SIZE / **/ /* HAS_MALLOC_GOOD_SIZE: * This symbol, if defined, indicates that the malloc_good_size * routine is available for use. */ /*#define HAS_MALLOC_GOOD_SIZE / **/ /* HAS_MKDTEMP: * This symbol, if defined, indicates that the mkdtemp routine is * available to exclusively create a uniquely named temporary directory. */ /*#define HAS_MKDTEMP / **/ /* HAS_MKSTEMPS: * This symbol, if defined, indicates that the mkstemps routine is * available to excluslvely create and open a uniquely named * (with a suffix) temporary file. */ /*#define HAS_MKSTEMPS / **/ /* HAS_MODFL: * This symbol, if defined, indicates that the modfl routine is * available to split a long double x into a fractional part f and * an integer part i such that |f| < 1.0 and (f + i) = x. */ /* HAS_MODFL_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the modfl() function. Otherwise, it is up * to the program to supply one. */ /* HAS_MODFL_POW32_BUG: * This symbol, if defined, indicates that the modfl routine is * broken for long doubles >= pow(2, 32). * For example from 4294967303.150000 one would get 4294967302.000000 * and 1.150000. The bug has been seen in certain versions of glibc, * release 2.2.2 is known to be okay. */ /*#define HAS_MODFL / **/ /*#define HAS_MODFL_PROTO / **/ /*#define HAS_MODFL_POW32_BUG / **/ /* HAS_MPROTECT: * This symbol, if defined, indicates that the mprotect system call is * available to modify the access protection of a memory mapped file. */ /*#define HAS_MPROTECT / **/ /* HAS_STRUCT_MSGHDR: * This symbol, if defined, indicates that the struct msghdr * is supported. */ /*#define HAS_STRUCT_MSGHDR / **/ /* HAS_NL_LANGINFO: * This symbol, if defined, indicates that the nl_langinfo routine is * available to return local data. You will also need * and therefore I_LANGINFO. */ /*#define HAS_NL_LANGINFO / **/ /* HAS_OFF64_T: * This symbol will be defined if the C compiler supports off64_t. */ /*#define HAS_OFF64_T / **/ /* HAS_PROCSELFEXE: * This symbol is defined if PROCSELFEXE_PATH is a symlink * to the absolute pathname of the executing program. */ /* PROCSELFEXE_PATH: * If HAS_PROCSELFEXE is defined this symbol is the filename * of the symbolic link pointing to the absolute pathname of * the executing program. */ /*#define HAS_PROCSELFEXE / **/ #if defined(HAS_PROCSELFEXE) && !defined(PROCSELFEXE_PATH) #define PROCSELFEXE_PATH /**/ #endif /* HAS_PTHREAD_ATTR_SETSCOPE: * This symbol, if defined, indicates that the pthread_attr_setscope * system call is available to set the contention scope attribute of * a thread attribute object. */ /*#define HAS_PTHREAD_ATTR_SETSCOPE / **/ /* HAS_READV: * This symbol, if defined, indicates that the readv routine is * available to do gather reads. You will also need * and there I_SYSUIO. */ /*#define HAS_READV / **/ /* HAS_RECVMSG: * This symbol, if defined, indicates that the recvmsg routine is * available to send structured socket messages. */ /*#define HAS_RECVMSG / **/ /* HAS_SBRK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the sbrk() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern void* sbrk(int); * extern void* sbrk(size_t); */ /*#define HAS_SBRK_PROTO / **/ /* HAS_SCALBNL: * This symbol, if defined, indicates that the scalbnl routine is * available. If ilogbl is also present we can emulate frexpl. */ /*#define HAS_SCALBNL / **/ /* HAS_SENDMSG: * This symbol, if defined, indicates that the sendmsg routine is * available to send structured socket messages. */ /*#define HAS_SENDMSG / **/ /* HAS_SETITIMER: * This symbol, if defined, indicates that the setitimer routine is * available to set interval timers. */ /*#define HAS_SETITIMER / **/ /* HAS_SETPROCTITLE: * This symbol, if defined, indicates that the setproctitle routine is * available to set process title. */ /*#define HAS_SETPROCTITLE / **/ /* USE_SFIO: * This symbol, if defined, indicates that sfio should * be used. */ /*#define USE_SFIO / **/ /* HAS_SIGNBIT: * This symbol, if defined, indicates that the signbit routine is * available to check if the given number has the sign bit set. * This should include correct testing of -0.0. This will only be set * if the signbit() routine is safe to use with the NV type used internally * in perl. Users should call Perl_signbit(), which will be #defined to * the system's signbit() function or macro if this symbol is defined. */ /*#define HAS_SIGNBIT / **/ /* HAS_SIGPROCMASK: * This symbol, if defined, indicates that the sigprocmask * system call is available to examine or change the signal mask * of the calling process. */ /*#define HAS_SIGPROCMASK / **/ /* USE_SITECUSTOMIZE: * This symbol, if defined, indicates that sitecustomize should * be used. */ #ifndef USE_SITECUSTOMIZE /*#define USE_SITECUSTOMIZE / **/ #endif /* HAS_SNPRINTF: * This symbol, if defined, indicates that the snprintf () library * function is available for use. */ /* HAS_VSNPRINTF: * This symbol, if defined, indicates that the vsnprintf () library * function is available for use. */ #define HAS_SNPRINTF /**/ #define HAS_VSNPRINTF /**/ /* HAS_SOCKATMARK: * This symbol, if defined, indicates that the sockatmark routine is * available to test whether a socket is at the out-of-band mark. */ /*#define HAS_SOCKATMARK / **/ /* HAS_SOCKATMARK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the sockatmark() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int sockatmark(int); */ /*#define HAS_SOCKATMARK_PROTO / **/ /* HAS_SOCKS5_INIT: * This symbol, if defined, indicates that the socks5_init routine is * available to initialize SOCKS 5. */ /*#define HAS_SOCKS5_INIT / **/ /* SPRINTF_RETURNS_STRLEN: * This variable defines whether sprintf returns the length of the string * (as per the ANSI spec). Some C libraries retain compatibility with * pre-ANSI C and return a pointer to the passed in buffer; for these * this variable will be undef. */ #define SPRINTF_RETURNS_STRLEN /**/ /* HAS_SQRTL: * This symbol, if defined, indicates that the sqrtl routine is * available to do long double square roots. */ /*#define HAS_SQRTL / **/ /* HAS_SETRESGID_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the setresgid() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern int setresgid(uid_t ruid, uid_t euid, uid_t suid); */ /*#define HAS_SETRESGID_PROTO / **/ /* HAS_SETRESUID_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the setresuid() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern int setresuid(uid_t ruid, uid_t euid, uid_t suid); */ /*#define HAS_SETRESUID_PROTO / **/ /* HAS_STRUCT_STATFS_F_FLAGS: * This symbol, if defined, indicates that the struct statfs * does have the f_flags member containing the mount flags of * the filesystem containing the file. * This kind of struct statfs is coming from (BSD 4.3), * not from (SYSV). Older BSDs (like Ultrix) do not * have statfs() and struct statfs, they have ustat() and getmnt() * with struct ustat and struct fs_data. */ /*#define HAS_STRUCT_STATFS_F_FLAGS / **/ /* HAS_STRUCT_STATFS: * This symbol, if defined, indicates that the struct statfs * to do statfs() is supported. */ /*#define HAS_STRUCT_STATFS / **/ /* HAS_FSTATVFS: * This symbol, if defined, indicates that the fstatvfs routine is * available to stat filesystems by file descriptors. */ /*#define HAS_FSTATVFS / **/ /* HAS_STRFTIME: * This symbol, if defined, indicates that the strftime routine is * available to do time formatting. */ #define HAS_STRFTIME /**/ /* HAS_STRLCAT: * This symbol, if defined, indicates that the strlcat () routine is * available to do string concatenation. */ /*#define HAS_STRLCAT / **/ /* HAS_STRLCPY: * This symbol, if defined, indicates that the strlcpy () routine is * available to do string copying. */ /*#define HAS_STRLCPY / **/ /* HAS_STRTOLD: * This symbol, if defined, indicates that the strtold routine is * available to convert strings to long doubles. */ /*#define HAS_STRTOLD / **/ /* HAS_STRTOLL: * This symbol, if defined, indicates that the strtoll routine is * available to convert strings to long longs. */ /*#define HAS_STRTOLL / **/ /* HAS_STRTOQ: * This symbol, if defined, indicates that the strtoq routine is * available to convert strings to long longs (quads). */ /*#define HAS_STRTOQ / **/ /* HAS_STRTOULL: * This symbol, if defined, indicates that the strtoull routine is * available to convert strings to unsigned long longs. */ /*#define HAS_STRTOULL / **/ /* HAS_STRTOUQ: * This symbol, if defined, indicates that the strtouq routine is * available to convert strings to unsigned long longs (quads). */ /*#define HAS_STRTOUQ / **/ /* HAS_SYSCALL_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the syscall() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern int syscall(int, ...); * extern int syscall(long, ...); */ /*#define HAS_SYSCALL_PROTO / **/ /* HAS_TELLDIR_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the telldir() function. Otherwise, it is up * to the program to supply one. A good guess is * extern long telldir(DIR*); */ #define HAS_TELLDIR_PROTO /**/ /* HAS_CTIME64: * This symbol, if defined, indicates that the ctime64 () routine is * available to do the 64bit variant of ctime () */ /* HAS_LOCALTIME64: * This symbol, if defined, indicates that the localtime64 () routine is * available to do the 64bit variant of localtime () */ /* HAS_GMTIME64: * This symbol, if defined, indicates that the gmtime64 () routine is * available to do the 64bit variant of gmtime () */ /* HAS_MKTIME64: * This symbol, if defined, indicates that the mktime64 () routine is * available to do the 64bit variant of mktime () */ /* HAS_DIFFTIME64: * This symbol, if defined, indicates that the difftime64 () routine is * available to do the 64bit variant of difftime () */ /* HAS_ASCTIME64: * This symbol, if defined, indicates that the asctime64 () routine is * available to do the 64bit variant of asctime () */ /*#define HAS_CTIME64 / **/ /*#define HAS_LOCALTIME64 / **/ /*#define HAS_GMTIME64 / **/ /*#define HAS_MKTIME64 / **/ /*#define HAS_DIFFTIME64 / **/ /*#define HAS_ASCTIME64 / **/ /* HAS_TIMEGM: * This symbol, if defined, indicates that the timegm routine is * available to do the opposite of gmtime () */ /*#define HAS_TIMEGM / **/ /* U32_ALIGNMENT_REQUIRED: * This symbol, if defined, indicates that you must access * character data through U32-aligned pointers. */ #ifndef U32_ALIGNMENT_REQUIRED #define U32_ALIGNMENT_REQUIRED /**/ #endif /* HAS_UALARM: * This symbol, if defined, indicates that the ualarm routine is * available to do alarms with microsecond granularity. */ /*#define HAS_UALARM / **/ /* HAS_UNORDERED: * This symbol, if defined, indicates that the unordered routine is * available to check whether two doubles are unordered * (effectively: whether either of them is NaN) */ /*#define HAS_UNORDERED / **/ /* HAS_UNSETENV: * This symbol, if defined, indicates that the unsetenv () routine is * available for use. */ /*#define HAS_UNSETENV / **/ /* HAS_USLEEP_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the usleep() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int usleep(useconds_t); */ /*#define HAS_USLEEP_PROTO / **/ /* HAS_USTAT: * This symbol, if defined, indicates that the ustat system call is * available to query file system statistics by dev_t. */ /*#define HAS_USTAT / **/ /* HAS_WRITEV: * This symbol, if defined, indicates that the writev routine is * available to do scatter writes. */ /*#define HAS_WRITEV / **/ /* USE_DYNAMIC_LOADING: * This symbol, if defined, indicates that dynamic loading of * some sort is available. */ #define USE_DYNAMIC_LOADING /**/ /* FFLUSH_NULL: * This symbol, if defined, tells that fflush(NULL) does flush * all pending stdio output. */ /* FFLUSH_ALL: * This symbol, if defined, tells that to flush * all pending stdio output one must loop through all * the stdio file handles stored in an array and fflush them. * Note that if fflushNULL is defined, fflushall will not * even be probed for and will be left undefined. */ #define FFLUSH_NULL /**/ /*#define FFLUSH_ALL / **/ /* I_ASSERT: * This symbol, if defined, indicates that exists and * could be included by the C program to get the assert() macro. */ #define I_ASSERT /**/ /* I_CRYPT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_CRYPT / **/ /* DB_Prefix_t: * This symbol contains the type of the prefix structure element * in the header file. In older versions of DB, it was * int, while in newer ones it is u_int32_t. */ /* DB_Hash_t: * This symbol contains the type of the prefix structure element * in the header file. In older versions of DB, it was * int, while in newer ones it is size_t. */ /* DB_VERSION_MAJOR_CFG: * This symbol, if defined, defines the major version number of * Berkeley DB found in the header when Perl was configured. */ /* DB_VERSION_MINOR_CFG: * This symbol, if defined, defines the minor version number of * Berkeley DB found in the header when Perl was configured. * For DB version 1 this is always 0. */ /* DB_VERSION_PATCH_CFG: * This symbol, if defined, defines the patch version number of * Berkeley DB found in the header when Perl was configured. * For DB version 1 this is always 0. */ #define DB_Hash_t int /**/ #define DB_Prefix_t int /**/ #define DB_VERSION_MAJOR_CFG 0 /**/ #define DB_VERSION_MINOR_CFG 0 /**/ #define DB_VERSION_PATCH_CFG 0 /**/ /* I_FP: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_FP / **/ /* I_FP_CLASS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_FP_CLASS / **/ /* I_IEEEFP: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_IEEEFP / **/ /* I_INTTYPES: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_INTTYPES / **/ /* I_LANGINFO: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_LANGINFO / **/ /* I_LIBUTIL: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_LIBUTIL / **/ /* I_MALLOCMALLOC: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_MALLOCMALLOC / **/ /* I_MNTENT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_MNTENT / **/ /* I_NETINET_TCP: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_NETINET_TCP / **/ /* I_POLL: * This symbol, if defined, indicates that exists and * should be included. (see also HAS_POLL) */ /*#define I_POLL / **/ /* I_PROT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_PROT / **/ /* I_SHADOW: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SHADOW / **/ /* I_SOCKS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SOCKS / **/ /* I_SUNMATH: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SUNMATH / **/ /* I_SYSLOG: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSLOG / **/ /* I_SYSMODE: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSMODE / **/ /* I_SYS_MOUNT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYS_MOUNT / **/ /* I_SYS_STATFS: * This symbol, if defined, indicates that exists. */ /*#define I_SYS_STATFS / **/ /* I_SYS_STATVFS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYS_STATVFS / **/ /* I_SYSUTSNAME: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSUTSNAME / **/ /* I_SYS_VFS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYS_VFS / **/ /* I_USTAT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_USTAT / **/ /* PERL_PRIfldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'f') for output. */ /* PERL_PRIgldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'g') for output. */ /* PERL_PRIeldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'e') for output. */ /* PERL_SCNfldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'f') for input. */ /*#define PERL_PRIfldbl "Lf" / **/ /*#define PERL_PRIgldbl "Lg" / **/ /*#define PERL_PRIeldbl "Le" / **/ /*#define PERL_SCNfldbl "Lf" / **/ /* PERL_MAD: * This symbol, if defined, indicates that the Misc Attribution * Declaration code should be conditionally compiled. */ /*#define PERL_MAD / **/ /* NEED_VA_COPY: * This symbol, if defined, indicates that the system stores * the variable argument list datatype, va_list, in a format * that cannot be copied by simple assignment, so that some * other means must be used when copying is required. * As such systems vary in their provision (or non-provision) * of copying mechanisms, handy.h defines a platform- * independent macro, Perl_va_copy(src, dst), to do the job. */ /*#define NEED_VA_COPY / **/ /* IVTYPE: * This symbol defines the C type used for Perl's IV. */ /* UVTYPE: * This symbol defines the C type used for Perl's UV. */ /* I8TYPE: * This symbol defines the C type used for Perl's I8. */ /* U8TYPE: * This symbol defines the C type used for Perl's U8. */ /* I16TYPE: * This symbol defines the C type used for Perl's I16. */ /* U16TYPE: * This symbol defines the C type used for Perl's U16. */ /* I32TYPE: * This symbol defines the C type used for Perl's I32. */ /* U32TYPE: * This symbol defines the C type used for Perl's U32. */ /* I64TYPE: * This symbol defines the C type used for Perl's I64. */ /* U64TYPE: * This symbol defines the C type used for Perl's U64. */ /* NVTYPE: * This symbol defines the C type used for Perl's NV. */ /* IVSIZE: * This symbol contains the sizeof(IV). */ /* UVSIZE: * This symbol contains the sizeof(UV). */ /* I8SIZE: * This symbol contains the sizeof(I8). */ /* U8SIZE: * This symbol contains the sizeof(U8). */ /* I16SIZE: * This symbol contains the sizeof(I16). */ /* U16SIZE: * This symbol contains the sizeof(U16). */ /* I32SIZE: * This symbol contains the sizeof(I32). */ /* U32SIZE: * This symbol contains the sizeof(U32). */ /* I64SIZE: * This symbol contains the sizeof(I64). */ /* U64SIZE: * This symbol contains the sizeof(U64). */ /* NVSIZE: * This symbol contains the sizeof(NV). */ /* NV_PRESERVES_UV: * This symbol, if defined, indicates that a variable of type NVTYPE * can preserve all the bits of a variable of type UVTYPE. */ /* NV_PRESERVES_UV_BITS: * This symbol contains the number of bits a variable of type NVTYPE * can preserve of a variable of type UVTYPE. */ /* NV_OVERFLOWS_INTEGERS_AT: * This symbol gives the largest integer value that NVs can hold. This * value + 1.0 cannot be stored accurately. It is expressed as constant * floating point expression to reduce the chance of decimale/binary * conversion issues. If it can not be determined, the value 0 is given. */ /* NV_ZERO_IS_ALLBITS_ZERO: * This symbol, if defined, indicates that a variable of type NVTYPE * stores 0.0 in memory as all bits zero. */ #define IVTYPE long /**/ #define UVTYPE unsigned long /**/ #define I8TYPE char /**/ #define U8TYPE unsigned char /**/ #define I16TYPE short /**/ #define U16TYPE unsigned short /**/ #define I32TYPE long /**/ #define U32TYPE unsigned long /**/ #ifdef HAS_QUAD #define I64TYPE __int64 /**/ #define U64TYPE unsigned __int64 /**/ #endif #define NVTYPE double /**/ #define IVSIZE 4 /**/ #define UVSIZE 4 /**/ #define I8SIZE 1 /**/ #define U8SIZE 1 /**/ #define I16SIZE 2 /**/ #define U16SIZE 2 /**/ #define I32SIZE 4 /**/ #define U32SIZE 4 /**/ #ifdef HAS_QUAD #define I64SIZE 8 /**/ #define U64SIZE 8 /**/ #endif #define NVSIZE 8 /**/ #define NV_PRESERVES_UV #define NV_PRESERVES_UV_BITS 32 #define NV_OVERFLOWS_INTEGERS_AT 256.0*256.0*256.0*256.0*256.0*256.0*2.0*2.0*2.0*2.0*2.0 #define NV_ZERO_IS_ALLBITS_ZERO #if UVSIZE == 8 # ifdef BYTEORDER # if BYTEORDER == 0x1234 # undef BYTEORDER # define BYTEORDER 0x12345678 # else # if BYTEORDER == 0x4321 # undef BYTEORDER # define BYTEORDER 0x87654321 # endif # endif # endif #endif /* IVdf: * This symbol defines the format string used for printing a Perl IV * as a signed decimal integer. */ /* UVuf: * This symbol defines the format string used for printing a Perl UV * as an unsigned decimal integer. */ /* UVof: * This symbol defines the format string used for printing a Perl UV * as an unsigned octal integer. */ /* UVxf: * This symbol defines the format string used for printing a Perl UV * as an unsigned hexadecimal integer in lowercase abcdef. */ /* UVXf: * This symbol defines the format string used for printing a Perl UV * as an unsigned hexadecimal integer in uppercase ABCDEF. */ /* NVef: * This symbol defines the format string used for printing a Perl NV * using %e-ish floating point format. */ /* NVff: * This symbol defines the format string used for printing a Perl NV * using %f-ish floating point format. */ /* NVgf: * This symbol defines the format string used for printing a Perl NV * using %g-ish floating point format. */ #define IVdf "ld" /**/ #define UVuf "lu" /**/ #define UVof "lo" /**/ #define UVxf "lx" /**/ #define UVXf "lX" /**/ #define NVef "e" /**/ #define NVff "f" /**/ #define NVgf "g" /**/ /* SELECT_MIN_BITS: * This symbol holds the minimum number of bits operated by select. * That is, if you do select(n, ...), how many bits at least will be * cleared in the masks if some activity is detected. Usually this * is either n or 32*ceil(n/32), especially many little-endians do * the latter. This is only useful if you have select(), naturally. */ #define SELECT_MIN_BITS 32 /**/ /* STARTPERL: * This variable contains the string to put in front of a perl * script to make sure (one hopes) that it runs with perl and not * some shell. */ #define STARTPERL "#!perl" /**/ /* HAS_STDIO_STREAM_ARRAY: * This symbol, if defined, tells that there is an array * holding the stdio streams. */ /* STDIO_STREAM_ARRAY: * This symbol tells the name of the array holding the stdio streams. * Usual values include _iob, __iob, and __sF. */ /*#define HAS_STDIO_STREAM_ARRAY / **/ #ifdef HAS_STDIO_STREAM_ARRAY #define STDIO_STREAM_ARRAY #endif /* GMTIME_MAX: * This symbol contains the maximum value for the time_t offset that * the system function gmtime () accepts, and defaults to 0 */ /* GMTIME_MIN: * This symbol contains the minimum value for the time_t offset that * the system function gmtime () accepts, and defaults to 0 */ /* LOCALTIME_MAX: * This symbol contains the maximum value for the time_t offset that * the system function localtime () accepts, and defaults to 0 */ /* LOCALTIME_MIN: * This symbol contains the minimum value for the time_t offset that * the system function localtime () accepts, and defaults to 0 */ #define GMTIME_MAX 2147483647 /**/ #define GMTIME_MIN 0 /**/ #define LOCALTIME_MAX 2147483647 /**/ #define LOCALTIME_MIN 0 /**/ /* USE_64_BIT_INT: * This symbol, if defined, indicates that 64-bit integers should * be used when available. If not defined, the native integers * will be employed (be they 32 or 64 bits). The minimal possible * 64-bitness is used, just enough to get 64-bit integers into Perl. * This may mean using for example "long longs", while your memory * may still be limited to 2 gigabytes. */ /* USE_64_BIT_ALL: * This symbol, if defined, indicates that 64-bit integers should * be used when available. If not defined, the native integers * will be used (be they 32 or 64 bits). The maximal possible * 64-bitness is employed: LP64 or ILP64, meaning that you will * be able to use more than 2 gigabytes of memory. This mode is * even more binary incompatible than USE_64_BIT_INT. You may not * be able to run the resulting executable in a 32-bit CPU at all or * you may need at least to reboot your OS to 64-bit mode. */ #ifndef USE_64_BIT_INT /*#define USE_64_BIT_INT / **/ #endif #ifndef USE_64_BIT_ALL /*#define USE_64_BIT_ALL / **/ #endif /* USE_DTRACE: * This symbol, if defined, indicates that Perl should * be built with support for DTrace. */ /*#define USE_DTRACE / **/ /* USE_FAST_STDIO: * This symbol, if defined, indicates that Perl should * be built to use 'fast stdio'. * Defaults to define in Perls 5.8 and earlier, to undef later. */ #ifndef USE_FAST_STDIO /*#define USE_FAST_STDIO / **/ #endif /* USE_LARGE_FILES: * This symbol, if defined, indicates that large file support * should be used when available. */ #ifndef USE_LARGE_FILES /*#define USE_LARGE_FILES / **/ #endif /* USE_LONG_DOUBLE: * This symbol, if defined, indicates that long doubles should * be used when available. */ #ifndef USE_LONG_DOUBLE /*#define USE_LONG_DOUBLE / **/ #endif /* USE_MORE_BITS: * This symbol, if defined, indicates that 64-bit interfaces and * long doubles should be used when available. */ #ifndef USE_MORE_BITS /*#define USE_MORE_BITS / **/ #endif /* MULTIPLICITY: * This symbol, if defined, indicates that Perl should * be built to use multiplicity. */ #ifndef MULTIPLICITY /*#define MULTIPLICITY / **/ #endif /* USE_PERLIO: * This symbol, if defined, indicates that the PerlIO abstraction should * be used throughout. If not defined, stdio should be * used in a fully backward compatible manner. */ #ifndef USE_PERLIO /*#define USE_PERLIO / **/ #endif /* USE_SOCKS: * This symbol, if defined, indicates that Perl should * be built to use socks. */ #ifndef USE_SOCKS /*#define USE_SOCKS / **/ #endif #endif perl-5.12.0-RC0/win32/config.gc64nox0000444000175000017500000005305511325127002015547 0ustar jessejesse## Configured by: ~cf_email~ ## Target system: WIN32 Author='' Date='$Date' Header='' Id='$Id' Locker='' Log='$Log' RCSfile='$RCSfile' Revision='$Revision' Source='' State='' _a='.a' _exe='.exe' _o='.o' afs='false' afsroot='/afs' alignbytes='8' ansi2knr='' aphostname='' api_revision='~PERL_API_REVISION~' api_subversion='~PERL_API_SUBVERSION~' api_version='~PERL_API_VERSION~' api_versionstring='~PERL_API_REVISION~.~PERL_API_VERSION~.~PERL_API_SUBVERSION~' ar='ar' archlib='~INST_TOP~~INST_VER~\lib~INST_ARCH~' archlibexp='~INST_TOP~~INST_VER~\lib~INST_ARCH~' archname64='' archname='MSWin32' archobjs='' asctime_r_proto='0' awk='awk' baserev='5' bash='' bin='~INST_TOP~~INST_VER~\bin~INST_ARCH~' binexp='~INST_TOP~~INST_VER~\bin~INST_ARCH~' bison='' byacc='byacc' byteorder='1234' c='' castflags='0' cat='type' cc='gcc' cccdlflags=' ' ccdlflags=' ' ccflags='-MD -DWIN32' ccflags_uselargefiles='' ccname='~cc~' ccsymbols='' ccversion='' cf_by='nobody' cf_email='nobody@no.where.net' cf_time='' chgrp='' chmod='' chown='' clocktype='clock_t' comm='' compress='' contains='grep' cp='copy' cpio='' cpp='~cc~ -E' cpp_stuff='42' cppccsymbols='' cppflags='-DWIN32' cpplast='' cppminus='-' cpprun='~cc~ -E' cppstdin='~cc~ -E' cppsymbols='' crypt_r_proto='0' cryptlib='' csh='undef' ctermid_r_proto='0' ctime_r_proto='0' d_Gconvert='sprintf((b),"%.*g",(n),(x))' d_PRIEUldbl='undef' d_PRIFUldbl='undef' d_PRIGUldbl='undef' d_PRIXU64='undef' d_PRId64='undef' d_PRIeldbl='undef' d_PRIfldbl='undef' d_PRIgldbl='undef' d_PRIi64='undef' d_PRIo64='undef' d_PRIu64='undef' d_PRIx64='undef' d_SCNfldbl='undef' d__fwalk='undef' d_access='define' d_accessx='undef' d_aintl='undef' d_alarm='define' d_archlib='define' d_asctime64='undef' d_asctime_r='undef' d_atolf='undef' d_atoll='define' d_attribute_deprecated='undef' d_attribute_format='undef' d_attribute_malloc='undef' d_attribute_nonnull='undef' d_attribute_noreturn='undef' d_attribute_pure='undef' d_attribute_unused='undef' d_attribute_warn_unused_result='undef' d_bcmp='undef' d_bcopy='undef' d_bsd='define' d_bsdgetpgrp='undef' d_bsdsetpgrp='undef' d_builtin_choose_expr='undef' d_builtin_expect='undef' d_bzero='undef' d_c99_variadic_macros='undef' d_casti32='define' d_castneg='define' d_charvspr='undef' d_chown='undef' d_chroot='undef' d_chsize='define' d_class='undef' d_clearenv='undef' d_closedir='define' d_cmsghdr_s='undef' d_const='define' d_copysignl='undef' d_cplusplus='undef' d_crypt='undef' d_crypt_r='undef' d_csh='undef' d_ctermid='undef' d_ctermid_r='undef' d_ctime64='undef' d_ctime_r='undef' d_cuserid='undef' d_dbl_dig='define' d_dbminitproto='undef' d_difftime64='undef' d_difftime='define' d_dir_dd_fd='undef' d_dirfd='undef' d_dirnamlen='define' d_dlerror='define' d_dlopen='define' d_dlsymun='undef' d_dosuid='undef' d_drand48_r='undef' d_drand48proto='undef' d_dup2='define' d_eaccess='undef' d_endgrent='undef' d_endgrent_r='undef' d_endhent='undef' d_endhostent_r='undef' d_endnent='undef' d_endnetent_r='undef' d_endpent='undef' d_endprotoent_r='undef' d_endpwent='undef' d_endpwent_r='undef' d_endsent='undef' d_endservent_r='undef' d_eofnblk='define' d_eunice='undef' d_faststdio='define' d_fchdir='undef' d_fchmod='undef' d_fchown='undef' d_fcntl_can_lock='undef' d_fcntl='undef' d_fd_macros='define' d_fd_set='define' d_fds_bits='define' d_fgetpos='define' d_finitel='undef' d_finite='undef' d_flexfnam='define' d_flock='define' d_flockproto='define' d_fork='undef' d_fp_class='undef' d_fpathconf='undef' d_fpclass='undef' d_fpclassify='undef' d_fpclassl='undef' d_fpos64_t='undef' d_frexpl='undef' d_fs_data_s='undef' d_fseeko='undef' d_fsetpos='define' d_fstatfs='undef' d_fstatvfs='undef' d_fsync='undef' d_ftello='undef' d_ftime='define' d_futimes='undef' d_gdbm_ndbm_h_uses_prototypes='undef' d_gdbmndbm_h_uses_prototypes='undef' d_getaddrinfo='undef' d_getcwd='define' d_getespwnam='undef' d_getfsstat='undef' d_getgrent='undef' d_getgrent_r='undef' d_getgrgid_r='undef' d_getgrnam_r='undef' d_getgrps='undef' d_gethbyaddr='define' d_gethbyname='define' d_gethent='undef' d_gethname='define' d_gethostbyaddr_r='undef' d_gethostbyname_r='undef' d_gethostent_r='undef' d_gethostprotos='define' d_getitimer='undef' d_getlogin='define' d_getlogin_r='undef' d_getmnt='undef' d_getmntent='undef' d_getnameinfo='undef' d_getnbyaddr='undef' d_getnbyname='undef' d_getnent='undef' d_getnetbyaddr_r='undef' d_getnetbyname_r='undef' d_getnetent_r='undef' d_getnetprotos='undef' d_getpagsz='undef' d_getpbyname='define' d_getpbynumber='define' d_getpent='undef' d_getpgid='undef' d_getpgrp2='undef' d_getpgrp='undef' d_getppid='undef' d_getprior='undef' d_getprotobyname_r='undef' d_getprotobynumber_r='undef' d_getprotoent_r='undef' d_getprotoprotos='define' d_getprpwnam='undef' d_getpwent='undef' d_getpwent_r='undef' d_getpwnam_r='undef' d_getpwuid_r='undef' d_getsbyname='define' d_getsbyport='define' d_getsent='undef' d_getservbyname_r='undef' d_getservbyport_r='undef' d_getservent_r='undef' d_getservprotos='define' d_getspnam='undef' d_getspnam_r='undef' d_gettimeod='define' d_gmtime64='undef' d_gmtime_r='undef' d_gnulibc='undef' d_grpasswd='undef' d_hasmntopt='undef' d_htonl='define' d_ilogbl='undef' d_inc_version_list='undef' d_index='undef' d_inetaton='undef' d_inetntop='undef' d_inetpton='undef' d_int64_t='undef' d_isascii='define' d_isfinite='undef' d_isinf='undef' d_isnan='define' d_isnanl='undef' d_killpg='define' d_lchown='undef' d_ldbl_dig='define' d_libm_lib_version='undef' d_link='define' d_localtime64='undef' d_localtime_r='undef' d_localtime_r_needs_tzset='undef' d_locconv='define' d_lockf='undef' d_longdbl='define' d_longlong='define' d_lseekproto='define' d_lstat='undef' d_madvise='undef' d_malloc_good_size='undef' d_malloc_size='undef' d_mblen='define' d_mbstowcs='define' d_mbtowc='define' d_memchr='define' d_memcmp='define' d_memcpy='define' d_memmove='define' d_memset='define' d_mkdir='define' d_mkdtemp='undef' d_mkfifo='undef' d_mkstemp='undef' d_mkstemps='undef' d_mktime64='undef' d_mktime='define' d_mmap='undef' d_modfl='undef' d_modfl_pow32_bug='undef' d_modflproto='undef' d_mprotect='undef' d_msgctl='undef' d_msg_ctrunc='undef' d_msg_dontroute='undef' d_msgget='undef' d_msghdr_s='undef' d_msg_oob='undef' d_msg_peek='undef' d_msg_proxy='undef' d_msgrcv='undef' d_msgsnd='undef' d_msg='undef' d_msync='undef' d_munmap='undef' d_mymalloc='undef' d_ndbm='undef' d_ndbm_h_uses_prototypes='undef' d_nice='undef' d_nl_langinfo='undef' d_nv_preserves_uv='undef' d_nv_zero_is_allbits_zero='define' d_off64_t='undef' d_old_pthread_create_joinable='undef' d_oldpthreads='undef' d_oldsock='undef' d_open3='undef' d_pathconf='undef' d_pause='define' d_perl_otherlibdirs='undef' d_phostname='undef' d_pipe='define' d_poll='undef' d_portable='define' d_printf_format_null='undef' d_procselfexe='undef' d_pseudofork='undef' d_pthread_atfork='undef' d_pthread_attr_setscope='undef' d_pthread_yield='undef' d_pwage='undef' d_pwchange='undef' d_pwclass='undef' d_pwcomment='undef' d_pwexpire='undef' d_pwgecos='undef' d_pwpasswd='undef' d_pwquota='undef' d_qgcvt='undef' d_quad='define' d_random_r='undef' d_readdir64_r='undef' d_readdir='define' d_readdir_r='undef' d_readlink='undef' d_readv='undef' d_recvmsg='undef' d_rename='define' d_rewinddir='define' d_rmdir='define' d_safebcpy='undef' d_safemcpy='undef' d_sanemcmp='define' d_sbrkproto='undef' d_scalbnl='undef' d_sched_yield='undef' d_scm_rights='undef' d_seekdir='define' d_select='define' d_sem='undef' d_semctl='undef' d_semctl_semid_ds='undef' d_semctl_semun='undef' d_semget='undef' d_semop='undef' d_sendmsg='undef' d_setegid='undef' d_seteuid='undef' d_setgrent='undef' d_setgrent_r='undef' d_setgrps='undef' d_sethent='undef' d_sethostent_r='undef' d_setitimer='undef' d_setlinebuf='undef' d_setlocale='define' d_setlocale_r='undef' d_setnent='undef' d_setnetent_r='undef' d_setpent='undef' d_setpgid='undef' d_setpgrp2='undef' d_setpgrp='undef' d_setprior='undef' d_setproctitle='undef' d_setprotoent_r='undef' d_setpwent='undef' d_setpwent_r='undef' d_setregid='undef' d_setresgid='undef' d_setresuid='undef' d_setreuid='undef' d_setrgid='undef' d_setruid='undef' d_setsent='undef' d_setservent_r='undef' d_setsid='undef' d_setvbuf='define' d_sfio='undef' d_shm='undef' d_shmat='undef' d_shmatprototype='undef' d_shmctl='undef' d_shmdt='undef' d_shmget='undef' d_sigaction='undef' d_signbit='undef' d_sigprocmask='undef' d_sigsetjmp='undef' d_sitearch='define' d_snprintf='define' d_sockatmark='undef' d_sockatmarkproto='undef' d_socket='define' d_socklen_t='undef' d_sockpair='undef' d_socks5_init='undef' d_sprintf_returns_strlen='define' d_sqrtl='undef' d_srand48_r='undef' d_srandom_r='undef' d_sresgproto='undef' d_sresuproto='undef' d_statblks='undef' d_statfs_f_flags='undef' d_statfs_s='undef' d_statvfs='undef' d_stdio_cnt_lval='define' d_stdio_ptr_lval='define' d_stdio_ptr_lval_nochange_cnt='define' d_stdio_ptr_lval_sets_cnt='undef' d_stdio_stream_array='undef' d_stdiobase='define' d_stdstdio='define' d_strchr='define' d_strcoll='define' d_strctcpy='define' d_strerrm='strerror(e)' d_strerror='define' d_strerror_r='undef' d_strftime='define' d_strlcat='undef' d_strlcpy='undef' d_strtod='define' d_strtol='define' d_strtold='undef' d_strtoll='define' d_strtoq='undef' d_strtoul='define' d_strtoull='define' d_strtouq='undef' d_strxfrm='define' d_suidsafe='undef' d_symlink='undef' d_syscall='undef' d_syscallproto='undef' d_sysconf='undef' d_sysernlst='' d_syserrlst='define' d_system='define' d_tcgetpgrp='undef' d_tcsetpgrp='undef' d_telldir='define' d_telldirproto='define' d_time='define' d_timegm='undef' d_times='define' d_tm_tm_gmtoff='undef' d_tm_tm_zone='undef' d_tmpnam_r='undef' d_truncate='undef' d_ttyname_r='undef' d_tzname='define' d_u32align='define' d_ualarm='undef' d_umask='define' d_uname='define' d_union_semun='define' d_unordered='undef' d_unsetenv='undef' d_usleep='undef' d_usleepproto='undef' d_ustat='undef' d_vendorarch='undef' d_vendorbin='undef' d_vendorlib='undef' d_vendorscript='undef' d_vfork='undef' d_void_closedir='undef' d_voidsig='define' d_voidtty='' d_volatile='define' d_vprintf='define' d_vsnprintf='define' d_wait4='undef' d_waitpid='define' d_wcstombs='define' d_wctomb='define' d_writev='undef' d_xenix='undef' date='date' db_hashtype='int' db_prefixtype='int' db_version_major='0' db_version_minor='0' db_version_patch='0' defvoidused='15' direntrytype='struct direct' dlext='dll' dlltool='dlltool' dlsrc='dl_win32.xs' doublesize='8' drand01='(rand()/(double)((unsigned)1< */ #include "EXTERN.h" #include "perl.h" #ifdef __GNUC__ /* Mingw32 defaults to globing command line * This is inconsistent with other Win32 ports and * seems to cause trouble with passing -DXSVERSION=\"1.6\" * So we turn it off like this: */ int _CRT_glob = 0; #endif /* Called from w32console/wmain.c */ extern int w32console_usefunctionkeys; int main(int argc, char **argv, char **env) { int res; if(argc == 1) XCEShowMessageA("Starting perl with no args is currently\r\n" "not useful on Windows CE"); w32console_usefunctionkeys = 0; /* this allows backspace key to work */ res = RunPerl(argc, argv, env); if(res != 0) XCEShowMessageA("Exitcode: %d", res); return res; } perl-5.12.0-RC0/win32/pod.mak0000444000175000017500000002620411342547046014355 0ustar jessejesseCONVERTERS = pod2html pod2latex pod2man pod2text \ pod2usage podchecker podselect HTMLROOT = / # Change this to fix cross-references in HTML POD2HTML = pod2html \ --htmlroot=$(HTMLROOT) \ --podroot=.. --podpath=pod:lib:ext:vms \ --libpods=perlfunc:perlguts:perlvar:perlrun:perlop all: $(CONVERTERS) html converters: $(CONVERTERS) PERL = ..\miniperl.exe REALPERL = ..\perl.exe ICWD = -I..\cpan\Cwd POD = \ perl.pod \ perl5004delta.pod \ perl5005delta.pod \ perl5100delta.pod \ perl5101delta.pod \ perl5110delta.pod \ perl5111delta.pod \ perl5112delta.pod \ perl5113delta.pod \ perl5114delta.pod \ perl5115delta.pod \ perl5116delta.pod \ perl5120delta.pod \ perl561delta.pod \ perl56delta.pod \ perl570delta.pod \ perl571delta.pod \ perl572delta.pod \ perl573delta.pod \ perl581delta.pod \ perl582delta.pod \ perl583delta.pod \ perl584delta.pod \ perl585delta.pod \ perl586delta.pod \ perl587delta.pod \ perl588delta.pod \ perl589delta.pod \ perl58delta.pod \ perl590delta.pod \ perl591delta.pod \ perl592delta.pod \ perl593delta.pod \ perl594delta.pod \ perl595delta.pod \ perlapi.pod \ perlapio.pod \ perlartistic.pod \ perlbook.pod \ perlboot.pod \ perlbot.pod \ perlcall.pod \ perlcheat.pod \ perlclib.pod \ perlcommunity.pod \ perlcompile.pod \ perldata.pod \ perldbmfilter.pod \ perldebguts.pod \ perldebtut.pod \ perldebug.pod \ perldelta.pod \ perldiag.pod \ perldoc.pod \ perldsc.pod \ perlebcdic.pod \ perlembed.pod \ perlfaq.pod \ perlfaq1.pod \ perlfaq2.pod \ perlfaq3.pod \ perlfaq4.pod \ perlfaq5.pod \ perlfaq6.pod \ perlfaq7.pod \ perlfaq8.pod \ perlfaq9.pod \ perlfilter.pod \ perlfork.pod \ perlform.pod \ perlfunc.pod \ perlglossary.pod \ perlgpl.pod \ perlguts.pod \ perlhack.pod \ perlhist.pod \ perlintern.pod \ perlintro.pod \ perliol.pod \ perlipc.pod \ perllexwarn.pod \ perllocale.pod \ perllol.pod \ perlmod.pod \ perlmodinstall.pod \ perlmodlib.pod \ perlmodstyle.pod \ perlmroapi.pod \ perlnewmod.pod \ perlnumber.pod \ perlobj.pod \ perlop.pod \ perlopentut.pod \ perlpacktut.pod \ perlperf.pod \ perlpod.pod \ perlpodspec.pod \ perlpolicy.pod \ perlport.pod \ perlpragma.pod \ perlre.pod \ perlreapi.pod \ perlrebackslash.pod \ perlrecharclass.pod \ perlref.pod \ perlreftut.pod \ perlreguts.pod \ perlrepository.pod \ perlrequick.pod \ perlreref.pod \ perlretut.pod \ perlrun.pod \ perlsec.pod \ perlstyle.pod \ perlsub.pod \ perlsyn.pod \ perlthrtut.pod \ perltie.pod \ perltoc.pod \ perltodo.pod \ perltooc.pod \ perltoot.pod \ perltrap.pod \ perlunicode.pod \ perlunifaq.pod \ perluniintro.pod \ perluniprops.pod \ perlunitut.pod \ perlutil.pod \ perlvar.pod \ perlvms.pod \ perlxs.pod \ perlxstut.pod MAN = \ perl.man \ perl5004delta.man \ perl5005delta.man \ perl5100delta.man \ perl5101delta.man \ perl5110delta.man \ perl5111delta.man \ perl5112delta.man \ perl5113delta.man \ perl5114delta.man \ perl5115delta.man \ perl5116delta.man \ perl5120delta.man \ perl561delta.man \ perl56delta.man \ perl570delta.man \ perl571delta.man \ perl572delta.man \ perl573delta.man \ perl581delta.man \ perl582delta.man \ perl583delta.man \ perl584delta.man \ perl585delta.man \ perl586delta.man \ perl587delta.man \ perl588delta.man \ perl589delta.man \ perl58delta.man \ perl590delta.man \ perl591delta.man \ perl592delta.man \ perl593delta.man \ perl594delta.man \ perl595delta.man \ perlapi.man \ perlapio.man \ perlartistic.man \ perlbook.man \ perlboot.man \ perlbot.man \ perlcall.man \ perlcheat.man \ perlclib.man \ perlcommunity.man \ perlcompile.man \ perldata.man \ perldbmfilter.man \ perldebguts.man \ perldebtut.man \ perldebug.man \ perldelta.man \ perldiag.man \ perldoc.man \ perldsc.man \ perlebcdic.man \ perlembed.man \ perlfaq.man \ perlfaq1.man \ perlfaq2.man \ perlfaq3.man \ perlfaq4.man \ perlfaq5.man \ perlfaq6.man \ perlfaq7.man \ perlfaq8.man \ perlfaq9.man \ perlfilter.man \ perlfork.man \ perlform.man \ perlfunc.man \ perlglossary.man \ perlgpl.man \ perlguts.man \ perlhack.man \ perlhist.man \ perlintern.man \ perlintro.man \ perliol.man \ perlipc.man \ perllexwarn.man \ perllocale.man \ perllol.man \ perlmod.man \ perlmodinstall.man \ perlmodlib.man \ perlmodstyle.man \ perlmroapi.man \ perlnewmod.man \ perlnumber.man \ perlobj.man \ perlop.man \ perlopentut.man \ perlpacktut.man \ perlperf.man \ perlpod.man \ perlpodspec.man \ perlpolicy.man \ perlport.man \ perlpragma.man \ perlre.man \ perlreapi.man \ perlrebackslash.man \ perlrecharclass.man \ perlref.man \ perlreftut.man \ perlreguts.man \ perlrepository.man \ perlrequick.man \ perlreref.man \ perlretut.man \ perlrun.man \ perlsec.man \ perlstyle.man \ perlsub.man \ perlsyn.man \ perlthrtut.man \ perltie.man \ perltoc.man \ perltodo.man \ perltooc.man \ perltoot.man \ perltrap.man \ perlunicode.man \ perlunifaq.man \ perluniintro.man \ perluniprops.man \ perlunitut.man \ perlutil.man \ perlvar.man \ perlvms.man \ perlxs.man \ perlxstut.man HTML = \ perl.html \ perl5004delta.html \ perl5005delta.html \ perl5100delta.html \ perl5101delta.html \ perl5110delta.html \ perl5111delta.html \ perl5112delta.html \ perl5113delta.html \ perl5114delta.html \ perl5115delta.html \ perl5116delta.html \ perl5120delta.html \ perl561delta.html \ perl56delta.html \ perl570delta.html \ perl571delta.html \ perl572delta.html \ perl573delta.html \ perl581delta.html \ perl582delta.html \ perl583delta.html \ perl584delta.html \ perl585delta.html \ perl586delta.html \ perl587delta.html \ perl588delta.html \ perl589delta.html \ perl58delta.html \ perl590delta.html \ perl591delta.html \ perl592delta.html \ perl593delta.html \ perl594delta.html \ perl595delta.html \ perlapi.html \ perlapio.html \ perlartistic.html \ perlbook.html \ perlboot.html \ perlbot.html \ perlcall.html \ perlcheat.html \ perlclib.html \ perlcommunity.html \ perlcompile.html \ perldata.html \ perldbmfilter.html \ perldebguts.html \ perldebtut.html \ perldebug.html \ perldelta.html \ perldiag.html \ perldoc.html \ perldsc.html \ perlebcdic.html \ perlembed.html \ perlfaq.html \ perlfaq1.html \ perlfaq2.html \ perlfaq3.html \ perlfaq4.html \ perlfaq5.html \ perlfaq6.html \ perlfaq7.html \ perlfaq8.html \ perlfaq9.html \ perlfilter.html \ perlfork.html \ perlform.html \ perlfunc.html \ perlglossary.html \ perlgpl.html \ perlguts.html \ perlhack.html \ perlhist.html \ perlintern.html \ perlintro.html \ perliol.html \ perlipc.html \ perllexwarn.html \ perllocale.html \ perllol.html \ perlmod.html \ perlmodinstall.html \ perlmodlib.html \ perlmodstyle.html \ perlmroapi.html \ perlnewmod.html \ perlnumber.html \ perlobj.html \ perlop.html \ perlopentut.html \ perlpacktut.html \ perlperf.html \ perlpod.html \ perlpodspec.html \ perlpolicy.html \ perlport.html \ perlpragma.html \ perlre.html \ perlreapi.html \ perlrebackslash.html \ perlrecharclass.html \ perlref.html \ perlreftut.html \ perlreguts.html \ perlrepository.html \ perlrequick.html \ perlreref.html \ perlretut.html \ perlrun.html \ perlsec.html \ perlstyle.html \ perlsub.html \ perlsyn.html \ perlthrtut.html \ perltie.html \ perltodo.html \ perltooc.html \ perltoot.html \ perltrap.html \ perlunicode.html \ perlunifaq.html \ perluniintro.html \ perluniprops.html \ perlunitut.html \ perlutil.html \ perlvar.html \ perlvms.html \ perlxs.html \ perlxstut.html # not perltoc.html TEX = \ perl.tex \ perl5004delta.tex \ perl5005delta.tex \ perl5100delta.tex \ perl5101delta.tex \ perl5110delta.tex \ perl5111delta.tex \ perl5112delta.tex \ perl5113delta.tex \ perl5114delta.tex \ perl5115delta.tex \ perl5116delta.tex \ perl5120delta.tex \ perl561delta.tex \ perl56delta.tex \ perl570delta.tex \ perl571delta.tex \ perl572delta.tex \ perl573delta.tex \ perl581delta.tex \ perl582delta.tex \ perl583delta.tex \ perl584delta.tex \ perl585delta.tex \ perl586delta.tex \ perl587delta.tex \ perl588delta.tex \ perl589delta.tex \ perl58delta.tex \ perl590delta.tex \ perl591delta.tex \ perl592delta.tex \ perl593delta.tex \ perl594delta.tex \ perl595delta.tex \ perlapi.tex \ perlapio.tex \ perlartistic.tex \ perlbook.tex \ perlboot.tex \ perlbot.tex \ perlcall.tex \ perlcheat.tex \ perlclib.tex \ perlcommunity.tex \ perlcompile.tex \ perldata.tex \ perldbmfilter.tex \ perldebguts.tex \ perldebtut.tex \ perldebug.tex \ perldelta.tex \ perldiag.tex \ perldoc.tex \ perldsc.tex \ perlebcdic.tex \ perlembed.tex \ perlfaq.tex \ perlfaq1.tex \ perlfaq2.tex \ perlfaq3.tex \ perlfaq4.tex \ perlfaq5.tex \ perlfaq6.tex \ perlfaq7.tex \ perlfaq8.tex \ perlfaq9.tex \ perlfilter.tex \ perlfork.tex \ perlform.tex \ perlfunc.tex \ perlglossary.tex \ perlgpl.tex \ perlguts.tex \ perlhack.tex \ perlhist.tex \ perlintern.tex \ perlintro.tex \ perliol.tex \ perlipc.tex \ perllexwarn.tex \ perllocale.tex \ perllol.tex \ perlmod.tex \ perlmodinstall.tex \ perlmodlib.tex \ perlmodstyle.tex \ perlmroapi.tex \ perlnewmod.tex \ perlnumber.tex \ perlobj.tex \ perlop.tex \ perlopentut.tex \ perlpacktut.tex \ perlperf.tex \ perlpod.tex \ perlpodspec.tex \ perlpolicy.tex \ perlport.tex \ perlpragma.tex \ perlre.tex \ perlreapi.tex \ perlrebackslash.tex \ perlrecharclass.tex \ perlref.tex \ perlreftut.tex \ perlreguts.tex \ perlrepository.tex \ perlrequick.tex \ perlreref.tex \ perlretut.tex \ perlrun.tex \ perlsec.tex \ perlstyle.tex \ perlsub.tex \ perlsyn.tex \ perlthrtut.tex \ perltie.tex \ perltoc.tex \ perltodo.tex \ perltooc.tex \ perltoot.tex \ perltrap.tex \ perlunicode.tex \ perlunifaq.tex \ perluniintro.tex \ perluniprops.tex \ perlunitut.tex \ perlutil.tex \ perlvar.tex \ perlvms.tex \ perlxs.tex \ perlxstut.tex man: pod2man $(MAN) html: pod2html $(HTML) tex: pod2latex $(TEX) toc: $(PERL) -I../lib buildtoc >perltoc.pod .SUFFIXES: .pm .pod .SUFFIXES: .man .pm.man: $(PERL) -I../lib pod2man $*.pm >$*.man .pod.man: $(PERL) -I../lib pod2man $*.pod >$*.man .SUFFIXES: .html .pm.html: $(PERL) -I../lib $(POD2HTML) --infile=$*.pm --outfile=$*.html .pod.html: $(PERL) -I../lib $(POD2HTML) --infile=$*.pod --outfile=$*.html .SUFFIXES: .tex .pm.tex: $(PERL) -I../lib pod2latex $*.pm .pod.tex: $(PERL) -I../lib pod2latex $*.pod clean: rm -f $(MAN) rm -f $(HTML) rm -f $(TEX) rm -f pod2html-*cache rm -f *.aux *.log *.exe realclean: clean rm -f $(CONVERTERS) distclean: realclean check: podchecker @echo "checking..."; \ $(PERL) -I../lib podchecker $(POD) # Dependencies. pod2latex: pod2latex.PL ../lib/Config.pm $(PERL) -I../lib $(ICWD) pod2latex.PL pod2html: pod2html.PL ../lib/Config.pm $(PERL) -I ../lib $(ICWD) pod2html.PL pod2man: pod2man.PL ../lib/Config.pm $(PERL) -I ../lib $(ICWD) pod2man.PL pod2text: pod2text.PL ../lib/Config.pm $(PERL) -I ../lib $(ICWD) pod2text.PL pod2usage: pod2usage.PL ../lib/Config.pm $(PERL) -I ../lib $(ICWD) pod2usage.PL podchecker: podchecker.PL ../lib/Config.pm $(PERL) -I ../lib $(ICWD) podchecker.PL podselect: podselect.PL ../lib/Config.pm $(PERL) -I ../lib $(ICWD) podselect.PL perl-5.12.0-RC0/win32/perlexe.ico0000444000175000017500000000545611325127002015232 0ustar jessejesse(6h^ hÆ( Àÿÿÿ{{{{{{{{{½½½{{{ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ÷ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿøÿÿÿÿÿÿÿÿÿÿøÿÿÿøÿÿÿÿÿÿÿÿÿÿÿøÿÿÿÿøÿÿÿÿÿÿÿÿøÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿž\û·t ý›xeý› tý[s ý[n ýusðpràleà wän æewÃg ÿŸe ÿÿonÿÿn ( @ÿÿÿþþþÖÖÖªªªýýýyyyzzzüüüAAAuuu„„„ËËË···ˆˆˆööö ¶¶¶ŠŠŠççç888kkk²²²ÁÁÁ  ppp›››ééèxxx###DDDââ⦦¦eeejjj´´´¯¯¯ÏÏÏlll±±±¿¿¿ñññXXXšššÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ :   '        ÿÿž\û·t ý›xeý› tý[s ý[n ýusðpràleà wän æewÃg ÿŸe ÿÿonÿÿn (  @ÿpN¿¿¿@XXX§e0ÿ÷lll“ÿÿKÿ¯¯¯Pÿÿÿjjj•ÿÿÿYeeešÿÿ‡î###ÜDDD»zzz…ÿ>êèý ôþÿýà õppp›››dÿÿÿÿÿÿÿÿÿÿçMÿñ888Çÿÿÿÿÿÿÿkkk”ÿ ßIŠŠŠuûÿÿÿÿåHÿüŠˆˆˆwýÿÿÿ~ AAA¾ÿÿuuuŠ„„„{ÿÿá4)Uyyy†ÿ…ÿÿž\û·t ý›xeý› tý[s ý[n ýusðpràleà wän æewÃg ÿŸe ÿÿonÿÿn perl-5.12.0-RC0/win32/perlexe.manifest0000444000175000017500000000144711325127002016262 0ustar jessejesse Perl perl-5.12.0-RC0/win32/config_H.gc64nox0000444000175000017500000043513711325127002016023 0ustar jessejesse/* * This file was produced by running the config_h.SH script, which * gets its values from undef, which is generally produced by * running Configure. * * Feel free to modify any of this as the need arises. Note, however, * that running config_h.SH again will wipe out any changes you've made. * For a more permanent change edit undef and rerun config_h.SH. * * $Id: Config_h.U 1 2006-08-24 12:32:52Z rmanfredi $ */ /* * Package name : perl5 * Source directory : * Configuration time: Sun Jan 10 19:53:56 2010 * Configured by : Steve * Target system : */ #ifndef _config_h_ #define _config_h_ /* LOC_SED: * This symbol holds the complete pathname to the sed program. */ #define LOC_SED "" /**/ /* HAS_ALARM: * This symbol, if defined, indicates that the alarm routine is * available. */ #define HAS_ALARM /**/ /* HAS_BCMP: * This symbol is defined if the bcmp() routine is available to * compare blocks of memory. */ /*#define HAS_BCMP / **/ /* HAS_BCOPY: * This symbol is defined if the bcopy() routine is available to * copy blocks of memory. */ /*#define HAS_BCOPY / **/ /* HAS_BZERO: * This symbol is defined if the bzero() routine is available to * set a memory block to 0. */ /*#define HAS_BZERO / **/ /* HAS_CHOWN: * This symbol, if defined, indicates that the chown routine is * available. */ /*#define HAS_CHOWN / **/ /* HAS_CHROOT: * This symbol, if defined, indicates that the chroot routine is * available. */ /*#define HAS_CHROOT / **/ /* HAS_CHSIZE: * This symbol, if defined, indicates that the chsize routine is available * to truncate files. You might need a -lx to get this routine. */ #define HAS_CHSIZE /**/ /* HAS_CRYPT: * This symbol, if defined, indicates that the crypt routine is available * to encrypt passwords and the like. */ /*#define HAS_CRYPT / **/ /* HAS_CTERMID: * This symbol, if defined, indicates that the ctermid routine is * available to generate filename for terminal. */ /*#define HAS_CTERMID / **/ /* HAS_CUSERID: * This symbol, if defined, indicates that the cuserid routine is * available to get character login names. */ /*#define HAS_CUSERID / **/ /* HAS_DBL_DIG: * This symbol, if defined, indicates that this system's * or defines the symbol DBL_DIG, which is the number * of significant digits in a double precision number. If this * symbol is not defined, a guess of 15 is usually pretty good. */ #define HAS_DBL_DIG /**/ /* HAS_DIFFTIME: * This symbol, if defined, indicates that the difftime routine is * available. */ #define HAS_DIFFTIME /**/ /* HAS_DLERROR: * This symbol, if defined, indicates that the dlerror routine is * available to return a string describing the last error that * occurred from a call to dlopen(), dlclose() or dlsym(). */ #define HAS_DLERROR /**/ /* HAS_DUP2: * This symbol, if defined, indicates that the dup2 routine is * available to duplicate file descriptors. */ #define HAS_DUP2 /**/ /* HAS_FCHMOD: * This symbol, if defined, indicates that the fchmod routine is available * to change mode of opened files. If unavailable, use chmod(). */ /*#define HAS_FCHMOD / **/ /* HAS_FCHOWN: * This symbol, if defined, indicates that the fchown routine is available * to change ownership of opened files. If unavailable, use chown(). */ /*#define HAS_FCHOWN / **/ /* HAS_FCNTL: * This symbol, if defined, indicates to the C program that * the fcntl() function exists. */ /*#define HAS_FCNTL / **/ /* HAS_FGETPOS: * This symbol, if defined, indicates that the fgetpos routine is * available to get the file position indicator, similar to ftell(). */ #define HAS_FGETPOS /**/ /* HAS_FLOCK: * This symbol, if defined, indicates that the flock routine is * available to do file locking. */ #define HAS_FLOCK /**/ /* HAS_FORK: * This symbol, if defined, indicates that the fork routine is * available. */ /*#define HAS_FORK / **/ /* HAS_FSETPOS: * This symbol, if defined, indicates that the fsetpos routine is * available to set the file position indicator, similar to fseek(). */ #define HAS_FSETPOS /**/ /* HAS_GETTIMEOFDAY: * This symbol, if defined, indicates that the gettimeofday() system * call is available for a sub-second accuracy clock. Usually, the file * needs to be included (see I_SYS_RESOURCE). * The type "Timeval" should be used to refer to "struct timeval". */ #define HAS_GETTIMEOFDAY /**/ #ifdef HAS_GETTIMEOFDAY #define Timeval struct timeval /* Structure used by gettimeofday() */ #endif /* HAS_GETGROUPS: * This symbol, if defined, indicates that the getgroups() routine is * available to get the list of process groups. If unavailable, multiple * groups are probably not supported. */ /*#define HAS_GETGROUPS / **/ /* HAS_GETLOGIN: * This symbol, if defined, indicates that the getlogin routine is * available to get the login name. */ #define HAS_GETLOGIN /**/ /* HAS_GETPGID: * This symbol, if defined, indicates to the C program that * the getpgid(pid) function is available to get the * process group id. */ /*#define HAS_GETPGID / **/ /* HAS_GETPGRP2: * This symbol, if defined, indicates that the getpgrp2() (as in DG/UX) * routine is available to get the current process group. */ /*#define HAS_GETPGRP2 / **/ /* HAS_GETPPID: * This symbol, if defined, indicates that the getppid routine is * available to get the parent process ID. */ /*#define HAS_GETPPID / **/ /* HAS_GETPRIORITY: * This symbol, if defined, indicates that the getpriority routine is * available to get a process's priority. */ /*#define HAS_GETPRIORITY / **/ /* HAS_INET_ATON: * This symbol, if defined, indicates to the C program that the * inet_aton() function is available to parse IP address "dotted-quad" * strings. */ /*#define HAS_INET_ATON / **/ /* HAS_KILLPG: * This symbol, if defined, indicates that the killpg routine is available * to kill process groups. If unavailable, you probably should use kill * with a negative process number. */ #define HAS_KILLPG /**/ /* HAS_LINK: * This symbol, if defined, indicates that the link routine is * available to create hard links. */ #define HAS_LINK /**/ /* HAS_LOCALECONV: * This symbol, if defined, indicates that the localeconv routine is * available for numeric and monetary formatting conventions. */ #define HAS_LOCALECONV /**/ /* HAS_LOCKF: * This symbol, if defined, indicates that the lockf routine is * available to do file locking. */ /*#define HAS_LOCKF / **/ /* HAS_LSTAT: * This symbol, if defined, indicates that the lstat routine is * available to do file stats on symbolic links. */ /*#define HAS_LSTAT / **/ /* HAS_MBLEN: * This symbol, if defined, indicates that the mblen routine is available * to find the number of bytes in a multibye character. */ #define HAS_MBLEN /**/ /* HAS_MBSTOWCS: * This symbol, if defined, indicates that the mbstowcs routine is * available to covert a multibyte string into a wide character string. */ #define HAS_MBSTOWCS /**/ /* HAS_MBTOWC: * This symbol, if defined, indicates that the mbtowc routine is available * to covert a multibyte to a wide character. */ #define HAS_MBTOWC /**/ /* HAS_MEMCMP: * This symbol, if defined, indicates that the memcmp routine is available * to compare blocks of memory. */ #define HAS_MEMCMP /**/ /* HAS_MEMCPY: * This symbol, if defined, indicates that the memcpy routine is available * to copy blocks of memory. */ #define HAS_MEMCPY /**/ /* HAS_MEMMOVE: * This symbol, if defined, indicates that the memmove routine is available * to copy potentially overlapping blocks of memory. This should be used * only when HAS_SAFE_BCOPY is not defined. If neither is there, roll your * own version. */ #define HAS_MEMMOVE /**/ /* HAS_MEMSET: * This symbol, if defined, indicates that the memset routine is available * to set blocks of memory. */ #define HAS_MEMSET /**/ /* HAS_MKDIR: * This symbol, if defined, indicates that the mkdir routine is available * to create directories. Otherwise you should fork off a new process to * exec /bin/mkdir. */ #define HAS_MKDIR /**/ /* HAS_MKFIFO: * This symbol, if defined, indicates that the mkfifo routine is * available to create FIFOs. Otherwise, mknod should be able to * do it for you. However, if mkfifo is there, mknod might require * super-user privileges which mkfifo will not. */ /*#define HAS_MKFIFO / **/ /* HAS_MKTIME: * This symbol, if defined, indicates that the mktime routine is * available. */ #define HAS_MKTIME /**/ /* HAS_MSYNC: * This symbol, if defined, indicates that the msync system call is * available to synchronize a mapped file. */ /*#define HAS_MSYNC / **/ /* HAS_MUNMAP: * This symbol, if defined, indicates that the munmap system call is * available to unmap a region, usually mapped by mmap(). */ /*#define HAS_MUNMAP / **/ /* HAS_NICE: * This symbol, if defined, indicates that the nice routine is * available. */ /*#define HAS_NICE / **/ /* HAS_PATHCONF: * This symbol, if defined, indicates that pathconf() is available * to determine file-system related limits and options associated * with a given filename. */ /* HAS_FPATHCONF: * This symbol, if defined, indicates that pathconf() is available * to determine file-system related limits and options associated * with a given open file descriptor. */ /*#define HAS_PATHCONF / **/ /*#define HAS_FPATHCONF / **/ /* HAS_PAUSE: * This symbol, if defined, indicates that the pause routine is * available to suspend a process until a signal is received. */ #define HAS_PAUSE /**/ /* HAS_PIPE: * This symbol, if defined, indicates that the pipe routine is * available to create an inter-process channel. */ #define HAS_PIPE /**/ /* HAS_POLL: * This symbol, if defined, indicates that the poll routine is * available to poll active file descriptors. Please check I_POLL and * I_SYS_POLL to know which header should be included as well. */ /*#define HAS_POLL / **/ /* HAS_READDIR: * This symbol, if defined, indicates that the readdir routine is * available to read directory entries. You may have to include * . See I_DIRENT. */ #define HAS_READDIR /**/ /* HAS_SEEKDIR: * This symbol, if defined, indicates that the seekdir routine is * available. You may have to include . See I_DIRENT. */ #define HAS_SEEKDIR /**/ /* HAS_TELLDIR: * This symbol, if defined, indicates that the telldir routine is * available. You may have to include . See I_DIRENT. */ #define HAS_TELLDIR /**/ /* HAS_REWINDDIR: * This symbol, if defined, indicates that the rewinddir routine is * available. You may have to include . See I_DIRENT. */ #define HAS_REWINDDIR /**/ /* HAS_READLINK: * This symbol, if defined, indicates that the readlink routine is * available to read the value of a symbolic link. */ /*#define HAS_READLINK / **/ /* HAS_RENAME: * This symbol, if defined, indicates that the rename routine is available * to rename files. Otherwise you should do the unlink(), link(), unlink() * trick. */ #define HAS_RENAME /**/ /* HAS_RMDIR: * This symbol, if defined, indicates that the rmdir routine is * available to remove directories. Otherwise you should fork off a * new process to exec /bin/rmdir. */ #define HAS_RMDIR /**/ /* HAS_SELECT: * This symbol, if defined, indicates that the select routine is * available to select active file descriptors. If the timeout field * is used, may need to be included. */ #define HAS_SELECT /**/ /* HAS_SETEGID: * This symbol, if defined, indicates that the setegid routine is available * to change the effective gid of the current program. */ /*#define HAS_SETEGID / **/ /* HAS_SETEUID: * This symbol, if defined, indicates that the seteuid routine is available * to change the effective uid of the current program. */ /*#define HAS_SETEUID / **/ /* HAS_SETGROUPS: * This symbol, if defined, indicates that the setgroups() routine is * available to set the list of process groups. If unavailable, multiple * groups are probably not supported. */ /*#define HAS_SETGROUPS / **/ /* HAS_SETLINEBUF: * This symbol, if defined, indicates that the setlinebuf routine is * available to change stderr or stdout from block-buffered or unbuffered * to a line-buffered mode. */ /*#define HAS_SETLINEBUF / **/ /* HAS_SETLOCALE: * This symbol, if defined, indicates that the setlocale routine is * available to handle locale-specific ctype implementations. */ #define HAS_SETLOCALE /**/ /* HAS_SETPGID: * This symbol, if defined, indicates that the setpgid(pid, gpid) * routine is available to set process group ID. */ /*#define HAS_SETPGID / **/ /* HAS_SETPGRP2: * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX) * routine is available to set the current process group. */ /*#define HAS_SETPGRP2 / **/ /* HAS_SETPRIORITY: * This symbol, if defined, indicates that the setpriority routine is * available to set a process's priority. */ /*#define HAS_SETPRIORITY / **/ /* HAS_SETREGID: * This symbol, if defined, indicates that the setregid routine is * available to change the real and effective gid of the current * process. */ /* HAS_SETRESGID: * This symbol, if defined, indicates that the setresgid routine is * available to change the real, effective and saved gid of the current * process. */ /*#define HAS_SETREGID / **/ /*#define HAS_SETRESGID / **/ /* HAS_SETREUID: * This symbol, if defined, indicates that the setreuid routine is * available to change the real and effective uid of the current * process. */ /* HAS_SETRESUID: * This symbol, if defined, indicates that the setresuid routine is * available to change the real, effective and saved uid of the current * process. */ /*#define HAS_SETREUID / **/ /*#define HAS_SETRESUID / **/ /* HAS_SETRGID: * This symbol, if defined, indicates that the setrgid routine is available * to change the real gid of the current program. */ /*#define HAS_SETRGID / **/ /* HAS_SETRUID: * This symbol, if defined, indicates that the setruid routine is available * to change the real uid of the current program. */ /*#define HAS_SETRUID / **/ /* HAS_SETSID: * This symbol, if defined, indicates that the setsid routine is * available to set the process group ID. */ /*#define HAS_SETSID / **/ /* HAS_STRCHR: * This symbol is defined to indicate that the strchr()/strrchr() * functions are available for string searching. If not, try the * index()/rindex() pair. */ /* HAS_INDEX: * This symbol is defined to indicate that the index()/rindex() * functions are available for string searching. */ #define HAS_STRCHR /**/ /*#define HAS_INDEX / **/ /* HAS_STRCOLL: * This symbol, if defined, indicates that the strcoll routine is * available to compare strings using collating information. */ #define HAS_STRCOLL /**/ /* HAS_STRTOD: * This symbol, if defined, indicates that the strtod routine is * available to provide better numeric string conversion than atof(). */ #define HAS_STRTOD /**/ /* HAS_STRTOL: * This symbol, if defined, indicates that the strtol routine is available * to provide better numeric string conversion than atoi() and friends. */ #define HAS_STRTOL /**/ /* HAS_STRXFRM: * This symbol, if defined, indicates that the strxfrm() routine is * available to transform strings. */ #define HAS_STRXFRM /**/ /* HAS_SYMLINK: * This symbol, if defined, indicates that the symlink routine is available * to create symbolic links. */ /*#define HAS_SYMLINK / **/ /* HAS_SYSCALL: * This symbol, if defined, indicates that the syscall routine is * available to call arbitrary system calls. If undefined, that's tough. */ /*#define HAS_SYSCALL / **/ /* HAS_SYSCONF: * This symbol, if defined, indicates that sysconf() is available * to determine system related limits and options. */ /*#define HAS_SYSCONF / **/ /* HAS_SYSTEM: * This symbol, if defined, indicates that the system routine is * available to issue a shell command. */ #define HAS_SYSTEM /**/ /* HAS_TCGETPGRP: * This symbol, if defined, indicates that the tcgetpgrp routine is * available to get foreground process group ID. */ /*#define HAS_TCGETPGRP / **/ /* HAS_TCSETPGRP: * This symbol, if defined, indicates that the tcsetpgrp routine is * available to set foreground process group ID. */ /*#define HAS_TCSETPGRP / **/ /* HAS_TRUNCATE: * This symbol, if defined, indicates that the truncate routine is * available to truncate files. */ /*#define HAS_TRUNCATE / **/ /* HAS_TZNAME: * This symbol, if defined, indicates that the tzname[] array is * available to access timezone names. */ #define HAS_TZNAME /**/ /* HAS_UMASK: * This symbol, if defined, indicates that the umask routine is * available to set and get the value of the file creation mask. */ #define HAS_UMASK /**/ /* HAS_USLEEP: * This symbol, if defined, indicates that the usleep routine is * available to let the process sleep on a sub-second accuracy. */ /*#define HAS_USLEEP / **/ /* HAS_WAIT4: * This symbol, if defined, indicates that wait4() exists. */ /*#define HAS_WAIT4 / **/ /* HAS_WAITPID: * This symbol, if defined, indicates that the waitpid routine is * available to wait for child process. */ #define HAS_WAITPID /**/ /* HAS_WCSTOMBS: * This symbol, if defined, indicates that the wcstombs routine is * available to convert wide character strings to multibyte strings. */ #define HAS_WCSTOMBS /**/ /* HAS_WCTOMB: * This symbol, if defined, indicates that the wctomb routine is available * to covert a wide character to a multibyte. */ #define HAS_WCTOMB /**/ /* Groups_t: * This symbol holds the type used for the second argument to * getgroups() and setgroups(). Usually, this is the same as * gidtype (gid_t) , but sometimes it isn't. * It can be int, ushort, gid_t, etc... * It may be necessary to include to get any * typedef'ed information. This is only required if you have * getgroups() or setgroups().. */ #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS) #define Groups_t gid_t /* Type for 2nd arg to [sg]etgroups() */ #endif /* I_ARPA_INET: * This symbol, if defined, indicates to the C program that it should * include to get inet_addr and friends declarations. */ #define I_ARPA_INET /**/ /* I_DBM: * This symbol, if defined, indicates that exists and should * be included. */ /* I_RPCSVC_DBM: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_DBM / **/ #define I_RPCSVC_DBM /**/ /* I_DLFCN: * This symbol, if defined, indicates that exists and should * be included. */ #define I_DLFCN /**/ /* I_FCNTL: * This manifest constant tells the C program to include . */ #define I_FCNTL /**/ /* I_FLOAT: * This symbol, if defined, indicates to the C program that it should * include to get definition of symbols like DBL_MAX or * DBL_MIN, i.e. machine dependent floating point values. */ #define I_FLOAT /**/ /* I_GDBM: * This symbol, if defined, indicates that exists and should * be included. */ /*#define I_GDBM / **/ /* I_LIMITS: * This symbol, if defined, indicates to the C program that it should * include to get definition of symbols like WORD_BIT or * LONG_MAX, i.e. machine dependant limitations. */ #define I_LIMITS /**/ /* I_LOCALE: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_LOCALE /**/ /* I_MATH: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_MATH /**/ /* I_MEMORY: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_MEMORY / **/ /* I_NETINET_IN: * This symbol, if defined, indicates to the C program that it should * include . Otherwise, you may try . */ /*#define I_NETINET_IN / **/ /* I_SFIO: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SFIO / **/ /* I_STDDEF: * This symbol, if defined, indicates that exists and should * be included. */ #define I_STDDEF /**/ /* I_STDLIB: * This symbol, if defined, indicates that exists and should * be included. */ #define I_STDLIB /**/ /* I_STRING: * This symbol, if defined, indicates to the C program that it should * include (USG systems) instead of (BSD systems). */ #define I_STRING /**/ /* I_SYS_DIR: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_DIR / **/ /* I_SYS_FILE: * This symbol, if defined, indicates to the C program that it should * include to get definition of R_OK and friends. */ /*#define I_SYS_FILE / **/ /* I_SYS_IOCTL: * This symbol, if defined, indicates that exists and should * be included. Otherwise, include or . */ /* I_SYS_SOCKIO: * This symbol, if defined, indicates the should be included * to get socket ioctl options, like SIOCATMARK. */ /*#define I_SYS_IOCTL / **/ /*#define I_SYS_SOCKIO / **/ /* I_SYS_NDIR: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_NDIR / **/ /* I_SYS_PARAM: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_PARAM / **/ /* I_SYS_POLL: * This symbol, if defined, indicates that the program may include * . When I_POLL is also defined, it's probably safest * to only include . */ /*#define I_SYS_POLL / **/ /* I_SYS_RESOURCE: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_RESOURCE / **/ /* I_SYS_SELECT: * This symbol, if defined, indicates to the C program that it should * include in order to get definition of struct timeval. */ /*#define I_SYS_SELECT / **/ /* I_SYS_STAT: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_STAT /**/ /* I_SYS_TIMES: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_TIMES / **/ /* I_SYS_TYPES: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_TYPES /**/ /* I_SYS_UN: * This symbol, if defined, indicates to the C program that it should * include to get UNIX domain socket definitions. */ /*#define I_SYS_UN / **/ /* I_SYS_WAIT: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_WAIT / **/ /* I_TERMIO: * This symbol, if defined, indicates that the program should include * rather than . There are also differences in * the ioctl() calls that depend on the value of this symbol. */ /* I_TERMIOS: * This symbol, if defined, indicates that the program should include * the POSIX termios.h rather than sgtty.h or termio.h. * There are also differences in the ioctl() calls that depend on the * value of this symbol. */ /* I_SGTTY: * This symbol, if defined, indicates that the program should include * rather than . There are also differences in * the ioctl() calls that depend on the value of this symbol. */ /*#define I_TERMIO / **/ /*#define I_TERMIOS / **/ /*#define I_SGTTY / **/ /* I_UNISTD: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_UNISTD / **/ /* I_UTIME: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_UTIME /**/ /* I_VALUES: * This symbol, if defined, indicates to the C program that it should * include to get definition of symbols like MINFLOAT or * MAXLONG, i.e. machine dependant limitations. Probably, you * should use instead, if it is available. */ /*#define I_VALUES / **/ /* I_VFORK: * This symbol, if defined, indicates to the C program that it should * include vfork.h. */ /*#define I_VFORK / **/ /* CAN_VAPROTO: * This variable is defined on systems supporting prototype declaration * of functions with a variable number of arguments. */ /* _V: * This macro is used to declare function parameters in prototypes for * functions with a variable number of parameters. Use double parentheses. * For example: * * int printf _V((char *fmt, ...)); * * Remember to use the plain simple _() macro when declaring a function * with no variable number of arguments, since it might be possible to * have a non-effect _V() macro and still get prototypes via _(). */ /*#define CAN_VAPROTO / **/ #ifdef CAN_VAPROTO #define _V(args) args #else #define _V(args) () #endif /* INTSIZE: * This symbol contains the value of sizeof(int) so that the C * preprocessor can make decisions based on it. */ /* LONGSIZE: * This symbol contains the value of sizeof(long) so that the C * preprocessor can make decisions based on it. */ /* SHORTSIZE: * This symbol contains the value of sizeof(short) so that the C * preprocessor can make decisions based on it. */ #define INTSIZE 4 /**/ #define LONGSIZE 4 /**/ #define SHORTSIZE 2 /**/ /* MULTIARCH: * This symbol, if defined, signifies that the build * process will produce some binary files that are going to be * used in a cross-platform environment. This is the case for * example with the NeXT "fat" binaries that contain executables * for several CPUs. */ /*#define MULTIARCH / **/ /* HAS_QUAD: * This symbol, if defined, tells that there's a 64-bit integer type, * Quad_t, and its unsigned counterpar, Uquad_t. QUADKIND will be one * of QUAD_IS_INT, QUAD_IS_LONG, QUAD_IS_LONG_LONG, QUAD_IS_INT64_T, * or QUAD_IS___INT64. */ #define HAS_QUAD /**/ #ifdef HAS_QUAD # ifdef _MSC_VER # define Quad_t __int64 /**/ # define Uquad_t unsigned __int64 /**/ # define QUADKIND 5 /**/ # else /* gcc presumably */ # define Quad_t long long /**/ # define Uquad_t unsigned long long /**/ # define QUADKIND 3 /**/ # endif # define QUAD_IS_INT 1 # define QUAD_IS_LONG 2 # define QUAD_IS_LONG_LONG 3 # define QUAD_IS_INT64_T 4 # define QUAD_IS___INT64 5 #endif /* OSNAME: * This symbol contains the name of the operating system, as determined * by Configure. You shouldn't rely on it too much; the specific * feature tests from Configure are generally more reliable. */ /* OSVERS: * This symbol contains the version of the operating system, as determined * by Configure. You shouldn't rely on it too much; the specific * feature tests from Configure are generally more reliable. */ #define OSNAME "MSWin32" /**/ #define OSVERS "5.1" /**/ /* ARCHLIB: * This variable, if defined, holds the name of the directory in * which the user wants to put architecture-dependent public * library files for perl5. It is most often a local directory * such as /usr/local/lib. Programs using this variable must be * prepared to deal with filename expansion. If ARCHLIB is the * same as PRIVLIB, it is not defined, since presumably the * program already searches PRIVLIB. */ /* ARCHLIB_EXP: * This symbol contains the ~name expanded version of ARCHLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ #define ARCHLIB "c:\\perl\\lib" /**/ /*#define ARCHLIB_EXP "" / **/ /* ARCHNAME: * This symbol holds a string representing the architecture name. * It may be used to construct an architecture-dependant pathname * where library files may be held under a private library, for * instance. */ #define ARCHNAME "MSWin32-x64" /**/ /* BIN: * This symbol holds the path of the bin directory where the package will * be installed. Program must be prepared to deal with ~name substitution. */ /* BIN_EXP: * This symbol is the filename expanded version of the BIN symbol, for * programs that do not want to deal with that at run-time. */ /* PERL_RELOCATABLE_INC: * This symbol, if defined, indicates that we'd like to relocate entries * in @INC at run time based on the location of the perl binary. */ #define BIN "c:\\perl\\bin" /**/ #define BIN_EXP "c:\\perl\\bin" /**/ #define PERL_RELOCATABLE_INC "undef" /**/ /* CAT2: * This macro concatenates 2 tokens together. */ /* STRINGIFY: * This macro surrounds its token with double quotes. */ #if 42 == 1 #define CAT2(a,b) a/**/b #undef STRINGIFY #define STRINGIFY(a) "a" #endif #if 42 == 42 #define PeRl_CaTiFy(a, b) a ## b #define PeRl_StGiFy(a) #a #define CAT2(a,b) PeRl_CaTiFy(a,b) #define StGiFy(a) PeRl_StGiFy(a) #undef STRINGIFY #define STRINGIFY(a) PeRl_StGiFy(a) #endif #if 42 != 1 && 42 != 42 #include "Bletch: How does this C preprocessor concatenate tokens?" #endif /* CPPSTDIN: * This symbol contains the first part of the string which will invoke * the C preprocessor on the standard input and produce to standard * output. Typical value of "cc -E" or "/lib/cpp", but it can also * call a wrapper. See CPPRUN. */ /* CPPMINUS: * This symbol contains the second part of the string which will invoke * the C preprocessor on the standard input and produce to standard * output. This symbol will have the value "-" if CPPSTDIN needs a minus * to specify standard input, otherwise the value is "". */ /* CPPRUN: * This symbol contains the string which will invoke a C preprocessor on * the standard input and produce to standard output. It needs to end * with CPPLAST, after all other preprocessor flags have been specified. * The main difference with CPPSTDIN is that this program will never be a * pointer to a shell wrapper, i.e. it will be empty if no preprocessor is * available directly to the user. Note that it may well be different from * the preprocessor used to compile the C program. */ /* CPPLAST: * This symbol is intended to be used along with CPPRUN in the same manner * symbol CPPMINUS is used with CPPSTDIN. It contains either "-" or "". */ #ifdef _MSC_VER # define CPPSTDIN "cppstdin" # define CPPMINUS "" # define CPPRUN "cl -nologo -E" #else # define CPPSTDIN "gcc -E" # define CPPMINUS "-" # define CPPRUN "gcc -E" #endif #define CPPLAST "" /* HAS_ACCESS: * This manifest constant lets the C program know that the access() * system call is available to check for accessibility using real UID/GID. * (always present on UNIX.) */ #define HAS_ACCESS /**/ /* HAS_ACCESSX: * This symbol, if defined, indicates that the accessx routine is * available to do extended access checks. */ /*#define HAS_ACCESSX / **/ /* HAS_ASCTIME_R: * This symbol, if defined, indicates that the asctime_r routine * is available to asctime re-entrantly. */ /* ASCTIME_R_PROTO: * This symbol encodes the prototype of asctime_r. * It is zero if d_asctime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_asctime_r * is defined. */ /*#define HAS_ASCTIME_R / **/ #define ASCTIME_R_PROTO 0 /**/ /* The HASATTRIBUTE_* defines are left undefined here because they vary from * one version of GCC to another. Instead, they are defined on the basis of * the compiler version in . */ /* HASATTRIBUTE_FORMAT: * Can we handle GCC attribute for checking printf-style formats */ /* PRINTF_FORMAT_NULL_OK: * Allows __printf__ format to be null when checking printf-style */ /* HASATTRIBUTE_MALLOC: * Can we handle GCC attribute for malloc-style functions. */ /* HASATTRIBUTE_NONNULL: * Can we handle GCC attribute for nonnull function parms. */ /* HASATTRIBUTE_NORETURN: * Can we handle GCC attribute for functions that do not return */ /* HASATTRIBUTE_PURE: * Can we handle GCC attribute for pure functions */ /* HASATTRIBUTE_UNUSED: * Can we handle GCC attribute for unused variables and arguments */ /* HASATTRIBUTE_DEPRECATED: * Can we handle GCC attribute for marking deprecated APIs */ /* HASATTRIBUTE_WARN_UNUSED_RESULT: * Can we handle GCC attribute for warning on unused results */ /*#define HASATTRIBUTE_DEPRECATED / **/ /*#define HASATTRIBUTE_FORMAT / **/ /*#define PRINTF_FORMAT_NULL_OK / **/ /*#define HASATTRIBUTE_NORETURN / **/ /*#define HASATTRIBUTE_MALLOC / **/ /*#define HASATTRIBUTE_NONNULL / **/ /*#define HASATTRIBUTE_PURE / **/ /*#define HASATTRIBUTE_UNUSED / **/ /*#define HASATTRIBUTE_WARN_UNUSED_RESULT / **/ /* HASCONST: * This symbol, if defined, indicates that this C compiler knows about * the const type. There is no need to actually test for that symbol * within your programs. The mere use of the "const" keyword will * trigger the necessary tests. */ #define HASCONST /**/ #ifndef HASCONST #define const #endif /* HAS_CRYPT_R: * This symbol, if defined, indicates that the crypt_r routine * is available to crypt re-entrantly. */ /* CRYPT_R_PROTO: * This symbol encodes the prototype of crypt_r. * It is zero if d_crypt_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_crypt_r * is defined. */ /*#define HAS_CRYPT_R / **/ #define CRYPT_R_PROTO 0 /**/ /* HAS_CSH: * This symbol, if defined, indicates that the C-shell exists. */ /* CSH: * This symbol, if defined, contains the full pathname of csh. */ /*#define HAS_CSH / **/ #ifdef HAS_CSH #define CSH "" /**/ #endif /* HAS_CTERMID_R: * This symbol, if defined, indicates that the ctermid_r routine * is available to ctermid re-entrantly. */ /* CTERMID_R_PROTO: * This symbol encodes the prototype of ctermid_r. * It is zero if d_ctermid_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ctermid_r * is defined. */ /*#define HAS_CTERMID_R / **/ #define CTERMID_R_PROTO 0 /**/ /* HAS_CTIME_R: * This symbol, if defined, indicates that the ctime_r routine * is available to ctime re-entrantly. */ /* CTIME_R_PROTO: * This symbol encodes the prototype of ctime_r. * It is zero if d_ctime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ctime_r * is defined. */ /*#define HAS_CTIME_R / **/ #define CTIME_R_PROTO 0 /**/ /* HAS_DRAND48_R: * This symbol, if defined, indicates that the drand48_r routine * is available to drand48 re-entrantly. */ /* DRAND48_R_PROTO: * This symbol encodes the prototype of drand48_r. * It is zero if d_drand48_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_drand48_r * is defined. */ /*#define HAS_DRAND48_R / **/ #define DRAND48_R_PROTO 0 /**/ /* HAS_DRAND48_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the drand48() function. Otherwise, it is up * to the program to supply one. A good guess is * extern double drand48(void); */ /*#define HAS_DRAND48_PROTO / **/ /* HAS_EACCESS: * This symbol, if defined, indicates that the eaccess routine is * available to do extended access checks. */ /*#define HAS_EACCESS / **/ /* HAS_ENDGRENT: * This symbol, if defined, indicates that the getgrent routine is * available for finalizing sequential access of the group database. */ /*#define HAS_ENDGRENT / **/ /* HAS_ENDGRENT_R: * This symbol, if defined, indicates that the endgrent_r routine * is available to endgrent re-entrantly. */ /* ENDGRENT_R_PROTO: * This symbol encodes the prototype of endgrent_r. * It is zero if d_endgrent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endgrent_r * is defined. */ /*#define HAS_ENDGRENT_R / **/ #define ENDGRENT_R_PROTO 0 /**/ /* HAS_ENDHOSTENT: * This symbol, if defined, indicates that the endhostent() routine is * available to close whatever was being used for host queries. */ /*#define HAS_ENDHOSTENT / **/ /* HAS_ENDHOSTENT_R: * This symbol, if defined, indicates that the endhostent_r routine * is available to endhostent re-entrantly. */ /* ENDHOSTENT_R_PROTO: * This symbol encodes the prototype of endhostent_r. * It is zero if d_endhostent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endhostent_r * is defined. */ /*#define HAS_ENDHOSTENT_R / **/ #define ENDHOSTENT_R_PROTO 0 /**/ /* HAS_ENDNETENT: * This symbol, if defined, indicates that the endnetent() routine is * available to close whatever was being used for network queries. */ /*#define HAS_ENDNETENT / **/ /* HAS_ENDNETENT_R: * This symbol, if defined, indicates that the endnetent_r routine * is available to endnetent re-entrantly. */ /* ENDNETENT_R_PROTO: * This symbol encodes the prototype of endnetent_r. * It is zero if d_endnetent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endnetent_r * is defined. */ /*#define HAS_ENDNETENT_R / **/ #define ENDNETENT_R_PROTO 0 /**/ /* HAS_ENDPROTOENT: * This symbol, if defined, indicates that the endprotoent() routine is * available to close whatever was being used for protocol queries. */ /*#define HAS_ENDPROTOENT / **/ /* HAS_ENDPROTOENT_R: * This symbol, if defined, indicates that the endprotoent_r routine * is available to endprotoent re-entrantly. */ /* ENDPROTOENT_R_PROTO: * This symbol encodes the prototype of endprotoent_r. * It is zero if d_endprotoent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endprotoent_r * is defined. */ /*#define HAS_ENDPROTOENT_R / **/ #define ENDPROTOENT_R_PROTO 0 /**/ /* HAS_ENDPWENT: * This symbol, if defined, indicates that the getgrent routine is * available for finalizing sequential access of the passwd database. */ /*#define HAS_ENDPWENT / **/ /* HAS_ENDPWENT_R: * This symbol, if defined, indicates that the endpwent_r routine * is available to endpwent re-entrantly. */ /* ENDPWENT_R_PROTO: * This symbol encodes the prototype of endpwent_r. * It is zero if d_endpwent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endpwent_r * is defined. */ /*#define HAS_ENDPWENT_R / **/ #define ENDPWENT_R_PROTO 0 /**/ /* HAS_ENDSERVENT: * This symbol, if defined, indicates that the endservent() routine is * available to close whatever was being used for service queries. */ /*#define HAS_ENDSERVENT / **/ /* HAS_ENDSERVENT_R: * This symbol, if defined, indicates that the endservent_r routine * is available to endservent re-entrantly. */ /* ENDSERVENT_R_PROTO: * This symbol encodes the prototype of endservent_r. * It is zero if d_endservent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endservent_r * is defined. */ /*#define HAS_ENDSERVENT_R / **/ #define ENDSERVENT_R_PROTO 0 /**/ /* FLEXFILENAMES: * This symbol, if defined, indicates that the system supports filenames * longer than 14 characters. */ #define FLEXFILENAMES /**/ /* HAS_GETGRENT: * This symbol, if defined, indicates that the getgrent routine is * available for sequential access of the group database. */ /*#define HAS_GETGRENT / **/ /* HAS_GETGRENT_R: * This symbol, if defined, indicates that the getgrent_r routine * is available to getgrent re-entrantly. */ /* GETGRENT_R_PROTO: * This symbol encodes the prototype of getgrent_r. * It is zero if d_getgrent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrent_r * is defined. */ /*#define HAS_GETGRENT_R / **/ #define GETGRENT_R_PROTO 0 /**/ /* HAS_GETGRGID_R: * This symbol, if defined, indicates that the getgrgid_r routine * is available to getgrgid re-entrantly. */ /* GETGRGID_R_PROTO: * This symbol encodes the prototype of getgrgid_r. * It is zero if d_getgrgid_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrgid_r * is defined. */ /*#define HAS_GETGRGID_R / **/ #define GETGRGID_R_PROTO 0 /**/ /* HAS_GETGRNAM_R: * This symbol, if defined, indicates that the getgrnam_r routine * is available to getgrnam re-entrantly. */ /* GETGRNAM_R_PROTO: * This symbol encodes the prototype of getgrnam_r. * It is zero if d_getgrnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrnam_r * is defined. */ /*#define HAS_GETGRNAM_R / **/ #define GETGRNAM_R_PROTO 0 /**/ /* HAS_GETHOSTBYADDR: * This symbol, if defined, indicates that the gethostbyaddr() routine is * available to look up hosts by their IP addresses. */ #define HAS_GETHOSTBYADDR /**/ /* HAS_GETHOSTBYNAME: * This symbol, if defined, indicates that the gethostbyname() routine is * available to look up host names in some data base or other. */ #define HAS_GETHOSTBYNAME /**/ /* HAS_GETHOSTENT: * This symbol, if defined, indicates that the gethostent() routine is * available to look up host names in some data base or another. */ /*#define HAS_GETHOSTENT / **/ /* HAS_GETHOSTNAME: * This symbol, if defined, indicates that the C program may use the * gethostname() routine to derive the host name. See also HAS_UNAME * and PHOSTNAME. */ /* HAS_UNAME: * This symbol, if defined, indicates that the C program may use the * uname() routine to derive the host name. See also HAS_GETHOSTNAME * and PHOSTNAME. */ /* PHOSTNAME: * This symbol, if defined, indicates the command to feed to the * popen() routine to derive the host name. See also HAS_GETHOSTNAME * and HAS_UNAME. Note that the command uses a fully qualified path, * so that it is safe even if used by a process with super-user * privileges. */ /* HAS_PHOSTNAME: * This symbol, if defined, indicates that the C program may use the * contents of PHOSTNAME as a command to feed to the popen() routine * to derive the host name. */ #define HAS_GETHOSTNAME /**/ #define HAS_UNAME /**/ /*#define HAS_PHOSTNAME / **/ #ifdef HAS_PHOSTNAME #define PHOSTNAME "" /* How to get the host name */ #endif /* HAS_GETHOSTBYADDR_R: * This symbol, if defined, indicates that the gethostbyaddr_r routine * is available to gethostbyaddr re-entrantly. */ /* GETHOSTBYADDR_R_PROTO: * This symbol encodes the prototype of gethostbyaddr_r. * It is zero if d_gethostbyaddr_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostbyaddr_r * is defined. */ /*#define HAS_GETHOSTBYADDR_R / **/ #define GETHOSTBYADDR_R_PROTO 0 /**/ /* HAS_GETHOSTBYNAME_R: * This symbol, if defined, indicates that the gethostbyname_r routine * is available to gethostbyname re-entrantly. */ /* GETHOSTBYNAME_R_PROTO: * This symbol encodes the prototype of gethostbyname_r. * It is zero if d_gethostbyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostbyname_r * is defined. */ /*#define HAS_GETHOSTBYNAME_R / **/ #define GETHOSTBYNAME_R_PROTO 0 /**/ /* HAS_GETHOSTENT_R: * This symbol, if defined, indicates that the gethostent_r routine * is available to gethostent re-entrantly. */ /* GETHOSTENT_R_PROTO: * This symbol encodes the prototype of gethostent_r. * It is zero if d_gethostent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostent_r * is defined. */ /*#define HAS_GETHOSTENT_R / **/ #define GETHOSTENT_R_PROTO 0 /**/ /* HAS_GETHOST_PROTOS: * This symbol, if defined, indicates that includes * prototypes for gethostent(), gethostbyname(), and * gethostbyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ #define HAS_GETHOST_PROTOS /**/ /* HAS_GETLOGIN_R: * This symbol, if defined, indicates that the getlogin_r routine * is available to getlogin re-entrantly. */ /* GETLOGIN_R_PROTO: * This symbol encodes the prototype of getlogin_r. * It is zero if d_getlogin_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getlogin_r * is defined. */ /*#define HAS_GETLOGIN_R / **/ #define GETLOGIN_R_PROTO 0 /**/ /* HAS_GETNETBYADDR: * This symbol, if defined, indicates that the getnetbyaddr() routine is * available to look up networks by their IP addresses. */ /*#define HAS_GETNETBYADDR / **/ /* HAS_GETNETBYNAME: * This symbol, if defined, indicates that the getnetbyname() routine is * available to look up networks by their names. */ /*#define HAS_GETNETBYNAME / **/ /* HAS_GETNETENT: * This symbol, if defined, indicates that the getnetent() routine is * available to look up network names in some data base or another. */ /*#define HAS_GETNETENT / **/ /* HAS_GETNETBYADDR_R: * This symbol, if defined, indicates that the getnetbyaddr_r routine * is available to getnetbyaddr re-entrantly. */ /* GETNETBYADDR_R_PROTO: * This symbol encodes the prototype of getnetbyaddr_r. * It is zero if d_getnetbyaddr_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetbyaddr_r * is defined. */ /*#define HAS_GETNETBYADDR_R / **/ #define GETNETBYADDR_R_PROTO 0 /**/ /* HAS_GETNETBYNAME_R: * This symbol, if defined, indicates that the getnetbyname_r routine * is available to getnetbyname re-entrantly. */ /* GETNETBYNAME_R_PROTO: * This symbol encodes the prototype of getnetbyname_r. * It is zero if d_getnetbyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetbyname_r * is defined. */ /*#define HAS_GETNETBYNAME_R / **/ #define GETNETBYNAME_R_PROTO 0 /**/ /* HAS_GETNETENT_R: * This symbol, if defined, indicates that the getnetent_r routine * is available to getnetent re-entrantly. */ /* GETNETENT_R_PROTO: * This symbol encodes the prototype of getnetent_r. * It is zero if d_getnetent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetent_r * is defined. */ /*#define HAS_GETNETENT_R / **/ #define GETNETENT_R_PROTO 0 /**/ /* HAS_GETNET_PROTOS: * This symbol, if defined, indicates that includes * prototypes for getnetent(), getnetbyname(), and * getnetbyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ /*#define HAS_GETNET_PROTOS / **/ /* HAS_GETPROTOENT: * This symbol, if defined, indicates that the getprotoent() routine is * available to look up protocols in some data base or another. */ /*#define HAS_GETPROTOENT / **/ /* HAS_GETPGRP: * This symbol, if defined, indicates that the getpgrp routine is * available to get the current process group. */ /* USE_BSD_GETPGRP: * This symbol, if defined, indicates that getpgrp needs one * arguments whereas USG one needs none. */ /*#define HAS_GETPGRP / **/ /*#define USE_BSD_GETPGRP / **/ /* HAS_GETPROTOBYNAME: * This symbol, if defined, indicates that the getprotobyname() * routine is available to look up protocols by their name. */ /* HAS_GETPROTOBYNUMBER: * This symbol, if defined, indicates that the getprotobynumber() * routine is available to look up protocols by their number. */ #define HAS_GETPROTOBYNAME /**/ #define HAS_GETPROTOBYNUMBER /**/ /* HAS_GETPROTOBYNAME_R: * This symbol, if defined, indicates that the getprotobyname_r routine * is available to getprotobyname re-entrantly. */ /* GETPROTOBYNAME_R_PROTO: * This symbol encodes the prototype of getprotobyname_r. * It is zero if d_getprotobyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotobyname_r * is defined. */ /*#define HAS_GETPROTOBYNAME_R / **/ #define GETPROTOBYNAME_R_PROTO 0 /**/ /* HAS_GETPROTOBYNUMBER_R: * This symbol, if defined, indicates that the getprotobynumber_r routine * is available to getprotobynumber re-entrantly. */ /* GETPROTOBYNUMBER_R_PROTO: * This symbol encodes the prototype of getprotobynumber_r. * It is zero if d_getprotobynumber_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotobynumber_r * is defined. */ /*#define HAS_GETPROTOBYNUMBER_R / **/ #define GETPROTOBYNUMBER_R_PROTO 0 /**/ /* HAS_GETPROTOENT_R: * This symbol, if defined, indicates that the getprotoent_r routine * is available to getprotoent re-entrantly. */ /* GETPROTOENT_R_PROTO: * This symbol encodes the prototype of getprotoent_r. * It is zero if d_getprotoent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotoent_r * is defined. */ /*#define HAS_GETPROTOENT_R / **/ #define GETPROTOENT_R_PROTO 0 /**/ /* HAS_GETPROTO_PROTOS: * This symbol, if defined, indicates that includes * prototypes for getprotoent(), getprotobyname(), and * getprotobyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ #define HAS_GETPROTO_PROTOS /**/ /* HAS_GETPWENT: * This symbol, if defined, indicates that the getpwent routine is * available for sequential access of the passwd database. * If this is not available, the older getpw() function may be available. */ /*#define HAS_GETPWENT / **/ /* HAS_GETPWENT_R: * This symbol, if defined, indicates that the getpwent_r routine * is available to getpwent re-entrantly. */ /* GETPWENT_R_PROTO: * This symbol encodes the prototype of getpwent_r. * It is zero if d_getpwent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwent_r * is defined. */ /*#define HAS_GETPWENT_R / **/ #define GETPWENT_R_PROTO 0 /**/ /* HAS_GETPWNAM_R: * This symbol, if defined, indicates that the getpwnam_r routine * is available to getpwnam re-entrantly. */ /* GETPWNAM_R_PROTO: * This symbol encodes the prototype of getpwnam_r. * It is zero if d_getpwnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwnam_r * is defined. */ /*#define HAS_GETPWNAM_R / **/ #define GETPWNAM_R_PROTO 0 /**/ /* HAS_GETPWUID_R: * This symbol, if defined, indicates that the getpwuid_r routine * is available to getpwuid re-entrantly. */ /* GETPWUID_R_PROTO: * This symbol encodes the prototype of getpwuid_r. * It is zero if d_getpwuid_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwuid_r * is defined. */ /*#define HAS_GETPWUID_R / **/ #define GETPWUID_R_PROTO 0 /**/ /* HAS_GETSERVENT: * This symbol, if defined, indicates that the getservent() routine is * available to look up network services in some data base or another. */ /*#define HAS_GETSERVENT / **/ /* HAS_GETSERVBYNAME_R: * This symbol, if defined, indicates that the getservbyname_r routine * is available to getservbyname re-entrantly. */ /* GETSERVBYNAME_R_PROTO: * This symbol encodes the prototype of getservbyname_r. * It is zero if d_getservbyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservbyname_r * is defined. */ /*#define HAS_GETSERVBYNAME_R / **/ #define GETSERVBYNAME_R_PROTO 0 /**/ /* HAS_GETSERVBYPORT_R: * This symbol, if defined, indicates that the getservbyport_r routine * is available to getservbyport re-entrantly. */ /* GETSERVBYPORT_R_PROTO: * This symbol encodes the prototype of getservbyport_r. * It is zero if d_getservbyport_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservbyport_r * is defined. */ /*#define HAS_GETSERVBYPORT_R / **/ #define GETSERVBYPORT_R_PROTO 0 /**/ /* HAS_GETSERVENT_R: * This symbol, if defined, indicates that the getservent_r routine * is available to getservent re-entrantly. */ /* GETSERVENT_R_PROTO: * This symbol encodes the prototype of getservent_r. * It is zero if d_getservent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservent_r * is defined. */ /*#define HAS_GETSERVENT_R / **/ #define GETSERVENT_R_PROTO 0 /**/ /* HAS_GETSERV_PROTOS: * This symbol, if defined, indicates that includes * prototypes for getservent(), getservbyname(), and * getservbyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ #define HAS_GETSERV_PROTOS /**/ /* HAS_GETSPNAM_R: * This symbol, if defined, indicates that the getspnam_r routine * is available to getspnam re-entrantly. */ /* GETSPNAM_R_PROTO: * This symbol encodes the prototype of getspnam_r. * It is zero if d_getspnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getspnam_r * is defined. */ /*#define HAS_GETSPNAM_R / **/ #define GETSPNAM_R_PROTO 0 /**/ /* HAS_GETSERVBYNAME: * This symbol, if defined, indicates that the getservbyname() * routine is available to look up services by their name. */ /* HAS_GETSERVBYPORT: * This symbol, if defined, indicates that the getservbyport() * routine is available to look up services by their port. */ #define HAS_GETSERVBYNAME /**/ #define HAS_GETSERVBYPORT /**/ /* HAS_GMTIME_R: * This symbol, if defined, indicates that the gmtime_r routine * is available to gmtime re-entrantly. */ /* GMTIME_R_PROTO: * This symbol encodes the prototype of gmtime_r. * It is zero if d_gmtime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gmtime_r * is defined. */ /*#define HAS_GMTIME_R / **/ #define GMTIME_R_PROTO 0 /**/ /* HAS_HTONL: * This symbol, if defined, indicates that the htonl() routine (and * friends htons() ntohl() ntohs()) are available to do network * order byte swapping. */ /* HAS_HTONS: * This symbol, if defined, indicates that the htons() routine (and * friends htonl() ntohl() ntohs()) are available to do network * order byte swapping. */ /* HAS_NTOHL: * This symbol, if defined, indicates that the ntohl() routine (and * friends htonl() htons() ntohs()) are available to do network * order byte swapping. */ /* HAS_NTOHS: * This symbol, if defined, indicates that the ntohs() routine (and * friends htonl() htons() ntohl()) are available to do network * order byte swapping. */ #define HAS_HTONL /**/ #define HAS_HTONS /**/ #define HAS_NTOHL /**/ #define HAS_NTOHS /**/ /* HAS_LOCALTIME_R: * This symbol, if defined, indicates that the localtime_r routine * is available to localtime re-entrantly. */ /* LOCALTIME_R_NEEDS_TZSET: * Many libc's localtime_r implementations do not call tzset, * making them differ from localtime(), and making timezone * changes using \undef{TZ} without explicitly calling tzset * impossible. This symbol makes us call tzset before localtime_r */ /*#define LOCALTIME_R_NEEDS_TZSET / **/ #ifdef LOCALTIME_R_NEEDS_TZSET #define L_R_TZSET tzset(), #else #define L_R_TZSET #endif /* LOCALTIME_R_PROTO: * This symbol encodes the prototype of localtime_r. * It is zero if d_localtime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_localtime_r * is defined. */ /*#define HAS_LOCALTIME_R / **/ #define LOCALTIME_R_PROTO 0 /**/ /* HAS_LONG_DOUBLE: * This symbol will be defined if the C compiler supports long * doubles. */ /* LONG_DOUBLESIZE: * This symbol contains the size of a long double, so that the * C preprocessor can make decisions based on it. It is only * defined if the system supports long doubles. */ #define HAS_LONG_DOUBLE /**/ #ifdef HAS_LONG_DOUBLE # ifdef _MSC_VER # define LONG_DOUBLESIZE 8 /**/ # else # define LONG_DOUBLESIZE 12 /**/ # endif #endif /* HAS_LONG_LONG: * This symbol will be defined if the C compiler supports long long. */ /* LONGLONGSIZE: * This symbol contains the size of a long long, so that the * C preprocessor can make decisions based on it. It is only * defined if the system supports long long. */ #ifdef __GNUC__ # define HAS_LONG_LONG /**/ #endif #ifdef HAS_LONG_LONG #define LONGLONGSIZE 8 /**/ #endif /* HAS_LSEEK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the lseek() function. Otherwise, it is up * to the program to supply one. A good guess is * extern off_t lseek(int, off_t, int); */ #define HAS_LSEEK_PROTO /**/ /* HAS_MEMCHR: * This symbol, if defined, indicates that the memchr routine is available * to locate characters within a C string. */ #define HAS_MEMCHR /**/ /* HAS_MKSTEMP: * This symbol, if defined, indicates that the mkstemp routine is * available to exclusively create and open a uniquely named * temporary file. */ /*#define HAS_MKSTEMP / **/ /* HAS_MMAP: * This symbol, if defined, indicates that the mmap system call is * available to map a file into memory. */ /* Mmap_t: * This symbol holds the return type of the mmap() system call * (and simultaneously the type of the first argument). * Usually set to 'void *' or 'caddr_t'. */ /*#define HAS_MMAP / **/ #define Mmap_t void * /**/ /* HAS_MSG: * This symbol, if defined, indicates that the entire msg*(2) library is * supported (IPC mechanism based on message queues). */ /*#define HAS_MSG / **/ /* OLD_PTHREAD_CREATE_JOINABLE: * This symbol, if defined, indicates how to create pthread * in joinable (aka undetached) state. NOTE: not defined * if pthread.h already has defined PTHREAD_CREATE_JOINABLE * (the new version of the constant). * If defined, known values are PTHREAD_CREATE_UNDETACHED * and __UNDETACHED. */ /*#define OLD_PTHREAD_CREATE_JOINABLE / **/ /* HAS_PTHREAD_ATFORK: * This symbol, if defined, indicates that the pthread_atfork routine * is available to setup fork handlers. */ /*#define HAS_PTHREAD_ATFORK / **/ /* HAS_PTHREAD_YIELD: * This symbol, if defined, indicates that the pthread_yield * routine is available to yield the execution of the current * thread. sched_yield is preferable to pthread_yield. */ /* SCHED_YIELD: * This symbol defines the way to yield the execution of * the current thread. Known ways are sched_yield, * pthread_yield, and pthread_yield with NULL. */ /* HAS_SCHED_YIELD: * This symbol, if defined, indicates that the sched_yield * routine is available to yield the execution of the current * thread. sched_yield is preferable to pthread_yield. */ /*#define HAS_PTHREAD_YIELD / **/ #define SCHED_YIELD /**/ /*#define HAS_SCHED_YIELD / **/ /* HAS_RANDOM_R: * This symbol, if defined, indicates that the random_r routine * is available to random re-entrantly. */ /* RANDOM_R_PROTO: * This symbol encodes the prototype of random_r. * It is zero if d_random_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_random_r * is defined. */ /*#define HAS_RANDOM_R / **/ #define RANDOM_R_PROTO 0 /**/ /* HAS_READDIR64_R: * This symbol, if defined, indicates that the readdir64_r routine * is available to readdir64 re-entrantly. */ /* READDIR64_R_PROTO: * This symbol encodes the prototype of readdir64_r. * It is zero if d_readdir64_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_readdir64_r * is defined. */ /*#define HAS_READDIR64_R / **/ #define READDIR64_R_PROTO 0 /**/ /* HAS_READDIR_R: * This symbol, if defined, indicates that the readdir_r routine * is available to readdir re-entrantly. */ /* READDIR_R_PROTO: * This symbol encodes the prototype of readdir_r. * It is zero if d_readdir_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_readdir_r * is defined. */ /*#define HAS_READDIR_R / **/ #define READDIR_R_PROTO 0 /**/ /* HAS_SEM: * This symbol, if defined, indicates that the entire sem*(2) library is * supported. */ /*#define HAS_SEM / **/ /* HAS_SETGRENT: * This symbol, if defined, indicates that the setgrent routine is * available for initializing sequential access of the group database. */ /*#define HAS_SETGRENT / **/ /* HAS_SETGRENT_R: * This symbol, if defined, indicates that the setgrent_r routine * is available to setgrent re-entrantly. */ /* SETGRENT_R_PROTO: * This symbol encodes the prototype of setgrent_r. * It is zero if d_setgrent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setgrent_r * is defined. */ /*#define HAS_SETGRENT_R / **/ #define SETGRENT_R_PROTO 0 /**/ /* HAS_SETHOSTENT: * This symbol, if defined, indicates that the sethostent() routine is * available. */ /*#define HAS_SETHOSTENT / **/ /* HAS_SETHOSTENT_R: * This symbol, if defined, indicates that the sethostent_r routine * is available to sethostent re-entrantly. */ /* SETHOSTENT_R_PROTO: * This symbol encodes the prototype of sethostent_r. * It is zero if d_sethostent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_sethostent_r * is defined. */ /*#define HAS_SETHOSTENT_R / **/ #define SETHOSTENT_R_PROTO 0 /**/ /* HAS_SETLOCALE_R: * This symbol, if defined, indicates that the setlocale_r routine * is available to setlocale re-entrantly. */ /* SETLOCALE_R_PROTO: * This symbol encodes the prototype of setlocale_r. * It is zero if d_setlocale_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setlocale_r * is defined. */ /*#define HAS_SETLOCALE_R / **/ #define SETLOCALE_R_PROTO 0 /**/ /* HAS_SETNETENT: * This symbol, if defined, indicates that the setnetent() routine is * available. */ /*#define HAS_SETNETENT / **/ /* HAS_SETNETENT_R: * This symbol, if defined, indicates that the setnetent_r routine * is available to setnetent re-entrantly. */ /* SETNETENT_R_PROTO: * This symbol encodes the prototype of setnetent_r. * It is zero if d_setnetent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setnetent_r * is defined. */ /*#define HAS_SETNETENT_R / **/ #define SETNETENT_R_PROTO 0 /**/ /* HAS_SETPROTOENT: * This symbol, if defined, indicates that the setprotoent() routine is * available. */ /*#define HAS_SETPROTOENT / **/ /* HAS_SETPGRP: * This symbol, if defined, indicates that the setpgrp routine is * available to set the current process group. */ /* USE_BSD_SETPGRP: * This symbol, if defined, indicates that setpgrp needs two * arguments whereas USG one needs none. See also HAS_SETPGID * for a POSIX interface. */ /*#define HAS_SETPGRP / **/ /*#define USE_BSD_SETPGRP / **/ /* HAS_SETPROTOENT_R: * This symbol, if defined, indicates that the setprotoent_r routine * is available to setprotoent re-entrantly. */ /* SETPROTOENT_R_PROTO: * This symbol encodes the prototype of setprotoent_r. * It is zero if d_setprotoent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setprotoent_r * is defined. */ /*#define HAS_SETPROTOENT_R / **/ #define SETPROTOENT_R_PROTO 0 /**/ /* HAS_SETPWENT: * This symbol, if defined, indicates that the setpwent routine is * available for initializing sequential access of the passwd database. */ /*#define HAS_SETPWENT / **/ /* HAS_SETPWENT_R: * This symbol, if defined, indicates that the setpwent_r routine * is available to setpwent re-entrantly. */ /* SETPWENT_R_PROTO: * This symbol encodes the prototype of setpwent_r. * It is zero if d_setpwent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setpwent_r * is defined. */ /*#define HAS_SETPWENT_R / **/ #define SETPWENT_R_PROTO 0 /**/ /* HAS_SETSERVENT: * This symbol, if defined, indicates that the setservent() routine is * available. */ /*#define HAS_SETSERVENT / **/ /* HAS_SETSERVENT_R: * This symbol, if defined, indicates that the setservent_r routine * is available to setservent re-entrantly. */ /* SETSERVENT_R_PROTO: * This symbol encodes the prototype of setservent_r. * It is zero if d_setservent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setservent_r * is defined. */ /*#define HAS_SETSERVENT_R / **/ #define SETSERVENT_R_PROTO 0 /**/ /* HAS_SETVBUF: * This symbol, if defined, indicates that the setvbuf routine is * available to change buffering on an open stdio stream. * to a line-buffered mode. */ #define HAS_SETVBUF /**/ /* HAS_SHM: * This symbol, if defined, indicates that the entire shm*(2) library is * supported. */ /*#define HAS_SHM / **/ /* Shmat_t: * This symbol holds the return type of the shmat() system call. * Usually set to 'void *' or 'char *'. */ /* HAS_SHMAT_PROTOTYPE: * This symbol, if defined, indicates that the sys/shm.h includes * a prototype for shmat(). Otherwise, it is up to the program to * guess one. Shmat_t shmat(int, Shmat_t, int) is a good guess, * but not always right so it should be emitted by the program only * when HAS_SHMAT_PROTOTYPE is not defined to avoid conflicting defs. */ #define Shmat_t void * /**/ /*#define HAS_SHMAT_PROTOTYPE / **/ /* HAS_SOCKET: * This symbol, if defined, indicates that the BSD socket interface is * supported. */ /* HAS_SOCKETPAIR: * This symbol, if defined, indicates that the BSD socketpair() call is * supported. */ /* HAS_MSG_CTRUNC: * This symbol, if defined, indicates that the MSG_CTRUNC is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_DONTROUTE: * This symbol, if defined, indicates that the MSG_DONTROUTE is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_OOB: * This symbol, if defined, indicates that the MSG_OOB is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_PEEK: * This symbol, if defined, indicates that the MSG_PEEK is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_PROXY: * This symbol, if defined, indicates that the MSG_PROXY is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_SCM_RIGHTS: * This symbol, if defined, indicates that the SCM_RIGHTS is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ #define HAS_SOCKET /**/ /*#define HAS_SOCKETPAIR / **/ /*#define HAS_MSG_CTRUNC / **/ /*#define HAS_MSG_DONTROUTE / **/ /*#define HAS_MSG_OOB / **/ /*#define HAS_MSG_PEEK / **/ /*#define HAS_MSG_PROXY / **/ /*#define HAS_SCM_RIGHTS / **/ /* HAS_SRAND48_R: * This symbol, if defined, indicates that the srand48_r routine * is available to srand48 re-entrantly. */ /* SRAND48_R_PROTO: * This symbol encodes the prototype of srand48_r. * It is zero if d_srand48_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_srand48_r * is defined. */ /*#define HAS_SRAND48_R / **/ #define SRAND48_R_PROTO 0 /**/ /* HAS_SRANDOM_R: * This symbol, if defined, indicates that the srandom_r routine * is available to srandom re-entrantly. */ /* SRANDOM_R_PROTO: * This symbol encodes the prototype of srandom_r. * It is zero if d_srandom_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_srandom_r * is defined. */ /*#define HAS_SRANDOM_R / **/ #define SRANDOM_R_PROTO 0 /**/ /* USE_STAT_BLOCKS: * This symbol is defined if this system has a stat structure declaring * st_blksize and st_blocks. */ #ifndef USE_STAT_BLOCKS /*#define USE_STAT_BLOCKS / **/ #endif /* USE_STRUCT_COPY: * This symbol, if defined, indicates that this C compiler knows how * to copy structures. If undefined, you'll need to use a block copy * routine of some sort instead. */ #define USE_STRUCT_COPY /**/ /* HAS_STRERROR: * This symbol, if defined, indicates that the strerror routine is * available to translate error numbers to strings. See the writeup * of Strerror() in this file before you try to define your own. */ /* HAS_SYS_ERRLIST: * This symbol, if defined, indicates that the sys_errlist array is * available to translate error numbers to strings. The extern int * sys_nerr gives the size of that table. */ /* Strerror: * This preprocessor symbol is defined as a macro if strerror() is * not available to translate error numbers to strings but sys_errlist[] * array is there. */ #define HAS_STRERROR /**/ #define HAS_SYS_ERRLIST /**/ #define Strerror(e) strerror(e) /* HAS_STRERROR_R: * This symbol, if defined, indicates that the strerror_r routine * is available to strerror re-entrantly. */ /* STRERROR_R_PROTO: * This symbol encodes the prototype of strerror_r. * It is zero if d_strerror_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_strerror_r * is defined. */ /*#define HAS_STRERROR_R / **/ #define STRERROR_R_PROTO 0 /**/ /* HAS_STRTOUL: * This symbol, if defined, indicates that the strtoul routine is * available to provide conversion of strings to unsigned long. */ #define HAS_STRTOUL /**/ /* HAS_TIME: * This symbol, if defined, indicates that the time() routine exists. */ /* Time_t: * This symbol holds the type returned by time(). It can be long, * or time_t on BSD sites (in which case should be * included). */ #define HAS_TIME /**/ #define Time_t time_t /* Time type */ /* HAS_TIMES: * This symbol, if defined, indicates that the times() routine exists. * Note that this became obsolete on some systems (SUNOS), which now * use getrusage(). It may be necessary to include . */ #define HAS_TIMES /**/ /* HAS_TMPNAM_R: * This symbol, if defined, indicates that the tmpnam_r routine * is available to tmpnam re-entrantly. */ /* TMPNAM_R_PROTO: * This symbol encodes the prototype of tmpnam_r. * It is zero if d_tmpnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_tmpnam_r * is defined. */ /*#define HAS_TMPNAM_R / **/ #define TMPNAM_R_PROTO 0 /**/ /* HAS_TTYNAME_R: * This symbol, if defined, indicates that the ttyname_r routine * is available to ttyname re-entrantly. */ /* TTYNAME_R_PROTO: * This symbol encodes the prototype of ttyname_r. * It is zero if d_ttyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ttyname_r * is defined. */ /*#define HAS_TTYNAME_R / **/ #define TTYNAME_R_PROTO 0 /**/ /* HAS_UNION_SEMUN: * This symbol, if defined, indicates that the union semun is * defined by including . If not, the user code * probably needs to define it as: * union semun { * int val; * struct semid_ds *buf; * unsigned short *array; * } */ /* USE_SEMCTL_SEMUN: * This symbol, if defined, indicates that union semun is * used for semctl IPC_STAT. */ /* USE_SEMCTL_SEMID_DS: * This symbol, if defined, indicates that struct semid_ds * is * used for semctl IPC_STAT. */ #define HAS_UNION_SEMUN /**/ /*#define USE_SEMCTL_SEMUN / **/ /*#define USE_SEMCTL_SEMID_DS / **/ /* HAS_VFORK: * This symbol, if defined, indicates that vfork() exists. */ /*#define HAS_VFORK / **/ /* HAS_PSEUDOFORK: * This symbol, if defined, indicates that an emulation of the * fork routine is available. */ /*#define HAS_PSEUDOFORK / **/ /* Signal_t: * This symbol's value is either "void" or "int", corresponding to the * appropriate return type of a signal handler. Thus, you can declare * a signal handler using "Signal_t (*handler)()", and define the * handler using "Signal_t handler(sig)". */ #define Signal_t void /* Signal handler's return type */ /* HASVOLATILE: * This symbol, if defined, indicates that this C compiler knows about * the volatile declaration. */ #define HASVOLATILE /**/ #ifndef HASVOLATILE #define volatile #endif /* Fpos_t: * This symbol holds the type used to declare file positions in libc. * It can be fpos_t, long, uint, etc... It may be necessary to include * to get any typedef'ed information. */ #define Fpos_t fpos_t /* File position type */ /* Gid_t_f: * This symbol defines the format string used for printing a Gid_t. */ #define Gid_t_f "ld" /**/ /* Gid_t_sign: * This symbol holds the signedess of a Gid_t. * 1 for unsigned, -1 for signed. */ #define Gid_t_sign -1 /* GID sign */ /* Gid_t_size: * This symbol holds the size of a Gid_t in bytes. */ #define Gid_t_size 4 /* GID size */ /* Gid_t: * This symbol holds the return type of getgid() and the type of * argument to setrgid() and related functions. Typically, * it is the type of group ids in the kernel. It can be int, ushort, * gid_t, etc... It may be necessary to include to get * any typedef'ed information. */ #define Gid_t gid_t /* Type for getgid(), etc... */ /* I_DIRENT: * This symbol, if defined, indicates to the C program that it should * include . Using this symbol also triggers the definition * of the Direntry_t define which ends up being 'struct dirent' or * 'struct direct' depending on the availability of . */ /* DIRNAMLEN: * This symbol, if defined, indicates to the C program that the length * of directory entry names is provided by a d_namlen field. Otherwise * you need to do strlen() on the d_name field. */ /* Direntry_t: * This symbol is set to 'struct direct' or 'struct dirent' depending on * whether dirent is available or not. You should use this pseudo type to * portably declare your directory entries. */ #define I_DIRENT /**/ #define DIRNAMLEN /**/ #define Direntry_t struct direct /* I_GRP: * This symbol, if defined, indicates to the C program that it should * include . */ /* GRPASSWD: * This symbol, if defined, indicates to the C program that struct group * in contains gr_passwd. */ /*#define I_GRP / **/ /*#define GRPASSWD / **/ /* I_MACH_CTHREADS: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_MACH_CTHREADS / **/ /* I_NDBM: * This symbol, if defined, indicates that exists and should * be included. */ /* I_GDBMNDBM: * This symbol, if defined, indicates that exists and should * be included. This was the location of the ndbm.h compatibility file * in RedHat 7.1. */ /* I_GDBM_NDBM: * This symbol, if defined, indicates that exists and should * be included. This is the location of the ndbm.h compatibility file * in Debian 4.0. */ /* NDBM_H_USES_PROTOTYPES: * This symbol, if defined, indicates that uses real ANSI C * prototypes instead of K&R style function declarations without any * parameter information. While ANSI C prototypes are supported in C++, * K&R style function declarations will yield errors. */ /* GDBMNDBM_H_USES_PROTOTYPES: * This symbol, if defined, indicates that uses real ANSI C * prototypes instead of K&R style function declarations without any * parameter information. While ANSI C prototypes are supported in C++, * K&R style function declarations will yield errors. */ /* GDBM_NDBM_H_USES_PROTOTYPES: * This symbol, if defined, indicates that uses real ANSI C * prototypes instead of K&R style function declarations without any * parameter information. While ANSI C prototypes are supported in C++, * K&R style function declarations will yield errors. */ /*#define I_NDBM / **/ /*#define I_GDBMNDBM / **/ /*#define I_GDBM_NDBM / **/ /*#define NDBM_H_USES_PROTOTYPES / **/ /*#define GDBMNDBM_H_USES_PROTOTYPES / **/ /*#define GDBM_NDBM_H_USES_PROTOTYPES / **/ /* I_NETDB: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_NETDB / **/ /* I_NET_ERRNO: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_NET_ERRNO / **/ /* I_PTHREAD: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_PTHREAD / **/ /* I_PWD: * This symbol, if defined, indicates to the C program that it should * include . */ /* PWQUOTA: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_quota. */ /* PWAGE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_age. */ /* PWCHANGE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_change. */ /* PWCLASS: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_class. */ /* PWEXPIRE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_expire. */ /* PWCOMMENT: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_comment. */ /* PWGECOS: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_gecos. */ /* PWPASSWD: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_passwd. */ /*#define I_PWD / **/ /*#define PWQUOTA / **/ /*#define PWAGE / **/ /*#define PWCHANGE / **/ /*#define PWCLASS / **/ /*#define PWEXPIRE / **/ /*#define PWCOMMENT / **/ /*#define PWGECOS / **/ /*#define PWPASSWD / **/ /* I_SYS_ACCESS: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_ACCESS / **/ /* I_SYS_SECURITY: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_SECURITY / **/ /* I_SYSUIO: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSUIO / **/ /* I_STDARG: * This symbol, if defined, indicates that exists and should * be included. */ /* I_VARARGS: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_STDARG /**/ /*#define I_VARARGS / **/ /* PERL_INC_VERSION_LIST: * This variable specifies the list of subdirectories in over * which perl.c:incpush() and lib/lib.pm will automatically * search when adding directories to @INC, in a format suitable * for a C initialization string. See the inc_version_list entry * in Porting/Glossary for more details. */ /*#define PERL_INC_VERSION_LIST 0 / **/ /* INSTALL_USR_BIN_PERL: * This symbol, if defined, indicates that Perl is to be installed * also as /usr/bin/perl. */ /*#define INSTALL_USR_BIN_PERL / **/ /* Off_t: * This symbol holds the type used to declare offsets in the kernel. * It can be int, long, off_t, etc... It may be necessary to include * to get any typedef'ed information. */ /* LSEEKSIZE: * This symbol holds the number of bytes used by the Off_t. */ /* Off_t_size: * This symbol holds the number of bytes used by the Off_t. */ #ifdef _MSC_VER # define Off_t __int64 /* type */ #else # define Off_t long long /* type */ #endif #define LSEEKSIZE 8 /* size */ #define Off_t_size 8 /* size */ /* Free_t: * This variable contains the return type of free(). It is usually * void, but occasionally int. */ /* Malloc_t: * This symbol is the type of pointer returned by malloc and realloc. */ #define Malloc_t void * /**/ #define Free_t void /**/ /* PERL_MALLOC_WRAP: * This symbol, if defined, indicates that we'd like malloc wrap checks. */ #define PERL_MALLOC_WRAP /**/ /* MYMALLOC: * This symbol, if defined, indicates that we're using our own malloc. */ /*#define MYMALLOC / **/ /* Mode_t: * This symbol holds the type used to declare file modes * for systems calls. It is usually mode_t, but may be * int or unsigned short. It may be necessary to include * to get any typedef'ed information. */ #define Mode_t mode_t /* file mode parameter for system calls */ /* Netdb_host_t: * This symbol holds the type used for the 1st argument * to gethostbyaddr(). */ /* Netdb_hlen_t: * This symbol holds the type used for the 2nd argument * to gethostbyaddr(). */ /* Netdb_name_t: * This symbol holds the type used for the argument to * gethostbyname(). */ /* Netdb_net_t: * This symbol holds the type used for the 1st argument to * getnetbyaddr(). */ #define Netdb_host_t char * /**/ #define Netdb_hlen_t int /**/ #define Netdb_name_t char * /**/ #define Netdb_net_t long /**/ /* PERL_OTHERLIBDIRS: * This variable contains a colon-separated set of paths for the perl * binary to search for additional library files or modules. * These directories will be tacked to the end of @INC. * Perl will automatically search below each path for version- * and architecture-specific directories. See PERL_INC_VERSION_LIST * for more details. */ /*#define PERL_OTHERLIBDIRS "" / **/ /* Pid_t: * This symbol holds the type used to declare process ids in the kernel. * It can be int, uint, pid_t, etc... It may be necessary to include * to get any typedef'ed information. */ #define Pid_t int /* PID type */ /* PRIVLIB: * This symbol contains the name of the private library for this package. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. The program * should be prepared to do ~ expansion. */ /* PRIVLIB_EXP: * This symbol contains the ~name expanded version of PRIVLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ #define PRIVLIB "c:\\perl\\lib" /**/ #define PRIVLIB_EXP (win32_get_privlib(PERL_VERSION_STRING)) /**/ /* CAN_PROTOTYPE: * If defined, this macro indicates that the C compiler can handle * function prototypes. */ /* _: * This macro is used to declare function parameters for folks who want * to make declarations with prototypes using a different style than * the above macros. Use double parentheses. For example: * * int main _((int argc, char *argv[])); */ #define CAN_PROTOTYPE /**/ #ifdef CAN_PROTOTYPE #define _(args) args #else #define _(args) () #endif /* Select_fd_set_t: * This symbol holds the type used for the 2nd, 3rd, and 4th * arguments to select. Usually, this is 'fd_set *', if HAS_FD_SET * is defined, and 'int *' otherwise. This is only useful if you * have select(), of course. */ #define Select_fd_set_t Perl_fd_set * /**/ /* SH_PATH: * This symbol contains the full pathname to the shell used on this * on this system to execute Bourne shell scripts. Usually, this will be * /bin/sh, though it's possible that some systems will have /bin/ksh, * /bin/pdksh, /bin/ash, /bin/bash, or even something such as * D:/bin/sh.exe. */ #define SH_PATH "cmd /x /c" /**/ /* SIG_NAME: * This symbol contains a list of signal names in order of * signal number. This is intended * to be used as a static array initialization, like this: * char *sig_name[] = { SIG_NAME }; * The signals in the list are separated with commas, and each signal * is surrounded by double quotes. There is no leading SIG in the signal * name, i.e. SIGQUIT is known as "QUIT". * Gaps in the signal numbers (up to NSIG) are filled in with NUMnn, * etc., where nn is the actual signal number (e.g. NUM37). * The signal number for sig_name[i] is stored in sig_num[i]. * The last element is 0 to terminate the list with a NULL. This * corresponds to the 0 at the end of the sig_name_init list. * Note that this variable is initialized from the sig_name_init, * not from sig_name (which is unused). */ /* SIG_NUM: * This symbol contains a list of signal numbers, in the same order as the * SIG_NAME list. It is suitable for static array initialization, as in: * int sig_num[] = { SIG_NUM }; * The signals in the list are separated with commas, and the indices * within that list and the SIG_NAME list match, so it's easy to compute * the signal name from a number or vice versa at the price of a small * dynamic linear lookup. * Duplicates are allowed, but are moved to the end of the list. * The signal number corresponding to sig_name[i] is sig_number[i]. * if (i < NSIG) then sig_number[i] == i. * The last element is 0, corresponding to the 0 at the end of * the sig_name_init list. * Note that this variable is initialized from the sig_num_init, * not from sig_num (which is unused). */ /* SIG_SIZE: * This variable contains the number of elements of the SIG_NAME * and SIG_NUM arrays, excluding the final NULL entry. */ #define SIG_NAME "ZERO", "HUP", "INT", "QUIT", "ILL", "NUM05", "NUM06", "NUM07", "FPE", "KILL", "NUM10", "SEGV", "NUM12", "PIPE", "ALRM", "TERM", "NUM16", "NUM17", "NUM18", "NUM19", "CHLD", "BREAK", "ABRT", "STOP", "NUM24", "CONT", "CLD", 0 /**/ #define SIG_NUM 0, 1, 2, 21, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 20, 0 /**/ #define SIG_SIZE 27 /**/ /* SITEARCH: * This symbol contains the name of the private library for this package. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. The program * should be prepared to do ~ expansion. * The standard distribution will put nothing in this directory. * After perl has been installed, users may install their own local * architecture-dependent modules in this directory with * MakeMaker Makefile.PL * or equivalent. See INSTALL for details. */ /* SITEARCH_EXP: * This symbol contains the ~name expanded version of SITEARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ #define SITEARCH "c:\\perl\\site\\lib" /**/ /*#define SITEARCH_EXP "" / **/ /* SITELIB: * This symbol contains the name of the private library for this package. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. The program * should be prepared to do ~ expansion. * The standard distribution will put nothing in this directory. * After perl has been installed, users may install their own local * architecture-independent modules in this directory with * MakeMaker Makefile.PL * or equivalent. See INSTALL for details. */ /* SITELIB_EXP: * This symbol contains the ~name expanded version of SITELIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ /* SITELIB_STEM: * This define is SITELIB_EXP with any trailing version-specific component * removed. The elements in inc_version_list (inc_version_list.U) can * be tacked onto this variable to generate a list of directories to search. */ #define SITELIB "c:\\perl\\site\\lib" /**/ #define SITELIB_EXP (win32_get_sitelib(PERL_VERSION_STRING)) /**/ #define SITELIB_STEM "" /**/ /* Size_t_size: * This symbol holds the size of a Size_t in bytes. */ #define Size_t_size 8 /**/ /* Size_t: * This symbol holds the type used to declare length parameters * for string functions. It is usually size_t, but may be * unsigned long, int, etc. It may be necessary to include * to get any typedef'ed information. */ #define Size_t size_t /* length paramater for string functions */ /* Sock_size_t: * This symbol holds the type used for the size argument of * various socket calls (just the base type, not the pointer-to). */ #define Sock_size_t int /**/ /* STDCHAR: * This symbol is defined to be the type of char used in stdio.h. * It has the values "unsigned char" or "char". */ #define STDCHAR char /**/ /* Uid_t_f: * This symbol defines the format string used for printing a Uid_t. */ #define Uid_t_f "ld" /**/ /* Uid_t_sign: * This symbol holds the signedess of a Uid_t. * 1 for unsigned, -1 for signed. */ #define Uid_t_sign -1 /* UID sign */ /* Uid_t_size: * This symbol holds the size of a Uid_t in bytes. */ #define Uid_t_size 4 /* UID size */ /* Uid_t: * This symbol holds the type used to declare user ids in the kernel. * It can be int, ushort, uid_t, etc... It may be necessary to include * to get any typedef'ed information. */ #define Uid_t uid_t /* UID type */ /* USE_ITHREADS: * This symbol, if defined, indicates that Perl should be built to * use the interpreter-based threading implementation. */ /* USE_5005THREADS: * This symbol, if defined, indicates that Perl should be built to * use the 5.005-based threading implementation. * Only valid up to 5.8.x. */ /* OLD_PTHREADS_API: * This symbol, if defined, indicates that Perl should * be built to use the old draft POSIX threads API. */ /* USE_REENTRANT_API: * This symbol, if defined, indicates that Perl should * try to use the various _r versions of library functions. * This is extremely experimental. */ /*#define USE_5005THREADS / **/ /*#define USE_ITHREADS / **/ #if defined(USE_5005THREADS) && !defined(USE_ITHREADS) #define USE_THREADS /* until src is revised*/ #endif /*#define OLD_PTHREADS_API / **/ /*#define USE_REENTRANT_API / **/ /* PERL_VENDORARCH: * If defined, this symbol contains the name of a private library. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. * It may have a ~ on the front. * The standard distribution will put nothing in this directory. * Vendors who distribute perl may wish to place their own * architecture-dependent modules and extensions in this directory with * MakeMaker Makefile.PL INSTALLDIRS=vendor * or equivalent. See INSTALL for details. */ /* PERL_VENDORARCH_EXP: * This symbol contains the ~name expanded version of PERL_VENDORARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ /*#define PERL_VENDORARCH "" / **/ /*#define PERL_VENDORARCH_EXP "" / **/ /* PERL_VENDORLIB_EXP: * This symbol contains the ~name expanded version of VENDORLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ /* PERL_VENDORLIB_STEM: * This define is PERL_VENDORLIB_EXP with any trailing version-specific component * removed. The elements in inc_version_list (inc_version_list.U) can * be tacked onto this variable to generate a list of directories to search. */ /*#define PERL_VENDORLIB_EXP "" / **/ /*#define PERL_VENDORLIB_STEM "" / **/ /* VOIDFLAGS: * This symbol indicates how much support of the void type is given by this * compiler. What various bits mean: * * 1 = supports declaration of void * 2 = supports arrays of pointers to functions returning void * 4 = supports comparisons between pointers to void functions and * addresses of void functions * 8 = suports declaration of generic void pointers * * The package designer should define VOIDUSED to indicate the requirements * of the package. This can be done either by #defining VOIDUSED before * including config.h, or by defining defvoidused in Myinit.U. If the * latter approach is taken, only those flags will be tested. If the * level of void support necessary is not present, defines void to int. */ #ifndef VOIDUSED #define VOIDUSED 15 #endif #define VOIDFLAGS 15 #if (VOIDFLAGS & VOIDUSED) != VOIDUSED #define void int /* is void to be avoided? */ #define M_VOID /* Xenix strikes again */ #endif /* USE_CROSS_COMPILE: * This symbol, if defined, indicates that Perl is being cross-compiled. */ /* PERL_TARGETARCH: * This symbol, if defined, indicates the target architecture * Perl has been cross-compiled to. Undefined if not a cross-compile. */ #ifndef USE_CROSS_COMPILE /*#define USE_CROSS_COMPILE / **/ #define PERL_TARGETARCH "" /**/ #endif /* MEM_ALIGNBYTES: * This symbol contains the number of bytes required to align a * double, or a long double when applicable. Usual values are 2, * 4 and 8. The default is eight, for safety. */ #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH) # define MEM_ALIGNBYTES 8 #else #define MEM_ALIGNBYTES 8 #endif /* BYTEORDER: * This symbol holds the hexadecimal constant defined in byteorder, * in a UV, i.e. 0x1234 or 0x4321 or 0x12345678, etc... * If the compiler supports cross-compiling or multiple-architecture * binaries (eg. on NeXT systems), use compiler-defined macros to * determine the byte order. * On NeXT 3.2 (and greater), you can build "Fat" Multiple Architecture * Binaries (MAB) on either big endian or little endian machines. * The endian-ness is available at compile-time. This only matters * for perl, where the config.h can be generated and installed on * one system, and used by a different architecture to build an * extension. Older versions of NeXT that might not have * defined either *_ENDIAN__ were all on Motorola 680x0 series, * so the default case (for NeXT) is big endian to catch them. * This might matter for NeXT 3.0. */ #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH) # ifdef __LITTLE_ENDIAN__ # if LONGSIZE == 4 # define BYTEORDER 0x1234 # else # if LONGSIZE == 8 # define BYTEORDER 0x12345678 # endif # endif # else # ifdef __BIG_ENDIAN__ # if LONGSIZE == 4 # define BYTEORDER 0x4321 # else # if LONGSIZE == 8 # define BYTEORDER 0x87654321 # endif # endif # endif # endif # if !defined(BYTEORDER) && (defined(NeXT) || defined(__NeXT__)) # define BYTEORDER 0x4321 # endif #else #define BYTEORDER 0x1234 /* large digits for MSB */ #endif /* NeXT */ /* CHARBITS: * This symbol contains the size of a char, so that the C preprocessor * can make decisions based on it. */ #define CHARBITS 8 /**/ /* CASTI32: * This symbol is defined if the C compiler can cast negative * or large floating point numbers to 32-bit ints. */ #ifndef _MSC_VER # define CASTI32 /**/ #endif /* CASTNEGFLOAT: * This symbol is defined if the C compiler can cast negative * numbers to unsigned longs, ints and shorts. */ /* CASTFLAGS: * This symbol contains flags that say what difficulties the compiler * has casting odd floating values to unsigned long: * 0 = ok * 1 = couldn't cast < 0 * 2 = couldn't cast >= 0x80000000 * 4 = couldn't cast in argument expression list */ #define CASTNEGFLOAT /**/ #define CASTFLAGS 0 /**/ /* VOID_CLOSEDIR: * This symbol, if defined, indicates that the closedir() routine * does not return a value. */ /*#define VOID_CLOSEDIR / **/ /* HAS_FD_SET: * This symbol, when defined, indicates presence of the fd_set typedef * in */ #define HAS_FD_SET /**/ /* Gconvert: * This preprocessor macro is defined to convert a floating point * number to a string without a trailing decimal point. This * emulates the behavior of sprintf("%g"), but is sometimes much more * efficient. If gconvert() is not available, but gcvt() drops the * trailing decimal point, then gcvt() is used. If all else fails, * a macro using sprintf("%g") is used. Arguments for the Gconvert * macro are: value, number of digits, whether trailing zeros should * be retained, and the output buffer. * The usual values are: * d_Gconvert='gconvert((x),(n),(t),(b))' * d_Gconvert='gcvt((x),(n),(b))' * d_Gconvert='sprintf((b),"%.*g",(n),(x))' * The last two assume trailing zeros should not be kept. */ #define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(x)) /* HAS_GETPAGESIZE: * This symbol, if defined, indicates that the getpagesize system call * is available to get system page size, which is the granularity of * many memory management calls. */ /*#define HAS_GETPAGESIZE / **/ /* HAS_GNULIBC: * This symbol, if defined, indicates to the C program that * the GNU C library is being used. A better check is to use * the __GLIBC__ and __GLIBC_MINOR__ symbols supplied with glibc. */ /*#define HAS_GNULIBC / **/ #if defined(HAS_GNULIBC) && !defined(_GNU_SOURCE) # define _GNU_SOURCE #endif /* HAS_ISASCII: * This manifest constant lets the C program know that isascii * is available. */ #define HAS_ISASCII /**/ /* HAS_LCHOWN: * This symbol, if defined, indicates that the lchown routine is * available to operate on a symbolic link (instead of following the * link). */ /*#define HAS_LCHOWN / **/ /* HAS_OPEN3: * This manifest constant lets the C program know that the three * argument form of open(2) is available. */ /*#define HAS_OPEN3 / **/ /* HAS_SAFE_BCOPY: * This symbol, if defined, indicates that the bcopy routine is available * to copy potentially overlapping memory blocks. Normally, you should * probably use memmove() or memcpy(). If neither is defined, roll your * own version. */ /*#define HAS_SAFE_BCOPY / **/ /* HAS_SAFE_MEMCPY: * This symbol, if defined, indicates that the memcpy routine is available * to copy potentially overlapping memory blocks. If you need to * copy overlapping memory blocks, you should check HAS_MEMMOVE and * use memmove() instead, if available. */ /*#define HAS_SAFE_MEMCPY / **/ /* HAS_SANE_MEMCMP: * This symbol, if defined, indicates that the memcmp routine is available * and can be used to compare relative magnitudes of chars with their high * bits set. If it is not defined, roll your own version. */ #define HAS_SANE_MEMCMP /**/ /* HAS_SIGACTION: * This symbol, if defined, indicates that Vr4's sigaction() routine * is available. */ /*#define HAS_SIGACTION / **/ /* HAS_SIGSETJMP: * This variable indicates to the C program that the sigsetjmp() * routine is available to save the calling process's registers * and stack environment for later use by siglongjmp(), and * to optionally save the process's signal mask. See * Sigjmp_buf, Sigsetjmp, and Siglongjmp. */ /* Sigjmp_buf: * This is the buffer type to be used with Sigsetjmp and Siglongjmp. */ /* Sigsetjmp: * This macro is used in the same way as sigsetjmp(), but will invoke * traditional setjmp() if sigsetjmp isn't available. * See HAS_SIGSETJMP. */ /* Siglongjmp: * This macro is used in the same way as siglongjmp(), but will invoke * traditional longjmp() if siglongjmp isn't available. * See HAS_SIGSETJMP. */ /*#define HAS_SIGSETJMP / **/ #ifdef HAS_SIGSETJMP #define Sigjmp_buf sigjmp_buf #define Sigsetjmp(buf,save_mask) sigsetjmp((buf),(save_mask)) #define Siglongjmp(buf,retval) siglongjmp((buf),(retval)) #else #define Sigjmp_buf jmp_buf #define Sigsetjmp(buf,save_mask) setjmp((buf)) #define Siglongjmp(buf,retval) longjmp((buf),(retval)) #endif /* USE_STDIO_PTR: * This symbol is defined if the _ptr and _cnt fields (or similar) * of the stdio FILE structure can be used to access the stdio buffer * for a file handle. If this is defined, then the FILE_ptr(fp) * and FILE_cnt(fp) macros will also be defined and should be used * to access these fields. */ /* FILE_ptr: * This macro is used to access the _ptr field (or equivalent) of the * FILE structure pointed to by its argument. This macro will always be * defined if USE_STDIO_PTR is defined. */ /* STDIO_PTR_LVALUE: * This symbol is defined if the FILE_ptr macro can be used as an * lvalue. */ /* FILE_cnt: * This macro is used to access the _cnt field (or equivalent) of the * FILE structure pointed to by its argument. This macro will always be * defined if USE_STDIO_PTR is defined. */ /* STDIO_CNT_LVALUE: * This symbol is defined if the FILE_cnt macro can be used as an * lvalue. */ /* STDIO_PTR_LVAL_SETS_CNT: * This symbol is defined if using the FILE_ptr macro as an lvalue * to increase the pointer by n has the side effect of decreasing the * value of File_cnt(fp) by n. */ /* STDIO_PTR_LVAL_NOCHANGE_CNT: * This symbol is defined if using the FILE_ptr macro as an lvalue * to increase the pointer by n leaves File_cnt(fp) unchanged. */ #define USE_STDIO_PTR /**/ #ifdef USE_STDIO_PTR #define FILE_ptr(fp) ((fp)->_ptr) #define STDIO_PTR_LVALUE /**/ #define FILE_cnt(fp) ((fp)->_cnt) #define STDIO_CNT_LVALUE /**/ /*#define STDIO_PTR_LVAL_SETS_CNT / **/ #define STDIO_PTR_LVAL_NOCHANGE_CNT /**/ #endif /* USE_STDIO_BASE: * This symbol is defined if the _base field (or similar) of the * stdio FILE structure can be used to access the stdio buffer for * a file handle. If this is defined, then the FILE_base(fp) macro * will also be defined and should be used to access this field. * Also, the FILE_bufsiz(fp) macro will be defined and should be used * to determine the number of bytes in the buffer. USE_STDIO_BASE * will never be defined unless USE_STDIO_PTR is. */ /* FILE_base: * This macro is used to access the _base field (or equivalent) of the * FILE structure pointed to by its argument. This macro will always be * defined if USE_STDIO_BASE is defined. */ /* FILE_bufsiz: * This macro is used to determine the number of bytes in the I/O * buffer pointed to by _base field (or equivalent) of the FILE * structure pointed to its argument. This macro will always be defined * if USE_STDIO_BASE is defined. */ #define USE_STDIO_BASE /**/ #ifdef USE_STDIO_BASE #define FILE_base(fp) ((fp)->_base) #define FILE_bufsiz(fp) ((fp)->_cnt + (fp)->_ptr - (fp)->_base) #endif /* HAS_VPRINTF: * This symbol, if defined, indicates that the vprintf routine is available * to printf with a pointer to an argument list. If unavailable, you * may need to write your own, probably in terms of _doprnt(). */ /* USE_CHAR_VSPRINTF: * This symbol is defined if this system has vsprintf() returning type * (char*). The trend seems to be to declare it as "int vsprintf()". It * is up to the package author to declare vsprintf correctly based on the * symbol. */ #define HAS_VPRINTF /**/ /*#define USE_CHAR_VSPRINTF / **/ /* DOUBLESIZE: * This symbol contains the size of a double, so that the C preprocessor * can make decisions based on it. */ #define DOUBLESIZE 8 /**/ /* I_TIME: * This symbol, if defined, indicates to the C program that it should * include . */ /* I_SYS_TIME: * This symbol, if defined, indicates to the C program that it should * include . */ /* I_SYS_TIME_KERNEL: * This symbol, if defined, indicates to the C program that it should * include with KERNEL defined. */ /* HAS_TM_TM_ZONE: * This symbol, if defined, indicates to the C program that * the struct tm has a tm_zone field. */ /* HAS_TM_TM_GMTOFF: * This symbol, if defined, indicates to the C program that * the struct tm has a tm_gmtoff field. */ #define I_TIME /**/ /*#define I_SYS_TIME / **/ /*#define I_SYS_TIME_KERNEL / **/ /*#define HAS_TM_TM_ZONE / **/ /*#define HAS_TM_TM_GMTOFF / **/ /* VAL_O_NONBLOCK: * This symbol is to be used during open() or fcntl(F_SETFL) to turn on * non-blocking I/O for the file descriptor. Note that there is no way * back, i.e. you cannot turn it blocking again this way. If you wish to * alternatively switch between blocking and non-blocking, use the * ioctl(FIOSNBIO) call instead, but that is not supported by all devices. */ /* VAL_EAGAIN: * This symbol holds the errno error code set by read() when no data was * present on the non-blocking file descriptor. */ /* RD_NODATA: * This symbol holds the return code from read() when no data is present * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is * not defined, then you can't distinguish between no data and EOF by * issuing a read(). You'll have to find another way to tell for sure! */ /* EOF_NONBLOCK: * This symbol, if defined, indicates to the C program that a read() on * a non-blocking file descriptor will return 0 on EOF, and not the value * held in RD_NODATA (-1 usually, in that case!). */ #define VAL_O_NONBLOCK O_NONBLOCK #define VAL_EAGAIN EAGAIN #define RD_NODATA -1 #define EOF_NONBLOCK /* PTRSIZE: * This symbol contains the size of a pointer, so that the C preprocessor * can make decisions based on it. It will be sizeof(void *) if * the compiler supports (void *); otherwise it will be * sizeof(char *). */ #define PTRSIZE 8 /**/ /* Drand01: * This macro is to be used to generate uniformly distributed * random numbers over the range [0., 1.[. You may have to supply * an 'extern double drand48();' in your program since SunOS 4.1.3 * doesn't provide you with anything relevant in its headers. * See HAS_DRAND48_PROTO. */ /* Rand_seed_t: * This symbol defines the type of the argument of the * random seed function. */ /* seedDrand01: * This symbol defines the macro to be used in seeding the * random number generator (see Drand01). */ /* RANDBITS: * This symbol indicates how many bits are produced by the * function used to generate normalized random numbers. * Values include 15, 16, 31, and 48. */ #define Drand01() (rand()/(double)((unsigned)1< or * to get any typedef'ed information. * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t). */ #ifdef _MSC_VER # define SSize_t __int64 /* signed count of bytes */ #else # define SSize_t long long /* signed count of bytes */ #endif /* EBCDIC: * This symbol, if defined, indicates that this system uses * EBCDIC encoding. */ /*#define EBCDIC / **/ /* SETUID_SCRIPTS_ARE_SECURE_NOW: * This symbol, if defined, indicates that the bug that prevents * setuid scripts from being secure is not present in this kernel. */ /* DOSUID: * This symbol, if defined, indicates that the C program should * check the script that it is executing for setuid/setgid bits, and * attempt to emulate setuid/setgid on systems that have disabled * setuid #! scripts because the kernel can't do it securely. * It is up to the package designer to make sure that this emulation * is done securely. Among other things, it should do an fstat on * the script it just opened to make sure it really is a setuid/setgid * script, it should make sure the arguments passed correspond exactly * to the argument on the #! line, and it should not trust any * subprocesses to which it must pass the filename rather than the * file descriptor of the script to be executed. */ /*#define SETUID_SCRIPTS_ARE_SECURE_NOW / **/ /*#define DOSUID / **/ /* PERL_USE_DEVEL: * This symbol, if defined, indicates that Perl was configured with * -Dusedevel, to enable development features. This should not be * done for production builds. */ /*#define PERL_USE_DEVEL / **/ /* HAS_ATOLF: * This symbol, if defined, indicates that the atolf routine is * available to convert strings into long doubles. */ /*#define HAS_ATOLF / **/ /* HAS_ATOLL: * This symbol, if defined, indicates that the atoll routine is * available to convert strings into long longs. */ #define HAS_ATOLL /**/ /* HAS__FWALK: * This symbol, if defined, indicates that the _fwalk system call is * available to apply a function to all the file handles. */ /*#define HAS__FWALK / **/ /* HAS_AINTL: * This symbol, if defined, indicates that the aintl routine is * available. If copysignl is also present we can emulate modfl. */ /*#define HAS_AINTL / **/ /* HAS_BUILTIN_CHOOSE_EXPR: * Can we handle GCC builtin for compile-time ternary-like expressions */ /* HAS_BUILTIN_EXPECT: * Can we handle GCC builtin for telling that certain values are more * likely */ /*#define HAS_BUILTIN_EXPECT / **/ /*#define HAS_BUILTIN_CHOOSE_EXPR / **/ /* HAS_C99_VARIADIC_MACROS: * If defined, the compiler supports C99 variadic macros. */ /*#define HAS_C99_VARIADIC_MACROS / **/ /* HAS_CLASS: * This symbol, if defined, indicates that the class routine is * available to classify doubles. Available for example in AIX. * The returned values are defined in and are: * * FP_PLUS_NORM Positive normalized, nonzero * FP_MINUS_NORM Negative normalized, nonzero * FP_PLUS_DENORM Positive denormalized, nonzero * FP_MINUS_DENORM Negative denormalized, nonzero * FP_PLUS_ZERO +0.0 * FP_MINUS_ZERO -0.0 * FP_PLUS_INF +INF * FP_MINUS_INF -INF * FP_NANS Signaling Not a Number (NaNS) * FP_NANQ Quiet Not a Number (NaNQ) */ /*#define HAS_CLASS / **/ /* HAS_CLEARENV: * This symbol, if defined, indicates that the clearenv () routine is * available for use. */ /*#define HAS_CLEARENV / **/ /* HAS_STRUCT_CMSGHDR: * This symbol, if defined, indicates that the struct cmsghdr * is supported. */ /*#define HAS_STRUCT_CMSGHDR / **/ /* HAS_COPYSIGNL: * This symbol, if defined, indicates that the copysignl routine is * available. If aintl is also present we can emulate modfl. */ /*#define HAS_COPYSIGNL / **/ /* USE_CPLUSPLUS: * This symbol, if defined, indicates that a C++ compiler was * used to compiled Perl and will be used to compile extensions. */ /*#define USE_CPLUSPLUS / **/ /* HAS_DBMINIT_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the dbminit() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int dbminit(char *); */ /*#define HAS_DBMINIT_PROTO / **/ /* HAS_DIR_DD_FD: * This symbol, if defined, indicates that the the DIR* dirstream * structure contains a member variable named dd_fd. */ /*#define HAS_DIR_DD_FD / **/ /* HAS_DIRFD: * This manifest constant lets the C program know that dirfd * is available. */ /*#define HAS_DIRFD / **/ /* DLSYM_NEEDS_UNDERSCORE: * This symbol, if defined, indicates that we need to prepend an * underscore to the symbol name before calling dlsym(). This only * makes sense if you *have* dlsym, which we will presume is the * case if you're using dl_dlopen.xs. */ /*#define DLSYM_NEEDS_UNDERSCORE / **/ /* HAS_FAST_STDIO: * This symbol, if defined, indicates that the "fast stdio" * is available to manipulate the stdio buffers directly. */ #define HAS_FAST_STDIO /**/ /* HAS_FCHDIR: * This symbol, if defined, indicates that the fchdir routine is * available to change directory using a file descriptor. */ /*#define HAS_FCHDIR / **/ /* FCNTL_CAN_LOCK: * This symbol, if defined, indicates that fcntl() can be used * for file locking. Normally on Unix systems this is defined. * It may be undefined on VMS. */ /*#define FCNTL_CAN_LOCK / **/ /* HAS_FINITE: * This symbol, if defined, indicates that the finite routine is * available to check whether a double is finite (non-infinity non-NaN). */ /*#define HAS_FINITE / **/ /* HAS_FINITEL: * This symbol, if defined, indicates that the finitel routine is * available to check whether a long double is finite * (non-infinity non-NaN). */ /*#define HAS_FINITEL / **/ /* HAS_FLOCK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the flock() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int flock(int, int); */ #define HAS_FLOCK_PROTO /**/ /* HAS_FP_CLASS: * This symbol, if defined, indicates that the fp_class routine is * available to classify doubles. Available for example in Digital UNIX. * The returned values are defined in and are: * * FP_SNAN Signaling NaN (Not-a-Number) * FP_QNAN Quiet NaN (Not-a-Number) * FP_POS_INF +infinity * FP_NEG_INF -infinity * FP_POS_NORM Positive normalized * FP_NEG_NORM Negative normalized * FP_POS_DENORM Positive denormalized * FP_NEG_DENORM Negative denormalized * FP_POS_ZERO +0.0 (positive zero) * FP_NEG_ZERO -0.0 (negative zero) */ /*#define HAS_FP_CLASS / **/ /* HAS_FPCLASS: * This symbol, if defined, indicates that the fpclass routine is * available to classify doubles. Available for example in Solaris/SVR4. * The returned values are defined in and are: * * FP_SNAN signaling NaN * FP_QNAN quiet NaN * FP_NINF negative infinity * FP_PINF positive infinity * FP_NDENORM negative denormalized non-zero * FP_PDENORM positive denormalized non-zero * FP_NZERO negative zero * FP_PZERO positive zero * FP_NNORM negative normalized non-zero * FP_PNORM positive normalized non-zero */ /*#define HAS_FPCLASS / **/ /* HAS_FPCLASSIFY: * This symbol, if defined, indicates that the fpclassify routine is * available to classify doubles. Available for example in HP-UX. * The returned values are defined in and are * * FP_NORMAL Normalized * FP_ZERO Zero * FP_INFINITE Infinity * FP_SUBNORMAL Denormalized * FP_NAN NaN * */ /*#define HAS_FPCLASSIFY / **/ /* HAS_FPCLASSL: * This symbol, if defined, indicates that the fpclassl routine is * available to classify long doubles. Available for example in IRIX. * The returned values are defined in and are: * * FP_SNAN signaling NaN * FP_QNAN quiet NaN * FP_NINF negative infinity * FP_PINF positive infinity * FP_NDENORM negative denormalized non-zero * FP_PDENORM positive denormalized non-zero * FP_NZERO negative zero * FP_PZERO positive zero * FP_NNORM negative normalized non-zero * FP_PNORM positive normalized non-zero */ /*#define HAS_FPCLASSL / **/ /* HAS_FPOS64_T: * This symbol will be defined if the C compiler supports fpos64_t. */ /*#define HAS_FPOS64_T / **/ /* HAS_FREXPL: * This symbol, if defined, indicates that the frexpl routine is * available to break a long double floating-point number into * a normalized fraction and an integral power of 2. */ /*#define HAS_FREXPL / **/ /* HAS_STRUCT_FS_DATA: * This symbol, if defined, indicates that the struct fs_data * to do statfs() is supported. */ /*#define HAS_STRUCT_FS_DATA / **/ /* HAS_FSEEKO: * This symbol, if defined, indicates that the fseeko routine is * available to fseek beyond 32 bits (useful for ILP32 hosts). */ /*#define HAS_FSEEKO / **/ /* HAS_FSTATFS: * This symbol, if defined, indicates that the fstatfs routine is * available to stat filesystems by file descriptors. */ /*#define HAS_FSTATFS / **/ /* HAS_FSYNC: * This symbol, if defined, indicates that the fsync routine is * available to write a file's modified data and attributes to * permanent storage. */ /*#define HAS_FSYNC / **/ /* HAS_FTELLO: * This symbol, if defined, indicates that the ftello routine is * available to ftell beyond 32 bits (useful for ILP32 hosts). */ /*#define HAS_FTELLO / **/ /* HAS_FUTIMES: * This symbol, if defined, indicates that the futimes routine is * available to change file descriptor time stamps with struct timevals. */ /*#define HAS_FUTIMES / **/ /* HAS_GETADDRINFO: * This symbol, if defined, indicates that the getaddrinfo() function * is available for use. */ /*#define HAS_GETADDRINFO / **/ /* HAS_GETCWD: * This symbol, if defined, indicates that the getcwd routine is * available to get the current working directory. */ #define HAS_GETCWD /**/ /* HAS_GETESPWNAM: * This symbol, if defined, indicates that the getespwnam system call is * available to retrieve enchanced (shadow) password entries by name. */ /*#define HAS_GETESPWNAM / **/ /* HAS_GETFSSTAT: * This symbol, if defined, indicates that the getfsstat routine is * available to stat filesystems in bulk. */ /*#define HAS_GETFSSTAT / **/ /* HAS_GETITIMER: * This symbol, if defined, indicates that the getitimer routine is * available to return interval timers. */ /*#define HAS_GETITIMER / **/ /* HAS_GETMNT: * This symbol, if defined, indicates that the getmnt routine is * available to get filesystem mount info by filename. */ /*#define HAS_GETMNT / **/ /* HAS_GETMNTENT: * This symbol, if defined, indicates that the getmntent routine is * available to iterate through mounted file systems to get their info. */ /*#define HAS_GETMNTENT / **/ /* HAS_GETNAMEINFO: * This symbol, if defined, indicates that the getnameinfo() function * is available for use. */ /*#define HAS_GETNAMEINFO / **/ /* HAS_GETPRPWNAM: * This symbol, if defined, indicates that the getprpwnam system call is * available to retrieve protected (shadow) password entries by name. */ /*#define HAS_GETPRPWNAM / **/ /* HAS_GETSPNAM: * This symbol, if defined, indicates that the getspnam system call is * available to retrieve SysV shadow password entries by name. */ /*#define HAS_GETSPNAM / **/ /* HAS_HASMNTOPT: * This symbol, if defined, indicates that the hasmntopt routine is * available to query the mount options of file systems. */ /*#define HAS_HASMNTOPT / **/ /* HAS_ILOGBL: * This symbol, if defined, indicates that the ilogbl routine is * available. If scalbnl is also present we can emulate frexpl. */ /*#define HAS_ILOGBL / **/ /* HAS_INETNTOP: * This symbol, if defined, indicates that the inet_ntop() function * is available to parse IPv4 and IPv6 strings. */ /*#define HAS_INETNTOP / **/ /* HAS_INETPTON: * This symbol, if defined, indicates that the inet_pton() function * is available to parse IPv4 and IPv6 strings. */ /*#define HAS_INETPTON / **/ /* HAS_INT64_T: * This symbol will defined if the C compiler supports int64_t. * Usually the needs to be included, but sometimes * is enough. */ /*#define HAS_INT64_T / **/ /* HAS_ISFINITE: * This symbol, if defined, indicates that the isfinite routine is * available to check whether a double is finite (non-infinity non-NaN). */ /*#define HAS_ISFINITE / **/ /* HAS_ISINF: * This symbol, if defined, indicates that the isinf routine is * available to check whether a double is an infinity. */ /*#define HAS_ISINF / **/ /* HAS_ISNAN: * This symbol, if defined, indicates that the isnan routine is * available to check whether a double is a NaN. */ #define HAS_ISNAN /**/ /* HAS_ISNANL: * This symbol, if defined, indicates that the isnanl routine is * available to check whether a long double is a NaN. */ /*#define HAS_ISNANL / **/ /* HAS_LDBL_DIG: * This symbol, if defined, indicates that this system's * or defines the symbol LDBL_DIG, which is the number * of significant digits in a long double precision number. Unlike * for DBL_DIG, there's no good guess for LDBL_DIG if it is undefined. */ #define HAS_LDBL_DIG /**/ /* LIBM_LIB_VERSION: * This symbol, if defined, indicates that libm exports _LIB_VERSION * and that math.h defines the enum to manipulate it. */ /*#define LIBM_LIB_VERSION / **/ /* HAS_MADVISE: * This symbol, if defined, indicates that the madvise system call is * available to map a file into memory. */ /*#define HAS_MADVISE / **/ /* HAS_MALLOC_SIZE: * This symbol, if defined, indicates that the malloc_size * routine is available for use. */ /*#define HAS_MALLOC_SIZE / **/ /* HAS_MALLOC_GOOD_SIZE: * This symbol, if defined, indicates that the malloc_good_size * routine is available for use. */ /*#define HAS_MALLOC_GOOD_SIZE / **/ /* HAS_MKDTEMP: * This symbol, if defined, indicates that the mkdtemp routine is * available to exclusively create a uniquely named temporary directory. */ /*#define HAS_MKDTEMP / **/ /* HAS_MKSTEMPS: * This symbol, if defined, indicates that the mkstemps routine is * available to excluslvely create and open a uniquely named * (with a suffix) temporary file. */ /*#define HAS_MKSTEMPS / **/ /* HAS_MODFL: * This symbol, if defined, indicates that the modfl routine is * available to split a long double x into a fractional part f and * an integer part i such that |f| < 1.0 and (f + i) = x. */ /* HAS_MODFL_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the modfl() function. Otherwise, it is up * to the program to supply one. */ /* HAS_MODFL_POW32_BUG: * This symbol, if defined, indicates that the modfl routine is * broken for long doubles >= pow(2, 32). * For example from 4294967303.150000 one would get 4294967302.000000 * and 1.150000. The bug has been seen in certain versions of glibc, * release 2.2.2 is known to be okay. */ /*#define HAS_MODFL / **/ /*#define HAS_MODFL_PROTO / **/ /*#define HAS_MODFL_POW32_BUG / **/ /* HAS_MPROTECT: * This symbol, if defined, indicates that the mprotect system call is * available to modify the access protection of a memory mapped file. */ /*#define HAS_MPROTECT / **/ /* HAS_STRUCT_MSGHDR: * This symbol, if defined, indicates that the struct msghdr * is supported. */ /*#define HAS_STRUCT_MSGHDR / **/ /* HAS_NL_LANGINFO: * This symbol, if defined, indicates that the nl_langinfo routine is * available to return local data. You will also need * and therefore I_LANGINFO. */ /*#define HAS_NL_LANGINFO / **/ /* HAS_OFF64_T: * This symbol will be defined if the C compiler supports off64_t. */ /*#define HAS_OFF64_T / **/ /* HAS_PROCSELFEXE: * This symbol is defined if PROCSELFEXE_PATH is a symlink * to the absolute pathname of the executing program. */ /* PROCSELFEXE_PATH: * If HAS_PROCSELFEXE is defined this symbol is the filename * of the symbolic link pointing to the absolute pathname of * the executing program. */ /*#define HAS_PROCSELFEXE / **/ #if defined(HAS_PROCSELFEXE) && !defined(PROCSELFEXE_PATH) #define PROCSELFEXE_PATH /**/ #endif /* HAS_PTHREAD_ATTR_SETSCOPE: * This symbol, if defined, indicates that the pthread_attr_setscope * system call is available to set the contention scope attribute of * a thread attribute object. */ /*#define HAS_PTHREAD_ATTR_SETSCOPE / **/ /* HAS_READV: * This symbol, if defined, indicates that the readv routine is * available to do gather reads. You will also need * and there I_SYSUIO. */ /*#define HAS_READV / **/ /* HAS_RECVMSG: * This symbol, if defined, indicates that the recvmsg routine is * available to send structured socket messages. */ /*#define HAS_RECVMSG / **/ /* HAS_SBRK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the sbrk() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern void* sbrk(int); * extern void* sbrk(size_t); */ /*#define HAS_SBRK_PROTO / **/ /* HAS_SCALBNL: * This symbol, if defined, indicates that the scalbnl routine is * available. If ilogbl is also present we can emulate frexpl. */ /*#define HAS_SCALBNL / **/ /* HAS_SENDMSG: * This symbol, if defined, indicates that the sendmsg routine is * available to send structured socket messages. */ /*#define HAS_SENDMSG / **/ /* HAS_SETITIMER: * This symbol, if defined, indicates that the setitimer routine is * available to set interval timers. */ /*#define HAS_SETITIMER / **/ /* HAS_SETPROCTITLE: * This symbol, if defined, indicates that the setproctitle routine is * available to set process title. */ /*#define HAS_SETPROCTITLE / **/ /* USE_SFIO: * This symbol, if defined, indicates that sfio should * be used. */ /*#define USE_SFIO / **/ /* HAS_SIGNBIT: * This symbol, if defined, indicates that the signbit routine is * available to check if the given number has the sign bit set. * This should include correct testing of -0.0. This will only be set * if the signbit() routine is safe to use with the NV type used internally * in perl. Users should call Perl_signbit(), which will be #defined to * the system's signbit() function or macro if this symbol is defined. */ /*#define HAS_SIGNBIT / **/ /* HAS_SIGPROCMASK: * This symbol, if defined, indicates that the sigprocmask * system call is available to examine or change the signal mask * of the calling process. */ /*#define HAS_SIGPROCMASK / **/ /* USE_SITECUSTOMIZE: * This symbol, if defined, indicates that sitecustomize should * be used. */ #ifndef USE_SITECUSTOMIZE /*#define USE_SITECUSTOMIZE / **/ #endif /* HAS_SNPRINTF: * This symbol, if defined, indicates that the snprintf () library * function is available for use. */ /* HAS_VSNPRINTF: * This symbol, if defined, indicates that the vsnprintf () library * function is available for use. */ #define HAS_SNPRINTF /**/ #define HAS_VSNPRINTF /**/ /* HAS_SOCKATMARK: * This symbol, if defined, indicates that the sockatmark routine is * available to test whether a socket is at the out-of-band mark. */ /*#define HAS_SOCKATMARK / **/ /* HAS_SOCKATMARK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the sockatmark() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int sockatmark(int); */ /*#define HAS_SOCKATMARK_PROTO / **/ /* HAS_SOCKS5_INIT: * This symbol, if defined, indicates that the socks5_init routine is * available to initialize SOCKS 5. */ /*#define HAS_SOCKS5_INIT / **/ /* SPRINTF_RETURNS_STRLEN: * This variable defines whether sprintf returns the length of the string * (as per the ANSI spec). Some C libraries retain compatibility with * pre-ANSI C and return a pointer to the passed in buffer; for these * this variable will be undef. */ #define SPRINTF_RETURNS_STRLEN /**/ /* HAS_SQRTL: * This symbol, if defined, indicates that the sqrtl routine is * available to do long double square roots. */ /*#define HAS_SQRTL / **/ /* HAS_SETRESGID_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the setresgid() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern int setresgid(uid_t ruid, uid_t euid, uid_t suid); */ /*#define HAS_SETRESGID_PROTO / **/ /* HAS_SETRESUID_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the setresuid() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern int setresuid(uid_t ruid, uid_t euid, uid_t suid); */ /*#define HAS_SETRESUID_PROTO / **/ /* HAS_STRUCT_STATFS_F_FLAGS: * This symbol, if defined, indicates that the struct statfs * does have the f_flags member containing the mount flags of * the filesystem containing the file. * This kind of struct statfs is coming from (BSD 4.3), * not from (SYSV). Older BSDs (like Ultrix) do not * have statfs() and struct statfs, they have ustat() and getmnt() * with struct ustat and struct fs_data. */ /*#define HAS_STRUCT_STATFS_F_FLAGS / **/ /* HAS_STRUCT_STATFS: * This symbol, if defined, indicates that the struct statfs * to do statfs() is supported. */ /*#define HAS_STRUCT_STATFS / **/ /* HAS_FSTATVFS: * This symbol, if defined, indicates that the fstatvfs routine is * available to stat filesystems by file descriptors. */ /*#define HAS_FSTATVFS / **/ /* HAS_STRFTIME: * This symbol, if defined, indicates that the strftime routine is * available to do time formatting. */ #define HAS_STRFTIME /**/ /* HAS_STRLCAT: * This symbol, if defined, indicates that the strlcat () routine is * available to do string concatenation. */ /*#define HAS_STRLCAT / **/ /* HAS_STRLCPY: * This symbol, if defined, indicates that the strlcpy () routine is * available to do string copying. */ /*#define HAS_STRLCPY / **/ /* HAS_STRTOLD: * This symbol, if defined, indicates that the strtold routine is * available to convert strings to long doubles. */ /*#define HAS_STRTOLD / **/ /* HAS_STRTOLL: * This symbol, if defined, indicates that the strtoll routine is * available to convert strings to long longs. */ #define HAS_STRTOLL /**/ /* HAS_STRTOQ: * This symbol, if defined, indicates that the strtoq routine is * available to convert strings to long longs (quads). */ /*#define HAS_STRTOQ / **/ /* HAS_STRTOULL: * This symbol, if defined, indicates that the strtoull routine is * available to convert strings to unsigned long longs. */ #define HAS_STRTOULL /**/ /* HAS_STRTOUQ: * This symbol, if defined, indicates that the strtouq routine is * available to convert strings to unsigned long longs (quads). */ /*#define HAS_STRTOUQ / **/ /* HAS_SYSCALL_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the syscall() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern int syscall(int, ...); * extern int syscall(long, ...); */ /*#define HAS_SYSCALL_PROTO / **/ /* HAS_TELLDIR_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the telldir() function. Otherwise, it is up * to the program to supply one. A good guess is * extern long telldir(DIR*); */ #define HAS_TELLDIR_PROTO /**/ /* HAS_CTIME64: * This symbol, if defined, indicates that the ctime64 () routine is * available to do the 64bit variant of ctime () */ /* HAS_LOCALTIME64: * This symbol, if defined, indicates that the localtime64 () routine is * available to do the 64bit variant of localtime () */ /* HAS_GMTIME64: * This symbol, if defined, indicates that the gmtime64 () routine is * available to do the 64bit variant of gmtime () */ /* HAS_MKTIME64: * This symbol, if defined, indicates that the mktime64 () routine is * available to do the 64bit variant of mktime () */ /* HAS_DIFFTIME64: * This symbol, if defined, indicates that the difftime64 () routine is * available to do the 64bit variant of difftime () */ /* HAS_ASCTIME64: * This symbol, if defined, indicates that the asctime64 () routine is * available to do the 64bit variant of asctime () */ /*#define HAS_CTIME64 / **/ /*#define HAS_LOCALTIME64 / **/ /*#define HAS_GMTIME64 / **/ /*#define HAS_MKTIME64 / **/ /*#define HAS_DIFFTIME64 / **/ /*#define HAS_ASCTIME64 / **/ /* HAS_TIMEGM: * This symbol, if defined, indicates that the timegm routine is * available to do the opposite of gmtime () */ /*#define HAS_TIMEGM / **/ /* U32_ALIGNMENT_REQUIRED: * This symbol, if defined, indicates that you must access * character data through U32-aligned pointers. */ #ifndef U32_ALIGNMENT_REQUIRED #define U32_ALIGNMENT_REQUIRED /**/ #endif /* HAS_UALARM: * This symbol, if defined, indicates that the ualarm routine is * available to do alarms with microsecond granularity. */ /*#define HAS_UALARM / **/ /* HAS_UNORDERED: * This symbol, if defined, indicates that the unordered routine is * available to check whether two doubles are unordered * (effectively: whether either of them is NaN) */ /*#define HAS_UNORDERED / **/ /* HAS_UNSETENV: * This symbol, if defined, indicates that the unsetenv () routine is * available for use. */ /*#define HAS_UNSETENV / **/ /* HAS_USLEEP_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the usleep() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int usleep(useconds_t); */ /*#define HAS_USLEEP_PROTO / **/ /* HAS_USTAT: * This symbol, if defined, indicates that the ustat system call is * available to query file system statistics by dev_t. */ /*#define HAS_USTAT / **/ /* HAS_WRITEV: * This symbol, if defined, indicates that the writev routine is * available to do scatter writes. */ /*#define HAS_WRITEV / **/ /* USE_DYNAMIC_LOADING: * This symbol, if defined, indicates that dynamic loading of * some sort is available. */ #define USE_DYNAMIC_LOADING /**/ /* FFLUSH_NULL: * This symbol, if defined, tells that fflush(NULL) does flush * all pending stdio output. */ /* FFLUSH_ALL: * This symbol, if defined, tells that to flush * all pending stdio output one must loop through all * the stdio file handles stored in an array and fflush them. * Note that if fflushNULL is defined, fflushall will not * even be probed for and will be left undefined. */ #define FFLUSH_NULL /**/ /*#define FFLUSH_ALL / **/ /* I_ASSERT: * This symbol, if defined, indicates that exists and * could be included by the C program to get the assert() macro. */ #define I_ASSERT /**/ /* I_CRYPT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_CRYPT / **/ /* DB_Prefix_t: * This symbol contains the type of the prefix structure element * in the header file. In older versions of DB, it was * int, while in newer ones it is u_int32_t. */ /* DB_Hash_t: * This symbol contains the type of the prefix structure element * in the header file. In older versions of DB, it was * int, while in newer ones it is size_t. */ /* DB_VERSION_MAJOR_CFG: * This symbol, if defined, defines the major version number of * Berkeley DB found in the header when Perl was configured. */ /* DB_VERSION_MINOR_CFG: * This symbol, if defined, defines the minor version number of * Berkeley DB found in the header when Perl was configured. * For DB version 1 this is always 0. */ /* DB_VERSION_PATCH_CFG: * This symbol, if defined, defines the patch version number of * Berkeley DB found in the header when Perl was configured. * For DB version 1 this is always 0. */ #define DB_Hash_t int /**/ #define DB_Prefix_t int /**/ #define DB_VERSION_MAJOR_CFG 0 /**/ #define DB_VERSION_MINOR_CFG 0 /**/ #define DB_VERSION_PATCH_CFG 0 /**/ /* I_FP: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_FP / **/ /* I_FP_CLASS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_FP_CLASS / **/ /* I_IEEEFP: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_IEEEFP / **/ /* I_INTTYPES: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_INTTYPES / **/ /* I_LANGINFO: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_LANGINFO / **/ /* I_LIBUTIL: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_LIBUTIL / **/ /* I_MALLOCMALLOC: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_MALLOCMALLOC / **/ /* I_MNTENT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_MNTENT / **/ /* I_NETINET_TCP: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_NETINET_TCP / **/ /* I_POLL: * This symbol, if defined, indicates that exists and * should be included. (see also HAS_POLL) */ /*#define I_POLL / **/ /* I_PROT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_PROT / **/ /* I_SHADOW: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SHADOW / **/ /* I_SOCKS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SOCKS / **/ /* I_SUNMATH: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SUNMATH / **/ /* I_SYSLOG: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSLOG / **/ /* I_SYSMODE: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSMODE / **/ /* I_SYS_MOUNT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYS_MOUNT / **/ /* I_SYS_STATFS: * This symbol, if defined, indicates that exists. */ /*#define I_SYS_STATFS / **/ /* I_SYS_STATVFS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYS_STATVFS / **/ /* I_SYSUTSNAME: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSUTSNAME / **/ /* I_SYS_VFS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYS_VFS / **/ /* I_USTAT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_USTAT / **/ /* PERL_PRIfldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'f') for output. */ /* PERL_PRIgldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'g') for output. */ /* PERL_PRIeldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'e') for output. */ /* PERL_SCNfldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'f') for input. */ /*#define PERL_PRIfldbl "f" / **/ /*#define PERL_PRIgldbl "g" / **/ /*#define PERL_PRIeldbl "e" / **/ /*#define PERL_SCNfldbl "f" / **/ /* PERL_MAD: * This symbol, if defined, indicates that the Misc Attribution * Declaration code should be conditionally compiled. */ /*#define PERL_MAD / **/ /* NEED_VA_COPY: * This symbol, if defined, indicates that the system stores * the variable argument list datatype, va_list, in a format * that cannot be copied by simple assignment, so that some * other means must be used when copying is required. * As such systems vary in their provision (or non-provision) * of copying mechanisms, handy.h defines a platform- * independent macro, Perl_va_copy(src, dst), to do the job. */ /*#define NEED_VA_COPY / **/ /* IVTYPE: * This symbol defines the C type used for Perl's IV. */ /* UVTYPE: * This symbol defines the C type used for Perl's UV. */ /* I8TYPE: * This symbol defines the C type used for Perl's I8. */ /* U8TYPE: * This symbol defines the C type used for Perl's U8. */ /* I16TYPE: * This symbol defines the C type used for Perl's I16. */ /* U16TYPE: * This symbol defines the C type used for Perl's U16. */ /* I32TYPE: * This symbol defines the C type used for Perl's I32. */ /* U32TYPE: * This symbol defines the C type used for Perl's U32. */ /* I64TYPE: * This symbol defines the C type used for Perl's I64. */ /* U64TYPE: * This symbol defines the C type used for Perl's U64. */ /* NVTYPE: * This symbol defines the C type used for Perl's NV. */ /* IVSIZE: * This symbol contains the sizeof(IV). */ /* UVSIZE: * This symbol contains the sizeof(UV). */ /* I8SIZE: * This symbol contains the sizeof(I8). */ /* U8SIZE: * This symbol contains the sizeof(U8). */ /* I16SIZE: * This symbol contains the sizeof(I16). */ /* U16SIZE: * This symbol contains the sizeof(U16). */ /* I32SIZE: * This symbol contains the sizeof(I32). */ /* U32SIZE: * This symbol contains the sizeof(U32). */ /* I64SIZE: * This symbol contains the sizeof(I64). */ /* U64SIZE: * This symbol contains the sizeof(U64). */ /* NVSIZE: * This symbol contains the sizeof(NV). */ /* NV_PRESERVES_UV: * This symbol, if defined, indicates that a variable of type NVTYPE * can preserve all the bits of a variable of type UVTYPE. */ /* NV_PRESERVES_UV_BITS: * This symbol contains the number of bits a variable of type NVTYPE * can preserve of a variable of type UVTYPE. */ /* NV_OVERFLOWS_INTEGERS_AT: * This symbol gives the largest integer value that NVs can hold. This * value + 1.0 cannot be stored accurately. It is expressed as constant * floating point expression to reduce the chance of decimale/binary * conversion issues. If it can not be determined, the value 0 is given. */ /* NV_ZERO_IS_ALLBITS_ZERO: * This symbol, if defined, indicates that a variable of type NVTYPE * stores 0.0 in memory as all bits zero. */ #ifdef _MSC_VER # define IVTYPE __int64 /**/ # define UVTYPE unsigned __int64 /**/ #else # define IVTYPE long long /**/ # define UVTYPE unsigned long long /**/ #endif #define I8TYPE char /**/ #define U8TYPE unsigned char /**/ #define I16TYPE short /**/ #define U16TYPE unsigned short /**/ #define I32TYPE long /**/ #define U32TYPE unsigned long /**/ #ifdef HAS_QUAD # ifdef _MSC_VER # define I64TYPE __int64 /**/ # define U64TYPE unsigned __int64 /**/ # else # define I64TYPE long long /**/ # define U64TYPE unsigned long long /**/ # endif #endif #define NVTYPE double /**/ #define IVSIZE 8 /**/ #define UVSIZE 8 /**/ #define I8SIZE 1 /**/ #define U8SIZE 1 /**/ #define I16SIZE 2 /**/ #define U16SIZE 2 /**/ #define I32SIZE 4 /**/ #define U32SIZE 4 /**/ #ifdef HAS_QUAD #define I64SIZE 8 /**/ #define U64SIZE 8 /**/ #endif #define NVSIZE 8 /**/ #undef NV_PRESERVES_UV #define NV_PRESERVES_UV_BITS 53 #define NV_OVERFLOWS_INTEGERS_AT 256.0*256.0*256.0*256.0*256.0*256.0*2.0*2.0*2.0*2.0*2.0 #define NV_ZERO_IS_ALLBITS_ZERO #if UVSIZE == 8 # ifdef BYTEORDER # if BYTEORDER == 0x1234 # undef BYTEORDER # define BYTEORDER 0x12345678 # else # if BYTEORDER == 0x4321 # undef BYTEORDER # define BYTEORDER 0x87654321 # endif # endif # endif #endif /* IVdf: * This symbol defines the format string used for printing a Perl IV * as a signed decimal integer. */ /* UVuf: * This symbol defines the format string used for printing a Perl UV * as an unsigned decimal integer. */ /* UVof: * This symbol defines the format string used for printing a Perl UV * as an unsigned octal integer. */ /* UVxf: * This symbol defines the format string used for printing a Perl UV * as an unsigned hexadecimal integer in lowercase abcdef. */ /* UVXf: * This symbol defines the format string used for printing a Perl UV * as an unsigned hexadecimal integer in uppercase ABCDEF. */ /* NVef: * This symbol defines the format string used for printing a Perl NV * using %e-ish floating point format. */ /* NVff: * This symbol defines the format string used for printing a Perl NV * using %f-ish floating point format. */ /* NVgf: * This symbol defines the format string used for printing a Perl NV * using %g-ish floating point format. */ #define IVdf "I64d" /**/ #define UVuf "I64u" /**/ #define UVof "I64o" /**/ #define UVxf "I64x" /**/ #define UVXf "I64X" /**/ #define NVef "e" /**/ #define NVff "f" /**/ #define NVgf "g" /**/ /* SELECT_MIN_BITS: * This symbol holds the minimum number of bits operated by select. * That is, if you do select(n, ...), how many bits at least will be * cleared in the masks if some activity is detected. Usually this * is either n or 32*ceil(n/32), especially many little-endians do * the latter. This is only useful if you have select(), naturally. */ #define SELECT_MIN_BITS 32 /**/ /* STARTPERL: * This variable contains the string to put in front of a perl * script to make sure (one hopes) that it runs with perl and not * some shell. */ #define STARTPERL "#!perl" /**/ /* HAS_STDIO_STREAM_ARRAY: * This symbol, if defined, tells that there is an array * holding the stdio streams. */ /* STDIO_STREAM_ARRAY: * This symbol tells the name of the array holding the stdio streams. * Usual values include _iob, __iob, and __sF. */ /*#define HAS_STDIO_STREAM_ARRAY / **/ #ifdef HAS_STDIO_STREAM_ARRAY #define STDIO_STREAM_ARRAY #endif /* GMTIME_MAX: * This symbol contains the maximum value for the time_t offset that * the system function gmtime () accepts, and defaults to 0 */ /* GMTIME_MIN: * This symbol contains the minimum value for the time_t offset that * the system function gmtime () accepts, and defaults to 0 */ /* LOCALTIME_MAX: * This symbol contains the maximum value for the time_t offset that * the system function localtime () accepts, and defaults to 0 */ /* LOCALTIME_MIN: * This symbol contains the minimum value for the time_t offset that * the system function localtime () accepts, and defaults to 0 */ #define GMTIME_MAX 2147483647 /**/ #define GMTIME_MIN 0 /**/ #define LOCALTIME_MAX 2147483647 /**/ #define LOCALTIME_MIN 0 /**/ /* USE_64_BIT_INT: * This symbol, if defined, indicates that 64-bit integers should * be used when available. If not defined, the native integers * will be employed (be they 32 or 64 bits). The minimal possible * 64-bitness is used, just enough to get 64-bit integers into Perl. * This may mean using for example "long longs", while your memory * may still be limited to 2 gigabytes. */ /* USE_64_BIT_ALL: * This symbol, if defined, indicates that 64-bit integers should * be used when available. If not defined, the native integers * will be used (be they 32 or 64 bits). The maximal possible * 64-bitness is employed: LP64 or ILP64, meaning that you will * be able to use more than 2 gigabytes of memory. This mode is * even more binary incompatible than USE_64_BIT_INT. You may not * be able to run the resulting executable in a 32-bit CPU at all or * you may need at least to reboot your OS to 64-bit mode. */ #ifndef USE_64_BIT_INT #define USE_64_BIT_INT /**/ #endif #ifndef USE_64_BIT_ALL /*#define USE_64_BIT_ALL / **/ #endif /* USE_DTRACE: * This symbol, if defined, indicates that Perl should * be built with support for DTrace. */ /*#define USE_DTRACE / **/ /* USE_FAST_STDIO: * This symbol, if defined, indicates that Perl should * be built to use 'fast stdio'. * Defaults to define in Perls 5.8 and earlier, to undef later. */ #ifndef USE_FAST_STDIO /*#define USE_FAST_STDIO / **/ #endif /* USE_LARGE_FILES: * This symbol, if defined, indicates that large file support * should be used when available. */ #ifndef USE_LARGE_FILES #define USE_LARGE_FILES /**/ #endif /* USE_LONG_DOUBLE: * This symbol, if defined, indicates that long doubles should * be used when available. */ #ifndef USE_LONG_DOUBLE /*#define USE_LONG_DOUBLE / **/ #endif /* USE_MORE_BITS: * This symbol, if defined, indicates that 64-bit interfaces and * long doubles should be used when available. */ #ifndef USE_MORE_BITS /*#define USE_MORE_BITS / **/ #endif /* MULTIPLICITY: * This symbol, if defined, indicates that Perl should * be built to use multiplicity. */ #ifndef MULTIPLICITY #define MULTIPLICITY /**/ #endif /* USE_PERLIO: * This symbol, if defined, indicates that the PerlIO abstraction should * be used throughout. If not defined, stdio should be * used in a fully backward compatible manner. */ #ifndef USE_PERLIO #define USE_PERLIO /**/ #endif /* USE_SOCKS: * This symbol, if defined, indicates that Perl should * be built to use socks. */ #ifndef USE_SOCKS /*#define USE_SOCKS / **/ #endif #endif perl-5.12.0-RC0/win32/create_perllibst_h.pl0000444000175000017500000000144111325125742017260 0ustar jessejesse#!perl -w use strict; # creates perllibst.h file for inclusion from perllib.c use Config; my @statics = split /\s+/, $Config{static_ext}; open my $fh, '>', 'perllibst.h' or die "Failed to write to perllibst.h:$!"; my @statics1 = map {local $_=$_;s/\//__/g;$_} @statics; my @statics2 = map {local $_=$_;s/\//::/g;$_} @statics; print $fh "/*DO NOT EDIT\n this file is included from perllib.c to init static extensions */\n"; print $fh "#ifdef STATIC1\n",(map {" \"$_\",\n"} @statics),"#undef STATIC1\n#endif\n"; print $fh "#ifdef STATIC2\n",(map {" EXTERN_C void boot_$_ (pTHX_ CV* cv);\n"} @statics1),"#undef STATIC2\n#endif\n"; print $fh "#ifdef STATIC3\n",(map {" newXS(\"$statics2[$_]::bootstrap\", boot_$statics1[$_], file);\n"} 0 .. $#statics),"#undef STATIC3\n#endif\n"; close $fh; perl-5.12.0-RC0/win32/config.bc0000444000175000017500000005303211325127002014636 0ustar jessejesse## Configured by: ~cf_email~ ## Target system: WIN32 Author='' Date='$Date' Header='' Id='$Id' Locker='' Log='$Log' RCSfile='$RCSfile' Revision='$Revision' Source='' State='' _a='.lib' _exe='.exe' _o='.obj' afs='false' afsroot='/afs' alignbytes='8' ansi2knr='' aphostname='' api_revision='~PERL_API_REVISION~' api_subversion='~PERL_API_SUBVERSION~' api_version='~PERL_API_VERSION~' api_versionstring='~PERL_API_REVISION~.~PERL_API_VERSION~.~PERL_API_SUBVERSION~' ar='tlib /P128' archlib='~INST_TOP~~INST_VER~\lib~INST_ARCH~' archlibexp='~INST_TOP~~INST_VER~\lib~INST_ARCH~' archname64='' archname='MSWin32' archobjs='' asctime_r_proto='0' awk='awk' baserev='5' bash='' bin='~INST_TOP~~INST_VER~\bin~INST_ARCH~' binexp='~INST_TOP~~INST_VER~\bin~INST_ARCH~' bison='' byacc='byacc' byteorder='1234' c='' castflags='0' cat='type' cc='bcc32' cccdlflags=' ' ccdlflags='-tWD' ccflags='-DWIN32' ccflags_uselargefiles='' ccname='~cc~' ccsymbols='' ccversion='' cf_by='nobody' cf_email='nobody@no.where.net' cf_time='' charbits='8' chgrp='' chmod='' chown='' clocktype='clock_t' comm='' compress='' contains='grep' cp='copy' cpio='' cpp='cpp32 -oCON' cpp_stuff='42' cppccsymbols='' cppflags='-DWIN32' cpplast='' cppminus='' cpprun='cpp32 -oCON' cppstdin='cppstdin' cppsymbols='' crypt_r_proto='0' cryptlib='' csh='undef' ctermid_r_proto='0' ctime_r_proto='0' d_Gconvert='gcvt((x),(n),(b))' d_PRIEUldbl='undef' d_PRIFUldbl='undef' d_PRIGUldbl='undef' d_PRIXU64='undef' d_PRId64='undef' d_PRIeldbl='undef' d_PRIfldbl='undef' d_PRIgldbl='undef' d_PRIi64='undef' d_PRIo64='undef' d_PRIu64='undef' d_PRIx64='undef' d_SCNfldbl='undef' d__fwalk='undef' d_access='define' d_accessx='undef' d_aintl='undef' d_alarm='define' d_archlib='define' d_asctime64='undef' d_asctime_r='undef' d_atolf='undef' d_atoll='undef' d_attribute_deprecated='undef' d_attribute_format='undef' d_attribute_malloc='undef' d_attribute_nonnull='undef' d_attribute_noreturn='undef' d_attribute_pure='undef' d_attribute_unused='undef' d_attribute_warn_unused_result='undef' d_bcmp='undef' d_bcopy='undef' d_bsd='define' d_bsdgetpgrp='undef' d_bsdsetpgrp='undef' d_builtin_choose_expr='undef' d_builtin_expect='undef' d_bzero='undef' d_c99_variadic_macros='undef' d_casti32='define' d_castneg='define' d_charvspr='undef' d_chown='undef' d_chroot='undef' d_chsize='define' d_class='undef' d_clearenv='undef' d_closedir='define' d_cmsghdr_s='undef' d_const='define' d_copysignl='undef' d_cplusplus='undef' d_crypt='undef' d_crypt_r='undef' d_csh='undef' d_ctermid='undef' d_ctermid_r='undef' d_ctime64='undef' d_ctime_r='undef' d_cuserid='undef' d_dbl_dig='define' d_dbminitproto='undef' d_difftime64='undef' d_difftime='define' d_dir_dd_fd='undef' d_dirfd='undef' d_dirnamlen='define' d_dlerror='define' d_dlopen='define' d_dlsymun='undef' d_dosuid='undef' d_drand48_r='undef' d_drand48proto='undef' d_dup2='define' d_eaccess='undef' d_endgrent='undef' d_endgrent_r='undef' d_endhent='undef' d_endhostent_r='undef' d_endnent='undef' d_endnetent_r='undef' d_endpent='undef' d_endprotoent_r='undef' d_endpwent='undef' d_endpwent_r='undef' d_endsent='undef' d_endservent_r='undef' d_eofnblk='define' d_eunice='undef' d_faststdio='define' d_fchdir='undef' d_fchmod='undef' d_fchown='undef' d_fcntl_can_lock='undef' d_fcntl='undef' d_fd_macros='define' d_fd_set='define' d_fds_bits='define' d_fgetpos='define' d_finitel='undef' d_finite='undef' d_flexfnam='define' d_flock='define' d_flockproto='define' d_fork='undef' d_fp_class='undef' d_fpathconf='undef' d_fpclass='undef' d_fpclassify='undef' d_fpclassl='undef' d_fpos64_t='undef' d_frexpl='undef' d_fs_data_s='undef' d_fseeko='undef' d_fsetpos='define' d_fstatfs='undef' d_fstatvfs='undef' d_fsync='undef' d_ftello='undef' d_ftime='define' d_futimes='undef' d_gdbm_ndbm_h_uses_prototypes='undef' d_gdbmndbm_h_uses_prototypes='undef' d_getaddrinfo='undef' d_getcwd='define' d_getespwnam='undef' d_getfsstat='undef' d_getgrent='undef' d_getgrent_r='undef' d_getgrgid_r='undef' d_getgrnam_r='undef' d_getgrps='undef' d_gethbyaddr='define' d_gethbyname='define' d_gethent='undef' d_gethname='define' d_gethostbyaddr_r='undef' d_gethostbyname_r='undef' d_gethostent_r='undef' d_gethostprotos='define' d_getitimer='undef' d_getlogin='define' d_getlogin_r='undef' d_getmnt='undef' d_getmntent='undef' d_getnameinfo='undef' d_getnbyaddr='undef' d_getnbyname='undef' d_getnent='undef' d_getnetbyaddr_r='undef' d_getnetbyname_r='undef' d_getnetent_r='undef' d_getnetprotos='undef' d_getpagsz='undef' d_getpbyname='define' d_getpbynumber='define' d_getpent='undef' d_getpgid='undef' d_getpgrp2='undef' d_getpgrp='undef' d_getppid='undef' d_getprior='undef' d_getprotobyname_r='undef' d_getprotobynumber_r='undef' d_getprotoent_r='undef' d_getprotoprotos='define' d_getprpwnam='undef' d_getpwent='undef' d_getpwent_r='undef' d_getpwnam_r='undef' d_getpwuid_r='undef' d_getsbyname='define' d_getsbyport='define' d_getsent='undef' d_getservbyname_r='undef' d_getservbyport_r='undef' d_getservent_r='undef' d_getservprotos='define' d_getspnam='undef' d_getspnam_r='undef' d_gettimeod='define' d_gmtime64='undef' d_gmtime_r='undef' d_gnulibc='undef' d_grpasswd='undef' d_hasmntopt='undef' d_htonl='define' d_ilogbl='undef' d_inc_version_list='undef' d_index='undef' d_inetaton='undef' d_inetntop='undef' d_inetpton='undef' d_int64_t='undef' d_isascii='define' d_isfinite='undef' d_isinf='undef' d_isnan='define' d_isnanl='undef' d_killpg='define' d_lchown='undef' d_ldbl_dig='define' d_libm_lib_version='undef' d_link='define' d_localtime64='undef' d_localtime_r='undef' d_localtime_r_needs_tzset='undef' d_locconv='define' d_lockf='undef' d_longdbl='define' d_longlong='undef' d_lseekproto='define' d_lstat='undef' d_madvise='undef' d_malloc_good_size='undef' d_malloc_size='undef' d_mblen='define' d_mbstowcs='define' d_mbtowc='define' d_memchr='define' d_memcmp='define' d_memcpy='define' d_memmove='define' d_memset='define' d_mkdir='define' d_mkdtemp='undef' d_mkfifo='undef' d_mkstemp='undef' d_mkstemps='undef' d_mktime64='undef' d_mktime='define' d_mmap='undef' d_modfl='undef' d_modfl_pow32_bug='undef' d_modflproto='undef' d_mprotect='undef' d_msgctl='undef' d_msg_ctrunc='undef' d_msg_dontroute='undef' d_msgget='undef' d_msghdr_s='undef' d_msg_oob='undef' d_msg_peek='undef' d_msg_proxy='undef' d_msgrcv='undef' d_msgsnd='undef' d_msg='undef' d_msync='undef' d_munmap='undef' d_mymalloc='undef' d_ndbm='undef' d_ndbm_h_uses_prototypes='undef' d_nice='undef' d_nl_langinfo='undef' d_nv_preserves_uv='define' d_nv_zero_is_allbits_zero='define' d_off64_t='undef' d_old_pthread_create_joinable='undef' d_oldpthreads='undef' d_oldsock='undef' d_open3='undef' d_pathconf='undef' d_pause='define' d_perl_otherlibdirs='undef' d_phostname='undef' d_pipe='define' d_poll='undef' d_portable='define' d_printf_format_null='undef' d_procselfexe='undef' d_pseudofork='undef' d_pthread_atfork='undef' d_pthread_attr_setscope='undef' d_pthread_yield='undef' d_pwage='undef' d_pwchange='undef' d_pwclass='undef' d_pwcomment='undef' d_pwexpire='undef' d_pwgecos='undef' d_pwpasswd='undef' d_pwquota='undef' d_qgcvt='undef' d_quad='define' d_random_r='undef' d_readdir64_r='undef' d_readdir='define' d_readdir_r='undef' d_readlink='undef' d_readv='undef' d_recvmsg='undef' d_rename='define' d_rewinddir='define' d_rmdir='define' d_safebcpy='undef' d_safemcpy='undef' d_sanemcmp='define' d_sbrkproto='undef' d_scalbnl='undef' d_sched_yield='undef' d_scm_rights='undef' d_seekdir='define' d_select='define' d_sem='undef' d_semctl='undef' d_semctl_semid_ds='undef' d_semctl_semun='undef' d_semget='undef' d_semop='undef' d_sendmsg='undef' d_setegid='undef' d_seteuid='undef' d_setgrent='undef' d_setgrent_r='undef' d_setgrps='undef' d_sethent='undef' d_sethostent_r='undef' d_setitimer='undef' d_setlinebuf='undef' d_setlocale='define' d_setlocale_r='undef' d_setnent='undef' d_setnetent_r='undef' d_setpent='undef' d_setpgid='undef' d_setpgrp2='undef' d_setpgrp='undef' d_setprior='undef' d_setproctitle='undef' d_setprotoent_r='undef' d_setpwent='undef' d_setpwent_r='undef' d_setregid='undef' d_setresgid='undef' d_setresuid='undef' d_setreuid='undef' d_setrgid='undef' d_setruid='undef' d_setsent='undef' d_setservent_r='undef' d_setsid='undef' d_setvbuf='define' d_sfio='undef' d_shm='undef' d_shmat='undef' d_shmatprototype='undef' d_shmctl='undef' d_shmdt='undef' d_shmget='undef' d_sigaction='undef' d_signbit='undef' d_sigprocmask='undef' d_sigsetjmp='undef' d_sitearch='define' d_snprintf='define' d_sockatmark='undef' d_sockatmarkproto='undef' d_socket='define' d_socklen_t='undef' d_sockpair='undef' d_socks5_init='undef' d_sprintf_returns_strlen='define' d_sqrtl='undef' d_srand48_r='undef' d_srandom_r='undef' d_sresgproto='undef' d_sresuproto='undef' d_statblks='undef' d_statfs_f_flags='undef' d_statfs_s='undef' d_statvfs='undef' d_stdio_cnt_lval='define' d_stdio_ptr_lval='define' d_stdio_ptr_lval_nochange_cnt='define' d_stdio_ptr_lval_sets_cnt='undef' d_stdio_stream_array='undef' d_stdiobase='define' d_stdstdio='define' d_strchr='define' d_strcoll='define' d_strctcpy='define' d_strerrm='strerror(e)' d_strerror='define' d_strerror_r='undef' d_strftime='define' d_strlcat='undef' d_strlcpy='undef' d_strtod='define' d_strtol='define' d_strtold='undef' d_strtoll='undef' d_strtoq='undef' d_strtoul='define' d_strtoull='undef' d_strtouq='undef' d_strxfrm='define' d_suidsafe='undef' d_symlink='undef' d_syscall='undef' d_syscallproto='undef' d_sysconf='undef' d_sysernlst='' d_syserrlst='define' d_system='define' d_tcgetpgrp='undef' d_tcsetpgrp='undef' d_telldir='define' d_telldirproto='define' d_time='define' d_timegm='undef' d_times='define' d_tm_tm_gmtoff='undef' d_tm_tm_zone='undef' d_tmpnam_r='undef' d_truncate='undef' d_ttyname_r='undef' d_tzname='define' d_u32align='define' d_ualarm='undef' d_umask='define' d_uname='define' d_union_semun='define' d_unordered='undef' d_unsetenv='undef' d_usleep='undef' d_usleepproto='undef' d_ustat='undef' d_vendorarch='undef' d_vendorbin='undef' d_vendorlib='undef' d_vendorscript='undef' d_vfork='undef' d_void_closedir='undef' d_voidsig='define' d_voidtty='' d_volatile='define' d_vprintf='define' d_vsnprintf='define' d_wait4='undef' d_waitpid='define' d_wcstombs='define' d_wctomb='define' d_writev='undef' d_xenix='undef' date='date' db_hashtype='int' db_prefixtype='int' db_version_major='0' db_version_minor='0' db_version_patch='0' defvoidused='15' direntrytype='struct direct' dlext='dll' dlsrc='dl_win32.xs' doublesize='8' drand01='(rand()/(double)((unsigned)1< * or defines the symbol DBL_DIG, which is the number * of significant digits in a double precision number. If this * symbol is not defined, a guess of 15 is usually pretty good. */ #define HAS_DBL_DIG /**/ /* HAS_DIFFTIME: * This symbol, if defined, indicates that the difftime routine is * available. */ #define HAS_DIFFTIME /**/ /* HAS_DLERROR: * This symbol, if defined, indicates that the dlerror routine is * available to return a string describing the last error that * occurred from a call to dlopen(), dlclose() or dlsym(). */ #define HAS_DLERROR /**/ /* HAS_DUP2: * This symbol, if defined, indicates that the dup2 routine is * available to duplicate file descriptors. */ #define HAS_DUP2 /**/ /* HAS_FCHMOD: * This symbol, if defined, indicates that the fchmod routine is available * to change mode of opened files. If unavailable, use chmod(). */ /*#define HAS_FCHMOD / **/ /* HAS_FCHOWN: * This symbol, if defined, indicates that the fchown routine is available * to change ownership of opened files. If unavailable, use chown(). */ /*#define HAS_FCHOWN / **/ /* HAS_FCNTL: * This symbol, if defined, indicates to the C program that * the fcntl() function exists. */ /*#define HAS_FCNTL / **/ /* HAS_FGETPOS: * This symbol, if defined, indicates that the fgetpos routine is * available to get the file position indicator, similar to ftell(). */ #define HAS_FGETPOS /**/ /* HAS_FLOCK: * This symbol, if defined, indicates that the flock routine is * available to do file locking. */ #define HAS_FLOCK /**/ /* HAS_FORK: * This symbol, if defined, indicates that the fork routine is * available. */ /*#define HAS_FORK / **/ /* HAS_FSETPOS: * This symbol, if defined, indicates that the fsetpos routine is * available to set the file position indicator, similar to fseek(). */ #define HAS_FSETPOS /**/ /* HAS_GETTIMEOFDAY: * This symbol, if defined, indicates that the gettimeofday() system * call is available for a sub-second accuracy clock. Usually, the file * needs to be included (see I_SYS_RESOURCE). * The type "Timeval" should be used to refer to "struct timeval". */ #define HAS_GETTIMEOFDAY /**/ #ifdef HAS_GETTIMEOFDAY #define Timeval struct timeval /* Structure used by gettimeofday() */ #endif /* HAS_GETGROUPS: * This symbol, if defined, indicates that the getgroups() routine is * available to get the list of process groups. If unavailable, multiple * groups are probably not supported. */ /*#define HAS_GETGROUPS / **/ /* HAS_GETLOGIN: * This symbol, if defined, indicates that the getlogin routine is * available to get the login name. */ #define HAS_GETLOGIN /**/ /* HAS_GETPGID: * This symbol, if defined, indicates to the C program that * the getpgid(pid) function is available to get the * process group id. */ /*#define HAS_GETPGID / **/ /* HAS_GETPGRP2: * This symbol, if defined, indicates that the getpgrp2() (as in DG/UX) * routine is available to get the current process group. */ /*#define HAS_GETPGRP2 / **/ /* HAS_GETPPID: * This symbol, if defined, indicates that the getppid routine is * available to get the parent process ID. */ /*#define HAS_GETPPID / **/ /* HAS_GETPRIORITY: * This symbol, if defined, indicates that the getpriority routine is * available to get a process's priority. */ /*#define HAS_GETPRIORITY / **/ /* HAS_INET_ATON: * This symbol, if defined, indicates to the C program that the * inet_aton() function is available to parse IP address "dotted-quad" * strings. */ /*#define HAS_INET_ATON / **/ /* HAS_KILLPG: * This symbol, if defined, indicates that the killpg routine is available * to kill process groups. If unavailable, you probably should use kill * with a negative process number. */ #define HAS_KILLPG /**/ /* HAS_LINK: * This symbol, if defined, indicates that the link routine is * available to create hard links. */ #define HAS_LINK /**/ /* HAS_LOCALECONV: * This symbol, if defined, indicates that the localeconv routine is * available for numeric and monetary formatting conventions. */ #define HAS_LOCALECONV /**/ /* HAS_LOCKF: * This symbol, if defined, indicates that the lockf routine is * available to do file locking. */ /*#define HAS_LOCKF / **/ /* HAS_LSTAT: * This symbol, if defined, indicates that the lstat routine is * available to do file stats on symbolic links. */ /*#define HAS_LSTAT / **/ /* HAS_MBLEN: * This symbol, if defined, indicates that the mblen routine is available * to find the number of bytes in a multibye character. */ #define HAS_MBLEN /**/ /* HAS_MBSTOWCS: * This symbol, if defined, indicates that the mbstowcs routine is * available to covert a multibyte string into a wide character string. */ #define HAS_MBSTOWCS /**/ /* HAS_MBTOWC: * This symbol, if defined, indicates that the mbtowc routine is available * to covert a multibyte to a wide character. */ #define HAS_MBTOWC /**/ /* HAS_MEMCMP: * This symbol, if defined, indicates that the memcmp routine is available * to compare blocks of memory. */ #define HAS_MEMCMP /**/ /* HAS_MEMCPY: * This symbol, if defined, indicates that the memcpy routine is available * to copy blocks of memory. */ #define HAS_MEMCPY /**/ /* HAS_MEMMOVE: * This symbol, if defined, indicates that the memmove routine is available * to copy potentially overlapping blocks of memory. This should be used * only when HAS_SAFE_BCOPY is not defined. If neither is there, roll your * own version. */ #define HAS_MEMMOVE /**/ /* HAS_MEMSET: * This symbol, if defined, indicates that the memset routine is available * to set blocks of memory. */ #define HAS_MEMSET /**/ /* HAS_MKDIR: * This symbol, if defined, indicates that the mkdir routine is available * to create directories. Otherwise you should fork off a new process to * exec /bin/mkdir. */ #define HAS_MKDIR /**/ /* HAS_MKFIFO: * This symbol, if defined, indicates that the mkfifo routine is * available to create FIFOs. Otherwise, mknod should be able to * do it for you. However, if mkfifo is there, mknod might require * super-user privileges which mkfifo will not. */ /*#define HAS_MKFIFO / **/ /* HAS_MKTIME: * This symbol, if defined, indicates that the mktime routine is * available. */ #define HAS_MKTIME /**/ /* HAS_MSYNC: * This symbol, if defined, indicates that the msync system call is * available to synchronize a mapped file. */ /*#define HAS_MSYNC / **/ /* HAS_MUNMAP: * This symbol, if defined, indicates that the munmap system call is * available to unmap a region, usually mapped by mmap(). */ /*#define HAS_MUNMAP / **/ /* HAS_NICE: * This symbol, if defined, indicates that the nice routine is * available. */ /*#define HAS_NICE / **/ /* HAS_PATHCONF: * This symbol, if defined, indicates that pathconf() is available * to determine file-system related limits and options associated * with a given filename. */ /* HAS_FPATHCONF: * This symbol, if defined, indicates that pathconf() is available * to determine file-system related limits and options associated * with a given open file descriptor. */ /*#define HAS_PATHCONF / **/ /*#define HAS_FPATHCONF / **/ /* HAS_PAUSE: * This symbol, if defined, indicates that the pause routine is * available to suspend a process until a signal is received. */ #define HAS_PAUSE /**/ /* HAS_PIPE: * This symbol, if defined, indicates that the pipe routine is * available to create an inter-process channel. */ #define HAS_PIPE /**/ /* HAS_POLL: * This symbol, if defined, indicates that the poll routine is * available to poll active file descriptors. Please check I_POLL and * I_SYS_POLL to know which header should be included as well. */ /*#define HAS_POLL / **/ /* HAS_READDIR: * This symbol, if defined, indicates that the readdir routine is * available to read directory entries. You may have to include * . See I_DIRENT. */ #define HAS_READDIR /**/ /* HAS_SEEKDIR: * This symbol, if defined, indicates that the seekdir routine is * available. You may have to include . See I_DIRENT. */ #define HAS_SEEKDIR /**/ /* HAS_TELLDIR: * This symbol, if defined, indicates that the telldir routine is * available. You may have to include . See I_DIRENT. */ #define HAS_TELLDIR /**/ /* HAS_REWINDDIR: * This symbol, if defined, indicates that the rewinddir routine is * available. You may have to include . See I_DIRENT. */ #define HAS_REWINDDIR /**/ /* HAS_READLINK: * This symbol, if defined, indicates that the readlink routine is * available to read the value of a symbolic link. */ /*#define HAS_READLINK / **/ /* HAS_RENAME: * This symbol, if defined, indicates that the rename routine is available * to rename files. Otherwise you should do the unlink(), link(), unlink() * trick. */ #define HAS_RENAME /**/ /* HAS_RMDIR: * This symbol, if defined, indicates that the rmdir routine is * available to remove directories. Otherwise you should fork off a * new process to exec /bin/rmdir. */ #define HAS_RMDIR /**/ /* HAS_SELECT: * This symbol, if defined, indicates that the select routine is * available to select active file descriptors. If the timeout field * is used, may need to be included. */ #define HAS_SELECT /**/ /* HAS_SETEGID: * This symbol, if defined, indicates that the setegid routine is available * to change the effective gid of the current program. */ /*#define HAS_SETEGID / **/ /* HAS_SETEUID: * This symbol, if defined, indicates that the seteuid routine is available * to change the effective uid of the current program. */ /*#define HAS_SETEUID / **/ /* HAS_SETGROUPS: * This symbol, if defined, indicates that the setgroups() routine is * available to set the list of process groups. If unavailable, multiple * groups are probably not supported. */ /*#define HAS_SETGROUPS / **/ /* HAS_SETLINEBUF: * This symbol, if defined, indicates that the setlinebuf routine is * available to change stderr or stdout from block-buffered or unbuffered * to a line-buffered mode. */ /*#define HAS_SETLINEBUF / **/ /* HAS_SETLOCALE: * This symbol, if defined, indicates that the setlocale routine is * available to handle locale-specific ctype implementations. */ #define HAS_SETLOCALE /**/ /* HAS_SETPGID: * This symbol, if defined, indicates that the setpgid(pid, gpid) * routine is available to set process group ID. */ /*#define HAS_SETPGID / **/ /* HAS_SETPGRP2: * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX) * routine is available to set the current process group. */ /*#define HAS_SETPGRP2 / **/ /* HAS_SETPRIORITY: * This symbol, if defined, indicates that the setpriority routine is * available to set a process's priority. */ /*#define HAS_SETPRIORITY / **/ /* HAS_SETREGID: * This symbol, if defined, indicates that the setregid routine is * available to change the real and effective gid of the current * process. */ /* HAS_SETRESGID: * This symbol, if defined, indicates that the setresgid routine is * available to change the real, effective and saved gid of the current * process. */ /*#define HAS_SETREGID / **/ /*#define HAS_SETRESGID / **/ /* HAS_SETREUID: * This symbol, if defined, indicates that the setreuid routine is * available to change the real and effective uid of the current * process. */ /* HAS_SETRESUID: * This symbol, if defined, indicates that the setresuid routine is * available to change the real, effective and saved uid of the current * process. */ /*#define HAS_SETREUID / **/ /*#define HAS_SETRESUID / **/ /* HAS_SETRGID: * This symbol, if defined, indicates that the setrgid routine is available * to change the real gid of the current program. */ /*#define HAS_SETRGID / **/ /* HAS_SETRUID: * This symbol, if defined, indicates that the setruid routine is available * to change the real uid of the current program. */ /*#define HAS_SETRUID / **/ /* HAS_SETSID: * This symbol, if defined, indicates that the setsid routine is * available to set the process group ID. */ /*#define HAS_SETSID / **/ /* HAS_STRCHR: * This symbol is defined to indicate that the strchr()/strrchr() * functions are available for string searching. If not, try the * index()/rindex() pair. */ /* HAS_INDEX: * This symbol is defined to indicate that the index()/rindex() * functions are available for string searching. */ #define HAS_STRCHR /**/ /*#define HAS_INDEX / **/ /* HAS_STRCOLL: * This symbol, if defined, indicates that the strcoll routine is * available to compare strings using collating information. */ #define HAS_STRCOLL /**/ /* HAS_STRTOD: * This symbol, if defined, indicates that the strtod routine is * available to provide better numeric string conversion than atof(). */ #define HAS_STRTOD /**/ /* HAS_STRTOL: * This symbol, if defined, indicates that the strtol routine is available * to provide better numeric string conversion than atoi() and friends. */ #define HAS_STRTOL /**/ /* HAS_STRXFRM: * This symbol, if defined, indicates that the strxfrm() routine is * available to transform strings. */ #define HAS_STRXFRM /**/ /* HAS_SYMLINK: * This symbol, if defined, indicates that the symlink routine is available * to create symbolic links. */ /*#define HAS_SYMLINK / **/ /* HAS_SYSCALL: * This symbol, if defined, indicates that the syscall routine is * available to call arbitrary system calls. If undefined, that's tough. */ /*#define HAS_SYSCALL / **/ /* HAS_SYSCONF: * This symbol, if defined, indicates that sysconf() is available * to determine system related limits and options. */ /*#define HAS_SYSCONF / **/ /* HAS_SYSTEM: * This symbol, if defined, indicates that the system routine is * available to issue a shell command. */ #define HAS_SYSTEM /**/ /* HAS_TCGETPGRP: * This symbol, if defined, indicates that the tcgetpgrp routine is * available to get foreground process group ID. */ /*#define HAS_TCGETPGRP / **/ /* HAS_TCSETPGRP: * This symbol, if defined, indicates that the tcsetpgrp routine is * available to set foreground process group ID. */ /*#define HAS_TCSETPGRP / **/ /* HAS_TRUNCATE: * This symbol, if defined, indicates that the truncate routine is * available to truncate files. */ /*#define HAS_TRUNCATE / **/ /* HAS_TZNAME: * This symbol, if defined, indicates that the tzname[] array is * available to access timezone names. */ #define HAS_TZNAME /**/ /* HAS_UMASK: * This symbol, if defined, indicates that the umask routine is * available to set and get the value of the file creation mask. */ #define HAS_UMASK /**/ /* HAS_USLEEP: * This symbol, if defined, indicates that the usleep routine is * available to let the process sleep on a sub-second accuracy. */ /*#define HAS_USLEEP / **/ /* HAS_WAIT4: * This symbol, if defined, indicates that wait4() exists. */ /*#define HAS_WAIT4 / **/ /* HAS_WAITPID: * This symbol, if defined, indicates that the waitpid routine is * available to wait for child process. */ #define HAS_WAITPID /**/ /* HAS_WCSTOMBS: * This symbol, if defined, indicates that the wcstombs routine is * available to convert wide character strings to multibyte strings. */ #define HAS_WCSTOMBS /**/ /* HAS_WCTOMB: * This symbol, if defined, indicates that the wctomb routine is available * to covert a wide character to a multibyte. */ #define HAS_WCTOMB /**/ /* Groups_t: * This symbol holds the type used for the second argument to * getgroups() and setgroups(). Usually, this is the same as * gidtype (gid_t) , but sometimes it isn't. * It can be int, ushort, gid_t, etc... * It may be necessary to include to get any * typedef'ed information. This is only required if you have * getgroups() or setgroups().. */ #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS) #define Groups_t gid_t /* Type for 2nd arg to [sg]etgroups() */ #endif /* I_ARPA_INET: * This symbol, if defined, indicates to the C program that it should * include to get inet_addr and friends declarations. */ #define I_ARPA_INET /**/ /* I_DBM: * This symbol, if defined, indicates that exists and should * be included. */ /* I_RPCSVC_DBM: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_DBM / **/ #define I_RPCSVC_DBM /**/ /* I_DLFCN: * This symbol, if defined, indicates that exists and should * be included. */ #define I_DLFCN /**/ /* I_FCNTL: * This manifest constant tells the C program to include . */ #define I_FCNTL /**/ /* I_FLOAT: * This symbol, if defined, indicates to the C program that it should * include to get definition of symbols like DBL_MAX or * DBL_MIN, i.e. machine dependent floating point values. */ #define I_FLOAT /**/ /* I_GDBM: * This symbol, if defined, indicates that exists and should * be included. */ /*#define I_GDBM / **/ /* I_LIMITS: * This symbol, if defined, indicates to the C program that it should * include to get definition of symbols like WORD_BIT or * LONG_MAX, i.e. machine dependant limitations. */ #define I_LIMITS /**/ /* I_LOCALE: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_LOCALE /**/ /* I_MATH: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_MATH /**/ /* I_MEMORY: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_MEMORY / **/ /* I_NETINET_IN: * This symbol, if defined, indicates to the C program that it should * include . Otherwise, you may try . */ /*#define I_NETINET_IN / **/ /* I_SFIO: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SFIO / **/ /* I_STDDEF: * This symbol, if defined, indicates that exists and should * be included. */ #define I_STDDEF /**/ /* I_STDLIB: * This symbol, if defined, indicates that exists and should * be included. */ #define I_STDLIB /**/ /* I_STRING: * This symbol, if defined, indicates to the C program that it should * include (USG systems) instead of (BSD systems). */ #define I_STRING /**/ /* I_SYS_DIR: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_DIR / **/ /* I_SYS_FILE: * This symbol, if defined, indicates to the C program that it should * include to get definition of R_OK and friends. */ /*#define I_SYS_FILE / **/ /* I_SYS_IOCTL: * This symbol, if defined, indicates that exists and should * be included. Otherwise, include or . */ /* I_SYS_SOCKIO: * This symbol, if defined, indicates the should be included * to get socket ioctl options, like SIOCATMARK. */ /*#define I_SYS_IOCTL / **/ /*#define I_SYS_SOCKIO / **/ /* I_SYS_NDIR: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_NDIR / **/ /* I_SYS_PARAM: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_PARAM / **/ /* I_SYS_POLL: * This symbol, if defined, indicates that the program may include * . When I_POLL is also defined, it's probably safest * to only include . */ /*#define I_SYS_POLL / **/ /* I_SYS_RESOURCE: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_RESOURCE / **/ /* I_SYS_SELECT: * This symbol, if defined, indicates to the C program that it should * include in order to get definition of struct timeval. */ /*#define I_SYS_SELECT / **/ /* I_SYS_STAT: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_STAT /**/ /* I_SYS_TIMES: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_TIMES / **/ /* I_SYS_TYPES: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_TYPES /**/ /* I_SYS_UN: * This symbol, if defined, indicates to the C program that it should * include to get UNIX domain socket definitions. */ /*#define I_SYS_UN / **/ /* I_SYS_WAIT: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_WAIT / **/ /* I_TERMIO: * This symbol, if defined, indicates that the program should include * rather than . There are also differences in * the ioctl() calls that depend on the value of this symbol. */ /* I_TERMIOS: * This symbol, if defined, indicates that the program should include * the POSIX termios.h rather than sgtty.h or termio.h. * There are also differences in the ioctl() calls that depend on the * value of this symbol. */ /* I_SGTTY: * This symbol, if defined, indicates that the program should include * rather than . There are also differences in * the ioctl() calls that depend on the value of this symbol. */ /*#define I_TERMIO / **/ /*#define I_TERMIOS / **/ /*#define I_SGTTY / **/ /* I_UNISTD: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_UNISTD / **/ /* I_UTIME: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_UTIME /**/ /* I_VALUES: * This symbol, if defined, indicates to the C program that it should * include to get definition of symbols like MINFLOAT or * MAXLONG, i.e. machine dependant limitations. Probably, you * should use instead, if it is available. */ /*#define I_VALUES / **/ /* I_VFORK: * This symbol, if defined, indicates to the C program that it should * include vfork.h. */ /*#define I_VFORK / **/ /* CAN_VAPROTO: * This variable is defined on systems supporting prototype declaration * of functions with a variable number of arguments. */ /* _V: * This macro is used to declare function parameters in prototypes for * functions with a variable number of parameters. Use double parentheses. * For example: * * int printf _V((char *fmt, ...)); * * Remember to use the plain simple _() macro when declaring a function * with no variable number of arguments, since it might be possible to * have a non-effect _V() macro and still get prototypes via _(). */ /*#define CAN_VAPROTO / **/ #ifdef CAN_VAPROTO #define _V(args) args #else #define _V(args) () #endif /* INTSIZE: * This symbol contains the value of sizeof(int) so that the C * preprocessor can make decisions based on it. */ /* LONGSIZE: * This symbol contains the value of sizeof(long) so that the C * preprocessor can make decisions based on it. */ /* SHORTSIZE: * This symbol contains the value of sizeof(short) so that the C * preprocessor can make decisions based on it. */ #define INTSIZE 4 /**/ #define LONGSIZE 4 /**/ #define SHORTSIZE 2 /**/ /* MULTIARCH: * This symbol, if defined, signifies that the build * process will produce some binary files that are going to be * used in a cross-platform environment. This is the case for * example with the NeXT "fat" binaries that contain executables * for several CPUs. */ /*#define MULTIARCH / **/ /* HAS_QUAD: * This symbol, if defined, tells that there's a 64-bit integer type, * Quad_t, and its unsigned counterpar, Uquad_t. QUADKIND will be one * of QUAD_IS_INT, QUAD_IS_LONG, QUAD_IS_LONG_LONG, QUAD_IS_INT64_T * or QUAD_IS___INT64. */ #define HAS_QUAD /**/ #ifdef HAS_QUAD # define Quad_t __int64 /**/ # define Uquad_t unsigned __int64 /**/ # define QUADKIND 5 /**/ # define QUAD_IS_INT 1 # define QUAD_IS_LONG 2 # define QUAD_IS_LONG_LONG 3 # define QUAD_IS_INT64_T 4 # define QUAD_IS___INT64 5 #endif /* OSNAME: * This symbol contains the name of the operating system, as determined * by Configure. You shouldn't rely on it too much; the specific * feature tests from Configure are generally more reliable. */ /* OSVERS: * This symbol contains the version of the operating system, as determined * by Configure. You shouldn't rely on it too much; the specific * feature tests from Configure are generally more reliable. */ #define OSNAME "MSWin32" /**/ #define OSVERS "5.1" /**/ /* ARCHLIB: * This variable, if defined, holds the name of the directory in * which the user wants to put architecture-dependent public * library files for perl5. It is most often a local directory * such as /usr/local/lib. Programs using this variable must be * prepared to deal with filename expansion. If ARCHLIB is the * same as PRIVLIB, it is not defined, since presumably the * program already searches PRIVLIB. */ /* ARCHLIB_EXP: * This symbol contains the ~name expanded version of ARCHLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ #define ARCHLIB "c:\\perl\\lib" /**/ /*#define ARCHLIB_EXP "" / **/ /* ARCHNAME: * This symbol holds a string representing the architecture name. * It may be used to construct an architecture-dependant pathname * where library files may be held under a private library, for * instance. */ #define ARCHNAME "MSWin32-x86" /**/ /* BIN: * This symbol holds the path of the bin directory where the package will * be installed. Program must be prepared to deal with ~name substitution. */ /* BIN_EXP: * This symbol is the filename expanded version of the BIN symbol, for * programs that do not want to deal with that at run-time. */ /* PERL_RELOCATABLE_INC: * This symbol, if defined, indicates that we'd like to relocate entries * in @INC at run time based on the location of the perl binary. */ #define BIN "c:\\perl\\bin" /**/ #define BIN_EXP "c:\\perl\\bin" /**/ #define PERL_RELOCATABLE_INC "undef" /**/ /* CAT2: * This macro concatenates 2 tokens together. */ /* STRINGIFY: * This macro surrounds its token with double quotes. */ #if 42 == 1 #define CAT2(a,b) a/**/b #define STRINGIFY(a) "a" #endif #if 42 == 42 #define PeRl_CaTiFy(a, b) a ## b #define PeRl_StGiFy(a) #a #define CAT2(a,b) PeRl_CaTiFy(a,b) #define StGiFy(a) PeRl_StGiFy(a) #define STRINGIFY(a) PeRl_StGiFy(a) #endif #if 42 != 1 && 42 != 42 #include "Bletch: How does this C preprocessor concatenate tokens?" #endif /* CPPSTDIN: * This symbol contains the first part of the string which will invoke * the C preprocessor on the standard input and produce to standard * output. Typical value of "cc -E" or "/lib/cpp", but it can also * call a wrapper. See CPPRUN. */ /* CPPMINUS: * This symbol contains the second part of the string which will invoke * the C preprocessor on the standard input and produce to standard * output. This symbol will have the value "-" if CPPSTDIN needs a minus * to specify standard input, otherwise the value is "". */ /* CPPRUN: * This symbol contains the string which will invoke a C preprocessor on * the standard input and produce to standard output. It needs to end * with CPPLAST, after all other preprocessor flags have been specified. * The main difference with CPPSTDIN is that this program will never be a * pointer to a shell wrapper, i.e. it will be empty if no preprocessor is * available directly to the user. Note that it may well be different from * the preprocessor used to compile the C program. */ /* CPPLAST: * This symbol is intended to be used along with CPPRUN in the same manner * symbol CPPMINUS is used with CPPSTDIN. It contains either "-" or "". */ #define CPPSTDIN "cppstdin" #define CPPMINUS "" #define CPPRUN "cl -nologo -E" #define CPPLAST "" /* HAS_ACCESS: * This manifest constant lets the C program know that the access() * system call is available to check for accessibility using real UID/GID. * (always present on UNIX.) */ #define HAS_ACCESS /**/ /* HAS_ACCESSX: * This symbol, if defined, indicates that the accessx routine is * available to do extended access checks. */ /*#define HAS_ACCESSX / **/ /* HAS_ASCTIME_R: * This symbol, if defined, indicates that the asctime_r routine * is available to asctime re-entrantly. */ /* ASCTIME_R_PROTO: * This symbol encodes the prototype of asctime_r. * It is zero if d_asctime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_asctime_r * is defined. */ /*#define HAS_ASCTIME_R / **/ #define ASCTIME_R_PROTO 0 /**/ /* HASATTRIBUTE_FORMAT: * Can we handle GCC attribute for checking printf-style formats */ /* PRINTF_FORMAT_NULL_OK: * Allows __printf__ format to be null when checking printf-style */ /* HASATTRIBUTE_MALLOC: * Can we handle GCC attribute for malloc-style functions. */ /* HASATTRIBUTE_NONNULL: * Can we handle GCC attribute for nonnull function parms. */ /* HASATTRIBUTE_NORETURN: * Can we handle GCC attribute for functions that do not return */ /* HASATTRIBUTE_PURE: * Can we handle GCC attribute for pure functions */ /* HASATTRIBUTE_UNUSED: * Can we handle GCC attribute for unused variables and arguments */ /* HASATTRIBUTE_DEPRECATED: * Can we handle GCC attribute for marking deprecated APIs */ /* HASATTRIBUTE_WARN_UNUSED_RESULT: * Can we handle GCC attribute for warning on unused results */ /*#define HASATTRIBUTE_DEPRECATED / **/ /*#define HASATTRIBUTE_FORMAT / **/ /*#define PRINTF_FORMAT_NULL_OK / **/ /*#define HASATTRIBUTE_NORETURN / **/ /*#define HASATTRIBUTE_MALLOC / **/ /*#define HASATTRIBUTE_NONNULL / **/ /*#define HASATTRIBUTE_PURE / **/ /*#define HASATTRIBUTE_UNUSED / **/ /*#define HASATTRIBUTE_WARN_UNUSED_RESULT / **/ /* HASCONST: * This symbol, if defined, indicates that this C compiler knows about * the const type. There is no need to actually test for that symbol * within your programs. The mere use of the "const" keyword will * trigger the necessary tests. */ #define HASCONST /**/ #ifndef HASCONST #define const #endif /* HAS_CRYPT_R: * This symbol, if defined, indicates that the crypt_r routine * is available to crypt re-entrantly. */ /* CRYPT_R_PROTO: * This symbol encodes the prototype of crypt_r. * It is zero if d_crypt_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_crypt_r * is defined. */ /*#define HAS_CRYPT_R / **/ #define CRYPT_R_PROTO 0 /**/ /* HAS_CSH: * This symbol, if defined, indicates that the C-shell exists. */ /* CSH: * This symbol, if defined, contains the full pathname of csh. */ /*#define HAS_CSH / **/ #ifdef HAS_CSH #define CSH "" /**/ #endif /* HAS_CTERMID_R: * This symbol, if defined, indicates that the ctermid_r routine * is available to ctermid re-entrantly. */ /* CTERMID_R_PROTO: * This symbol encodes the prototype of ctermid_r. * It is zero if d_ctermid_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ctermid_r * is defined. */ /*#define HAS_CTERMID_R / **/ #define CTERMID_R_PROTO 0 /**/ /* HAS_CTIME_R: * This symbol, if defined, indicates that the ctime_r routine * is available to ctime re-entrantly. */ /* CTIME_R_PROTO: * This symbol encodes the prototype of ctime_r. * It is zero if d_ctime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ctime_r * is defined. */ /*#define HAS_CTIME_R / **/ #define CTIME_R_PROTO 0 /**/ /* HAS_DRAND48_R: * This symbol, if defined, indicates that the drand48_r routine * is available to drand48 re-entrantly. */ /* DRAND48_R_PROTO: * This symbol encodes the prototype of drand48_r. * It is zero if d_drand48_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_drand48_r * is defined. */ /*#define HAS_DRAND48_R / **/ #define DRAND48_R_PROTO 0 /**/ /* HAS_DRAND48_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the drand48() function. Otherwise, it is up * to the program to supply one. A good guess is * extern double drand48(void); */ /*#define HAS_DRAND48_PROTO / **/ /* HAS_EACCESS: * This symbol, if defined, indicates that the eaccess routine is * available to do extended access checks. */ /*#define HAS_EACCESS / **/ /* HAS_ENDGRENT: * This symbol, if defined, indicates that the getgrent routine is * available for finalizing sequential access of the group database. */ /*#define HAS_ENDGRENT / **/ /* HAS_ENDGRENT_R: * This symbol, if defined, indicates that the endgrent_r routine * is available to endgrent re-entrantly. */ /* ENDGRENT_R_PROTO: * This symbol encodes the prototype of endgrent_r. * It is zero if d_endgrent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endgrent_r * is defined. */ /*#define HAS_ENDGRENT_R / **/ #define ENDGRENT_R_PROTO 0 /**/ /* HAS_ENDHOSTENT: * This symbol, if defined, indicates that the endhostent() routine is * available to close whatever was being used for host queries. */ /*#define HAS_ENDHOSTENT / **/ /* HAS_ENDHOSTENT_R: * This symbol, if defined, indicates that the endhostent_r routine * is available to endhostent re-entrantly. */ /* ENDHOSTENT_R_PROTO: * This symbol encodes the prototype of endhostent_r. * It is zero if d_endhostent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endhostent_r * is defined. */ /*#define HAS_ENDHOSTENT_R / **/ #define ENDHOSTENT_R_PROTO 0 /**/ /* HAS_ENDNETENT: * This symbol, if defined, indicates that the endnetent() routine is * available to close whatever was being used for network queries. */ /*#define HAS_ENDNETENT / **/ /* HAS_ENDNETENT_R: * This symbol, if defined, indicates that the endnetent_r routine * is available to endnetent re-entrantly. */ /* ENDNETENT_R_PROTO: * This symbol encodes the prototype of endnetent_r. * It is zero if d_endnetent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endnetent_r * is defined. */ /*#define HAS_ENDNETENT_R / **/ #define ENDNETENT_R_PROTO 0 /**/ /* HAS_ENDPROTOENT: * This symbol, if defined, indicates that the endprotoent() routine is * available to close whatever was being used for protocol queries. */ /*#define HAS_ENDPROTOENT / **/ /* HAS_ENDPROTOENT_R: * This symbol, if defined, indicates that the endprotoent_r routine * is available to endprotoent re-entrantly. */ /* ENDPROTOENT_R_PROTO: * This symbol encodes the prototype of endprotoent_r. * It is zero if d_endprotoent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endprotoent_r * is defined. */ /*#define HAS_ENDPROTOENT_R / **/ #define ENDPROTOENT_R_PROTO 0 /**/ /* HAS_ENDPWENT: * This symbol, if defined, indicates that the getgrent routine is * available for finalizing sequential access of the passwd database. */ /*#define HAS_ENDPWENT / **/ /* HAS_ENDPWENT_R: * This symbol, if defined, indicates that the endpwent_r routine * is available to endpwent re-entrantly. */ /* ENDPWENT_R_PROTO: * This symbol encodes the prototype of endpwent_r. * It is zero if d_endpwent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endpwent_r * is defined. */ /*#define HAS_ENDPWENT_R / **/ #define ENDPWENT_R_PROTO 0 /**/ /* HAS_ENDSERVENT: * This symbol, if defined, indicates that the endservent() routine is * available to close whatever was being used for service queries. */ /*#define HAS_ENDSERVENT / **/ /* HAS_ENDSERVENT_R: * This symbol, if defined, indicates that the endservent_r routine * is available to endservent re-entrantly. */ /* ENDSERVENT_R_PROTO: * This symbol encodes the prototype of endservent_r. * It is zero if d_endservent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endservent_r * is defined. */ /*#define HAS_ENDSERVENT_R / **/ #define ENDSERVENT_R_PROTO 0 /**/ /* FLEXFILENAMES: * This symbol, if defined, indicates that the system supports filenames * longer than 14 characters. */ #define FLEXFILENAMES /**/ /* HAS_GETGRENT: * This symbol, if defined, indicates that the getgrent routine is * available for sequential access of the group database. */ /*#define HAS_GETGRENT / **/ /* HAS_GETGRENT_R: * This symbol, if defined, indicates that the getgrent_r routine * is available to getgrent re-entrantly. */ /* GETGRENT_R_PROTO: * This symbol encodes the prototype of getgrent_r. * It is zero if d_getgrent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrent_r * is defined. */ /*#define HAS_GETGRENT_R / **/ #define GETGRENT_R_PROTO 0 /**/ /* HAS_GETGRGID_R: * This symbol, if defined, indicates that the getgrgid_r routine * is available to getgrgid re-entrantly. */ /* GETGRGID_R_PROTO: * This symbol encodes the prototype of getgrgid_r. * It is zero if d_getgrgid_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrgid_r * is defined. */ /*#define HAS_GETGRGID_R / **/ #define GETGRGID_R_PROTO 0 /**/ /* HAS_GETGRNAM_R: * This symbol, if defined, indicates that the getgrnam_r routine * is available to getgrnam re-entrantly. */ /* GETGRNAM_R_PROTO: * This symbol encodes the prototype of getgrnam_r. * It is zero if d_getgrnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrnam_r * is defined. */ /*#define HAS_GETGRNAM_R / **/ #define GETGRNAM_R_PROTO 0 /**/ /* HAS_GETHOSTBYADDR: * This symbol, if defined, indicates that the gethostbyaddr() routine is * available to look up hosts by their IP addresses. */ #define HAS_GETHOSTBYADDR /**/ /* HAS_GETHOSTBYNAME: * This symbol, if defined, indicates that the gethostbyname() routine is * available to look up host names in some data base or other. */ #define HAS_GETHOSTBYNAME /**/ /* HAS_GETHOSTENT: * This symbol, if defined, indicates that the gethostent() routine is * available to look up host names in some data base or another. */ /*#define HAS_GETHOSTENT / **/ /* HAS_GETHOSTNAME: * This symbol, if defined, indicates that the C program may use the * gethostname() routine to derive the host name. See also HAS_UNAME * and PHOSTNAME. */ /* HAS_UNAME: * This symbol, if defined, indicates that the C program may use the * uname() routine to derive the host name. See also HAS_GETHOSTNAME * and PHOSTNAME. */ /* PHOSTNAME: * This symbol, if defined, indicates the command to feed to the * popen() routine to derive the host name. See also HAS_GETHOSTNAME * and HAS_UNAME. Note that the command uses a fully qualified path, * so that it is safe even if used by a process with super-user * privileges. */ /* HAS_PHOSTNAME: * This symbol, if defined, indicates that the C program may use the * contents of PHOSTNAME as a command to feed to the popen() routine * to derive the host name. */ #define HAS_GETHOSTNAME /**/ #define HAS_UNAME /**/ /*#define HAS_PHOSTNAME / **/ #ifdef HAS_PHOSTNAME #define PHOSTNAME "" /* How to get the host name */ #endif /* HAS_GETHOSTBYADDR_R: * This symbol, if defined, indicates that the gethostbyaddr_r routine * is available to gethostbyaddr re-entrantly. */ /* GETHOSTBYADDR_R_PROTO: * This symbol encodes the prototype of gethostbyaddr_r. * It is zero if d_gethostbyaddr_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostbyaddr_r * is defined. */ /*#define HAS_GETHOSTBYADDR_R / **/ #define GETHOSTBYADDR_R_PROTO 0 /**/ /* HAS_GETHOSTBYNAME_R: * This symbol, if defined, indicates that the gethostbyname_r routine * is available to gethostbyname re-entrantly. */ /* GETHOSTBYNAME_R_PROTO: * This symbol encodes the prototype of gethostbyname_r. * It is zero if d_gethostbyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostbyname_r * is defined. */ /*#define HAS_GETHOSTBYNAME_R / **/ #define GETHOSTBYNAME_R_PROTO 0 /**/ /* HAS_GETHOSTENT_R: * This symbol, if defined, indicates that the gethostent_r routine * is available to gethostent re-entrantly. */ /* GETHOSTENT_R_PROTO: * This symbol encodes the prototype of gethostent_r. * It is zero if d_gethostent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostent_r * is defined. */ /*#define HAS_GETHOSTENT_R / **/ #define GETHOSTENT_R_PROTO 0 /**/ /* HAS_GETHOST_PROTOS: * This symbol, if defined, indicates that includes * prototypes for gethostent(), gethostbyname(), and * gethostbyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ #define HAS_GETHOST_PROTOS /**/ /* HAS_GETLOGIN_R: * This symbol, if defined, indicates that the getlogin_r routine * is available to getlogin re-entrantly. */ /* GETLOGIN_R_PROTO: * This symbol encodes the prototype of getlogin_r. * It is zero if d_getlogin_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getlogin_r * is defined. */ /*#define HAS_GETLOGIN_R / **/ #define GETLOGIN_R_PROTO 0 /**/ /* HAS_GETNETBYADDR: * This symbol, if defined, indicates that the getnetbyaddr() routine is * available to look up networks by their IP addresses. */ /*#define HAS_GETNETBYADDR / **/ /* HAS_GETNETBYNAME: * This symbol, if defined, indicates that the getnetbyname() routine is * available to look up networks by their names. */ /*#define HAS_GETNETBYNAME / **/ /* HAS_GETNETENT: * This symbol, if defined, indicates that the getnetent() routine is * available to look up network names in some data base or another. */ /*#define HAS_GETNETENT / **/ /* HAS_GETNETBYADDR_R: * This symbol, if defined, indicates that the getnetbyaddr_r routine * is available to getnetbyaddr re-entrantly. */ /* GETNETBYADDR_R_PROTO: * This symbol encodes the prototype of getnetbyaddr_r. * It is zero if d_getnetbyaddr_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetbyaddr_r * is defined. */ /*#define HAS_GETNETBYADDR_R / **/ #define GETNETBYADDR_R_PROTO 0 /**/ /* HAS_GETNETBYNAME_R: * This symbol, if defined, indicates that the getnetbyname_r routine * is available to getnetbyname re-entrantly. */ /* GETNETBYNAME_R_PROTO: * This symbol encodes the prototype of getnetbyname_r. * It is zero if d_getnetbyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetbyname_r * is defined. */ /*#define HAS_GETNETBYNAME_R / **/ #define GETNETBYNAME_R_PROTO 0 /**/ /* HAS_GETNETENT_R: * This symbol, if defined, indicates that the getnetent_r routine * is available to getnetent re-entrantly. */ /* GETNETENT_R_PROTO: * This symbol encodes the prototype of getnetent_r. * It is zero if d_getnetent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetent_r * is defined. */ /*#define HAS_GETNETENT_R / **/ #define GETNETENT_R_PROTO 0 /**/ /* HAS_GETNET_PROTOS: * This symbol, if defined, indicates that includes * prototypes for getnetent(), getnetbyname(), and * getnetbyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ /*#define HAS_GETNET_PROTOS / **/ /* HAS_GETPROTOENT: * This symbol, if defined, indicates that the getprotoent() routine is * available to look up protocols in some data base or another. */ /*#define HAS_GETPROTOENT / **/ /* HAS_GETPGRP: * This symbol, if defined, indicates that the getpgrp routine is * available to get the current process group. */ /* USE_BSD_GETPGRP: * This symbol, if defined, indicates that getpgrp needs one * arguments whereas USG one needs none. */ /*#define HAS_GETPGRP / **/ /*#define USE_BSD_GETPGRP / **/ /* HAS_GETPROTOBYNAME: * This symbol, if defined, indicates that the getprotobyname() * routine is available to look up protocols by their name. */ /* HAS_GETPROTOBYNUMBER: * This symbol, if defined, indicates that the getprotobynumber() * routine is available to look up protocols by their number. */ #define HAS_GETPROTOBYNAME /**/ #define HAS_GETPROTOBYNUMBER /**/ /* HAS_GETPROTOBYNAME_R: * This symbol, if defined, indicates that the getprotobyname_r routine * is available to getprotobyname re-entrantly. */ /* GETPROTOBYNAME_R_PROTO: * This symbol encodes the prototype of getprotobyname_r. * It is zero if d_getprotobyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotobyname_r * is defined. */ /*#define HAS_GETPROTOBYNAME_R / **/ #define GETPROTOBYNAME_R_PROTO 0 /**/ /* HAS_GETPROTOBYNUMBER_R: * This symbol, if defined, indicates that the getprotobynumber_r routine * is available to getprotobynumber re-entrantly. */ /* GETPROTOBYNUMBER_R_PROTO: * This symbol encodes the prototype of getprotobynumber_r. * It is zero if d_getprotobynumber_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotobynumber_r * is defined. */ /*#define HAS_GETPROTOBYNUMBER_R / **/ #define GETPROTOBYNUMBER_R_PROTO 0 /**/ /* HAS_GETPROTOENT_R: * This symbol, if defined, indicates that the getprotoent_r routine * is available to getprotoent re-entrantly. */ /* GETPROTOENT_R_PROTO: * This symbol encodes the prototype of getprotoent_r. * It is zero if d_getprotoent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotoent_r * is defined. */ /*#define HAS_GETPROTOENT_R / **/ #define GETPROTOENT_R_PROTO 0 /**/ /* HAS_GETPROTO_PROTOS: * This symbol, if defined, indicates that includes * prototypes for getprotoent(), getprotobyname(), and * getprotobyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ #define HAS_GETPROTO_PROTOS /**/ /* HAS_GETPWENT: * This symbol, if defined, indicates that the getpwent routine is * available for sequential access of the passwd database. * If this is not available, the older getpw() function may be available. */ /*#define HAS_GETPWENT / **/ /* HAS_GETPWENT_R: * This symbol, if defined, indicates that the getpwent_r routine * is available to getpwent re-entrantly. */ /* GETPWENT_R_PROTO: * This symbol encodes the prototype of getpwent_r. * It is zero if d_getpwent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwent_r * is defined. */ /*#define HAS_GETPWENT_R / **/ #define GETPWENT_R_PROTO 0 /**/ /* HAS_GETPWNAM_R: * This symbol, if defined, indicates that the getpwnam_r routine * is available to getpwnam re-entrantly. */ /* GETPWNAM_R_PROTO: * This symbol encodes the prototype of getpwnam_r. * It is zero if d_getpwnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwnam_r * is defined. */ /*#define HAS_GETPWNAM_R / **/ #define GETPWNAM_R_PROTO 0 /**/ /* HAS_GETPWUID_R: * This symbol, if defined, indicates that the getpwuid_r routine * is available to getpwuid re-entrantly. */ /* GETPWUID_R_PROTO: * This symbol encodes the prototype of getpwuid_r. * It is zero if d_getpwuid_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwuid_r * is defined. */ /*#define HAS_GETPWUID_R / **/ #define GETPWUID_R_PROTO 0 /**/ /* HAS_GETSERVENT: * This symbol, if defined, indicates that the getservent() routine is * available to look up network services in some data base or another. */ /*#define HAS_GETSERVENT / **/ /* HAS_GETSERVBYNAME_R: * This symbol, if defined, indicates that the getservbyname_r routine * is available to getservbyname re-entrantly. */ /* GETSERVBYNAME_R_PROTO: * This symbol encodes the prototype of getservbyname_r. * It is zero if d_getservbyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservbyname_r * is defined. */ /*#define HAS_GETSERVBYNAME_R / **/ #define GETSERVBYNAME_R_PROTO 0 /**/ /* HAS_GETSERVBYPORT_R: * This symbol, if defined, indicates that the getservbyport_r routine * is available to getservbyport re-entrantly. */ /* GETSERVBYPORT_R_PROTO: * This symbol encodes the prototype of getservbyport_r. * It is zero if d_getservbyport_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservbyport_r * is defined. */ /*#define HAS_GETSERVBYPORT_R / **/ #define GETSERVBYPORT_R_PROTO 0 /**/ /* HAS_GETSERVENT_R: * This symbol, if defined, indicates that the getservent_r routine * is available to getservent re-entrantly. */ /* GETSERVENT_R_PROTO: * This symbol encodes the prototype of getservent_r. * It is zero if d_getservent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservent_r * is defined. */ /*#define HAS_GETSERVENT_R / **/ #define GETSERVENT_R_PROTO 0 /**/ /* HAS_GETSERV_PROTOS: * This symbol, if defined, indicates that includes * prototypes for getservent(), getservbyname(), and * getservbyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ #define HAS_GETSERV_PROTOS /**/ /* HAS_GETSPNAM_R: * This symbol, if defined, indicates that the getspnam_r routine * is available to getspnam re-entrantly. */ /* GETSPNAM_R_PROTO: * This symbol encodes the prototype of getspnam_r. * It is zero if d_getspnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getspnam_r * is defined. */ /*#define HAS_GETSPNAM_R / **/ #define GETSPNAM_R_PROTO 0 /**/ /* HAS_GETSERVBYNAME: * This symbol, if defined, indicates that the getservbyname() * routine is available to look up services by their name. */ /* HAS_GETSERVBYPORT: * This symbol, if defined, indicates that the getservbyport() * routine is available to look up services by their port. */ #define HAS_GETSERVBYNAME /**/ #define HAS_GETSERVBYPORT /**/ /* HAS_GMTIME_R: * This symbol, if defined, indicates that the gmtime_r routine * is available to gmtime re-entrantly. */ /* GMTIME_R_PROTO: * This symbol encodes the prototype of gmtime_r. * It is zero if d_gmtime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gmtime_r * is defined. */ /*#define HAS_GMTIME_R / **/ #define GMTIME_R_PROTO 0 /**/ /* HAS_HTONL: * This symbol, if defined, indicates that the htonl() routine (and * friends htons() ntohl() ntohs()) are available to do network * order byte swapping. */ /* HAS_HTONS: * This symbol, if defined, indicates that the htons() routine (and * friends htonl() ntohl() ntohs()) are available to do network * order byte swapping. */ /* HAS_NTOHL: * This symbol, if defined, indicates that the ntohl() routine (and * friends htonl() htons() ntohs()) are available to do network * order byte swapping. */ /* HAS_NTOHS: * This symbol, if defined, indicates that the ntohs() routine (and * friends htonl() htons() ntohl()) are available to do network * order byte swapping. */ #define HAS_HTONL /**/ #define HAS_HTONS /**/ #define HAS_NTOHL /**/ #define HAS_NTOHS /**/ /* HAS_LOCALTIME_R: * This symbol, if defined, indicates that the localtime_r routine * is available to localtime re-entrantly. */ /* LOCALTIME_R_NEEDS_TZSET: * Many libc's localtime_r implementations do not call tzset, * making them differ from localtime(), and making timezone * changes using \undef{TZ} without explicitly calling tzset * impossible. This symbol makes us call tzset before localtime_r */ /*#define LOCALTIME_R_NEEDS_TZSET / **/ #ifdef LOCALTIME_R_NEEDS_TZSET #define L_R_TZSET tzset(), #else #define L_R_TZSET #endif /* LOCALTIME_R_PROTO: * This symbol encodes the prototype of localtime_r. * It is zero if d_localtime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_localtime_r * is defined. */ /*#define HAS_LOCALTIME_R / **/ #define LOCALTIME_R_PROTO 0 /**/ /* HAS_LONG_DOUBLE: * This symbol will be defined if the C compiler supports long * doubles. */ /* LONG_DOUBLESIZE: * This symbol contains the size of a long double, so that the * C preprocessor can make decisions based on it. It is only * defined if the system supports long doubles. */ #define HAS_LONG_DOUBLE /**/ #ifdef HAS_LONG_DOUBLE #define LONG_DOUBLESIZE 8 /**/ #endif /* HAS_LONG_LONG: * This symbol will be defined if the C compiler supports long long. */ /* LONGLONGSIZE: * This symbol contains the size of a long long, so that the * C preprocessor can make decisions based on it. It is only * defined if the system supports long long. */ /*#define HAS_LONG_LONG / **/ #ifdef HAS_LONG_LONG #define LONGLONGSIZE 8 /**/ #endif /* HAS_LSEEK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the lseek() function. Otherwise, it is up * to the program to supply one. A good guess is * extern off_t lseek(int, off_t, int); */ #define HAS_LSEEK_PROTO /**/ /* HAS_MEMCHR: * This symbol, if defined, indicates that the memchr routine is available * to locate characters within a C string. */ #define HAS_MEMCHR /**/ /* HAS_MKSTEMP: * This symbol, if defined, indicates that the mkstemp routine is * available to exclusively create and open a uniquely named * temporary file. */ /*#define HAS_MKSTEMP / **/ /* HAS_MMAP: * This symbol, if defined, indicates that the mmap system call is * available to map a file into memory. */ /* Mmap_t: * This symbol holds the return type of the mmap() system call * (and simultaneously the type of the first argument). * Usually set to 'void *' or 'caddr_t'. */ /*#define HAS_MMAP / **/ #define Mmap_t void * /**/ /* HAS_MSG: * This symbol, if defined, indicates that the entire msg*(2) library is * supported (IPC mechanism based on message queues). */ /*#define HAS_MSG / **/ /* OLD_PTHREAD_CREATE_JOINABLE: * This symbol, if defined, indicates how to create pthread * in joinable (aka undetached) state. NOTE: not defined * if pthread.h already has defined PTHREAD_CREATE_JOINABLE * (the new version of the constant). * If defined, known values are PTHREAD_CREATE_UNDETACHED * and __UNDETACHED. */ /*#define OLD_PTHREAD_CREATE_JOINABLE / **/ /* HAS_PTHREAD_ATFORK: * This symbol, if defined, indicates that the pthread_atfork routine * is available to setup fork handlers. */ /*#define HAS_PTHREAD_ATFORK / **/ /* HAS_PTHREAD_YIELD: * This symbol, if defined, indicates that the pthread_yield * routine is available to yield the execution of the current * thread. sched_yield is preferable to pthread_yield. */ /* SCHED_YIELD: * This symbol defines the way to yield the execution of * the current thread. Known ways are sched_yield, * pthread_yield, and pthread_yield with NULL. */ /* HAS_SCHED_YIELD: * This symbol, if defined, indicates that the sched_yield * routine is available to yield the execution of the current * thread. sched_yield is preferable to pthread_yield. */ /*#define HAS_PTHREAD_YIELD / **/ #define SCHED_YIELD /**/ /*#define HAS_SCHED_YIELD / **/ /* HAS_RANDOM_R: * This symbol, if defined, indicates that the random_r routine * is available to random re-entrantly. */ /* RANDOM_R_PROTO: * This symbol encodes the prototype of random_r. * It is zero if d_random_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_random_r * is defined. */ /*#define HAS_RANDOM_R / **/ #define RANDOM_R_PROTO 0 /**/ /* HAS_READDIR64_R: * This symbol, if defined, indicates that the readdir64_r routine * is available to readdir64 re-entrantly. */ /* READDIR64_R_PROTO: * This symbol encodes the prototype of readdir64_r. * It is zero if d_readdir64_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_readdir64_r * is defined. */ /*#define HAS_READDIR64_R / **/ #define READDIR64_R_PROTO 0 /**/ /* HAS_READDIR_R: * This symbol, if defined, indicates that the readdir_r routine * is available to readdir re-entrantly. */ /* READDIR_R_PROTO: * This symbol encodes the prototype of readdir_r. * It is zero if d_readdir_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_readdir_r * is defined. */ /*#define HAS_READDIR_R / **/ #define READDIR_R_PROTO 0 /**/ /* HAS_SEM: * This symbol, if defined, indicates that the entire sem*(2) library is * supported. */ /*#define HAS_SEM / **/ /* HAS_SETGRENT: * This symbol, if defined, indicates that the setgrent routine is * available for initializing sequential access of the group database. */ /*#define HAS_SETGRENT / **/ /* HAS_SETGRENT_R: * This symbol, if defined, indicates that the setgrent_r routine * is available to setgrent re-entrantly. */ /* SETGRENT_R_PROTO: * This symbol encodes the prototype of setgrent_r. * It is zero if d_setgrent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setgrent_r * is defined. */ /*#define HAS_SETGRENT_R / **/ #define SETGRENT_R_PROTO 0 /**/ /* HAS_SETHOSTENT: * This symbol, if defined, indicates that the sethostent() routine is * available. */ /*#define HAS_SETHOSTENT / **/ /* HAS_SETHOSTENT_R: * This symbol, if defined, indicates that the sethostent_r routine * is available to sethostent re-entrantly. */ /* SETHOSTENT_R_PROTO: * This symbol encodes the prototype of sethostent_r. * It is zero if d_sethostent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_sethostent_r * is defined. */ /*#define HAS_SETHOSTENT_R / **/ #define SETHOSTENT_R_PROTO 0 /**/ /* HAS_SETLOCALE_R: * This symbol, if defined, indicates that the setlocale_r routine * is available to setlocale re-entrantly. */ /* SETLOCALE_R_PROTO: * This symbol encodes the prototype of setlocale_r. * It is zero if d_setlocale_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setlocale_r * is defined. */ /*#define HAS_SETLOCALE_R / **/ #define SETLOCALE_R_PROTO 0 /**/ /* HAS_SETNETENT: * This symbol, if defined, indicates that the setnetent() routine is * available. */ /*#define HAS_SETNETENT / **/ /* HAS_SETNETENT_R: * This symbol, if defined, indicates that the setnetent_r routine * is available to setnetent re-entrantly. */ /* SETNETENT_R_PROTO: * This symbol encodes the prototype of setnetent_r. * It is zero if d_setnetent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setnetent_r * is defined. */ /*#define HAS_SETNETENT_R / **/ #define SETNETENT_R_PROTO 0 /**/ /* HAS_SETPROTOENT: * This symbol, if defined, indicates that the setprotoent() routine is * available. */ /*#define HAS_SETPROTOENT / **/ /* HAS_SETPGRP: * This symbol, if defined, indicates that the setpgrp routine is * available to set the current process group. */ /* USE_BSD_SETPGRP: * This symbol, if defined, indicates that setpgrp needs two * arguments whereas USG one needs none. See also HAS_SETPGID * for a POSIX interface. */ /*#define HAS_SETPGRP / **/ /*#define USE_BSD_SETPGRP / **/ /* HAS_SETPROTOENT_R: * This symbol, if defined, indicates that the setprotoent_r routine * is available to setprotoent re-entrantly. */ /* SETPROTOENT_R_PROTO: * This symbol encodes the prototype of setprotoent_r. * It is zero if d_setprotoent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setprotoent_r * is defined. */ /*#define HAS_SETPROTOENT_R / **/ #define SETPROTOENT_R_PROTO 0 /**/ /* HAS_SETPWENT: * This symbol, if defined, indicates that the setpwent routine is * available for initializing sequential access of the passwd database. */ /*#define HAS_SETPWENT / **/ /* HAS_SETPWENT_R: * This symbol, if defined, indicates that the setpwent_r routine * is available to setpwent re-entrantly. */ /* SETPWENT_R_PROTO: * This symbol encodes the prototype of setpwent_r. * It is zero if d_setpwent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setpwent_r * is defined. */ /*#define HAS_SETPWENT_R / **/ #define SETPWENT_R_PROTO 0 /**/ /* HAS_SETSERVENT: * This symbol, if defined, indicates that the setservent() routine is * available. */ /*#define HAS_SETSERVENT / **/ /* HAS_SETSERVENT_R: * This symbol, if defined, indicates that the setservent_r routine * is available to setservent re-entrantly. */ /* SETSERVENT_R_PROTO: * This symbol encodes the prototype of setservent_r. * It is zero if d_setservent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setservent_r * is defined. */ /*#define HAS_SETSERVENT_R / **/ #define SETSERVENT_R_PROTO 0 /**/ /* HAS_SETVBUF: * This symbol, if defined, indicates that the setvbuf routine is * available to change buffering on an open stdio stream. * to a line-buffered mode. */ #define HAS_SETVBUF /**/ /* HAS_SHM: * This symbol, if defined, indicates that the entire shm*(2) library is * supported. */ /*#define HAS_SHM / **/ /* Shmat_t: * This symbol holds the return type of the shmat() system call. * Usually set to 'void *' or 'char *'. */ /* HAS_SHMAT_PROTOTYPE: * This symbol, if defined, indicates that the sys/shm.h includes * a prototype for shmat(). Otherwise, it is up to the program to * guess one. Shmat_t shmat(int, Shmat_t, int) is a good guess, * but not always right so it should be emitted by the program only * when HAS_SHMAT_PROTOTYPE is not defined to avoid conflicting defs. */ #define Shmat_t void * /**/ /*#define HAS_SHMAT_PROTOTYPE / **/ /* HAS_SOCKET: * This symbol, if defined, indicates that the BSD socket interface is * supported. */ /* HAS_SOCKETPAIR: * This symbol, if defined, indicates that the BSD socketpair() call is * supported. */ /* HAS_MSG_CTRUNC: * This symbol, if defined, indicates that the MSG_CTRUNC is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_DONTROUTE: * This symbol, if defined, indicates that the MSG_DONTROUTE is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_OOB: * This symbol, if defined, indicates that the MSG_OOB is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_PEEK: * This symbol, if defined, indicates that the MSG_PEEK is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_PROXY: * This symbol, if defined, indicates that the MSG_PROXY is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_SCM_RIGHTS: * This symbol, if defined, indicates that the SCM_RIGHTS is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ #define HAS_SOCKET /**/ /*#define HAS_SOCKETPAIR / **/ /*#define HAS_MSG_CTRUNC / **/ /*#define HAS_MSG_DONTROUTE / **/ /*#define HAS_MSG_OOB / **/ /*#define HAS_MSG_PEEK / **/ /*#define HAS_MSG_PROXY / **/ /*#define HAS_SCM_RIGHTS / **/ /* HAS_SRAND48_R: * This symbol, if defined, indicates that the srand48_r routine * is available to srand48 re-entrantly. */ /* SRAND48_R_PROTO: * This symbol encodes the prototype of srand48_r. * It is zero if d_srand48_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_srand48_r * is defined. */ /*#define HAS_SRAND48_R / **/ #define SRAND48_R_PROTO 0 /**/ /* HAS_SRANDOM_R: * This symbol, if defined, indicates that the srandom_r routine * is available to srandom re-entrantly. */ /* SRANDOM_R_PROTO: * This symbol encodes the prototype of srandom_r. * It is zero if d_srandom_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_srandom_r * is defined. */ /*#define HAS_SRANDOM_R / **/ #define SRANDOM_R_PROTO 0 /**/ /* USE_STAT_BLOCKS: * This symbol is defined if this system has a stat structure declaring * st_blksize and st_blocks. */ #ifndef USE_STAT_BLOCKS /*#define USE_STAT_BLOCKS / **/ #endif /* USE_STRUCT_COPY: * This symbol, if defined, indicates that this C compiler knows how * to copy structures. If undefined, you'll need to use a block copy * routine of some sort instead. */ #define USE_STRUCT_COPY /**/ /* HAS_STRERROR: * This symbol, if defined, indicates that the strerror routine is * available to translate error numbers to strings. See the writeup * of Strerror() in this file before you try to define your own. */ /* HAS_SYS_ERRLIST: * This symbol, if defined, indicates that the sys_errlist array is * available to translate error numbers to strings. The extern int * sys_nerr gives the size of that table. */ /* Strerror: * This preprocessor symbol is defined as a macro if strerror() is * not available to translate error numbers to strings but sys_errlist[] * array is there. */ #define HAS_STRERROR /**/ #define HAS_SYS_ERRLIST /**/ #define Strerror(e) strerror(e) /* HAS_STRERROR_R: * This symbol, if defined, indicates that the strerror_r routine * is available to strerror re-entrantly. */ /* STRERROR_R_PROTO: * This symbol encodes the prototype of strerror_r. * It is zero if d_strerror_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_strerror_r * is defined. */ /*#define HAS_STRERROR_R / **/ #define STRERROR_R_PROTO 0 /**/ /* HAS_STRTOUL: * This symbol, if defined, indicates that the strtoul routine is * available to provide conversion of strings to unsigned long. */ #define HAS_STRTOUL /**/ /* HAS_TIME: * This symbol, if defined, indicates that the time() routine exists. */ /* Time_t: * This symbol holds the type returned by time(). It can be long, * or time_t on BSD sites (in which case should be * included). */ #define HAS_TIME /**/ #define Time_t time_t /* Time type */ /* HAS_TIMES: * This symbol, if defined, indicates that the times() routine exists. * Note that this became obsolete on some systems (SUNOS), which now * use getrusage(). It may be necessary to include . */ #define HAS_TIMES /**/ /* HAS_TMPNAM_R: * This symbol, if defined, indicates that the tmpnam_r routine * is available to tmpnam re-entrantly. */ /* TMPNAM_R_PROTO: * This symbol encodes the prototype of tmpnam_r. * It is zero if d_tmpnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_tmpnam_r * is defined. */ /*#define HAS_TMPNAM_R / **/ #define TMPNAM_R_PROTO 0 /**/ /* HAS_TTYNAME_R: * This symbol, if defined, indicates that the ttyname_r routine * is available to ttyname re-entrantly. */ /* TTYNAME_R_PROTO: * This symbol encodes the prototype of ttyname_r. * It is zero if d_ttyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ttyname_r * is defined. */ /*#define HAS_TTYNAME_R / **/ #define TTYNAME_R_PROTO 0 /**/ /* HAS_UNION_SEMUN: * This symbol, if defined, indicates that the union semun is * defined by including . If not, the user code * probably needs to define it as: * union semun { * int val; * struct semid_ds *buf; * unsigned short *array; * } */ /* USE_SEMCTL_SEMUN: * This symbol, if defined, indicates that union semun is * used for semctl IPC_STAT. */ /* USE_SEMCTL_SEMID_DS: * This symbol, if defined, indicates that struct semid_ds * is * used for semctl IPC_STAT. */ #define HAS_UNION_SEMUN /**/ /*#define USE_SEMCTL_SEMUN / **/ /*#define USE_SEMCTL_SEMID_DS / **/ /* HAS_VFORK: * This symbol, if defined, indicates that vfork() exists. */ /*#define HAS_VFORK / **/ /* HAS_PSEUDOFORK: * This symbol, if defined, indicates that an emulation of the * fork routine is available. */ /*#define HAS_PSEUDOFORK / **/ /* Signal_t: * This symbol's value is either "void" or "int", corresponding to the * appropriate return type of a signal handler. Thus, you can declare * a signal handler using "Signal_t (*handler)()", and define the * handler using "Signal_t handler(sig)". */ #define Signal_t void /* Signal handler's return type */ /* HASVOLATILE: * This symbol, if defined, indicates that this C compiler knows about * the volatile declaration. */ #define HASVOLATILE /**/ #ifndef HASVOLATILE #define volatile #endif /* Fpos_t: * This symbol holds the type used to declare file positions in libc. * It can be fpos_t, long, uint, etc... It may be necessary to include * to get any typedef'ed information. */ #define Fpos_t fpos_t /* File position type */ /* Gid_t_f: * This symbol defines the format string used for printing a Gid_t. */ #define Gid_t_f "ld" /**/ /* Gid_t_sign: * This symbol holds the signedess of a Gid_t. * 1 for unsigned, -1 for signed. */ #define Gid_t_sign -1 /* GID sign */ /* Gid_t_size: * This symbol holds the size of a Gid_t in bytes. */ #define Gid_t_size 4 /* GID size */ /* Gid_t: * This symbol holds the return type of getgid() and the type of * argument to setrgid() and related functions. Typically, * it is the type of group ids in the kernel. It can be int, ushort, * gid_t, etc... It may be necessary to include to get * any typedef'ed information. */ #define Gid_t gid_t /* Type for getgid(), etc... */ /* I_DIRENT: * This symbol, if defined, indicates to the C program that it should * include . Using this symbol also triggers the definition * of the Direntry_t define which ends up being 'struct dirent' or * 'struct direct' depending on the availability of . */ /* DIRNAMLEN: * This symbol, if defined, indicates to the C program that the length * of directory entry names is provided by a d_namlen field. Otherwise * you need to do strlen() on the d_name field. */ /* Direntry_t: * This symbol is set to 'struct direct' or 'struct dirent' depending on * whether dirent is available or not. You should use this pseudo type to * portably declare your directory entries. */ #define I_DIRENT /**/ #define DIRNAMLEN /**/ #define Direntry_t struct direct /* I_GRP: * This symbol, if defined, indicates to the C program that it should * include . */ /* GRPASSWD: * This symbol, if defined, indicates to the C program that struct group * in contains gr_passwd. */ /*#define I_GRP / **/ /*#define GRPASSWD / **/ /* I_MACH_CTHREADS: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_MACH_CTHREADS / **/ /* I_NDBM: * This symbol, if defined, indicates that exists and should * be included. */ /* I_GDBMNDBM: * This symbol, if defined, indicates that exists and should * be included. This was the location of the ndbm.h compatibility file * in RedHat 7.1. */ /* I_GDBM_NDBM: * This symbol, if defined, indicates that exists and should * be included. This is the location of the ndbm.h compatibility file * in Debian 4.0. */ /* NDBM_H_USES_PROTOTYPES: * This symbol, if defined, indicates that uses real ANSI C * prototypes instead of K&R style function declarations without any * parameter information. While ANSI C prototypes are supported in C++, * K&R style function declarations will yield errors. */ /* GDBMNDBM_H_USES_PROTOTYPES: * This symbol, if defined, indicates that uses real ANSI C * prototypes instead of K&R style function declarations without any * parameter information. While ANSI C prototypes are supported in C++, * K&R style function declarations will yield errors. */ /* GDBM_NDBM_H_USES_PROTOTYPES: * This symbol, if defined, indicates that uses real ANSI C * prototypes instead of K&R style function declarations without any * parameter information. While ANSI C prototypes are supported in C++, * K&R style function declarations will yield errors. */ /*#define I_NDBM / **/ /*#define I_GDBMNDBM / **/ /*#define I_GDBM_NDBM / **/ /*#define NDBM_H_USES_PROTOTYPES / **/ /*#define GDBMNDBM_H_USES_PROTOTYPES / **/ /*#define GDBM_NDBM_H_USES_PROTOTYPES / **/ /* I_NETDB: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_NETDB / **/ /* I_NET_ERRNO: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_NET_ERRNO / **/ /* I_PTHREAD: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_PTHREAD / **/ /* I_PWD: * This symbol, if defined, indicates to the C program that it should * include . */ /* PWQUOTA: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_quota. */ /* PWAGE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_age. */ /* PWCHANGE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_change. */ /* PWCLASS: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_class. */ /* PWEXPIRE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_expire. */ /* PWCOMMENT: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_comment. */ /* PWGECOS: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_gecos. */ /* PWPASSWD: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_passwd. */ /*#define I_PWD / **/ /*#define PWQUOTA / **/ /*#define PWAGE / **/ /*#define PWCHANGE / **/ /*#define PWCLASS / **/ /*#define PWEXPIRE / **/ /*#define PWCOMMENT / **/ /*#define PWGECOS / **/ /*#define PWPASSWD / **/ /* I_SYS_ACCESS: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_ACCESS / **/ /* I_SYS_SECURITY: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_SECURITY / **/ /* I_SYSUIO: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSUIO / **/ /* I_STDARG: * This symbol, if defined, indicates that exists and should * be included. */ /* I_VARARGS: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_STDARG /**/ /*#define I_VARARGS / **/ /* PERL_INC_VERSION_LIST: * This variable specifies the list of subdirectories in over * which perl.c:incpush() and lib/lib.pm will automatically * search when adding directories to @INC, in a format suitable * for a C initialization string. See the inc_version_list entry * in Porting/Glossary for more details. */ /*#define PERL_INC_VERSION_LIST 0 / **/ /* INSTALL_USR_BIN_PERL: * This symbol, if defined, indicates that Perl is to be installed * also as /usr/bin/perl. */ /*#define INSTALL_USR_BIN_PERL / **/ /* Off_t: * This symbol holds the type used to declare offsets in the kernel. * It can be int, long, off_t, etc... It may be necessary to include * to get any typedef'ed information. */ /* LSEEKSIZE: * This symbol holds the number of bytes used by the Off_t. */ /* Off_t_size: * This symbol holds the number of bytes used by the Off_t. */ #define Off_t long /* type */ #define LSEEKSIZE 4 /* size */ #define Off_t_size 4 /* size */ /* Free_t: * This variable contains the return type of free(). It is usually * void, but occasionally int. */ /* Malloc_t: * This symbol is the type of pointer returned by malloc and realloc. */ #define Malloc_t void * /**/ #define Free_t void /**/ /* PERL_MALLOC_WRAP: * This symbol, if defined, indicates that we'd like malloc wrap checks. */ #define PERL_MALLOC_WRAP /**/ /* MYMALLOC: * This symbol, if defined, indicates that we're using our own malloc. */ /*#define MYMALLOC / **/ /* Mode_t: * This symbol holds the type used to declare file modes * for systems calls. It is usually mode_t, but may be * int or unsigned short. It may be necessary to include * to get any typedef'ed information. */ #define Mode_t mode_t /* file mode parameter for system calls */ /* Netdb_host_t: * This symbol holds the type used for the 1st argument * to gethostbyaddr(). */ /* Netdb_hlen_t: * This symbol holds the type used for the 2nd argument * to gethostbyaddr(). */ /* Netdb_name_t: * This symbol holds the type used for the argument to * gethostbyname(). */ /* Netdb_net_t: * This symbol holds the type used for the 1st argument to * getnetbyaddr(). */ #define Netdb_host_t char * /**/ #define Netdb_hlen_t int /**/ #define Netdb_name_t char * /**/ #define Netdb_net_t long /**/ /* PERL_OTHERLIBDIRS: * This variable contains a colon-separated set of paths for the perl * binary to search for additional library files or modules. * These directories will be tacked to the end of @INC. * Perl will automatically search below each path for version- * and architecture-specific directories. See PERL_INC_VERSION_LIST * for more details. */ /*#define PERL_OTHERLIBDIRS "" / **/ /* Pid_t: * This symbol holds the type used to declare process ids in the kernel. * It can be int, uint, pid_t, etc... It may be necessary to include * to get any typedef'ed information. */ #define Pid_t int /* PID type */ /* PRIVLIB: * This symbol contains the name of the private library for this package. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. The program * should be prepared to do ~ expansion. */ /* PRIVLIB_EXP: * This symbol contains the ~name expanded version of PRIVLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ #define PRIVLIB "c:\\perl\\lib" /**/ #define PRIVLIB_EXP (win32_get_privlib(PERL_VERSION_STRING, NULL)) /**/ /* CAN_PROTOTYPE: * If defined, this macro indicates that the C compiler can handle * function prototypes. */ /* _: * This macro is used to declare function parameters for folks who want * to make declarations with prototypes using a different style than * the above macros. Use double parentheses. For example: * * int main _((int argc, char *argv[])); */ #define CAN_PROTOTYPE /**/ #ifdef CAN_PROTOTYPE #define _(args) args #else #define _(args) () #endif /* Select_fd_set_t: * This symbol holds the type used for the 2nd, 3rd, and 4th * arguments to select. Usually, this is 'fd_set *', if HAS_FD_SET * is defined, and 'int *' otherwise. This is only useful if you * have select(), of course. */ #define Select_fd_set_t Perl_fd_set * /**/ /* SH_PATH: * This symbol contains the full pathname to the shell used on this * on this system to execute Bourne shell scripts. Usually, this will be * /bin/sh, though it's possible that some systems will have /bin/ksh, * /bin/pdksh, /bin/ash, /bin/bash, or even something such as * D:/bin/sh.exe. */ #define SH_PATH "cmd /x /c" /**/ /* SIG_NAME: * This symbol contains a list of signal names in order of * signal number. This is intended * to be used as a static array initialization, like this: * char *sig_name[] = { SIG_NAME }; * The signals in the list are separated with commas, and each signal * is surrounded by double quotes. There is no leading SIG in the signal * name, i.e. SIGQUIT is known as "QUIT". * Gaps in the signal numbers (up to NSIG) are filled in with NUMnn, * etc., where nn is the actual signal number (e.g. NUM37). * The signal number for sig_name[i] is stored in sig_num[i]. * The last element is 0 to terminate the list with a NULL. This * corresponds to the 0 at the end of the sig_name_init list. * Note that this variable is initialized from the sig_name_init, * not from sig_name (which is unused). */ /* SIG_NUM: * This symbol contains a list of signal numbers, in the same order as the * SIG_NAME list. It is suitable for static array initialization, as in: * int sig_num[] = { SIG_NUM }; * The signals in the list are separated with commas, and the indices * within that list and the SIG_NAME list match, so it's easy to compute * the signal name from a number or vice versa at the price of a small * dynamic linear lookup. * Duplicates are allowed, but are moved to the end of the list. * The signal number corresponding to sig_name[i] is sig_number[i]. * if (i < NSIG) then sig_number[i] == i. * The last element is 0, corresponding to the 0 at the end of * the sig_name_init list. * Note that this variable is initialized from the sig_num_init, * not from sig_num (which is unused). */ /* SIG_SIZE: * This variable contains the number of elements of the SIG_NAME * and SIG_NUM arrays, excluding the final NULL entry. */ #define SIG_NAME "ZERO", "HUP", "INT", "QUIT", "ILL", "NUM05", "NUM06", "NUM07", "FPE", "KILL", "NUM10", "SEGV", "NUM12", "PIPE", "ALRM", "TERM", "NUM16", "NUM17", "NUM18", "NUM19", "CHLD", "BREAK", "ABRT", "STOP", "NUM24", "CONT", "CLD", 0 /**/ #define SIG_NUM 0, 1, 2, 21, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 20, 0 /**/ #define SIG_SIZE 27 /**/ /* SITEARCH: * This symbol contains the name of the private library for this package. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. The program * should be prepared to do ~ expansion. * The standard distribution will put nothing in this directory. * After perl has been installed, users may install their own local * architecture-dependent modules in this directory with * MakeMaker Makefile.PL * or equivalent. See INSTALL for details. */ /* SITEARCH_EXP: * This symbol contains the ~name expanded version of SITEARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ #define SITEARCH "c:\\perl\\site\\lib" /**/ /*#define SITEARCH_EXP "" / **/ /* SITELIB: * This symbol contains the name of the private library for this package. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. The program * should be prepared to do ~ expansion. * The standard distribution will put nothing in this directory. * After perl has been installed, users may install their own local * architecture-independent modules in this directory with * MakeMaker Makefile.PL * or equivalent. See INSTALL for details. */ /* SITELIB_EXP: * This symbol contains the ~name expanded version of SITELIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ /* SITELIB_STEM: * This define is SITELIB_EXP with any trailing version-specific component * removed. The elements in inc_version_list (inc_version_list.U) can * be tacked onto this variable to generate a list of directories to search. */ #define SITELIB "c:\\perl\\site\\lib" /**/ #define SITELIB_EXP (win32_get_sitelib(PERL_VERSION_STRING, NULL)) /**/ #define SITELIB_STEM "" /**/ /* Size_t_size: * This symbol holds the size of a Size_t in bytes. */ #define Size_t_size 8 /**/ /* Size_t: * This symbol holds the type used to declare length parameters * for string functions. It is usually size_t, but may be * unsigned long, int, etc. It may be necessary to include * to get any typedef'ed information. */ #define Size_t size_t /* length paramater for string functions */ /* Sock_size_t: * This symbol holds the type used for the size argument of * various socket calls (just the base type, not the pointer-to). */ #define Sock_size_t int /**/ /* STDCHAR: * This symbol is defined to be the type of char used in stdio.h. * It has the values "unsigned char" or "char". */ #define STDCHAR char /**/ /* Uid_t_f: * This symbol defines the format string used for printing a Uid_t. */ #define Uid_t_f "ld" /**/ /* Uid_t_sign: * This symbol holds the signedess of a Uid_t. * 1 for unsigned, -1 for signed. */ #define Uid_t_sign -1 /* UID sign */ /* Uid_t_size: * This symbol holds the size of a Uid_t in bytes. */ #define Uid_t_size 4 /* UID size */ /* Uid_t: * This symbol holds the type used to declare user ids in the kernel. * It can be int, ushort, uid_t, etc... It may be necessary to include * to get any typedef'ed information. */ #define Uid_t uid_t /* UID type */ /* USE_ITHREADS: * This symbol, if defined, indicates that Perl should be built to * use the interpreter-based threading implementation. */ /* USE_5005THREADS: * This symbol, if defined, indicates that Perl should be built to * use the 5.005-based threading implementation. * Only valid up to 5.8.x. */ /* OLD_PTHREADS_API: * This symbol, if defined, indicates that Perl should * be built to use the old draft POSIX threads API. */ /* USE_REENTRANT_API: * This symbol, if defined, indicates that Perl should * try to use the various _r versions of library functions. * This is extremely experimental. */ /*#define USE_5005THREADS / **/ /*#define USE_ITHREADS / **/ #if defined(USE_5005THREADS) && !defined(USE_ITHREADS) #define USE_THREADS /* until src is revised*/ #endif /*#define OLD_PTHREADS_API / **/ /*#define USE_REENTRANT_API / **/ /* PERL_VENDORARCH: * If defined, this symbol contains the name of a private library. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. * It may have a ~ on the front. * The standard distribution will put nothing in this directory. * Vendors who distribute perl may wish to place their own * architecture-dependent modules and extensions in this directory with * MakeMaker Makefile.PL INSTALLDIRS=vendor * or equivalent. See INSTALL for details. */ /* PERL_VENDORARCH_EXP: * This symbol contains the ~name expanded version of PERL_VENDORARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ /*#define PERL_VENDORARCH "" / **/ /*#define PERL_VENDORARCH_EXP "" / **/ /* PERL_VENDORLIB_EXP: * This symbol contains the ~name expanded version of VENDORLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ /* PERL_VENDORLIB_STEM: * This define is PERL_VENDORLIB_EXP with any trailing version-specific component * removed. The elements in inc_version_list (inc_version_list.U) can * be tacked onto this variable to generate a list of directories to search. */ /*#define PERL_VENDORLIB_EXP "" / **/ /*#define PERL_VENDORLIB_STEM "" / **/ /* VOIDFLAGS: * This symbol indicates how much support of the void type is given by this * compiler. What various bits mean: * * 1 = supports declaration of void * 2 = supports arrays of pointers to functions returning void * 4 = supports comparisons between pointers to void functions and * addresses of void functions * 8 = suports declaration of generic void pointers * * The package designer should define VOIDUSED to indicate the requirements * of the package. This can be done either by #defining VOIDUSED before * including config.h, or by defining defvoidused in Myinit.U. If the * latter approach is taken, only those flags will be tested. If the * level of void support necessary is not present, defines void to int. */ #ifndef VOIDUSED #define VOIDUSED 15 #endif #define VOIDFLAGS 15 #if (VOIDFLAGS & VOIDUSED) != VOIDUSED #define void int /* is void to be avoided? */ #define M_VOID /* Xenix strikes again */ #endif /* USE_CROSS_COMPILE: * This symbol, if defined, indicates that Perl is being cross-compiled. */ /* PERL_TARGETARCH: * This symbol, if defined, indicates the target architecture * Perl has been cross-compiled to. Undefined if not a cross-compile. */ #ifndef USE_CROSS_COMPILE /*#define USE_CROSS_COMPILE / **/ #define PERL_TARGETARCH "" /**/ #endif /* MEM_ALIGNBYTES: * This symbol contains the number of bytes required to align a * double, or a long double when applicable. Usual values are 2, * 4 and 8. The default is eight, for safety. */ #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH) # define MEM_ALIGNBYTES 8 #else #define MEM_ALIGNBYTES 8 #endif /* BYTEORDER: * This symbol holds the hexadecimal constant defined in byteorder, * in a UV, i.e. 0x1234 or 0x4321 or 0x12345678, etc... * If the compiler supports cross-compiling or multiple-architecture * binaries (eg. on NeXT systems), use compiler-defined macros to * determine the byte order. * On NeXT 3.2 (and greater), you can build "Fat" Multiple Architecture * Binaries (MAB) on either big endian or little endian machines. * The endian-ness is available at compile-time. This only matters * for perl, where the config.h can be generated and installed on * one system, and used by a different architecture to build an * extension. Older versions of NeXT that might not have * defined either *_ENDIAN__ were all on Motorola 680x0 series, * so the default case (for NeXT) is big endian to catch them. * This might matter for NeXT 3.0. */ #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH) # ifdef __LITTLE_ENDIAN__ # if LONGSIZE == 4 # define BYTEORDER 0x1234 # else # if LONGSIZE == 8 # define BYTEORDER 0x12345678 # endif # endif # else # ifdef __BIG_ENDIAN__ # if LONGSIZE == 4 # define BYTEORDER 0x4321 # else # if LONGSIZE == 8 # define BYTEORDER 0x87654321 # endif # endif # endif # endif # if !defined(BYTEORDER) && (defined(NeXT) || defined(__NeXT__)) # define BYTEORDER 0x4321 # endif #else #define BYTEORDER 0x1234 /* large digits for MSB */ #endif /* NeXT */ /* CHARBITS: * This symbol contains the size of a char, so that the C preprocessor * can make decisions based on it. */ #define CHARBITS 8 /**/ /* CASTI32: * This symbol is defined if the C compiler can cast negative * or large floating point numbers to 32-bit ints. */ /*#define CASTI32 / **/ /* CASTNEGFLOAT: * This symbol is defined if the C compiler can cast negative * numbers to unsigned longs, ints and shorts. */ /* CASTFLAGS: * This symbol contains flags that say what difficulties the compiler * has casting odd floating values to unsigned long: * 0 = ok * 1 = couldn't cast < 0 * 2 = couldn't cast >= 0x80000000 * 4 = couldn't cast in argument expression list */ #define CASTNEGFLOAT /**/ #define CASTFLAGS 0 /**/ /* VOID_CLOSEDIR: * This symbol, if defined, indicates that the closedir() routine * does not return a value. */ /*#define VOID_CLOSEDIR / **/ /* HAS_FD_SET: * This symbol, when defined, indicates presence of the fd_set typedef * in */ #define HAS_FD_SET /**/ /* Gconvert: * This preprocessor macro is defined to convert a floating point * number to a string without a trailing decimal point. This * emulates the behavior of sprintf("%g"), but is sometimes much more * efficient. If gconvert() is not available, but gcvt() drops the * trailing decimal point, then gcvt() is used. If all else fails, * a macro using sprintf("%g") is used. Arguments for the Gconvert * macro are: value, number of digits, whether trailing zeros should * be retained, and the output buffer. * The usual values are: * d_Gconvert='gconvert((x),(n),(t),(b))' * d_Gconvert='gcvt((x),(n),(b))' * d_Gconvert='sprintf((b),"%.*g",(n),(x))' * The last two assume trailing zeros should not be kept. */ #define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(x)) /* HAS_GETPAGESIZE: * This symbol, if defined, indicates that the getpagesize system call * is available to get system page size, which is the granularity of * many memory management calls. */ /*#define HAS_GETPAGESIZE / **/ /* HAS_GNULIBC: * This symbol, if defined, indicates to the C program that * the GNU C library is being used. A better check is to use * the __GLIBC__ and __GLIBC_MINOR__ symbols supplied with glibc. */ /*#define HAS_GNULIBC / **/ #if defined(HAS_GNULIBC) && !defined(_GNU_SOURCE) # define _GNU_SOURCE #endif /* HAS_ISASCII: * This manifest constant lets the C program know that isascii * is available. */ #define HAS_ISASCII /**/ /* HAS_LCHOWN: * This symbol, if defined, indicates that the lchown routine is * available to operate on a symbolic link (instead of following the * link). */ /*#define HAS_LCHOWN / **/ /* HAS_OPEN3: * This manifest constant lets the C program know that the three * argument form of open(2) is available. */ /*#define HAS_OPEN3 / **/ /* HAS_SAFE_BCOPY: * This symbol, if defined, indicates that the bcopy routine is available * to copy potentially overlapping memory blocks. Normally, you should * probably use memmove() or memcpy(). If neither is defined, roll your * own version. */ /*#define HAS_SAFE_BCOPY / **/ /* HAS_SAFE_MEMCPY: * This symbol, if defined, indicates that the memcpy routine is available * to copy potentially overlapping memory blocks. If you need to * copy overlapping memory blocks, you should check HAS_MEMMOVE and * use memmove() instead, if available. */ /*#define HAS_SAFE_MEMCPY / **/ /* HAS_SANE_MEMCMP: * This symbol, if defined, indicates that the memcmp routine is available * and can be used to compare relative magnitudes of chars with their high * bits set. If it is not defined, roll your own version. */ #define HAS_SANE_MEMCMP /**/ /* HAS_SIGACTION: * This symbol, if defined, indicates that Vr4's sigaction() routine * is available. */ /*#define HAS_SIGACTION / **/ /* HAS_SIGSETJMP: * This variable indicates to the C program that the sigsetjmp() * routine is available to save the calling process's registers * and stack environment for later use by siglongjmp(), and * to optionally save the process's signal mask. See * Sigjmp_buf, Sigsetjmp, and Siglongjmp. */ /* Sigjmp_buf: * This is the buffer type to be used with Sigsetjmp and Siglongjmp. */ /* Sigsetjmp: * This macro is used in the same way as sigsetjmp(), but will invoke * traditional setjmp() if sigsetjmp isn't available. * See HAS_SIGSETJMP. */ /* Siglongjmp: * This macro is used in the same way as siglongjmp(), but will invoke * traditional longjmp() if siglongjmp isn't available. * See HAS_SIGSETJMP. */ /*#define HAS_SIGSETJMP / **/ #ifdef HAS_SIGSETJMP #define Sigjmp_buf sigjmp_buf #define Sigsetjmp(buf,save_mask) sigsetjmp((buf),(save_mask)) #define Siglongjmp(buf,retval) siglongjmp((buf),(retval)) #else #define Sigjmp_buf jmp_buf #define Sigsetjmp(buf,save_mask) setjmp((buf)) #define Siglongjmp(buf,retval) longjmp((buf),(retval)) #endif /* USE_STDIO_PTR: * This symbol is defined if the _ptr and _cnt fields (or similar) * of the stdio FILE structure can be used to access the stdio buffer * for a file handle. If this is defined, then the FILE_ptr(fp) * and FILE_cnt(fp) macros will also be defined and should be used * to access these fields. */ /* FILE_ptr: * This macro is used to access the _ptr field (or equivalent) of the * FILE structure pointed to by its argument. This macro will always be * defined if USE_STDIO_PTR is defined. */ /* STDIO_PTR_LVALUE: * This symbol is defined if the FILE_ptr macro can be used as an * lvalue. */ /* FILE_cnt: * This macro is used to access the _cnt field (or equivalent) of the * FILE structure pointed to by its argument. This macro will always be * defined if USE_STDIO_PTR is defined. */ /* STDIO_CNT_LVALUE: * This symbol is defined if the FILE_cnt macro can be used as an * lvalue. */ /* STDIO_PTR_LVAL_SETS_CNT: * This symbol is defined if using the FILE_ptr macro as an lvalue * to increase the pointer by n has the side effect of decreasing the * value of File_cnt(fp) by n. */ /* STDIO_PTR_LVAL_NOCHANGE_CNT: * This symbol is defined if using the FILE_ptr macro as an lvalue * to increase the pointer by n leaves File_cnt(fp) unchanged. */ #define USE_STDIO_PTR /**/ #ifdef USE_STDIO_PTR #define FILE_ptr(fp) ((fp)->_ptr) #define STDIO_PTR_LVALUE /**/ #define FILE_cnt(fp) ((fp)->_cnt) #define STDIO_CNT_LVALUE /**/ /*#define STDIO_PTR_LVAL_SETS_CNT / **/ #define STDIO_PTR_LVAL_NOCHANGE_CNT /**/ #endif /* USE_STDIO_BASE: * This symbol is defined if the _base field (or similar) of the * stdio FILE structure can be used to access the stdio buffer for * a file handle. If this is defined, then the FILE_base(fp) macro * will also be defined and should be used to access this field. * Also, the FILE_bufsiz(fp) macro will be defined and should be used * to determine the number of bytes in the buffer. USE_STDIO_BASE * will never be defined unless USE_STDIO_PTR is. */ /* FILE_base: * This macro is used to access the _base field (or equivalent) of the * FILE structure pointed to by its argument. This macro will always be * defined if USE_STDIO_BASE is defined. */ /* FILE_bufsiz: * This macro is used to determine the number of bytes in the I/O * buffer pointed to by _base field (or equivalent) of the FILE * structure pointed to its argument. This macro will always be defined * if USE_STDIO_BASE is defined. */ #define USE_STDIO_BASE /**/ #ifdef USE_STDIO_BASE #define FILE_base(fp) ((fp)->_base) #define FILE_bufsiz(fp) ((fp)->_cnt + (fp)->_ptr - (fp)->_base) #endif /* HAS_VPRINTF: * This symbol, if defined, indicates that the vprintf routine is available * to printf with a pointer to an argument list. If unavailable, you * may need to write your own, probably in terms of _doprnt(). */ /* USE_CHAR_VSPRINTF: * This symbol is defined if this system has vsprintf() returning type * (char*). The trend seems to be to declare it as "int vsprintf()". It * is up to the package author to declare vsprintf correctly based on the * symbol. */ #define HAS_VPRINTF /**/ /*#define USE_CHAR_VSPRINTF / **/ /* DOUBLESIZE: * This symbol contains the size of a double, so that the C preprocessor * can make decisions based on it. */ #define DOUBLESIZE 8 /**/ /* I_TIME: * This symbol, if defined, indicates to the C program that it should * include . */ /* I_SYS_TIME: * This symbol, if defined, indicates to the C program that it should * include . */ /* I_SYS_TIME_KERNEL: * This symbol, if defined, indicates to the C program that it should * include with KERNEL defined. */ /* HAS_TM_TM_ZONE: * This symbol, if defined, indicates to the C program that * the struct tm has a tm_zone field. */ /* HAS_TM_TM_GMTOFF: * This symbol, if defined, indicates to the C program that * the struct tm has a tm_gmtoff field. */ #define I_TIME /**/ /*#define I_SYS_TIME / **/ /*#define I_SYS_TIME_KERNEL / **/ /*#define HAS_TM_TM_ZONE / **/ /*#define HAS_TM_TM_GMTOFF / **/ /* VAL_O_NONBLOCK: * This symbol is to be used during open() or fcntl(F_SETFL) to turn on * non-blocking I/O for the file descriptor. Note that there is no way * back, i.e. you cannot turn it blocking again this way. If you wish to * alternatively switch between blocking and non-blocking, use the * ioctl(FIOSNBIO) call instead, but that is not supported by all devices. */ /* VAL_EAGAIN: * This symbol holds the errno error code set by read() when no data was * present on the non-blocking file descriptor. */ /* RD_NODATA: * This symbol holds the return code from read() when no data is present * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is * not defined, then you can't distinguish between no data and EOF by * issuing a read(). You'll have to find another way to tell for sure! */ /* EOF_NONBLOCK: * This symbol, if defined, indicates to the C program that a read() on * a non-blocking file descriptor will return 0 on EOF, and not the value * held in RD_NODATA (-1 usually, in that case!). */ #define VAL_O_NONBLOCK O_NONBLOCK #define VAL_EAGAIN EAGAIN #define RD_NODATA -1 #define EOF_NONBLOCK /* PTRSIZE: * This symbol contains the size of a pointer, so that the C preprocessor * can make decisions based on it. It will be sizeof(void *) if * the compiler supports (void *); otherwise it will be * sizeof(char *). */ #define PTRSIZE 8 /**/ /* Drand01: * This macro is to be used to generate uniformly distributed * random numbers over the range [0., 1.[. You may have to supply * an 'extern double drand48();' in your program since SunOS 4.1.3 * doesn't provide you with anything relevant in its headers. * See HAS_DRAND48_PROTO. */ /* Rand_seed_t: * This symbol defines the type of the argument of the * random seed function. */ /* seedDrand01: * This symbol defines the macro to be used in seeding the * random number generator (see Drand01). */ /* RANDBITS: * This symbol indicates how many bits are produced by the * function used to generate normalized random numbers. * Values include 15, 16, 31, and 48. */ #define Drand01() (rand()/(double)((unsigned)1< or * to get any typedef'ed information. * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t). */ #define SSize_t __int64 /* signed count of bytes */ /* EBCDIC: * This symbol, if defined, indicates that this system uses * EBCDIC encoding. */ /*#define EBCDIC / **/ /* SETUID_SCRIPTS_ARE_SECURE_NOW: * This symbol, if defined, indicates that the bug that prevents * setuid scripts from being secure is not present in this kernel. */ /* DOSUID: * This symbol, if defined, indicates that the C program should * check the script that it is executing for setuid/setgid bits, and * attempt to emulate setuid/setgid on systems that have disabled * setuid #! scripts because the kernel can't do it securely. * It is up to the package designer to make sure that this emulation * is done securely. Among other things, it should do an fstat on * the script it just opened to make sure it really is a setuid/setgid * script, it should make sure the arguments passed correspond exactly * to the argument on the #! line, and it should not trust any * subprocesses to which it must pass the filename rather than the * file descriptor of the script to be executed. */ /*#define SETUID_SCRIPTS_ARE_SECURE_NOW / **/ /*#define DOSUID / **/ /* PERL_USE_DEVEL: * This symbol, if defined, indicates that Perl was configured with * -Dusedevel, to enable development features. This should not be * done for production builds. */ /*#define PERL_USE_DEVEL / **/ /* HAS_ATOLF: * This symbol, if defined, indicates that the atolf routine is * available to convert strings into long doubles. */ /*#define HAS_ATOLF / **/ /* HAS_ATOLL: * This symbol, if defined, indicates that the atoll routine is * available to convert strings into long longs. */ #define HAS_ATOLL /**/ /* HAS__FWALK: * This symbol, if defined, indicates that the _fwalk system call is * available to apply a function to all the file handles. */ /*#define HAS__FWALK / **/ /* HAS_AINTL: * This symbol, if defined, indicates that the aintl routine is * available. If copysignl is also present we can emulate modfl. */ /*#define HAS_AINTL / **/ /* HAS_BUILTIN_CHOOSE_EXPR: * Can we handle GCC builtin for compile-time ternary-like expressions */ /* HAS_BUILTIN_EXPECT: * Can we handle GCC builtin for telling that certain values are more * likely */ /*#define HAS_BUILTIN_EXPECT / **/ /*#define HAS_BUILTIN_CHOOSE_EXPR / **/ /* HAS_C99_VARIADIC_MACROS: * If defined, the compiler supports C99 variadic macros. */ /*#define HAS_C99_VARIADIC_MACROS / **/ /* HAS_CLASS: * This symbol, if defined, indicates that the class routine is * available to classify doubles. Available for example in AIX. * The returned values are defined in and are: * * FP_PLUS_NORM Positive normalized, nonzero * FP_MINUS_NORM Negative normalized, nonzero * FP_PLUS_DENORM Positive denormalized, nonzero * FP_MINUS_DENORM Negative denormalized, nonzero * FP_PLUS_ZERO +0.0 * FP_MINUS_ZERO -0.0 * FP_PLUS_INF +INF * FP_MINUS_INF -INF * FP_NANS Signaling Not a Number (NaNS) * FP_NANQ Quiet Not a Number (NaNQ) */ /*#define HAS_CLASS / **/ /* HAS_CLEARENV: * This symbol, if defined, indicates that the clearenv () routine is * available for use. */ /*#define HAS_CLEARENV / **/ /* HAS_STRUCT_CMSGHDR: * This symbol, if defined, indicates that the struct cmsghdr * is supported. */ /*#define HAS_STRUCT_CMSGHDR / **/ /* HAS_COPYSIGNL: * This symbol, if defined, indicates that the copysignl routine is * available. If aintl is also present we can emulate modfl. */ /*#define HAS_COPYSIGNL / **/ /* USE_CPLUSPLUS: * This symbol, if defined, indicates that a C++ compiler was * used to compiled Perl and will be used to compile extensions. */ /*#define USE_CPLUSPLUS / **/ /* HAS_DBMINIT_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the dbminit() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int dbminit(char *); */ /*#define HAS_DBMINIT_PROTO / **/ /* HAS_DIR_DD_FD: * This symbol, if defined, indicates that the the DIR* dirstream * structure contains a member variable named dd_fd. */ /*#define HAS_DIR_DD_FD / **/ /* HAS_DIRFD: * This manifest constant lets the C program know that dirfd * is available. */ /*#define HAS_DIRFD / **/ /* DLSYM_NEEDS_UNDERSCORE: * This symbol, if defined, indicates that we need to prepend an * underscore to the symbol name before calling dlsym(). This only * makes sense if you *have* dlsym, which we will presume is the * case if you're using dl_dlopen.xs. */ /*#define DLSYM_NEEDS_UNDERSCORE / **/ /* HAS_FAST_STDIO: * This symbol, if defined, indicates that the "fast stdio" * is available to manipulate the stdio buffers directly. */ #define HAS_FAST_STDIO /**/ /* HAS_FCHDIR: * This symbol, if defined, indicates that the fchdir routine is * available to change directory using a file descriptor. */ /*#define HAS_FCHDIR / **/ /* FCNTL_CAN_LOCK: * This symbol, if defined, indicates that fcntl() can be used * for file locking. Normally on Unix systems this is defined. * It may be undefined on VMS. */ /*#define FCNTL_CAN_LOCK / **/ /* HAS_FINITE: * This symbol, if defined, indicates that the finite routine is * available to check whether a double is finite (non-infinity non-NaN). */ /*#define HAS_FINITE / **/ /* HAS_FINITEL: * This symbol, if defined, indicates that the finitel routine is * available to check whether a long double is finite * (non-infinity non-NaN). */ /*#define HAS_FINITEL / **/ /* HAS_FLOCK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the flock() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int flock(int, int); */ #define HAS_FLOCK_PROTO /**/ /* HAS_FP_CLASS: * This symbol, if defined, indicates that the fp_class routine is * available to classify doubles. Available for example in Digital UNIX. * The returned values are defined in and are: * * FP_SNAN Signaling NaN (Not-a-Number) * FP_QNAN Quiet NaN (Not-a-Number) * FP_POS_INF +infinity * FP_NEG_INF -infinity * FP_POS_NORM Positive normalized * FP_NEG_NORM Negative normalized * FP_POS_DENORM Positive denormalized * FP_NEG_DENORM Negative denormalized * FP_POS_ZERO +0.0 (positive zero) * FP_NEG_ZERO -0.0 (negative zero) */ /*#define HAS_FP_CLASS / **/ /* HAS_FPCLASS: * This symbol, if defined, indicates that the fpclass routine is * available to classify doubles. Available for example in Solaris/SVR4. * The returned values are defined in and are: * * FP_SNAN signaling NaN * FP_QNAN quiet NaN * FP_NINF negative infinity * FP_PINF positive infinity * FP_NDENORM negative denormalized non-zero * FP_PDENORM positive denormalized non-zero * FP_NZERO negative zero * FP_PZERO positive zero * FP_NNORM negative normalized non-zero * FP_PNORM positive normalized non-zero */ /*#define HAS_FPCLASS / **/ /* HAS_FPCLASSIFY: * This symbol, if defined, indicates that the fpclassify routine is * available to classify doubles. Available for example in HP-UX. * The returned values are defined in and are * * FP_NORMAL Normalized * FP_ZERO Zero * FP_INFINITE Infinity * FP_SUBNORMAL Denormalized * FP_NAN NaN * */ /*#define HAS_FPCLASSIFY / **/ /* HAS_FPCLASSL: * This symbol, if defined, indicates that the fpclassl routine is * available to classify long doubles. Available for example in IRIX. * The returned values are defined in and are: * * FP_SNAN signaling NaN * FP_QNAN quiet NaN * FP_NINF negative infinity * FP_PINF positive infinity * FP_NDENORM negative denormalized non-zero * FP_PDENORM positive denormalized non-zero * FP_NZERO negative zero * FP_PZERO positive zero * FP_NNORM negative normalized non-zero * FP_PNORM positive normalized non-zero */ /*#define HAS_FPCLASSL / **/ /* HAS_FPOS64_T: * This symbol will be defined if the C compiler supports fpos64_t. */ /*#define HAS_FPOS64_T / **/ /* HAS_FREXPL: * This symbol, if defined, indicates that the frexpl routine is * available to break a long double floating-point number into * a normalized fraction and an integral power of 2. */ /*#define HAS_FREXPL / **/ /* HAS_STRUCT_FS_DATA: * This symbol, if defined, indicates that the struct fs_data * to do statfs() is supported. */ /*#define HAS_STRUCT_FS_DATA / **/ /* HAS_FSEEKO: * This symbol, if defined, indicates that the fseeko routine is * available to fseek beyond 32 bits (useful for ILP32 hosts). */ /*#define HAS_FSEEKO / **/ /* HAS_FSTATFS: * This symbol, if defined, indicates that the fstatfs routine is * available to stat filesystems by file descriptors. */ /*#define HAS_FSTATFS / **/ /* HAS_FSYNC: * This symbol, if defined, indicates that the fsync routine is * available to write a file's modified data and attributes to * permanent storage. */ /*#define HAS_FSYNC / **/ /* HAS_FTELLO: * This symbol, if defined, indicates that the ftello routine is * available to ftell beyond 32 bits (useful for ILP32 hosts). */ /*#define HAS_FTELLO / **/ /* HAS_FUTIMES: * This symbol, if defined, indicates that the futimes routine is * available to change file descriptor time stamps with struct timevals. */ /*#define HAS_FUTIMES / **/ /* HAS_GETADDRINFO: * This symbol, if defined, indicates that the getaddrinfo() function * is available for use. */ /*#define HAS_GETADDRINFO / **/ /* HAS_GETCWD: * This symbol, if defined, indicates that the getcwd routine is * available to get the current working directory. */ #define HAS_GETCWD /**/ /* HAS_GETESPWNAM: * This symbol, if defined, indicates that the getespwnam system call is * available to retrieve enchanced (shadow) password entries by name. */ /*#define HAS_GETESPWNAM / **/ /* HAS_GETFSSTAT: * This symbol, if defined, indicates that the getfsstat routine is * available to stat filesystems in bulk. */ /*#define HAS_GETFSSTAT / **/ /* HAS_GETITIMER: * This symbol, if defined, indicates that the getitimer routine is * available to return interval timers. */ /*#define HAS_GETITIMER / **/ /* HAS_GETMNT: * This symbol, if defined, indicates that the getmnt routine is * available to get filesystem mount info by filename. */ /*#define HAS_GETMNT / **/ /* HAS_GETMNTENT: * This symbol, if defined, indicates that the getmntent routine is * available to iterate through mounted file systems to get their info. */ /*#define HAS_GETMNTENT / **/ /* HAS_GETNAMEINFO: * This symbol, if defined, indicates that the getnameinfo() function * is available for use. */ /*#define HAS_GETNAMEINFO / **/ /* HAS_GETPRPWNAM: * This symbol, if defined, indicates that the getprpwnam system call is * available to retrieve protected (shadow) password entries by name. */ /*#define HAS_GETPRPWNAM / **/ /* HAS_GETSPNAM: * This symbol, if defined, indicates that the getspnam system call is * available to retrieve SysV shadow password entries by name. */ /*#define HAS_GETSPNAM / **/ /* HAS_HASMNTOPT: * This symbol, if defined, indicates that the hasmntopt routine is * available to query the mount options of file systems. */ /*#define HAS_HASMNTOPT / **/ /* HAS_ILOGBL: * This symbol, if defined, indicates that the ilogbl routine is * available. If scalbnl is also present we can emulate frexpl. */ /*#define HAS_ILOGBL / **/ /* HAS_INETNTOP: * This symbol, if defined, indicates that the inet_ntop() function * is available to parse IPv4 and IPv6 strings. */ /*#define HAS_INETNTOP / **/ /* HAS_INETPTON: * This symbol, if defined, indicates that the inet_pton() function * is available to parse IPv4 and IPv6 strings. */ /*#define HAS_INETPTON / **/ /* HAS_INT64_T: * This symbol will defined if the C compiler supports int64_t. * Usually the needs to be included, but sometimes * is enough. */ /*#define HAS_INT64_T / **/ /* HAS_ISFINITE: * This symbol, if defined, indicates that the isfinite routine is * available to check whether a double is finite (non-infinity non-NaN). */ /*#define HAS_ISFINITE / **/ /* HAS_ISINF: * This symbol, if defined, indicates that the isinf routine is * available to check whether a double is an infinity. */ /*#define HAS_ISINF / **/ /* HAS_ISNAN: * This symbol, if defined, indicates that the isnan routine is * available to check whether a double is a NaN. */ #define HAS_ISNAN /**/ /* HAS_ISNANL: * This symbol, if defined, indicates that the isnanl routine is * available to check whether a long double is a NaN. */ /*#define HAS_ISNANL / **/ /* HAS_LDBL_DIG: * This symbol, if defined, indicates that this system's * or defines the symbol LDBL_DIG, which is the number * of significant digits in a long double precision number. Unlike * for DBL_DIG, there's no good guess for LDBL_DIG if it is undefined. */ #define HAS_LDBL_DIG /**/ /* LIBM_LIB_VERSION: * This symbol, if defined, indicates that libm exports _LIB_VERSION * and that math.h defines the enum to manipulate it. */ /*#define LIBM_LIB_VERSION / **/ /* HAS_MADVISE: * This symbol, if defined, indicates that the madvise system call is * available to map a file into memory. */ /*#define HAS_MADVISE / **/ /* HAS_MALLOC_SIZE: * This symbol, if defined, indicates that the malloc_size * routine is available for use. */ /*#define HAS_MALLOC_SIZE / **/ /* HAS_MALLOC_GOOD_SIZE: * This symbol, if defined, indicates that the malloc_good_size * routine is available for use. */ /*#define HAS_MALLOC_GOOD_SIZE / **/ /* HAS_MKDTEMP: * This symbol, if defined, indicates that the mkdtemp routine is * available to exclusively create a uniquely named temporary directory. */ /*#define HAS_MKDTEMP / **/ /* HAS_MKSTEMPS: * This symbol, if defined, indicates that the mkstemps routine is * available to excluslvely create and open a uniquely named * (with a suffix) temporary file. */ /*#define HAS_MKSTEMPS / **/ /* HAS_MODFL: * This symbol, if defined, indicates that the modfl routine is * available to split a long double x into a fractional part f and * an integer part i such that |f| < 1.0 and (f + i) = x. */ /* HAS_MODFL_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the modfl() function. Otherwise, it is up * to the program to supply one. */ /* HAS_MODFL_POW32_BUG: * This symbol, if defined, indicates that the modfl routine is * broken for long doubles >= pow(2, 32). * For example from 4294967303.150000 one would get 4294967302.000000 * and 1.150000. The bug has been seen in certain versions of glibc, * release 2.2.2 is known to be okay. */ /*#define HAS_MODFL / **/ /*#define HAS_MODFL_PROTO / **/ /*#define HAS_MODFL_POW32_BUG / **/ /* HAS_MPROTECT: * This symbol, if defined, indicates that the mprotect system call is * available to modify the access protection of a memory mapped file. */ /*#define HAS_MPROTECT / **/ /* HAS_STRUCT_MSGHDR: * This symbol, if defined, indicates that the struct msghdr * is supported. */ /*#define HAS_STRUCT_MSGHDR / **/ /* HAS_NL_LANGINFO: * This symbol, if defined, indicates that the nl_langinfo routine is * available to return local data. You will also need * and therefore I_LANGINFO. */ /*#define HAS_NL_LANGINFO / **/ /* HAS_OFF64_T: * This symbol will be defined if the C compiler supports off64_t. */ /*#define HAS_OFF64_T / **/ /* HAS_PROCSELFEXE: * This symbol is defined if PROCSELFEXE_PATH is a symlink * to the absolute pathname of the executing program. */ /* PROCSELFEXE_PATH: * If HAS_PROCSELFEXE is defined this symbol is the filename * of the symbolic link pointing to the absolute pathname of * the executing program. */ /*#define HAS_PROCSELFEXE / **/ #if defined(HAS_PROCSELFEXE) && !defined(PROCSELFEXE_PATH) #define PROCSELFEXE_PATH /**/ #endif /* HAS_PTHREAD_ATTR_SETSCOPE: * This symbol, if defined, indicates that the pthread_attr_setscope * system call is available to set the contention scope attribute of * a thread attribute object. */ /*#define HAS_PTHREAD_ATTR_SETSCOPE / **/ /* HAS_READV: * This symbol, if defined, indicates that the readv routine is * available to do gather reads. You will also need * and there I_SYSUIO. */ /*#define HAS_READV / **/ /* HAS_RECVMSG: * This symbol, if defined, indicates that the recvmsg routine is * available to send structured socket messages. */ /*#define HAS_RECVMSG / **/ /* HAS_SBRK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the sbrk() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern void* sbrk(int); * extern void* sbrk(size_t); */ /*#define HAS_SBRK_PROTO / **/ /* HAS_SCALBNL: * This symbol, if defined, indicates that the scalbnl routine is * available. If ilogbl is also present we can emulate frexpl. */ /*#define HAS_SCALBNL / **/ /* HAS_SENDMSG: * This symbol, if defined, indicates that the sendmsg routine is * available to send structured socket messages. */ /*#define HAS_SENDMSG / **/ /* HAS_SETITIMER: * This symbol, if defined, indicates that the setitimer routine is * available to set interval timers. */ /*#define HAS_SETITIMER / **/ /* HAS_SETPROCTITLE: * This symbol, if defined, indicates that the setproctitle routine is * available to set process title. */ /*#define HAS_SETPROCTITLE / **/ /* USE_SFIO: * This symbol, if defined, indicates that sfio should * be used. */ /*#define USE_SFIO / **/ /* HAS_SIGNBIT: * This symbol, if defined, indicates that the signbit routine is * available to check if the given number has the sign bit set. * This should include correct testing of -0.0. This will only be set * if the signbit() routine is safe to use with the NV type used internally * in perl. Users should call Perl_signbit(), which will be #defined to * the system's signbit() function or macro if this symbol is defined. */ /*#define HAS_SIGNBIT / **/ /* HAS_SIGPROCMASK: * This symbol, if defined, indicates that the sigprocmask * system call is available to examine or change the signal mask * of the calling process. */ /*#define HAS_SIGPROCMASK / **/ /* USE_SITECUSTOMIZE: * This symbol, if defined, indicates that sitecustomize should * be used. */ #ifndef USE_SITECUSTOMIZE /*#define USE_SITECUSTOMIZE / **/ #endif /* HAS_SNPRINTF: * This symbol, if defined, indicates that the snprintf () library * function is available for use. */ /* HAS_VSNPRINTF: * This symbol, if defined, indicates that the vsnprintf () library * function is available for use. */ #define HAS_SNPRINTF /**/ #define HAS_VSNPRINTF /**/ /* HAS_SOCKATMARK: * This symbol, if defined, indicates that the sockatmark routine is * available to test whether a socket is at the out-of-band mark. */ /*#define HAS_SOCKATMARK / **/ /* HAS_SOCKATMARK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the sockatmark() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int sockatmark(int); */ /*#define HAS_SOCKATMARK_PROTO / **/ /* HAS_SOCKS5_INIT: * This symbol, if defined, indicates that the socks5_init routine is * available to initialize SOCKS 5. */ /*#define HAS_SOCKS5_INIT / **/ /* SPRINTF_RETURNS_STRLEN: * This variable defines whether sprintf returns the length of the string * (as per the ANSI spec). Some C libraries retain compatibility with * pre-ANSI C and return a pointer to the passed in buffer; for these * this variable will be undef. */ #define SPRINTF_RETURNS_STRLEN /**/ /* HAS_SQRTL: * This symbol, if defined, indicates that the sqrtl routine is * available to do long double square roots. */ /*#define HAS_SQRTL / **/ /* HAS_SETRESGID_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the setresgid() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern int setresgid(uid_t ruid, uid_t euid, uid_t suid); */ /*#define HAS_SETRESGID_PROTO / **/ /* HAS_SETRESUID_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the setresuid() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern int setresuid(uid_t ruid, uid_t euid, uid_t suid); */ /*#define HAS_SETRESUID_PROTO / **/ /* HAS_STRUCT_STATFS_F_FLAGS: * This symbol, if defined, indicates that the struct statfs * does have the f_flags member containing the mount flags of * the filesystem containing the file. * This kind of struct statfs is coming from (BSD 4.3), * not from (SYSV). Older BSDs (like Ultrix) do not * have statfs() and struct statfs, they have ustat() and getmnt() * with struct ustat and struct fs_data. */ /*#define HAS_STRUCT_STATFS_F_FLAGS / **/ /* HAS_STRUCT_STATFS: * This symbol, if defined, indicates that the struct statfs * to do statfs() is supported. */ /*#define HAS_STRUCT_STATFS / **/ /* HAS_FSTATVFS: * This symbol, if defined, indicates that the fstatvfs routine is * available to stat filesystems by file descriptors. */ /*#define HAS_FSTATVFS / **/ /* HAS_STRFTIME: * This symbol, if defined, indicates that the strftime routine is * available to do time formatting. */ #define HAS_STRFTIME /**/ /* HAS_STRLCAT: * This symbol, if defined, indicates that the strlcat () routine is * available to do string concatenation. */ /*#define HAS_STRLCAT / **/ /* HAS_STRLCPY: * This symbol, if defined, indicates that the strlcpy () routine is * available to do string copying. */ /*#define HAS_STRLCPY / **/ /* HAS_STRTOLD: * This symbol, if defined, indicates that the strtold routine is * available to convert strings to long doubles. */ /*#define HAS_STRTOLD / **/ /* HAS_STRTOLL: * This symbol, if defined, indicates that the strtoll routine is * available to convert strings to long longs. */ #define HAS_STRTOLL /**/ /* HAS_STRTOQ: * This symbol, if defined, indicates that the strtoq routine is * available to convert strings to long longs (quads). */ /*#define HAS_STRTOQ / **/ /* HAS_STRTOULL: * This symbol, if defined, indicates that the strtoull routine is * available to convert strings to unsigned long longs. */ #define HAS_STRTOULL /**/ /* HAS_STRTOUQ: * This symbol, if defined, indicates that the strtouq routine is * available to convert strings to unsigned long longs (quads). */ /*#define HAS_STRTOUQ / **/ /* HAS_SYSCALL_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the syscall() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern int syscall(int, ...); * extern int syscall(long, ...); */ /*#define HAS_SYSCALL_PROTO / **/ /* HAS_TELLDIR_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the telldir() function. Otherwise, it is up * to the program to supply one. A good guess is * extern long telldir(DIR*); */ #define HAS_TELLDIR_PROTO /**/ /* HAS_CTIME64: * This symbol, if defined, indicates that the ctime64 () routine is * available to do the 64bit variant of ctime () */ /* HAS_LOCALTIME64: * This symbol, if defined, indicates that the localtime64 () routine is * available to do the 64bit variant of localtime () */ /* HAS_GMTIME64: * This symbol, if defined, indicates that the gmtime64 () routine is * available to do the 64bit variant of gmtime () */ /* HAS_MKTIME64: * This symbol, if defined, indicates that the mktime64 () routine is * available to do the 64bit variant of mktime () */ /* HAS_DIFFTIME64: * This symbol, if defined, indicates that the difftime64 () routine is * available to do the 64bit variant of difftime () */ /* HAS_ASCTIME64: * This symbol, if defined, indicates that the asctime64 () routine is * available to do the 64bit variant of asctime () */ /*#define HAS_CTIME64 / **/ /*#define HAS_LOCALTIME64 / **/ /*#define HAS_GMTIME64 / **/ /*#define HAS_MKTIME64 / **/ /*#define HAS_DIFFTIME64 / **/ /*#define HAS_ASCTIME64 / **/ /* HAS_TIMEGM: * This symbol, if defined, indicates that the timegm routine is * available to do the opposite of gmtime () */ /*#define HAS_TIMEGM / **/ /* U32_ALIGNMENT_REQUIRED: * This symbol, if defined, indicates that you must access * character data through U32-aligned pointers. */ #ifndef U32_ALIGNMENT_REQUIRED #define U32_ALIGNMENT_REQUIRED /**/ #endif /* HAS_UALARM: * This symbol, if defined, indicates that the ualarm routine is * available to do alarms with microsecond granularity. */ /*#define HAS_UALARM / **/ /* HAS_UNORDERED: * This symbol, if defined, indicates that the unordered routine is * available to check whether two doubles are unordered * (effectively: whether either of them is NaN) */ /*#define HAS_UNORDERED / **/ /* HAS_UNSETENV: * This symbol, if defined, indicates that the unsetenv () routine is * available for use. */ /*#define HAS_UNSETENV / **/ /* HAS_USLEEP_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the usleep() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int usleep(useconds_t); */ /*#define HAS_USLEEP_PROTO / **/ /* HAS_USTAT: * This symbol, if defined, indicates that the ustat system call is * available to query file system statistics by dev_t. */ /*#define HAS_USTAT / **/ /* HAS_WRITEV: * This symbol, if defined, indicates that the writev routine is * available to do scatter writes. */ /*#define HAS_WRITEV / **/ /* USE_DYNAMIC_LOADING: * This symbol, if defined, indicates that dynamic loading of * some sort is available. */ #define USE_DYNAMIC_LOADING /**/ /* FFLUSH_NULL: * This symbol, if defined, tells that fflush(NULL) does flush * all pending stdio output. */ /* FFLUSH_ALL: * This symbol, if defined, tells that to flush * all pending stdio output one must loop through all * the stdio file handles stored in an array and fflush them. * Note that if fflushNULL is defined, fflushall will not * even be probed for and will be left undefined. */ #define FFLUSH_NULL /**/ /*#define FFLUSH_ALL / **/ /* I_ASSERT: * This symbol, if defined, indicates that exists and * could be included by the C program to get the assert() macro. */ #define I_ASSERT /**/ /* I_CRYPT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_CRYPT / **/ /* DB_Prefix_t: * This symbol contains the type of the prefix structure element * in the header file. In older versions of DB, it was * int, while in newer ones it is u_int32_t. */ /* DB_Hash_t: * This symbol contains the type of the prefix structure element * in the header file. In older versions of DB, it was * int, while in newer ones it is size_t. */ /* DB_VERSION_MAJOR_CFG: * This symbol, if defined, defines the major version number of * Berkeley DB found in the header when Perl was configured. */ /* DB_VERSION_MINOR_CFG: * This symbol, if defined, defines the minor version number of * Berkeley DB found in the header when Perl was configured. * For DB version 1 this is always 0. */ /* DB_VERSION_PATCH_CFG: * This symbol, if defined, defines the patch version number of * Berkeley DB found in the header when Perl was configured. * For DB version 1 this is always 0. */ #define DB_Hash_t int /**/ #define DB_Prefix_t int /**/ #define DB_VERSION_MAJOR_CFG 0 /**/ #define DB_VERSION_MINOR_CFG 0 /**/ #define DB_VERSION_PATCH_CFG 0 /**/ /* I_FP: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_FP / **/ /* I_FP_CLASS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_FP_CLASS / **/ /* I_IEEEFP: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_IEEEFP / **/ /* I_INTTYPES: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_INTTYPES / **/ /* I_LANGINFO: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_LANGINFO / **/ /* I_LIBUTIL: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_LIBUTIL / **/ /* I_MALLOCMALLOC: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_MALLOCMALLOC / **/ /* I_MNTENT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_MNTENT / **/ /* I_NETINET_TCP: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_NETINET_TCP / **/ /* I_POLL: * This symbol, if defined, indicates that exists and * should be included. (see also HAS_POLL) */ /*#define I_POLL / **/ /* I_PROT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_PROT / **/ /* I_SHADOW: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SHADOW / **/ /* I_SOCKS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SOCKS / **/ /* I_SUNMATH: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SUNMATH / **/ /* I_SYSLOG: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSLOG / **/ /* I_SYSMODE: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSMODE / **/ /* I_SYS_MOUNT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYS_MOUNT / **/ /* I_SYS_STATFS: * This symbol, if defined, indicates that exists. */ /*#define I_SYS_STATFS / **/ /* I_SYS_STATVFS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYS_STATVFS / **/ /* I_SYSUTSNAME: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSUTSNAME / **/ /* I_SYS_VFS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYS_VFS / **/ /* I_USTAT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_USTAT / **/ /* PERL_PRIfldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'f') for output. */ /* PERL_PRIgldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'g') for output. */ /* PERL_PRIeldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'e') for output. */ /* PERL_SCNfldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'f') for input. */ /*#define PERL_PRIfldbl "f" / **/ /*#define PERL_PRIgldbl "g" / **/ /*#define PERL_PRIeldbl "e" / **/ /*#define PERL_SCNfldbl "f" / **/ /* PERL_MAD: * This symbol, if defined, indicates that the Misc Attribution * Declaration code should be conditionally compiled. */ /*#define PERL_MAD / **/ /* NEED_VA_COPY: * This symbol, if defined, indicates that the system stores * the variable argument list datatype, va_list, in a format * that cannot be copied by simple assignment, so that some * other means must be used when copying is required. * As such systems vary in their provision (or non-provision) * of copying mechanisms, handy.h defines a platform- * independent macro, Perl_va_copy(src, dst), to do the job. */ /*#define NEED_VA_COPY / **/ /* IVTYPE: * This symbol defines the C type used for Perl's IV. */ /* UVTYPE: * This symbol defines the C type used for Perl's UV. */ /* I8TYPE: * This symbol defines the C type used for Perl's I8. */ /* U8TYPE: * This symbol defines the C type used for Perl's U8. */ /* I16TYPE: * This symbol defines the C type used for Perl's I16. */ /* U16TYPE: * This symbol defines the C type used for Perl's U16. */ /* I32TYPE: * This symbol defines the C type used for Perl's I32. */ /* U32TYPE: * This symbol defines the C type used for Perl's U32. */ /* I64TYPE: * This symbol defines the C type used for Perl's I64. */ /* U64TYPE: * This symbol defines the C type used for Perl's U64. */ /* NVTYPE: * This symbol defines the C type used for Perl's NV. */ /* IVSIZE: * This symbol contains the sizeof(IV). */ /* UVSIZE: * This symbol contains the sizeof(UV). */ /* I8SIZE: * This symbol contains the sizeof(I8). */ /* U8SIZE: * This symbol contains the sizeof(U8). */ /* I16SIZE: * This symbol contains the sizeof(I16). */ /* U16SIZE: * This symbol contains the sizeof(U16). */ /* I32SIZE: * This symbol contains the sizeof(I32). */ /* U32SIZE: * This symbol contains the sizeof(U32). */ /* I64SIZE: * This symbol contains the sizeof(I64). */ /* U64SIZE: * This symbol contains the sizeof(U64). */ /* NVSIZE: * This symbol contains the sizeof(NV). */ /* NV_PRESERVES_UV: * This symbol, if defined, indicates that a variable of type NVTYPE * can preserve all the bits of a variable of type UVTYPE. */ /* NV_PRESERVES_UV_BITS: * This symbol contains the number of bits a variable of type NVTYPE * can preserve of a variable of type UVTYPE. */ /* NV_OVERFLOWS_INTEGERS_AT: * This symbol gives the largest integer value that NVs can hold. This * value + 1.0 cannot be stored accurately. It is expressed as constant * floating point expression to reduce the chance of decimale/binary * conversion issues. If it can not be determined, the value 0 is given. */ /* NV_ZERO_IS_ALLBITS_ZERO: * This symbol, if defined, indicates that a variable of type NVTYPE * stores 0.0 in memory as all bits zero. */ #define IVTYPE __int64 /**/ #define UVTYPE unsigned __int64 /**/ #define I8TYPE char /**/ #define U8TYPE unsigned char /**/ #define I16TYPE short /**/ #define U16TYPE unsigned short /**/ #define I32TYPE long /**/ #define U32TYPE unsigned long /**/ #ifdef HAS_QUAD #define I64TYPE __int64 /**/ #define U64TYPE unsigned __int64 /**/ #endif #define NVTYPE double /**/ #define IVSIZE 8 /**/ #define UVSIZE 8 /**/ #define I8SIZE 1 /**/ #define U8SIZE 1 /**/ #define I16SIZE 2 /**/ #define U16SIZE 2 /**/ #define I32SIZE 4 /**/ #define U32SIZE 4 /**/ #ifdef HAS_QUAD #define I64SIZE 8 /**/ #define U64SIZE 8 /**/ #endif #define NVSIZE 8 /**/ #undef NV_PRESERVES_UV #define NV_PRESERVES_UV_BITS 53 #define NV_OVERFLOWS_INTEGERS_AT 256.0*256.0*256.0*256.0*256.0*256.0*2.0*2.0*2.0*2.0*2.0 #define NV_ZERO_IS_ALLBITS_ZERO #if UVSIZE == 8 # ifdef BYTEORDER # if BYTEORDER == 0x1234 # undef BYTEORDER # define BYTEORDER 0x12345678 # else # if BYTEORDER == 0x4321 # undef BYTEORDER # define BYTEORDER 0x87654321 # endif # endif # endif #endif /* IVdf: * This symbol defines the format string used for printing a Perl IV * as a signed decimal integer. */ /* UVuf: * This symbol defines the format string used for printing a Perl UV * as an unsigned decimal integer. */ /* UVof: * This symbol defines the format string used for printing a Perl UV * as an unsigned octal integer. */ /* UVxf: * This symbol defines the format string used for printing a Perl UV * as an unsigned hexadecimal integer in lowercase abcdef. */ /* UVXf: * This symbol defines the format string used for printing a Perl UV * as an unsigned hexadecimal integer in uppercase ABCDEF. */ /* NVef: * This symbol defines the format string used for printing a Perl NV * using %e-ish floating point format. */ /* NVff: * This symbol defines the format string used for printing a Perl NV * using %f-ish floating point format. */ /* NVgf: * This symbol defines the format string used for printing a Perl NV * using %g-ish floating point format. */ #define IVdf "I64d" /**/ #define UVuf "I64u" /**/ #define UVof "I64o" /**/ #define UVxf "I64x" /**/ #define UVXf "I64X" /**/ #define NVef "e" /**/ #define NVff "f" /**/ #define NVgf "g" /**/ /* SELECT_MIN_BITS: * This symbol holds the minimum number of bits operated by select. * That is, if you do select(n, ...), how many bits at least will be * cleared in the masks if some activity is detected. Usually this * is either n or 32*ceil(n/32), especially many little-endians do * the latter. This is only useful if you have select(), naturally. */ #define SELECT_MIN_BITS 32 /**/ /* STARTPERL: * This variable contains the string to put in front of a perl * script to make sure (one hopes) that it runs with perl and not * some shell. */ #define STARTPERL "#!perl" /**/ /* HAS_STDIO_STREAM_ARRAY: * This symbol, if defined, tells that there is an array * holding the stdio streams. */ /* STDIO_STREAM_ARRAY: * This symbol tells the name of the array holding the stdio streams. * Usual values include _iob, __iob, and __sF. */ /*#define HAS_STDIO_STREAM_ARRAY / **/ #ifdef HAS_STDIO_STREAM_ARRAY #define STDIO_STREAM_ARRAY #endif /* GMTIME_MAX: * This symbol contains the maximum value for the time_t offset that * the system function gmtime () accepts, and defaults to 0 */ /* GMTIME_MIN: * This symbol contains the minimum value for the time_t offset that * the system function gmtime () accepts, and defaults to 0 */ /* LOCALTIME_MAX: * This symbol contains the maximum value for the time_t offset that * the system function localtime () accepts, and defaults to 0 */ /* LOCALTIME_MIN: * This symbol contains the minimum value for the time_t offset that * the system function localtime () accepts, and defaults to 0 */ #define GMTIME_MAX 2147483647 /**/ #define GMTIME_MIN 0 /**/ #define LOCALTIME_MAX 2147483647 /**/ #define LOCALTIME_MIN 0 /**/ /* USE_64_BIT_INT: * This symbol, if defined, indicates that 64-bit integers should * be used when available. If not defined, the native integers * will be employed (be they 32 or 64 bits). The minimal possible * 64-bitness is used, just enough to get 64-bit integers into Perl. * This may mean using for example "long longs", while your memory * may still be limited to 2 gigabytes. */ /* USE_64_BIT_ALL: * This symbol, if defined, indicates that 64-bit integers should * be used when available. If not defined, the native integers * will be used (be they 32 or 64 bits). The maximal possible * 64-bitness is employed: LP64 or ILP64, meaning that you will * be able to use more than 2 gigabytes of memory. This mode is * even more binary incompatible than USE_64_BIT_INT. You may not * be able to run the resulting executable in a 32-bit CPU at all or * you may need at least to reboot your OS to 64-bit mode. */ #ifndef USE_64_BIT_INT #define USE_64_BIT_INT /**/ #endif #ifndef USE_64_BIT_ALL /*#define USE_64_BIT_ALL / **/ #endif /* USE_DTRACE: * This symbol, if defined, indicates that Perl should * be built with support for DTrace. */ /*#define USE_DTRACE / **/ /* USE_FAST_STDIO: * This symbol, if defined, indicates that Perl should * be built to use 'fast stdio'. * Defaults to define in Perls 5.8 and earlier, to undef later. */ #ifndef USE_FAST_STDIO /*#define USE_FAST_STDIO / **/ #endif /* USE_LARGE_FILES: * This symbol, if defined, indicates that large file support * should be used when available. */ #ifndef USE_LARGE_FILES /*#define USE_LARGE_FILES / **/ #endif /* USE_LONG_DOUBLE: * This symbol, if defined, indicates that long doubles should * be used when available. */ #ifndef USE_LONG_DOUBLE /*#define USE_LONG_DOUBLE / **/ #endif /* USE_MORE_BITS: * This symbol, if defined, indicates that 64-bit interfaces and * long doubles should be used when available. */ #ifndef USE_MORE_BITS /*#define USE_MORE_BITS / **/ #endif /* MULTIPLICITY: * This symbol, if defined, indicates that Perl should * be built to use multiplicity. */ #ifndef MULTIPLICITY /*#define MULTIPLICITY / **/ #endif /* USE_PERLIO: * This symbol, if defined, indicates that the PerlIO abstraction should * be used throughout. If not defined, stdio should be * used in a fully backward compatible manner. */ #ifndef USE_PERLIO /*#define USE_PERLIO / **/ #endif /* USE_SOCKS: * This symbol, if defined, indicates that Perl should * be built to use socks. */ #ifndef USE_SOCKS /*#define USE_SOCKS / **/ #endif #endif perl-5.12.0-RC0/win32/win32.c0000444000175000017500000040213511325127002014173 0ustar jessejesse/* WIN32.C * * (c) 1995 Microsoft Corporation. All rights reserved. * Developed by hip communications inc. * Portions (c) 1993 Intergraph Corporation. All rights reserved. * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. */ #define PERLIO_NOT_STDIO 0 #define WIN32_LEAN_AND_MEAN #define WIN32IO_IS_STDIO #include #ifdef __GNUC__ #define Win32_Winsock #endif #include #ifndef HWND_MESSAGE # define HWND_MESSAGE ((HWND)-3) #endif #ifndef WC_NO_BEST_FIT_CHARS # define WC_NO_BEST_FIT_CHARS 0x00000400 /* requires Windows 2000 or later */ #endif #include #include #include #include #include #define SystemProcessesAndThreadsInformation 5 /* Inline some definitions from the DDK */ typedef struct { USHORT Length; USHORT MaximumLength; PWSTR Buffer; } UNICODE_STRING; typedef struct { ULONG NextEntryDelta; ULONG ThreadCount; ULONG Reserved1[6]; LARGE_INTEGER CreateTime; LARGE_INTEGER UserTime; LARGE_INTEGER KernelTime; UNICODE_STRING ProcessName; LONG BasePriority; ULONG ProcessId; ULONG InheritedFromProcessId; /* Remainder of the structure depends on the Windows version, * but we don't need those additional fields anyways... */ } SYSTEM_PROCESSES; /* #include "config.h" */ #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO) #define PerlIO FILE #endif #include #include "EXTERN.h" #include "perl.h" #define NO_XSLOCKS #define PERL_NO_GET_CONTEXT #include "XSUB.h" #include #ifndef __GNUC__ /* assert.h conflicts with #define of assert in perl.h */ #include #endif #include #include #include #include #if defined(_MSC_VER) || defined(__MINGW32__) #include #else #include #endif #ifdef __GNUC__ /* Mingw32 defaults to globing command line * So we turn it off like this: */ int _CRT_glob = 0; #endif #if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1) /* Mingw32-1.1 is missing some prototypes */ START_EXTERN_C FILE * _wfopen(LPCWSTR wszFileName, LPCWSTR wszMode); FILE * _wfdopen(int nFd, LPCWSTR wszMode); FILE * _freopen(LPCWSTR wszFileName, LPCWSTR wszMode, FILE * pOldStream); int _flushall(); int _fcloseall(); END_EXTERN_C #endif #if defined(__BORLANDC__) # define _stat stat # define _utimbuf utimbuf #endif #define EXECF_EXEC 1 #define EXECF_SPAWN 2 #define EXECF_SPAWN_NOWAIT 3 #if defined(PERL_IMPLICIT_SYS) # undef win32_get_privlib # define win32_get_privlib g_win32_get_privlib # undef win32_get_sitelib # define win32_get_sitelib g_win32_get_sitelib # undef win32_get_vendorlib # define win32_get_vendorlib g_win32_get_vendorlib # undef getlogin # define getlogin g_getlogin #endif static void get_shell(void); static long tokenize(const char *str, char **dest, char ***destv); static int do_spawn2(pTHX_ const char *cmd, int exectype); static BOOL has_shell_metachars(const char *ptr); static long filetime_to_clock(PFILETIME ft); static BOOL filetime_from_time(PFILETIME ft, time_t t); static char * get_emd_part(SV **leading, STRLEN *const len, char *trailing, ...); static void remove_dead_process(long deceased); static long find_pid(int pid); static char * qualified_path(const char *cmd); static char * win32_get_xlib(const char *pl, const char *xlib, const char *libname, STRLEN *const len); static LRESULT win32_process_message(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam); #ifdef USE_ITHREADS static void remove_dead_pseudo_process(long child); static long find_pseudo_pid(int pid); #endif START_EXTERN_C HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE; char w32_module_name[MAX_PATH+1]; END_EXTERN_C static OSVERSIONINFO g_osver = {0, 0, 0, 0, 0, ""}; static HANDLE (WINAPI *pfnCreateToolhelp32Snapshot)(DWORD, DWORD) = NULL; static BOOL (WINAPI *pfnProcess32First)(HANDLE, PROCESSENTRY32*) = NULL; static BOOL (WINAPI *pfnProcess32Next)(HANDLE, PROCESSENTRY32*) = NULL; static LONG (WINAPI *pfnZwQuerySystemInformation)(UINT, PVOID, ULONG, PULONG); #ifdef __BORLANDC__ /* Silence STDERR grumblings from Borland's math library. */ DllExport int _matherr(struct _exception *a) { PERL_UNUSED_VAR(a); return 1; } #endif /* VS2005 (MSC version 14) provides a mechanism to set an invalid * parameter handler. This functionality is not available in the * 64-bit compiler from the Platform SDK, which unfortunately also * believes itself to be MSC version 14. * * There is no #define related to _set_invalid_parameter_handler(), * but we can check for one of the constants defined for * _set_abort_behavior(), which was introduced into stdlib.h at * the same time. */ #if _MSC_VER >= 1400 && defined(_WRITE_ABORT_MSG) # define SET_INVALID_PARAMETER_HANDLER #endif #ifdef SET_INVALID_PARAMETER_HANDLER void my_invalid_parameter_handler(const wchar_t* expression, const wchar_t* function, const wchar_t* file, unsigned int line, uintptr_t pReserved) { # ifdef _DEBUG wprintf(L"Invalid parameter detected in function %s." L" File: %s Line: %d\n", function, file, line); wprintf(L"Expression: %s\n", expression); # endif } #endif int IsWin95(void) { return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_WINDOWS); } int IsWinNT(void) { return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT); } int IsWin2000(void) { return (g_osver.dwMajorVersion > 4); } EXTERN_C void set_w32_module_name(void) { /* this function may be called at DLL_PROCESS_ATTACH time */ char* ptr; HMODULE module = (HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE) ? GetModuleHandle(NULL) : w32_perldll_handle); OSVERSIONINFO osver; /* g_osver may not yet be initialized */ osver.dwOSVersionInfoSize = sizeof(osver); GetVersionEx(&osver); if (osver.dwMajorVersion > 4) { WCHAR modulename[MAX_PATH]; WCHAR fullname[MAX_PATH]; char *ansi; DWORD (__stdcall *pfnGetLongPathNameW)(LPCWSTR, LPWSTR, DWORD) = (DWORD (__stdcall *)(LPCWSTR, LPWSTR, DWORD)) GetProcAddress(GetModuleHandle("kernel32.dll"), "GetLongPathNameW"); GetModuleFileNameW(module, modulename, sizeof(modulename)/sizeof(WCHAR)); /* Make sure we get an absolute pathname in case the module was loaded * explicitly by LoadLibrary() with a relative path. */ GetFullPathNameW(modulename, sizeof(fullname)/sizeof(WCHAR), fullname, NULL); /* Make sure we start with the long path name of the module because we * later scan for pathname components to match "5.xx" to locate * compatible sitelib directories, and the short pathname might mangle * this path segment (e.g. by removing the dot on NTFS to something * like "5xx~1.yy") */ if (pfnGetLongPathNameW) pfnGetLongPathNameW(fullname, fullname, sizeof(fullname)/sizeof(WCHAR)); /* remove \\?\ prefix */ if (memcmp(fullname, L"\\\\?\\", 4*sizeof(WCHAR)) == 0) memmove(fullname, fullname+4, (wcslen(fullname+4)+1)*sizeof(WCHAR)); ansi = win32_ansipath(fullname); my_strlcpy(w32_module_name, ansi, sizeof(w32_module_name)); win32_free(ansi); } else { GetModuleFileName(module, w32_module_name, sizeof(w32_module_name)); /* remove \\?\ prefix */ if (memcmp(w32_module_name, "\\\\?\\", 4) == 0) memmove(w32_module_name, w32_module_name+4, strlen(w32_module_name+4)+1); /* try to get full path to binary (which may be mangled when perl is * run from a 16-bit app) */ /*PerlIO_printf(Perl_debug_log, "Before %s\n", w32_module_name);*/ win32_longpath(w32_module_name); /*PerlIO_printf(Perl_debug_log, "After %s\n", w32_module_name);*/ } /* normalize to forward slashes */ ptr = w32_module_name; while (*ptr) { if (*ptr == '\\') *ptr = '/'; ++ptr; } } /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */ static char* get_regstr_from(HKEY hkey, const char *valuename, SV **svp) { /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */ HKEY handle; DWORD type; const char *subkey = "Software\\Perl"; char *str = NULL; long retval; retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle); if (retval == ERROR_SUCCESS) { DWORD datalen; retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen); if (retval == ERROR_SUCCESS && (type == REG_SZ || type == REG_EXPAND_SZ)) { dTHX; if (!*svp) *svp = sv_2mortal(newSVpvn("",0)); 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); } } RegCloseKey(handle); } return str; } /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */ static char* get_regstr(const char *valuename, SV **svp) { char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp); if (!str) str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp); return str; } /* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */ static char * get_emd_part(SV **prev_pathp, STRLEN *const len, char *trailing_path, ...) { char base[10]; va_list ap; char mod_name[MAX_PATH+1]; char *ptr; char *optr; char *strip; STRLEN baselen; va_start(ap, trailing_path); strip = va_arg(ap, char *); sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION); baselen = strlen(base); if (!*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' && strncmp(strip, base, baselen) == 0 && strncmp(ptr+1, base, baselen) == 0)) { *optr = '/'; ptr = optr; } } strip = va_arg(ap, char *); } if (!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(newSVpvn("",0)); else if (SvPVX(*prev_pathp)) sv_catpvn(*prev_pathp, ";", 1); sv_catpv(*prev_pathp, mod_name); if(len) *len = SvCUR(*prev_pathp); return SvPVX(*prev_pathp); } return NULL; } char * win32_get_privlib(const char *pl, STRLEN *const len) { dTHX; char *stdlib = "lib"; char buffer[MAX_PATH+1]; SV *sv = NULL; /* $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); /* $stdlib .= ";$EMD/../../lib" */ return get_emd_part(&sv, len, stdlib, ARCHNAME, "bin", NULL); } static char * win32_get_xlib(const char *pl, const char *xlib, const char *libname, STRLEN *const len) { dTHX; char regstr[40]; char pathstr[MAX_PATH+1]; SV *sv1 = NULL; SV *sv2 = NULL; /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */ sprintf(regstr, "%s-%s", xlib, pl); (void)get_regstr(regstr, &sv1); /* $xlib .= * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */ sprintf(pathstr, "%s/%s/lib", libname, pl); (void)get_emd_part(&sv1, NULL, pathstr, ARCHNAME, "bin", pl, NULL); /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */ (void)get_regstr(xlib, &sv2); /* $xlib .= * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */ sprintf(pathstr, "%s/lib", libname); (void)get_emd_part(&sv2, NULL, pathstr, ARCHNAME, "bin", pl, NULL); if (!sv1 && !sv2) return NULL; if (!sv1) { sv1 = sv2; } else if (sv2) { sv_catpvn(sv1, ";", 1); sv_catsv(sv1, sv2); } if (len) *len = SvCUR(sv1); return SvPVX(sv1); } char * win32_get_sitelib(const char *pl, STRLEN *const len) { return win32_get_xlib(pl, "sitelib", "site", len); } #ifndef PERL_VENDORLIB_NAME # define PERL_VENDORLIB_NAME "vendor" #endif char * win32_get_vendorlib(const char *pl, STRLEN *const len) { return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME, len); } static BOOL has_shell_metachars(const char *ptr) { int inquote = 0; char quote = '\0'; /* * Scan string looking for redirection (< or >) or pipe * characters (|) that are not in a quoted string. * 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; } return FALSE; } #if !defined(PERL_IMPLICIT_SYS) /* since the current process environment is being updated in util.c * the library functions will get the correct environment */ PerlIO * Perl_my_popen(pTHX_ const char *cmd, const char *mode) { #ifdef FIXCMD #define fixcmd(x) { \ char *pspace = strchr((x),' '); \ if (pspace) { \ char *p = (x); \ while (p < pspace) { \ if (*p == '/') \ *p = '\\'; \ p++; \ } \ } \ } #else #define fixcmd(x) #endif fixcmd(cmd); PERL_FLUSHALL_FOR_CHILD; return win32_popen(cmd, mode); } long Perl_my_pclose(pTHX_ PerlIO *fp) { return win32_pclose(fp); } #endif DllExport unsigned long win32_os_id(void) { return (unsigned long)g_osver.dwPlatformId; } DllExport int win32_getpid(void) { int pid; #ifdef USE_ITHREADS dTHX; if (w32_pseudo_id) return -((int)w32_pseudo_id); #endif pid = _getpid(); /* Windows 9x appears to always reports a pid for threads and processes * that has the high bit set. So we treat the lower 31 bits as the * "real" PID for Perl's purposes. */ if (IsWin95() && pid < 0) pid = -pid; return pid; } /* Tokenize a string. Words are null-separated, and the list * ends with a doubled null. Any character (except null and * including backslash) may be escaped by preceding it with a * backslash (the backslash will be stripped). * Returns number of words in result buffer. */ static long tokenize(const char *str, char **dest, char ***destv) { char *retstart = NULL; char **retvstart = 0; int items = -1; if (str) { dTHX; int slen = strlen(str); register char *ret; register 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; return items; } static void 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 = (IsWinNT() ? "cmd.exe /x/d/c" : "command.com /c"); const char *usershell = PerlEnv_getenv("PERL5SHELL"); w32_perlshell_items = tokenize(usershell ? usershell : defaultshell, &w32_perlshell_tokens, &w32_perlshell_vec); } } int Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp) { char **argv; char *str; int status; int flag = P_WAIT; int index = 0; PERL_ARGS_ASSERT_DO_ASPAWN; if (sp <= mark) return -1; get_shell(); Newx(argv, (sp - mark) + w32_perlshell_items + 2, char*); if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) { ++mark; flag = SvIVx(*mark); } while (++mark <= sp) { 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); if (status < 0 && (errno == ENOEXEC || errno == 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]; 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() */ } 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; } Safefree(argv); return (status); } /* returns pointer to the next unquoted space or the end of the string */ static char* 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++; } return (char*)s; } static int do_spawn2(pTHX_ const char *cmd, int exectype) { char **a; char *s; char **argv; int status = -1; BOOL needToTry = TRUE; char *cmd2; /* 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 = win32_spawnvp(P_NOWAIT, argv[0], (const char* const*)argv); 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 = win32_spawnvp(P_NOWAIT, argv[0], (const char* const*)argv); 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() */ } 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; } return (status); } int Perl_do_spawn(pTHX_ char *cmd) { PERL_ARGS_ASSERT_DO_SPAWN; return do_spawn2(aTHX_ cmd, EXECF_SPAWN); } int Perl_do_spawn_nowait(pTHX_ char *cmd) { PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT; return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT); } bool Perl_do_exec(pTHX_ const char *cmd) { PERL_ARGS_ASSERT_DO_EXEC; do_spawn2(aTHX_ cmd, EXECF_EXEC); return FALSE; } /* The idea here is to read all the directory names into a string table * (separated by nulls) and when one of the other dir functions is called * return the pointer to the current file name. */ DllExport DIR * win32_opendir(const char *filename) { dTHX; DIR *dirp; long len; long idx; char scanname[MAX_PATH+3]; Stat_t sbuf; WIN32_FIND_DATAA aFindData; WIN32_FIND_DATAW wFindData; bool using_wide; char buffer[MAX_PATH*2]; char *ptr; len = strlen(filename); if (len > MAX_PATH) return NULL; /* check to see if filename is a directory */ if (win32_stat(filename, &sbuf) < 0 || !S_ISDIR(sbuf.st_mode)) return NULL; /* Get us a DIR structure */ Newxz(dirp, 1, DIR); /* Create the search pattern */ strcpy(scanname, filename); /* bare drive name means look in cwd for drive */ if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') { scanname[len++] = '.'; scanname[len++] = '/'; } else if (scanname[len-1] != '/' && scanname[len-1] != '\\') { scanname[len++] = '/'; } scanname[len++] = '*'; scanname[len] = '\0'; /* do the FindFirstFile call */ if (IsWin2000()) { WCHAR wscanname[sizeof(scanname)]; MultiByteToWideChar(CP_ACP, 0, scanname, -1, wscanname, sizeof(wscanname)/sizeof(WCHAR)); dirp->handle = FindFirstFileW(PerlDir_mapW(wscanname), &wFindData); using_wide = TRUE; } else { dirp->handle = FindFirstFileA(PerlDir_mapA(scanname), &aFindData); } 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; } if (using_wide) { BOOL use_default = FALSE; WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wFindData.cFileName, -1, buffer, sizeof(buffer), NULL, &use_default); if (use_default && *wFindData.cAlternateFileName) { WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wFindData.cAlternateFileName, -1, buffer, sizeof(buffer), NULL, NULL); } ptr = buffer; } else { ptr = aFindData.cFileName; } /* now allocate the first part of the string table for * the filenames that we find. */ idx = strlen(ptr)+1; if (idx < 256) dirp->size = 256; else dirp->size = idx; Newx(dirp->start, dirp->size, char); strcpy(dirp->start, ptr); dirp->nfiles++; dirp->end = dirp->curr = dirp->start; dirp->end += idx; return dirp; } /* Readdir just returns the current string pointer and bumps the * string pointer to the nDllExport entry. */ DllExport struct direct * 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; /* 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) { dTHX; BOOL res; WIN32_FIND_DATAA aFindData; char buffer[MAX_PATH*2]; char *ptr; /* finding the next file that matches the wildcard * (which should be all of them in this directory!). */ if (IsWin2000()) { WIN32_FIND_DATAW wFindData; res = FindNextFileW(dirp->handle, &wFindData); if (res) { BOOL use_default = FALSE; WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wFindData.cFileName, -1, buffer, sizeof(buffer), NULL, &use_default); if (use_default && *wFindData.cAlternateFileName) { WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wFindData.cAlternateFileName, -1, buffer, sizeof(buffer), NULL, NULL); } ptr = buffer; } } else { res = FindNextFileA(dirp->handle, &aFindData); ptr = aFindData.cFileName; } if (res) { long endpos = dirp->end - dirp->start; long newsize = endpos + strlen(ptr) + 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; dirp->size *= 2; Renew(dirp->start, dirp->size, char); dirp->curr = dirp->start + curpos; } strcpy(dirp->start + endpos, ptr); dirp->end = dirp->start + newsize; dirp->nfiles++; } else dirp->curr = NULL; } return &(dirp->dirstr); } else return NULL; } /* Telldir returns the current string pointer position */ DllExport long win32_telldir(DIR *dirp) { return (dirp->curr - dirp->start); } /* Seekdir moves the string pointer to a previously saved position * (returned by telldir). */ DllExport void win32_seekdir(DIR *dirp, long loc) { dirp->curr = dirp->start + loc; } /* Rewinddir resets the string pointer to the start */ DllExport void win32_rewinddir(DIR *dirp) { dirp->curr = dirp->start; } /* free the memory allocated by opendir */ DllExport int win32_closedir(DIR *dirp) { dTHX; if (dirp->handle != INVALID_HANDLE_VALUE) FindClose(dirp->handle); Safefree(dirp->start); Safefree(dirp); return 1; } /* * various stubs */ /* Ownership * * Just pretend that everyone is a superuser. NT will let us know if * we don\'t really have permission to do something. */ #define ROOT_UID ((uid_t)0) #define ROOT_GID ((gid_t)0) uid_t getuid(void) { return ROOT_UID; } uid_t geteuid(void) { return ROOT_UID; } gid_t getgid(void) { return ROOT_GID; } gid_t getegid(void) { return ROOT_GID; } int setuid(uid_t auid) { return (auid == ROOT_UID ? 0 : -1); } int setgid(gid_t agid) { return (agid == ROOT_GID ? 0 : -1); } char * getlogin(void) { dTHX; char *buf = w32_getlogin_buffer; DWORD size = sizeof(w32_getlogin_buffer); if (GetUserName(buf,&size)) return buf; return (char*)NULL; } int chown(const char *path, uid_t owner, gid_t group) { /* XXX noop */ return 0; } /* * XXX this needs strengthening (for PerlIO) * -- BKS, 11-11-200 */ int mkstemp(const char *path) { dTHX; char buf[MAX_PATH+1]; int i = 0, fd = -1; retry: if (i++ > 10) { /* give up */ errno = ENOENT; return -1; } if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) { errno = ENOENT; return -1; } fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600); if (fd == -1) goto retry; return fd; } static long find_pid(int pid) { dTHX; long child = w32_num_children; while (--child >= 0) { if ((int)w32_child_pids[child] == pid) return child; } return -1; } 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--; } } #ifdef USE_ITHREADS static long find_pseudo_pid(int pid) { dTHX; long child = w32_num_pseudo_children; while (--child >= 0) { if ((int)w32_pseudo_child_pids[child] == pid) return child; } return -1; } 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); w32_num_pseudo_children--; } } #endif static int terminate_process(DWORD pid, HANDLE process_handle, int sig) { switch(sig) { case 0: /* "Does process exist?" use of kill */ return 1; case 2: if (GenerateConsoleCtrlEvent(CTRL_C_EVENT, pid)) return 1; break; case SIGBREAK: case SIGTERM: if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, pid)) return 1; break; default: /* For now be backwards compatible with perl 5.6 */ case 9: /* Note that we will only be able to kill processes owned by the * current process owner, even when we are running as an administrator. * To kill processes of other owners we would need to set the * 'SeDebugPrivilege' privilege before obtaining the process handle. */ if (TerminateProcess(process_handle, sig)) return 1; break; } return 0; } /* Traverse process tree using ToolHelp functions */ static int kill_process_tree_toolhelp(DWORD pid, int sig) { HANDLE process_handle; HANDLE snapshot_handle; int killed = 0; process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid); if (process_handle == NULL) return 0; killed += terminate_process(pid, process_handle, sig); snapshot_handle = pfnCreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); if (snapshot_handle != INVALID_HANDLE_VALUE) { PROCESSENTRY32 entry; entry.dwSize = sizeof(entry); if (pfnProcess32First(snapshot_handle, &entry)) { do { if (entry.th32ParentProcessID == pid) killed += kill_process_tree_toolhelp(entry.th32ProcessID, sig); entry.dwSize = sizeof(entry); } while (pfnProcess32Next(snapshot_handle, &entry)); } CloseHandle(snapshot_handle); } CloseHandle(process_handle); return killed; } /* Traverse process tree using undocumented system information structures. * This is only necessary on Windows NT, which lacks the ToolHelp functions. */ static int kill_process_tree_sysinfo(SYSTEM_PROCESSES *process_info, DWORD pid, int sig) { HANDLE process_handle; SYSTEM_PROCESSES *p = process_info; int killed = 0; process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid); if (process_handle == NULL) return 0; killed += terminate_process(pid, process_handle, sig); while (1) { if (p->InheritedFromProcessId == (DWORD)pid) killed += kill_process_tree_sysinfo(process_info, p->ProcessId, sig); if (p->NextEntryDelta == 0) break; p = (SYSTEM_PROCESSES*)((char*)p + p->NextEntryDelta); } CloseHandle(process_handle); return killed; } int killpg(int pid, int sig) { /* Use "documented" method whenever available */ if (pfnCreateToolhelp32Snapshot && pfnProcess32First && pfnProcess32Next) { return kill_process_tree_toolhelp((DWORD)pid, sig); } /* Fall back to undocumented Windows internals on Windows NT */ if (pfnZwQuerySystemInformation) { dTHX; char *buffer; DWORD size = 0; pfnZwQuerySystemInformation(SystemProcessesAndThreadsInformation, NULL, 0, &size); Newx(buffer, size, char); if (pfnZwQuerySystemInformation(SystemProcessesAndThreadsInformation, buffer, size, NULL) >= 0) { int killed = kill_process_tree_sysinfo((SYSTEM_PROCESSES*)buffer, (DWORD)pid, sig); Safefree(buffer); return killed; } } return 0; } static int my_kill(int pid, int sig) { int retval = 0; HANDLE process_handle; if (sig < 0) return killpg(pid, -sig); process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid); /* OpenProcess() returns NULL on error, *not* INVALID_HANDLE_VALUE */ if (process_handle != NULL) { retval = terminate_process(pid, process_handle, sig); CloseHandle(process_handle); } return retval; } DllExport int win32_kill(int pid, int sig) { dTHX; long child; #ifdef USE_ITHREADS if (pid < 0) { /* it is a pseudo-forked child */ child = find_pseudo_pid(-pid); if (child >= 0) { HWND hwnd = w32_pseudo_child_message_hwnds[child]; 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 */ if (TerminateThread(hProcess, sig)) { remove_dead_pseudo_process(child); return 0; } break; default: { int count = 0; /* pseudo-process has not yet properly initialized if hwnd isn't set */ while (hwnd == INVALID_HANDLE_VALUE && count < 5) { /* Yield and wait for the other thread to send us its message_hwnd */ Sleep(0); win32_async_check(aTHX); hwnd = w32_pseudo_child_message_hwnds[child]; ++count; } if (hwnd != INVALID_HANDLE_VALUE) { /* We fake signals to pseudo-processes using Win32 * message queue. In Win9X the pids are negative already. */ if ((hwnd != NULL && PostMessage(hwnd, WM_USER_KILL, sig, 0)) || PostThreadMessage(IsWin95() ? pid : -pid, WM_USER_KILL, sig, 0)) { /* It might be us ... */ PERL_ASYNC_CHECK(); return 0; } } break; } } /* switch */ } else if (IsWin95()) { pid = -pid; goto alien_process; } } else #endif { child = find_pid(pid); if (child >= 0) { if (my_kill(pid, sig)) { DWORD exitcode = 0; if (GetExitCodeProcess(w32_child_handles[child], &exitcode) && exitcode != STILL_ACTIVE) { remove_dead_process(child); } return 0; } } else { alien_process: if (my_kill((IsWin95() ? -pid : pid), sig)) return 0; } } errno = EINVAL; return -1; } DllExport int win32_stat(const char *path, Stat_t *sbuf) { dTHX; char buffer[MAX_PATH+1]; int l = strlen(path); int res; int nlink = 1; BOOL expect_dir = FALSE; GV *gv_sloppy = gv_fetchpvs("\027IN32_SLOPPY_STAT", GV_NOTQUAL, SVt_PV); BOOL sloppy = gv_sloppy && SvTRUE(GvSV(gv_sloppy)); if (l > 1) { switch(path[l - 1]) { /* FindFirstFile() and stat() are buggy with a trailing * slashes, except for the root directory of a drive */ case '\\': case '/': if (l > sizeof(buffer)) { errno = ENAMETOOLONG; return -1; } --l; strncpy(buffer, path, l); /* remove additional trailing slashes */ while (l > 1 && (buffer[l-1] == '/' || buffer[l-1] == '\\')) --l; /* add back slash if we otherwise end up with just a drive letter */ if (l == 2 && isALPHA(buffer[0]) && buffer[1] == ':') buffer[l++] = '\\'; buffer[l] = '\0'; path = buffer; expect_dir = TRUE; break; /* FindFirstFile() is buggy with "x:", so add a dot :-( */ case ':': if (l == 2 && isALPHA(path[0])) { buffer[0] = path[0]; buffer[1] = ':'; buffer[2] = '.'; buffer[3] = '\0'; l = 3; path = buffer; } break; } } path = PerlDir_mapA(path); l = strlen(path); if (!sloppy) { /* We must open & close the file once; otherwise file attribute changes */ /* might not yet have propagated to "other" hard links of the same file. */ /* This also gives us an opportunity to determine the number of links. */ HANDLE handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL); if (handle != INVALID_HANDLE_VALUE) { BY_HANDLE_FILE_INFORMATION bhi; if (GetFileInformationByHandle(handle, &bhi)) nlink = bhi.nNumberOfLinks; CloseHandle(handle); } } /* path will be mapped correctly above */ #if defined(WIN64) || defined(USE_LARGE_FILES) res = _stati64(path, sbuf); #else res = stat(path, sbuf); #endif sbuf->st_nlink = nlink; if (res < 0) { /* CRT is buggy on sharenames, so make sure it really isn't. * XXX using GetFileAttributesEx() will enable us to set * sbuf->st_*time (but note that's not available on the * Windows of 1995) */ DWORD r = GetFileAttributesA(path); if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) { /* sbuf may still contain old garbage since stat() failed */ Zero(sbuf, 1, Stat_t); sbuf->st_mode = S_IFDIR | S_IREAD; errno = 0; if (!(r & FILE_ATTRIBUTE_READONLY)) sbuf->st_mode |= S_IWRITE | S_IEXEC; return 0; } } else { if (l == 3 && isALPHA(path[0]) && path[1] == ':' && (path[2] == '\\' || path[2] == '/')) { /* The drive can be inaccessible, some _stat()s are buggy */ if (!GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) { errno = ENOENT; return -1; } } if (expect_dir && !S_ISDIR(sbuf->st_mode)) { errno = ENOTDIR; return -1; } if (S_ISDIR(sbuf->st_mode)) { /* Ensure the "write" bit is switched off in the mode for * directories with the read-only attribute set. Borland (at least) * switches it on for directories, which is technically correct * (directories are indeed always writable unless denied by DACLs), * but we want stat() and -w to reflect the state of the read-only * attribute for symmetry with chmod(). */ DWORD r = GetFileAttributesA(path); if (r != 0xffffffff && (r & FILE_ATTRIBUTE_READONLY)) { sbuf->st_mode &= ~S_IWRITE; } } #ifdef __BORLANDC__ if (S_ISDIR(sbuf->st_mode)) { sbuf->st_mode |= S_IEXEC; } else if (S_ISREG(sbuf->st_mode)) { int perms; if (l >= 4 && path[l-4] == '.') { const char *e = path + l - 3; if (strnicmp(e,"exe",3) && strnicmp(e,"bat",3) && strnicmp(e,"com",3) && (IsWin95() || strnicmp(e,"cmd",3))) sbuf->st_mode &= ~S_IEXEC; else sbuf->st_mode |= S_IEXEC; } else sbuf->st_mode &= ~S_IEXEC; /* Propagate permissions to _group_ and _others_ */ perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC); sbuf->st_mode |= (perms>>3) | (perms>>6); } #endif } return res; } #define isSLASH(c) ((c) == '/' || (c) == '\\') #define SKIP_SLASHES(s) \ STMT_START { \ while (*(s) && isSLASH(*(s))) \ ++(s); \ } STMT_END #define COPY_NONSLASHES(d,s) \ STMT_START { \ while (*(s) && !isSLASH(*(s))) \ *(d)++ = *(s)++; \ } STMT_END /* Find the longname of a given path. path is destructively modified. * It should have space for at least MAX_PATH characters. */ DllExport char * win32_longpath(char *path) { WIN32_FIND_DATA fdata; HANDLE fhand; char tmpbuf[MAX_PATH+1]; char *tmpstart = tmpbuf; char *start = path; char sep; if (!path) return NULL; /* drive prefix */ if (isALPHA(path[0]) && path[1] == ':') { 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 */ } } *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 */ /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/ errno = EINVAL; return NULL; } } strcpy(path,tmpbuf); return path; } static void out_of_memory(void) { if (PL_curinterp) { dTHX; /* Can't use PerlIO to write as it allocates memory */ PerlLIO_write(PerlIO_fileno(Perl_error_log), PL_no_mem, strlen(PL_no_mem)); my_exit(1); } exit(1); } /* The win32_ansipath() function takes a Unicode filename and converts it * into the current Windows codepage. If some characters cannot be mapped, * then it will convert the short name instead. * * The buffer to the ansi pathname must be freed with win32_free() when it * it no longer needed. * * The argument to win32_ansipath() must exist before this function is * called; otherwise there is no way to determine the short path name. * * Ideas for future refinement: * - Only convert those segments of the path that are not in the current * codepage, but leave the other segments in their long form. * - If the resulting name is longer than MAX_PATH, start converting * additional path segments into short names until the full name * is shorter than MAX_PATH. Shorten the filename part last! */ DllExport char * win32_ansipath(const WCHAR *widename) { char *name; BOOL use_default = FALSE; size_t widelen = wcslen(widename)+1; int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen, NULL, 0, NULL, NULL); name = win32_malloc(len); if (!name) out_of_memory(); WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen, name, len, NULL, &use_default); if (use_default) { DWORD shortlen = GetShortPathNameW(widename, NULL, 0); if (shortlen) { WCHAR *shortname = win32_malloc(shortlen*sizeof(WCHAR)); if (!shortname) out_of_memory(); shortlen = GetShortPathNameW(widename, shortname, shortlen)+1; len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen, NULL, 0, NULL, NULL); name = win32_realloc(name, len); if (!name) out_of_memory(); WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen, name, len, NULL, NULL); win32_free(shortname); } } return name; } DllExport char * win32_getenv(const char *name) { dTHX; DWORD needlen; SV *curitem = NULL; needlen = GetEnvironmentVariableA(name,NULL,0); if (needlen != 0) { curitem = sv_2mortal(newSVpvn("", 0)); do { SvGROW(curitem, needlen+1); needlen = GetEnvironmentVariableA(name,SvPVX(curitem), needlen); } while (needlen >= SvLEN(curitem)); SvCUR_set(curitem, needlen); } else { /* allow any environment variables that begin with 'PERL' to be stored in the registry */ if (strncmp(name, "PERL", 4) == 0) (void)get_regstr(name, &curitem); } if (curitem && SvCUR(curitem)) return SvPVX(curitem); return NULL; } DllExport int win32_putenv(const char *name) { dTHX; char* curitem; char* val; int relval = -1; if (name) { Newx(curitem,strlen(name)+1,char); strcpy(curitem, name); val = strchr(curitem, '='); if (val) { /* The sane way to deal with the environment. * Has these advantages over putenv() & co.: * * enables us to store a truly empty value in the * environment (like in UNIX). * * we don't have to deal with RTL globals, bugs and leaks * (specifically, see http://support.microsoft.com/kb/235601). * * Much faster. * Why you may want to use the RTL environment handling * (previously enabled by USE_WIN32_RTL_ENV): * * environ[] and RTL functions will not reflect changes, * which might be an issue if extensions want to access * the env. via RTL. This cuts both ways, since RTL will * not see changes made by extensions that call the Win32 * functions directly, either. * GSAR 97-06-07 */ *val++ = '\0'; if (SetEnvironmentVariableA(curitem, *val ? val : NULL)) relval = 0; } Safefree(curitem); } return relval; } static long filetime_to_clock(PFILETIME ft) { __int64 qw = ft->dwHighDateTime; qw <<= 32; qw |= ft->dwLowDateTime; qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */ return (long) qw; } DllExport int win32_times(struct tms *timebuf) { FILETIME user; FILETIME kernel; FILETIME dummy; 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; } 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; } return process_time_so_far; } /* fix utime() so it works on directories in NT */ static BOOL filetime_from_time(PFILETIME pFileTime, time_t Time) { struct tm *pTM = localtime(&Time); SYSTEMTIME SystemTime; FILETIME LocalTime; if (pTM == NULL) return FALSE; SystemTime.wYear = pTM->tm_year + 1900; SystemTime.wMonth = pTM->tm_mon + 1; SystemTime.wDay = pTM->tm_mday; SystemTime.wHour = pTM->tm_hour; SystemTime.wMinute = pTM->tm_min; SystemTime.wSecond = pTM->tm_sec; SystemTime.wMilliseconds = 0; return SystemTimeToFileTime(&SystemTime, &LocalTime) && LocalFileTimeToFileTime(&LocalTime, pFileTime); } DllExport int win32_unlink(const char *filename) { dTHX; int ret; DWORD attrs; filename = PerlDir_mapA(filename); attrs = GetFileAttributesA(filename); if (attrs == 0xFFFFFFFF) { errno = ENOENT; return -1; } if (attrs & FILE_ATTRIBUTE_READONLY) { (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY); ret = unlink(filename); if (ret == -1) (void)SetFileAttributesA(filename, attrs); } else ret = unlink(filename); return ret; } DllExport int win32_utime(const char *filename, struct utimbuf *times) { dTHX; HANDLE handle; FILETIME ftCreate; FILETIME ftAccess; FILETIME ftWrite; struct utimbuf TimeBuffer; int rc; filename = PerlDir_mapA(filename); rc = utime(filename, times); /* EACCES: path specifies directory or readonly file */ if (rc == 0 || errno != EACCES /* || !IsWinNT() */) return rc; if (times == NULL) { times = &TimeBuffer; time(×->actime); times->modtime = times->actime; } /* This will (and should) still fail on readonly files */ handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE, FILE_SHARE_READ | FILE_SHARE_DELETE, NULL, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL); if (handle == INVALID_HANDLE_VALUE) return rc; if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) && filetime_from_time(&ftAccess, times->actime) && filetime_from_time(&ftWrite, times->modtime) && SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite)) { rc = 0; } CloseHandle(handle); return rc; } typedef union { unsigned __int64 ft_i64; FILETIME ft_val; } FT_t; #ifdef __GNUC__ #define Const64(x) x##LL #else #define Const64(x) x##i64 #endif /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */ #define EPOCH_BIAS Const64(116444736000000000) /* NOTE: This does not compute the timezone info (doing so can be expensive, * and appears to be unsupported even by glibc) */ DllExport int win32_gettimeofday(struct timeval *tp, void *not_used) { FT_t ft; /* this returns time in 100-nanosecond units (i.e. tens of usecs) */ GetSystemTimeAsFileTime(&ft.ft_val); /* seconds since epoch */ tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000)); /* microseconds remaining */ tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000)); return 0; } DllExport int win32_uname(struct utsname *name) { struct hostent *hep; STRLEN nodemax = sizeof(name->nodename)-1; /* sysname */ switch (g_osver.dwPlatformId) { case VER_PLATFORM_WIN32_WINDOWS: strcpy(name->sysname, "Windows"); break; case VER_PLATFORM_WIN32_NT: strcpy(name->sysname, "Windows NT"); break; case VER_PLATFORM_WIN32s: strcpy(name->sysname, "Win32s"); break; default: strcpy(name->sysname, "Win32 Unknown"); break; } /* release */ sprintf(name->release, "%d.%d", g_osver.dwMajorVersion, g_osver.dwMinorVersion); /* version */ sprintf(name->version, "Build %d", g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT ? g_osver.dwBuildNumber : (g_osver.dwBuildNumber & 0xffff)); if (g_osver.szCSDVersion[0]) { char *buf = name->version + strlen(name->version); sprintf(buf, " (%s)", g_osver.szCSDVersion); } /* 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'; } } else { DWORD sz = nodemax; if (!GetComputerName(name->nodename, &sz)) *name->nodename = '\0'; } /* machine (architecture) */ { SYSTEM_INFO info; DWORD procarch; char *arch; GetSystemInfo(&info); #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \ || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION) && !defined(__MINGW_EXTENSION)) procarch = info.u.s.wProcessorArchitecture; #else procarch = info.wProcessorArchitecture; #endif switch (procarch) { case PROCESSOR_ARCHITECTURE_INTEL: arch = "x86"; break; case PROCESSOR_ARCHITECTURE_MIPS: arch = "mips"; break; case PROCESSOR_ARCHITECTURE_ALPHA: arch = "alpha"; break; case PROCESSOR_ARCHITECTURE_PPC: arch = "ppc"; break; #ifdef PROCESSOR_ARCHITECTURE_SHX case PROCESSOR_ARCHITECTURE_SHX: arch = "shx"; break; #endif #ifdef PROCESSOR_ARCHITECTURE_ARM case PROCESSOR_ARCHITECTURE_ARM: arch = "arm"; break; #endif #ifdef PROCESSOR_ARCHITECTURE_IA64 case PROCESSOR_ARCHITECTURE_IA64: arch = "ia64"; break; #endif #ifdef PROCESSOR_ARCHITECTURE_ALPHA64 case PROCESSOR_ARCHITECTURE_ALPHA64: arch = "alpha64"; break; #endif #ifdef PROCESSOR_ARCHITECTURE_MSIL case PROCESSOR_ARCHITECTURE_MSIL: arch = "msil"; break; #endif #ifdef PROCESSOR_ARCHITECTURE_AMD64 case PROCESSOR_ARCHITECTURE_AMD64: arch = "amd64"; break; #endif #ifdef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64 case PROCESSOR_ARCHITECTURE_IA32_ON_WIN64: arch = "ia32-64"; break; #endif #ifdef PROCESSOR_ARCHITECTURE_UNKNOWN case PROCESSOR_ARCHITECTURE_UNKNOWN: arch = "unknown"; break; #endif default: sprintf(name->machine, "unknown(0x%x)", procarch); arch = name->machine; break; } if (name->machine != arch) strcpy(name->machine, arch); } return 0; } /* Timing related stuff */ 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) { #ifdef SIGCLD case SIGCLD: #endif #ifdef SIGCHLD case SIGCHLD: #endif case 0: return 0; case SIGTERM: default: break; } } } /* Tell caller to exit thread/process as approriate */ return 1; } void sig_terminate(pTHX_ int sig) { Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig); /* exit() seems to be safe, my_exit() or die() is a problem in ^C thread */ exit(sig); } DllExport int win32_async_check(pTHX) { MSG msg; HWND hwnd = w32_message_hwnd; /* Reset w32_poll_count before doing anything else, incase we dispatch * messages that end up calling back into perl */ w32_poll_count = 0; if (hwnd != INVALID_HANDLE_VALUE) { /* Passing PeekMessage -1 as HWND (2nd arg) only gets PostThreadMessage() messages * and ignores window messages - should co-exist better with windows apps e.g. Tk */ if (hwnd == NULL) hwnd = (HWND)-1; while (PeekMessage(&msg, hwnd, WM_TIMER, WM_TIMER, PM_REMOVE|PM_NOYIELD) || PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD)) { /* re-post a WM_QUIT message (we'll mark it as read later) */ if(msg.message == WM_QUIT) { PostQuitMessage((int)msg.wParam); break; } if(!CallMsgFilter(&msg, MSGF_USER)) { TranslateMessage(&msg); DispatchMessage(&msg); } } } /* Call PeekMessage() to mark all pending messages in the queue as "old". * This is necessary when we are being called by win32_msgwait() to * make sure MsgWaitForMultipleObjects() stops reporting the same waiting * message over and over. An example how this can happen is when * Perl is calling win32_waitpid() inside a GUI application and the GUI * is generating messages before the process terminated. */ PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD); /* Above or other stuff may have set a signal flag */ if (PL_sig_pending) despatch_signals(); return 1; } /* This function will not return until the timeout has elapsed, or until * one of the handles is ready. */ DllExport DWORD win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp) { /* We may need several goes at this - so compute when we stop */ DWORD ticks = 0; if (timeout != INFINITE) { ticks = GetTickCount(); timeout += ticks; } while (1) { DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, 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) { ticks = GetTickCount(); } if (result == WAIT_OBJECT_0 + count) { /* Message has arrived - check it */ (void)win32_async_check(aTHX); } else { /* Not timeout or message - one of handles is ready */ break; } } /* compute time left to wait */ ticks = timeout - ticks; /* If we are past the end say zero */ return (ticks > 0) ? ticks : 0; } int win32_internal_wait(int *status, DWORD timeout) { /* XXX this wait emulation only knows about processes * spawned via win32_spawnvp(P_NOWAIT, ...). */ dTHX; int i, retval; DWORD exitcode, waitcode; #ifdef USE_ITHREADS if (w32_num_pseudo_children) { 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; } } } #endif if (!w32_num_children) { 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; } 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; } } errno = GetLastError(); return -1; } DllExport int win32_waitpid(int pid, int *status, int flags) { dTHX; DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE; int retval = -1; long child; if (pid == -1) /* XXX threadid == 1 ? */ return win32_internal_wait(status, timeout); #ifdef USE_ITHREADS else if (pid < 0) { child = find_pseudo_pid(-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; } else if (IsWin95()) { pid = -pid; goto alien_process; } } #endif else { HANDLE hProcess; DWORD waitcode; child = find_pid(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 { alien_process: hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE, (IsWin95() ? -pid : 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 retval >= 0 ? pid : retval; } DllExport int win32_wait(int *status) { return win32_internal_wait(status, INFINITE); } DllExport unsigned int win32_sleep(unsigned int t) { dTHX; /* Win32 times are in ms so *1000 in and /1000 out */ return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000; } DllExport unsigned int win32_alarm(unsigned int sec) { /* * the 'obvious' implentation is SetTimer() with a callback * which does whatever receiving SIGALRM would do * we cannot use SIGALRM even via raise() as it is not * one of the supported codes in */ dTHX; if (w32_message_hwnd == INVALID_HANDLE_VALUE) w32_message_hwnd = win32_create_message_window(); if (sec) { if (w32_message_hwnd == NULL) w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL); else { w32_timerid = 1; SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL); } } else { if (w32_timerid) { KillTimer(w32_message_hwnd, w32_timerid); w32_timerid = 0; } } return 0; } #ifdef HAVE_DES_FCRYPT extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf); #endif DllExport char * win32_crypt(const char *txt, const char *salt) { dTHX; #ifdef HAVE_DES_FCRYPT return des_fcrypt(txt, salt, w32_crypt_buffer); #else Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia."); return NULL; #endif } #ifdef USE_FIXED_OSFHANDLE #define FOPEN 0x01 /* file handle open */ #define FNOINHERIT 0x10 /* file handle opened O_NOINHERIT */ #define FAPPEND 0x20 /* file handle opened O_APPEND */ #define FDEV 0x40 /* file handle refers to device */ #define FTEXT 0x80 /* file handle is in text mode */ /*** *int my_open_osfhandle(intptr_t osfhandle, int flags) - open C Runtime file handle * *Purpose: * This function allocates a free C Runtime file handle and associates * it with the Win32 HANDLE specified by the first parameter. This is a * temperary fix for WIN95's brain damage GetFileType() error on socket * we just bypass that call for socket * * This works with MSVC++ 4.0+ or GCC/Mingw32 * *Entry: * intptr_t osfhandle - Win32 HANDLE to associate with C Runtime file handle. * int flags - flags to associate with C Runtime file handle. * *Exit: * returns index of entry in fh, if successful * return -1, if no free entry is found * *Exceptions: * *******************************************************************************/ /* * we fake up some parts of the CRT that aren't exported by MSVCRT.dll * this lets sockets work on Win9X with GCC and should fix the problems * with perl95.exe * -- BKS, 1-23-2000 */ /* create an ioinfo entry, kill its handle, and steal the entry */ static int _alloc_osfhnd(void) { HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL); int fh = _open_osfhandle((intptr_t)hF, 0); CloseHandle(hF); if (fh == -1) return fh; EnterCriticalSection(&(_pioinfo(fh)->lock)); return fh; } static int my_open_osfhandle(intptr_t osfhandle, int flags) { int fh; char fileflags; /* _osfile flags */ /* copy relevant flags from second parameter */ fileflags = FDEV; if (flags & O_APPEND) fileflags |= FAPPEND; if (flags & O_TEXT) fileflags |= FTEXT; if (flags & O_NOINHERIT) fileflags |= FNOINHERIT; /* attempt to allocate a C Runtime file handle */ if ((fh = _alloc_osfhnd()) == -1) { errno = EMFILE; /* too many open files */ _doserrno = 0L; /* not an OS error */ return -1; /* return error to caller */ } /* the file is open. now, set the info in _osfhnd array */ _set_osfhnd(fh, osfhandle); fileflags |= FOPEN; /* mark as open */ _osfile(fh) = fileflags; /* set osfile entry */ LeaveCriticalSection(&_pioinfo(fh)->lock); return fh; /* return handle */ } #endif /* USE_FIXED_OSFHANDLE */ /* simulate flock by locking a range on the file */ #define LK_LEN 0xffff0000 DllExport int win32_flock(int fd, int oper) { OVERLAPPED o; int i = -1; HANDLE fh; if (!IsWinNT()) { dTHX; Perl_croak_nocontext("flock() unimplemented on this platform"); return -1; } fh = (HANDLE)_get_osfhandle(fd); if (fh == (HANDLE)-1) /* _get_osfhandle() already sets errno to EBADF */ return -1; memset(&o, 0, sizeof(o)); switch(oper) { case LOCK_SH: /* shared lock */ if (LockFileEx(fh, 0, 0, LK_LEN, 0, &o)) i = 0; break; case LOCK_EX: /* exclusive lock */ if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o)) i = 0; break; case LOCK_SH|LOCK_NB: /* non-blocking shared lock */ if (LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o)) i = 0; break; case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */ if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o)) i = 0; break; case LOCK_UN: /* unlock lock */ if (UnlockFileEx(fh, 0, LK_LEN, 0, &o)) i = 0; break; default: /* unknown */ errno = EINVAL; return -1; } if (i == -1) { if (GetLastError() == ERROR_LOCK_VIOLATION) errno = WSAEWOULDBLOCK; else errno = EINVAL; } return i; } #undef LK_LEN /* * redirected io subsystem for all XS modules * */ DllExport int * win32_errno(void) { return (&errno); } DllExport char *** win32_environ(void) { return (&(_environ)); } /* the rest are the remapped stdio routines */ DllExport FILE * win32_stderr(void) { return (stderr); } DllExport FILE * win32_stdin(void) { return (stdin); } DllExport FILE * win32_stdout(void) { return (stdout); } DllExport int win32_ferror(FILE *fp) { return (ferror(fp)); } DllExport int win32_feof(FILE *fp) { return (feof(fp)); } /* * Since the errors returned by the socket error function * WSAGetLastError() are not known by the library routine strerror * we have to roll our own. */ DllExport char * win32_strerror(int e) { #if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */ extern int sys_nerr; #endif if (e < 0 || e > sys_nerr) { dTHX; if (e < 0) e = GetLastError(); if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM |FORMAT_MESSAGE_IGNORE_INSERTS, NULL, e, 0, w32_strerror_buffer, sizeof(w32_strerror_buffer), NULL) == 0) { strcpy(w32_strerror_buffer, "Unknown Error"); } return w32_strerror_buffer; } #undef strerror return strerror(e); #define strerror win32_strerror } DllExport void 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); /* 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'; } if (0 == dwLen) { 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); } } DllExport int win32_fprintf(FILE *fp, const char *format, ...) { va_list marker; va_start(marker, format); /* Initialize variable arguments. */ return (vfprintf(fp, format, marker)); } DllExport int win32_printf(const char *format, ...) { va_list marker; va_start(marker, format); /* Initialize variable arguments. */ return (vprintf(format, marker)); } DllExport int win32_vfprintf(FILE *fp, const char *format, va_list args) { return (vfprintf(fp, format, args)); } DllExport int win32_vprintf(const char *format, va_list args) { return (vprintf(format, args)); } DllExport size_t win32_fread(void *buf, size_t size, size_t count, FILE *fp) { return fread(buf, size, count, fp); } DllExport size_t win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp) { return fwrite(buf, size, count, fp); } #define MODE_SIZE 10 DllExport FILE * win32_fopen(const char *filename, const char *mode) { dTHX; FILE *f; if (!*filename) return NULL; if (stricmp(filename, "/dev/null")==0) filename = "NUL"; f = fopen(PerlDir_mapA(filename), mode); /* avoid buffering headaches for child processes */ if (f && *mode == 'a') win32_fseek(f, 0, SEEK_END); return f; } #ifndef USE_SOCKETS_AS_HANDLES #undef fdopen #define fdopen my_fdopen #endif DllExport FILE * win32_fdopen(int handle, const char *mode) { dTHX; FILE *f; f = fdopen(handle, (char *) mode); /* avoid buffering headaches for child processes */ if (f && *mode == 'a') win32_fseek(f, 0, SEEK_END); return f; } DllExport FILE * win32_freopen(const char *path, const char *mode, FILE *stream) { dTHX; if (stricmp(path, "/dev/null")==0) path = "NUL"; return freopen(PerlDir_mapA(path), mode, stream); } DllExport int win32_fclose(FILE *pf) { return my_fclose(pf); /* defined in win32sck.c */ } DllExport int win32_fputs(const char *s,FILE *pf) { return fputs(s, pf); } DllExport int win32_fputc(int c,FILE *pf) { return fputc(c,pf); } DllExport int win32_ungetc(int c,FILE *pf) { return ungetc(c,pf); } DllExport int win32_getc(FILE *pf) { return getc(pf); } DllExport int win32_fileno(FILE *pf) { return fileno(pf); } DllExport void win32_clearerr(FILE *pf) { clearerr(pf); return; } DllExport int win32_fflush(FILE *pf) { return fflush(pf); } DllExport Off_t win32_ftell(FILE *pf) { #if defined(WIN64) || defined(USE_LARGE_FILES) #if defined(__BORLANDC__) /* buk */ return win32_tell( fileno( pf ) ); #else fpos_t pos; if (fgetpos(pf, &pos)) return -1; return (Off_t)pos; #endif #else return ftell(pf); #endif } DllExport int win32_fseek(FILE *pf, Off_t offset,int origin) { #if defined(WIN64) || defined(USE_LARGE_FILES) #if defined(__BORLANDC__) /* buk */ return win32_lseek( fileno(pf), offset, origin ); #else fpos_t pos; switch (origin) { case SEEK_CUR: if (fgetpos(pf, &pos)) return -1; offset += pos; break; case SEEK_END: fseek(pf, 0, SEEK_END); pos = _telli64(fileno(pf)); offset += pos; break; case SEEK_SET: break; default: errno = EINVAL; return -1; } return fsetpos(pf, &offset); #endif #else return fseek(pf, (long)offset, origin); #endif } DllExport int win32_fgetpos(FILE *pf,fpos_t *p) { #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */ if( win32_tell(fileno(pf)) == -1L ) { errno = EBADF; return -1; } return 0; #else return fgetpos(pf, p); #endif } DllExport int win32_fsetpos(FILE *pf,const fpos_t *p) { #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */ return win32_lseek(fileno(pf), *p, SEEK_CUR); #else return fsetpos(pf, p); #endif } DllExport void win32_rewind(FILE *pf) { rewind(pf); return; } DllExport int win32_tmpfd(void) { dTHX; char prefix[MAX_PATH+1]; char filename[MAX_PATH+1]; DWORD len = GetTempPath(MAX_PATH, prefix); 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, 0); if (fd >= 0) { #if defined(__BORLANDC__) setmode(fd,O_BINARY); #endif DEBUG_p(PerlIO_printf(Perl_debug_log, "Created tmpfile=%s\n",filename)); return fd; } } } } return -1; } DllExport FILE* win32_tmpfile(void) { int fd = win32_tmpfd(); if (fd >= 0) return win32_fdopen(fd, "w+b"); return NULL; } DllExport void win32_abort(void) { abort(); return; } DllExport int win32_fstat(int fd, Stat_t *sbufptr) { #ifdef __BORLANDC__ /* A file designated by filehandle is not shown as accessible * for write operations, probably because it is opened for reading. * --Vadim Konovalov */ BY_HANDLE_FILE_INFORMATION bhfi; #if defined(WIN64) || defined(USE_LARGE_FILES) /* Borland 5.5.1 has a 64-bit stat, but only a 32-bit fstat */ struct stat tmp; int rc = fstat(fd,&tmp); sbufptr->st_dev = tmp.st_dev; sbufptr->st_ino = tmp.st_ino; sbufptr->st_mode = tmp.st_mode; sbufptr->st_nlink = tmp.st_nlink; sbufptr->st_uid = tmp.st_uid; sbufptr->st_gid = tmp.st_gid; sbufptr->st_rdev = tmp.st_rdev; sbufptr->st_size = tmp.st_size; sbufptr->st_atime = tmp.st_atime; sbufptr->st_mtime = tmp.st_mtime; sbufptr->st_ctime = tmp.st_ctime; #else int rc = fstat(fd,sbufptr); #endif if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) { #if defined(WIN64) || defined(USE_LARGE_FILES) sbufptr->st_size = ((__int64)bhfi.nFileSizeHigh << 32) | bhfi.nFileSizeLow ; #endif sbufptr->st_mode &= 0xFE00; if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY) sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6)); else sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3) + ((S_IREAD|S_IWRITE) >> 6)); } return rc; #else return my_fstat(fd,sbufptr); #endif } DllExport int win32_pipe(int *pfd, unsigned int size, int mode) { return _pipe(pfd, size, mode); } DllExport PerlIO* win32_popenlist(const char *mode, IV narg, SV **args) { dTHX; Perl_croak(aTHX_ "List form of pipe open not implemented"); return NULL; } /* * a popen() clone that respects PERL5SHELL * * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000 */ DllExport PerlIO* win32_popen(const char *command, const char *mode) { #ifdef USE_RTL_POPEN return _popen(command, mode); #else dTHX; int p[2]; int parent, child; int stdfd, oldfd; int ourmode; int childpid; DWORD nhandle; HANDLE old_h; int lock_held = 0; /* establish which ends read and write */ if (strchr(mode,'w')) { stdfd = 0; /* stdin */ parent = 1; child = 0; nhandle = STD_INPUT_HANDLE; } else if (strchr(mode,'r')) { stdfd = 1; /* stdout */ parent = 0; child = 1; nhandle = STD_OUTPUT_HANDLE; } else return NULL; /* set the correct mode */ if (strchr(mode,'b')) ourmode = O_BINARY; else if (strchr(mode,'t')) ourmode = O_TEXT; else ourmode = _fmode & (O_TEXT | O_BINARY); /* the child doesn't inherit handles */ ourmode |= O_NOINHERIT; if (win32_pipe(p, 512, ourmode) == -1) return NULL; /* save the old std handle (this needs to happen before the * dup2(), since that might call SetStdHandle() too) */ OP_REFCNT_LOCK; lock_held = 1; old_h = GetStdHandle(nhandle); /* save current stdfd */ if ((oldfd = win32_dup(stdfd)) == -1) goto cleanup; /* make stdfd go to child end of pipe (implicitly closes stdfd) */ /* stdfd will be inherited by the child */ if (win32_dup2(p[child], stdfd) == -1) goto cleanup; /* close the child end in parent */ win32_close(p[child]); /* set the new std handle (in case dup2() above didn't) */ SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd)); /* start the child */ { dTHX; if ((childpid = do_spawn_nowait((char*)command)) == -1) goto cleanup; /* revert stdfd to whatever it was before */ if (win32_dup2(oldfd, stdfd) == -1) goto cleanup; /* close saved handle */ win32_close(oldfd); /* restore the old std handle (this needs to happen after the * dup2(), since that might call SetStdHandle() too */ if (lock_held) { SetStdHandle(nhandle, old_h); OP_REFCNT_UNLOCK; lock_held = 0; } 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; } /* we have an fd, return a file stream */ return (PerlIO_fdopen(p[parent], (char *)mode)); cleanup: /* we don't need to check for errors here */ win32_close(p[0]); win32_close(p[1]); if (oldfd != -1) { win32_dup2(oldfd, stdfd); win32_close(oldfd); } if (lock_held) { SetStdHandle(nhandle, old_h); OP_REFCNT_UNLOCK; lock_held = 0; } return (NULL); #endif /* USE_RTL_POPEN */ } /* * pclose() clone */ DllExport int win32_pclose(PerlIO *pf) { #ifdef USE_RTL_POPEN return _pclose(pf); #else dTHX; int childpid, status; SV *sv; sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE); if (SvIOK(sv)) childpid = SvIVX(sv); else childpid = 0; if (!childpid) { errno = EBADF; return -1; } #ifdef USE_PERLIO PerlIO_close(pf); #else fclose(pf); #endif SvIVX(sv) = 0; if (win32_waitpid(childpid, &status, 0) == -1) return -1; return status; #endif /* USE_RTL_POPEN */ } static BOOL WINAPI Nt4CreateHardLinkW( LPCWSTR lpFileName, LPCWSTR lpExistingFileName, LPSECURITY_ATTRIBUTES lpSecurityAttributes) { HANDLE handle; WCHAR wFullName[MAX_PATH+1]; LPVOID lpContext = NULL; WIN32_STREAM_ID StreamId; DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId; DWORD dwWritten; DWORD dwLen; BOOL bSuccess; BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD, BOOL, BOOL, LPVOID*) = (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD, BOOL, BOOL, LPVOID*)) GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite"); if (pfnBackupWrite == NULL) return 0; dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL); if (dwLen == 0) return 0; dwLen = (dwLen+1)*sizeof(WCHAR); handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES, FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, NULL, OPEN_EXISTING, 0, NULL); if (handle == INVALID_HANDLE_VALUE) return 0; StreamId.dwStreamId = BACKUP_LINK; StreamId.dwStreamAttributes = 0; StreamId.dwStreamNameSize = 0; #if defined(__BORLANDC__) \ ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION)) StreamId.Size.u.HighPart = 0; StreamId.Size.u.LowPart = dwLen; #else StreamId.Size.HighPart = 0; StreamId.Size.LowPart = dwLen; #endif bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten, FALSE, FALSE, &lpContext); if (bSuccess) { bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten, FALSE, FALSE, &lpContext); pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext); } CloseHandle(handle); return bSuccess; } DllExport int win32_link(const char *oldname, const char *newname) { dTHX; BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES); WCHAR wOldName[MAX_PATH+1]; WCHAR wNewName[MAX_PATH+1]; if (IsWin95()) Perl_croak(aTHX_ PL_no_func, "link"); pfnCreateHardLinkW = (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES)) GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW"); if (pfnCreateHardLinkW == NULL) pfnCreateHardLinkW = Nt4CreateHardLinkW; if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) && MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) && (wcscpy(wOldName, PerlDir_mapW(wOldName)), pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL))) { return 0; } errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL; return -1; } DllExport int win32_rename(const char *oname, const char *newname) { char szOldName[MAX_PATH+1]; char szNewName[MAX_PATH+1]; BOOL bResult; dTHX; /* XXX despite what the documentation says about MoveFileEx(), * it doesn't work under Windows95! */ if (IsWinNT()) { DWORD dwFlags = MOVEFILE_COPY_ALLOWED; if (stricmp(newname, oname)) dwFlags |= MOVEFILE_REPLACE_EXISTING; strcpy(szOldName, PerlDir_mapA(oname)); bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags); if (!bResult) { DWORD err = GetLastError(); switch (err) { case ERROR_BAD_NET_NAME: case ERROR_BAD_NETPATH: case ERROR_BAD_PATHNAME: case ERROR_FILE_NOT_FOUND: case ERROR_FILENAME_EXCED_RANGE: case ERROR_INVALID_DRIVE: case ERROR_NO_MORE_FILES: case ERROR_PATH_NOT_FOUND: errno = ENOENT; break; default: errno = EACCES; break; } return -1; } return 0; } else { int retval = 0; char szTmpName[MAX_PATH+1]; char dname[MAX_PATH+1]; char *endname = NULL; STRLEN tmplen = 0; DWORD from_attr, to_attr; strcpy(szOldName, PerlDir_mapA(oname)); strcpy(szNewName, PerlDir_mapA(newname)); /* if oname doesn't exist, do nothing */ from_attr = GetFileAttributes(szOldName); if (from_attr == 0xFFFFFFFF) { errno = ENOENT; return -1; } /* if newname exists, rename it to a temporary name so that we * don't delete it in case oname happens to be the same file * (but perhaps accessed via a different path) */ to_attr = GetFileAttributes(szNewName); if (to_attr != 0xFFFFFFFF) { /* if newname is a directory, we fail * XXX could overcome this with yet more convoluted logic */ if (to_attr & FILE_ATTRIBUTE_DIRECTORY) { errno = EACCES; return -1; } tmplen = strlen(szNewName); strcpy(szTmpName,szNewName); endname = szTmpName+tmplen; for (; endname > szTmpName ; --endname) { if (*endname == '/' || *endname == '\\') { *endname = '\0'; break; } } if (endname > szTmpName) endname = strcpy(dname,szTmpName); else endname = "."; /* get a temporary filename in same directory * XXX is this really the best we can do? */ if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) { errno = ENOENT; return -1; } DeleteFile(szTmpName); retval = rename(szNewName, szTmpName); if (retval != 0) { errno = EACCES; return retval; } } /* rename oname to newname */ retval = rename(szOldName, szNewName); /* if we created a temporary file before ... */ if (endname != NULL) { /* ...and rename succeeded, delete temporary file/directory */ if (retval == 0) DeleteFile(szTmpName); /* else restore it to what it was */ else (void)rename(szTmpName, szNewName); } return retval; } } DllExport int win32_setmode(int fd, int mode) { return setmode(fd, mode); } DllExport int win32_chsize(int fd, Off_t size) { #if defined(WIN64) || defined(USE_LARGE_FILES) int retval = 0; Off_t cur, end, extend; cur = win32_tell(fd); if (cur < 0) return -1; end = win32_lseek(fd, 0, SEEK_END); if (end < 0) return -1; extend = size - end; if (extend == 0) { /* 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); } else { /* shrink the file */ win32_lseek(fd, size, SEEK_SET); if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) { errno = EACCES; retval = -1; } } finish: win32_lseek(fd, cur, SEEK_SET); return retval; #else return chsize(fd, (long)size); #endif } DllExport Off_t win32_lseek(int fd, Off_t offset, int origin) { #if defined(WIN64) || defined(USE_LARGE_FILES) #if defined(__BORLANDC__) /* buk */ LARGE_INTEGER pos; pos.QuadPart = offset; pos.LowPart = SetFilePointer( (HANDLE)_get_osfhandle(fd), pos.LowPart, &pos.HighPart, origin ); if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) { pos.QuadPart = -1; } return pos.QuadPart; #else return _lseeki64(fd, offset, origin); #endif #else return lseek(fd, (long)offset, origin); #endif } DllExport Off_t win32_tell(int fd) { #if defined(WIN64) || defined(USE_LARGE_FILES) #if defined(__BORLANDC__) /* buk */ LARGE_INTEGER pos; pos.QuadPart = 0; pos.LowPart = SetFilePointer( (HANDLE)_get_osfhandle(fd), pos.LowPart, &pos.HighPart, FILE_CURRENT ); if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) { pos.QuadPart = -1; } return pos.QuadPart; /* return tell(fd); */ #else return _telli64(fd); #endif #else return tell(fd); #endif } DllExport int win32_open(const char *path, int flag, ...) { dTHX; va_list ap; int pmode; va_start(ap, flag); pmode = va_arg(ap, int); va_end(ap); if (stricmp(path, "/dev/null")==0) path = "NUL"; return open(PerlDir_mapA(path), flag, pmode); } /* close() that understands socket */ extern int my_close(int); /* in win32sck.c */ DllExport int win32_close(int fd) { return my_close(fd); } DllExport int win32_eof(int fd) { return eof(fd); } DllExport int win32_isatty(int fd) { /* The Microsoft isatty() function returns true for *all* * character mode devices, including "nul". Our implementation * should only return true if the handle has a console buffer. */ DWORD mode; HANDLE fh = (HANDLE)_get_osfhandle(fd); if (fh == (HANDLE)-1) { /* errno is already set to EBADF */ return 0; } if (GetConsoleMode(fh, &mode)) return 1; errno = ENOTTY; return 0; } DllExport int win32_dup(int fd) { return dup(fd); } DllExport int win32_dup2(int fd1,int fd2) { return dup2(fd1,fd2); } #ifdef PERL_MSVCRT_READFIX #define LF 10 /* line feed */ #define CR 13 /* carriage return */ #define CTRLZ 26 /* ctrl-z means eof for text */ #define FOPEN 0x01 /* file handle open */ #define FEOFLAG 0x02 /* end of file has been encountered */ #define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */ #define FPIPE 0x08 /* file handle refers to a pipe */ #define FAPPEND 0x20 /* file handle opened O_APPEND */ #define FDEV 0x40 /* file handle refers to device */ #define FTEXT 0x80 /* file handle is in text mode */ #define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */ int __cdecl _fixed_read(int fh, void *buf, unsigned cnt) { int bytes_read; /* number of bytes read */ char *buffer; /* buffer to read to */ int os_read; /* bytes read on OS call */ char *p, *q; /* pointers into buffer */ char peekchr; /* peek-ahead character */ ULONG filepos; /* file position after seek */ ULONG dosretval; /* o.s. return value */ /* validate handle */ if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) || !(_osfile(fh) & FOPEN)) { /* out of range -- return error */ errno = EBADF; _doserrno = 0; /* not o.s. error */ return -1; } /* * If lockinitflag is FALSE, assume fd is device * lockinitflag is set to TRUE by open. */ if (_pioinfo(fh)->lockinitflag) EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */ bytes_read = 0; /* nothing read yet */ buffer = (char*)buf; if (cnt == 0 || (_osfile(fh) & FEOFLAG)) { /* nothing to read or at EOF, so return 0 read */ goto functionexit; } if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) { /* a pipe/device and pipe lookahead non-empty: read the lookahead * char */ *buffer++ = _pipech(fh); ++bytes_read; --cnt; _pipech(fh) = LF; /* mark as empty */ } /* read the data */ if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL)) { /* ReadFile has reported an error. recognize two special cases. * * 1. map ERROR_ACCESS_DENIED to EBADF * * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it * means the handle is a read-handle on a pipe for which * all write-handles have been closed and all data has been * read. */ if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) { /* wrong read/write mode should return EBADF, not EACCES */ errno = EBADF; _doserrno = dosretval; bytes_read = -1; goto functionexit; } else if (dosretval == ERROR_BROKEN_PIPE) { bytes_read = 0; goto functionexit; } else { bytes_read = -1; goto functionexit; } } bytes_read += os_read; /* update bytes read */ if (_osfile(fh) & FTEXT) { /* now must translate CR-LFs to LFs in the buffer */ /* set CRLF flag to indicate LF at beginning of buffer */ /* if ((os_read != 0) && (*(char *)buf == LF)) */ /* _osfile(fh) |= FCRLF; */ /* else */ /* _osfile(fh) &= ~FCRLF; */ _osfile(fh) &= ~FCRLF; /* convert chars in the buffer: p is src, q is dest */ p = q = (char*)buf; while (p < (char *)buf + bytes_read) { if (*p == CTRLZ) { /* if fh is not a device, set ctrl-z flag */ if (!(_osfile(fh) & FDEV)) _osfile(fh) |= FEOFLAG; break; /* stop translating */ } else if (*p != CR) *q++ = *p++; else { /* *p is CR, so must check next char for LF */ if (p < (char *)buf + bytes_read - 1) { if (*(p+1) == LF) { p += 2; *q++ = LF; /* convert CR-LF to LF */ } else *q++ = *p++; /* store char normally */ } else { /* This is the hard part. We found a CR at end of buffer. We must peek ahead to see if next char is an LF. */ ++p; dosretval = 0; if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1, (LPDWORD)&os_read, NULL)) dosretval = GetLastError(); if (dosretval != 0 || os_read == 0) { /* couldn't read ahead, store CR */ *q++ = CR; } else { /* peekchr now has the extra character -- we now have several possibilities: 1. disk file and char is not LF; just seek back and copy CR 2. disk file and char is LF; store LF, don't seek back 3. pipe/device and char is LF; store LF. 4. pipe/device and char isn't LF, store CR and put char in pipe lookahead buffer. */ if (_osfile(fh) & (FDEV|FPIPE)) { /* non-seekable device */ if (peekchr == LF) *q++ = LF; else { *q++ = CR; _pipech(fh) = peekchr; } } else { /* disk file */ if (peekchr == LF) { /* nothing read yet; must make some progress */ *q++ = LF; /* turn on this flag for tell routine */ _osfile(fh) |= FCRLF; } else { HANDLE osHandle; /* o.s. handle value */ /* seek back */ if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1) { if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1) dosretval = GetLastError(); } if (peekchr != LF) *q++ = CR; } } } } } } /* we now change bytes_read to reflect the true number of chars in the buffer */ bytes_read = q - (char *)buf; } functionexit: if (_pioinfo(fh)->lockinitflag) LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */ return bytes_read; } #endif /* PERL_MSVCRT_READFIX */ DllExport int win32_read(int fd, void *buf, unsigned int cnt) { #ifdef PERL_MSVCRT_READFIX return _fixed_read(fd, buf, cnt); #else return read(fd, buf, cnt); #endif } DllExport int win32_write(int fd, const void *buf, unsigned int cnt) { return write(fd, buf, cnt); } DllExport int win32_mkdir(const char *dir, int mode) { dTHX; return mkdir(PerlDir_mapA(dir)); /* just ignore mode */ } DllExport int win32_rmdir(const char *dir) { dTHX; return rmdir(PerlDir_mapA(dir)); } DllExport int win32_chdir(const char *dir) { dTHX; if (!dir) { errno = ENOENT; return -1; } return chdir(dir); } DllExport int win32_access(const char *path, int mode) { dTHX; return access(PerlDir_mapA(path), mode); } DllExport int win32_chmod(const char *path, int mode) { dTHX; return chmod(PerlDir_mapA(path), mode); } static char * create_command_line(char *cname, STRLEN clen, const char * const *args) { dTHX; int index, argc; char *cmd, *ptr; const char *arg; STRLEN len = 0; bool bat_file = FALSE; bool cmd_shell = FALSE; bool dumb_shell = FALSE; bool extra_quotes = FALSE; bool quote_next = FALSE; if (!cname) 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 * of the following is true: * 1. the /S switch was used * 2. there are more than two dquotes * 3. there is a special character from this set: &<>()@^| * 4. no whitespace characters within the two dquotes * 5. string between two dquotes isn't an executable file * To work around this, we always add a leading and trailing dquote * to the string, if the first argument is either "cmd.exe" or "cmd", * and there were at least two or more arguments passed to cmd.exe * (not including switches). * XXX the above rules (from "cmd /?") don't seem to be applied * always, making for the convolutions below :-( */ if (cname) { if (!clen) clen = strlen(cname); if (clen > 4 && (stricmp(&cname[clen-4], ".bat") == 0 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0))) { bat_file = TRUE; if (!IsWin95()) 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; } } } 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)); } DEBUG_p(PerlIO_printf(Perl_debug_log, "\n")); argc = index; Newx(cmd, len, char); ptr = cmd; if (bat_file && !IsWin95()) { *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; } } } } if (extra_quotes) *ptr++ = '"'; *ptr = '\0'; return cmd; } static char * qualified_path(const char *cmd) { dTHX; char *pathstr; char *fullcmd, *curfullcmd; STRLEN cmdlen = 0; int has_slash = 0; if (!cmd) return NULL; fullcmd = (char*)cmd; while (*fullcmd) { if (*fullcmd == '/' || *fullcmd == '\\') has_slash++; fullcmd++; cmdlen++; } /* look in PATH */ pathstr = PerlEnv_getenv("PATH"); /* worst case: PATH is a single directory; we need additional space * to append "/", ".exe" and trailing "\0" */ Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char); 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] != '.')) { strcpy(curfullcmd, ".exe"); 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 { *curfullcmd++ = *pathstr++; } } if (*pathstr) pathstr++; /* skip trailing semi */ if (curfullcmd > fullcmd /* append a dir separator */ && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\') { *curfullcmd++ = '\\'; } } Safefree(fullcmd); return NULL; } /* The following are just place holders. * Some hosts may provide and environment that the OS is * not tracking, therefore, these host must provide that * environment and the current directory to CreateProcess */ DllExport void* win32_get_childenv(void) { return NULL; } DllExport void win32_free_childenv(void* d) { } DllExport void win32_clearenv(void) { char *envv = GetEnvironmentStrings(); 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; } FreeEnvironmentStrings(envv); } DllExport char* win32_get_childdir(void) { dTHX; char* ptr; char szfilename[MAX_PATH+1]; GetCurrentDirectoryA(MAX_PATH+1, szfilename); Newx(ptr, strlen(szfilename)+1, char); strcpy(ptr, szfilename); return ptr; } DllExport void win32_free_childdir(char* d) { dTHX; Safefree(d); } /* XXX this needs to be made more compatible with the spawnvp() * provided by the various RTLs. In particular, searching for * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented. * This doesn't significantly affect perl itself, because we * always invoke things using PERL5SHELL if a direct attempt to * spawn the executable fails. * * XXX splitting and rejoining the commandline between do_aspawn() * and win32_spawnvp() could also be avoided. */ DllExport int win32_spawnvp(int mode, const char *cmdname, const char *const *argv) { #ifdef USE_RTL_SPAWNVP return spawnvp(mode, cmdname, (char * const *)argv); #else dTHX; int ret; void* env; char* dir; child_IO_table tbl; STARTUPINFO StartupInfo; PROCESS_INFORMATION ProcessInformation; DWORD create = 0; char *cmd; char *fullcmd = NULL; char *cname = (char *)cmdname; 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'; } } cmd = create_command_line(cname, clen, argv); env = PerlEnv_get_childenv(); dir = PerlEnv_get_childdir(); 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() */ create |= CREATE_NEW_PROCESS_GROUP; /* FALL THROUGH */ case P_WAIT: /* synchronous execution */ break; default: /* invalid mode */ errno = EINVAL; ret = -1; goto RETVAL; } memset(&StartupInfo,0,sizeof(StartupInfo)); StartupInfo.cb = sizeof(StartupInfo); memset(&tbl,0,sizeof(tbl)); PerlEnv_get_child_IO(&tbl); StartupInfo.dwFlags = tbl.dwFlags; StartupInfo.dwX = tbl.dwX; StartupInfo.dwY = tbl.dwY; StartupInfo.dwXSize = tbl.dwXSize; StartupInfo.dwYSize = tbl.dwYSize; StartupInfo.dwXCountChars = tbl.dwXCountChars; StartupInfo.dwYCountChars = tbl.dwYCountChars; StartupInfo.dwFillAttribute = tbl.dwFillAttribute; StartupInfo.wShowWindow = tbl.wShowWindow; StartupInfo.hStdInput = tbl.childStdIn; StartupInfo.hStdOutput = tbl.childStdOut; StartupInfo.hStdError = tbl.childStdErr; if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE && StartupInfo.hStdOutput == INVALID_HANDLE_VALUE && StartupInfo.hStdError == INVALID_HANDLE_VALUE) { create |= CREATE_NEW_CONSOLE; } else { StartupInfo.dwFlags |= STARTF_USESTDHANDLES; } if (w32_use_showwindow) { StartupInfo.dwFlags |= STARTF_USESHOWWINDOW; StartupInfo.wShowWindow = w32_showwindow; } DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n", 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)) { /* 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); 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; if (IsWin95() && ret < 0) ret = -ret; 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 */ GetExitCodeProcess(ProcessInformation.hProcess, &status); ret = (int)status; CloseHandle(ProcessInformation.hProcess); } CloseHandle(ProcessInformation.hThread); RETVAL: PerlEnv_free_childenv(env); PerlEnv_free_childdir(dir); Safefree(cmd); if (cname != cmdname) Safefree(cname); return ret; #endif } DllExport int win32_execv(const char *cmdname, const char *const *argv) { #ifdef USE_ITHREADS dTHX; /* if this is a pseudo-forked child, we just want to spawn * the new program, and return */ if (w32_pseudo_id) # ifdef __BORLANDC__ return spawnv(P_WAIT, cmdname, (char *const *)argv); # else return spawnv(P_WAIT, cmdname, argv); # endif #endif #ifdef __BORLANDC__ return execv(cmdname, (char *const *)argv); #else return execv(cmdname, argv); #endif } DllExport int win32_execvp(const char *cmdname, const char *const *argv) { #ifdef USE_ITHREADS dTHX; /* 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; } #endif #ifdef __BORLANDC__ return execvp(cmdname, (char *const *)argv); #else return execvp(cmdname, argv); #endif } DllExport void win32_perror(const char *str) { perror(str); } DllExport void win32_setbuf(FILE *pf, char *buf) { setbuf(pf, buf); } DllExport int win32_setvbuf(FILE *pf, char *buf, int type, size_t size) { return setvbuf(pf, buf, type, size); } DllExport int win32_flushall(void) { return flushall(); } DllExport int win32_fcloseall(void) { return fcloseall(); } DllExport char* win32_fgets(char *s, int n, FILE *pf) { return fgets(s, n, pf); } DllExport char* win32_gets(char *s) { return gets(s); } DllExport int win32_fgetc(FILE *pf) { return fgetc(pf); } DllExport int win32_putc(int c, FILE *pf) { return putc(c,pf); } DllExport int win32_puts(const char *s) { return puts(s); } DllExport int win32_getchar(void) { return getchar(); } DllExport int win32_putchar(int c) { return putchar(c); } #ifdef MYMALLOC #ifndef USE_PERL_SBRK static char *committed = NULL; /* XXX threadead */ static char *base = NULL; /* XXX threadead */ static char *reserved = NULL; /* XXX threadead */ static char *brk = NULL; /* XXX threadead */ static DWORD pagesize = 0; /* XXX threadead */ void * sbrk(ptrdiff_t need) { void *result; if (!pagesize) {SYSTEM_INFO info; GetSystemInfo(&info); /* Pretend page size is larger so we don't perpetually * call the OS to commit just one page ... */ pagesize = info.dwPageSize << 3; } if (brk+need >= reserved) { DWORD size = brk+need-reserved; char *addr; char *prev_committed = NULL; if (committed && reserved && committed < reserved) { /* Commit last of previous chunk cannot span allocations */ addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE); if (addr) { /* Remember where we committed from in case we want to decommit later */ prev_committed = committed; committed = reserved; } } /* Reserve some (more) space * Contiguous blocks give us greater efficiency, so reserve big blocks - * this is only address space not memory... * Note this is a little sneaky, 1st call passes NULL as reserved * so lets system choose where we start, subsequent calls pass * the old end address so ask for a contiguous block */ sbrk_reserve: if (size < 64*1024*1024) size = 64*1024*1024; size = ((size + pagesize - 1) / pagesize) * pagesize; addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS); if (addr) { reserved = addr+size; if (!base) base = addr; if (!committed) committed = base; if (!brk) brk = committed; } else if (reserved) { /* The existing block could not be extended far enough, so decommit * anything that was just committed above and start anew */ if (prev_committed) { if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT)) return (void *) -1; } reserved = base = committed = brk = NULL; size = need; goto sbrk_reserve; } else { return (void *) -1; } } result = brk; brk += need; if (brk > committed) { DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize; char *addr; if (committed+size > reserved) size = reserved-committed; addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE); if (addr) committed += size; else return (void *) -1; } return result; } #endif #endif DllExport void* win32_malloc(size_t size) { return malloc(size); } DllExport void* win32_calloc(size_t numitems, size_t size) { return calloc(numitems,size); } DllExport void* win32_realloc(void *block, size_t size) { return realloc(block,size); } DllExport void win32_free(void *block) { free(block); } DllExport int win32_open_osfhandle(intptr_t handle, int flags) { #ifdef USE_FIXED_OSFHANDLE if (IsWin95()) return my_open_osfhandle(handle, flags); #endif return _open_osfhandle(handle, flags); } DllExport intptr_t win32_get_osfhandle(int fd) { return (intptr_t)_get_osfhandle(fd); } DllExport FILE * win32_fdupopen(FILE *pf) { FILE* pfdup; fpos_t pos; char mode[3]; int fileno = win32_dup(win32_fileno(pf)); /* open the file in the same mode */ #ifdef __BORLANDC__ if((pf)->flags & _F_READ) { mode[0] = 'r'; mode[1] = 0; } else if((pf)->flags & _F_WRIT) { mode[0] = 'a'; mode[1] = 0; } else if((pf)->flags & _F_RDWR) { mode[0] = 'r'; mode[1] = '+'; mode[2] = 0; } #else if((pf)->_flag & _IOREAD) { mode[0] = 'r'; mode[1] = 0; } else if((pf)->_flag & _IOWRT) { mode[0] = 'a'; mode[1] = 0; } else if((pf)->_flag & _IORW) { mode[0] = 'r'; mode[1] = '+'; mode[2] = 0; } #endif /* it appears that the binmode is attached to the * file descriptor so binmode files will be handled * correctly */ pfdup = win32_fdopen(fileno, mode); /* move the file pointer to the same position */ if (!fgetpos(pf, &pos)) { fsetpos(pfdup, &pos); } return pfdup; } DllExport void* win32_dynaload(const char* filename) { dTHX; char buf[MAX_PATH+1]; char *first; /* LoadLibrary() doesn't recognize forward slashes correctly, * 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; } } return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH); } XS(w32_SetChildShowWindow) { dXSARGS; BOOL use_showwindow = w32_use_showwindow; /* use "unsigned short" because Perl has redefined "WORD" */ unsigned short showwindow = w32_showwindow; if (items > 1) Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)"); if (items == 0 || !SvOK(ST(0))) w32_use_showwindow = FALSE; else { w32_use_showwindow = TRUE; w32_showwindow = (unsigned short)SvIV(ST(0)); } EXTEND(SP, 1); if (use_showwindow) ST(0) = sv_2mortal(newSViv(showwindow)); else ST(0) = &PL_sv_undef; XSRETURN(1); } void Perl_init_os_extras(void) { dTHX; char *file = __FILE__; /* Initialize Win32CORE if it has been statically linked. */ void (*pfn_init)(pTHX); #if defined(__BORLANDC__) /* makedef.pl seems to have given up on fixing this issue in the .def file */ pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "_init_Win32CORE"); #else pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "init_Win32CORE"); #endif if (pfn_init) pfn_init(aTHX); newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file); } void * win32_signal_context(void) { dTHX; #ifdef MULTIPLICITY if (!my_perl) { my_perl = PL_curinterp; PERL_SET_THX(my_perl); } return my_perl; #else return PL_curinterp; #endif } BOOL WINAPI win32_ctrlhandler(DWORD dwCtrlType) { #ifdef MULTIPLICITY dTHXa(PERL_GET_SIG_CONTEXT); if (!my_perl) return FALSE; #endif switch(dwCtrlType) { case CTRL_CLOSE_EVENT: /* A signal that the system sends to all processes attached to a console when the user closes the console (either by choosing the Close command from the 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; case CTRL_C_EVENT: /* 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; 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; 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; default: break; } return FALSE; } #ifdef SET_INVALID_PARAMETER_HANDLER # include #endif static void ansify_path(void) { size_t len; char *ansi_path; WCHAR *wide_path; WCHAR *wide_dir; /* win32_ansipath() requires Windows 2000 or later */ if (!IsWin2000()) return; /* fetch Unicode version of PATH */ len = 2000; wide_path = win32_malloc(len*sizeof(WCHAR)); while (wide_path) { size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len); if (newlen < len) break; len = newlen; wide_path = win32_realloc(wide_path, len*sizeof(WCHAR)); } if (!wide_path) return; /* convert to ANSI pathnames */ wide_dir = wide_path; ansi_path = NULL; while (wide_dir) { WCHAR *sep = wcschr(wide_dir, ';'); char *ansi_dir; size_t ansi_len; size_t wide_len; if (sep) *sep++ = '\0'; /* remove quotes around pathname */ if (*wide_dir == '"') ++wide_dir; wide_len = wcslen(wide_dir); if (wide_len && wide_dir[wide_len-1] == '"') wide_dir[wide_len-1] = '\0'; /* append ansi_dir to ansi_path */ ansi_dir = win32_ansipath(wide_dir); ansi_len = strlen(ansi_dir); if (ansi_path) { size_t newlen = len + 1 + ansi_len; ansi_path = win32_realloc(ansi_path, newlen+1); if (!ansi_path) break; ansi_path[len] = ';'; memcpy(ansi_path+len+1, ansi_dir, ansi_len+1); len = newlen; } else { len = ansi_len; ansi_path = win32_malloc(5+len+1); if (!ansi_path) break; memcpy(ansi_path, "PATH=", 5); memcpy(ansi_path+5, ansi_dir, len+1); len += 5; } win32_free(ansi_dir); wide_dir = sep; } if (ansi_path) { /* Update C RTL environ array. This will only have full effect if * perl_parse() is later called with `environ` as the `env` argument. * Otherwise S_init_postdump_symbols() will overwrite PATH again. * * We do have to ansify() the PATH before Perl has been fully * initialized because S_find_script() uses the PATH when perl * is being invoked with the -S option. This happens before %ENV * is initialized in S_init_postdump_symbols(). * * XXX Is this a bug? Should S_find_script() use the environment * XXX passed in the `env` arg to parse_perl()? */ putenv(ansi_path); /* Keep system environment in sync because S_init_postdump_symbols() * will not call mg_set() if it initializes %ENV from `environ`. */ SetEnvironmentVariableA("PATH", ansi_path+5); /* We are intentionally leaking the ansi_path string here because * the Borland runtime library puts it directly into the environ * array. The Microsoft runtime library seems to make a copy, * but will leak the copy should it be replaced again later. * Since this code is only called once during PERL_SYS_INIT this * shouldn't really matter. */ } win32_free(wide_path); } void Perl_win32_init(int *argcp, char ***argvp) { HMODULE module; #ifdef SET_INVALID_PARAMETER_HANDLER _invalid_parameter_handler oldHandler, newHandler; newHandler = my_invalid_parameter_handler; oldHandler = _set_invalid_parameter_handler(newHandler); _CrtSetReportMode(_CRT_ASSERT, 0); #endif /* Disable floating point errors, Perl will trap the ones we * care about. VC++ RTL defaults to switching these off * already, but the Borland RTL doesn't. Since we don't * want to be at the vendor's whim on the default, we set * it explicitly here. */ #if !defined(_ALPHA_) && !defined(__GNUC__) _control87(MCW_EM, MCW_EM); #endif MALLOC_INIT; /* When the manifest resource requests Common-Controls v6 then * user32.dll no longer registers all the Windows classes used for * standard controls but leaves some of them to be registered by * comctl32.dll. InitCommonControls() doesn't do anything but calling * it makes sure comctl32.dll gets loaded into the process and registers * the standard control classes. Without this even normal Windows APIs * like MessageBox() can fail under some versions of Windows XP. */ InitCommonControls(); module = GetModuleHandle("ntdll.dll"); if (module) { *(FARPROC*)&pfnZwQuerySystemInformation = GetProcAddress(module, "ZwQuerySystemInformation"); } module = GetModuleHandle("kernel32.dll"); if (module) { *(FARPROC*)&pfnCreateToolhelp32Snapshot = GetProcAddress(module, "CreateToolhelp32Snapshot"); *(FARPROC*)&pfnProcess32First = GetProcAddress(module, "Process32First"); *(FARPROC*)&pfnProcess32Next = GetProcAddress(module, "Process32Next"); } g_osver.dwOSVersionInfoSize = sizeof(g_osver); GetVersionEx(&g_osver); ansify_path(); } void Perl_win32_term(void) { dTHX; HINTS_REFCNT_TERM; OP_REFCNT_TERM; PERLIO_TERM; MALLOC_TERM; } void win32_get_child_IO(child_IO_table* ptbl) { ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE); ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE); ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE); } Sighandler_t win32_signal(int sig, Sighandler_t subcode) { dTHX; if (sig < SIG_SIZE) { int save_errno = errno; Sighandler_t result = signal(sig, subcode); if (result == SIG_ERR) { result = w32_sighandler[sig]; errno = save_errno; } w32_sighandler[sig] = subcode; return result; } else { errno = EINVAL; return SIG_ERR; } } /* The PerlMessageWindowClass's WindowProc */ LRESULT CALLBACK win32_message_window_proc(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam) { return win32_process_message(hwnd, msg, wParam, lParam) ? 0 : DefWindowProc(hwnd, msg, wParam, lParam); } /* we use a message filter hook to process thread messages, passing any * messages that we don't process on to the rest of the hook chain * Anyone else writing a message loop that wants to play nicely with perl * should do * CallMsgFilter(&msg, MSGF_***); * between their GetMessage and DispatchMessage calls. */ LRESULT CALLBACK win32_message_filter_proc(int code, WPARAM wParam, LPARAM lParam) { LPMSG pmsg = (LPMSG)lParam; /* we'll process it if code says we're allowed, and it's a thread message */ if (code >= 0 && pmsg->hwnd == NULL && win32_process_message(pmsg->hwnd, pmsg->message, pmsg->wParam, pmsg->lParam)) { return TRUE; } /* XXX: MSDN says that hhk is ignored, but we should really use the * return value from SetWindowsHookEx() in win32_create_message_window(). */ return CallNextHookEx(NULL, code, wParam, lParam); } /* The real message handler. Can be called with * hwnd == NULL to process our thread messages. Returns TRUE for any messages * that it processes */ static LRESULT win32_process_message(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam) { /* BEWARE. The context retrieved using dTHX; is the context of the * 'parent' thread during the CreateWindow() phase - i.e. for all messages * up to and including WM_CREATE. If it ever happens that you need the * 'child' context before this, then it needs to be passed into * win32_create_message_window(), and passed to the WM_NCCREATE handler * from the lparam of CreateWindow(). It could then be stored/retrieved * using [GS]etWindowLongPtr(... GWLP_USERDATA ...), possibly eliminating * the dTHX calls here. */ /* XXX For now it is assumed that the overhead of the dTHX; for what * are relativley infrequent code-paths, is better than the added * complexity of getting the correct context passed into * win32_create_message_window() */ switch(msg) { #ifdef USE_ITHREADS case WM_USER_MESSAGE: { long child = find_pseudo_pid((int)wParam); if (child >= 0) { dTHX; w32_pseudo_child_message_hwnds[child] = (HWND)lParam; return 1; } break; } #endif case WM_USER_KILL: { dTHX; /* We use WM_USER_KILL to fake kill() with other signals */ int sig = (int)wParam; if (do_raise(aTHX_ sig)) sig_terminate(aTHX_ sig); return 1; } case WM_TIMER: { dTHX; /* alarm() is a one-shot but SetTimer() repeats so kill it */ if (w32_timerid && w32_timerid==(UINT)wParam) { KillTimer(w32_message_hwnd, w32_timerid); w32_timerid=0; /* Now fake a call to signal handler */ if (do_raise(aTHX_ 14)) sig_terminate(aTHX_ 14); return 1; } break; } default: break; } /* switch */ /* Above or other stuff may have set a signal flag, and we may not have * been called from win32_async_check() (e.g. some other GUI's message * loop. BUT DON'T dispatch signals here: If someone has set a SIGALRM * handler that die's, and the message loop that calls here is wrapped * in an eval, then you may well end up with orphaned windows - signals * are dispatched by win32_async_check() */ return 0; } void win32_create_message_window_class(void) { /* create the window class for "message only" windows */ WNDCLASS wc; Zero(&wc, 1, wc); wc.lpfnWndProc = win32_message_window_proc; wc.hInstance = (HINSTANCE)GetModuleHandle(NULL); wc.lpszClassName = "PerlMessageWindowClass"; /* second and subsequent calls will fail, but class * will already be registered */ RegisterClass(&wc); } HWND win32_create_message_window(void) { HWND hwnd = NULL; /* "message-only" windows have been implemented in Windows 2000 and later. * On earlier versions we'll continue to post messages to a specific * thread and use hwnd==NULL. This is brittle when either an embedding * application or an XS module is also posting messages to hwnd=NULL * because once removed from the queue they cannot be delivered to the * "right" place with DispatchMessage() anymore, as there is no WindowProc * if there is no window handle. */ /* Using HWND_MESSAGE appears to work under Win98, despite MSDN * documentation to the contrary, however, there is some evidence that * there may be problems with the implementation on Win98. As it is not * officially supported we take the cautious route and stick with thread * messages (hwnd == NULL) on platforms prior to Win2k. */ if (IsWin2000()) { win32_create_message_window_class(); hwnd = CreateWindow("PerlMessageWindowClass", "PerlMessageWindow", 0, 0, 0, 0, 0, HWND_MESSAGE, NULL, NULL, NULL); } /* If we din't create a window for any reason, then we'll use thread * messages for our signalling, so we install a hook which * is called by CallMsgFilter in win32_async_check(), or any other * modal loop (e.g. Win32::MsgBox or any other GUI extention, or anything * that use OLE, etc. */ if(!hwnd) { SetWindowsHookEx(WH_MSGFILTER, win32_message_filter_proc, NULL, GetCurrentThreadId()); } return hwnd; } #ifdef HAVE_INTERP_INTERN static void win32_csighandler(int sig) { #if 0 dTHXa(PERL_GET_SIG_CONTEXT); Perl_warn(aTHX_ "Got signal %d",sig); #endif /* Does nothing */ } #if defined(__MINGW32__) && defined(__cplusplus) #define CAST_HWND__(x) (HWND__*)(x) #else #define CAST_HWND__(x) x #endif void Perl_sys_intern_init(pTHX) { int i; w32_perlshell_tokens = NULL; w32_perlshell_vec = (char**)NULL; w32_perlshell_items = 0; w32_fdpid = newAV(); Newx(w32_children, 1, child_tab); w32_num_children = 0; # ifdef USE_ITHREADS w32_pseudo_id = 0; Newx(w32_pseudo_children, 1, pseudo_child_tab); w32_num_pseudo_children = 0; # endif w32_timerid = 0; w32_message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE); w32_poll_count = 0; for (i=0; i < SIG_SIZE; i++) { 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); /* We spawn asynchronous processes with the CREATE_NEW_PROCESS_GROUP * flag. This has the side-effect of disabling Ctrl-C events in all * processes in this group. At least on Windows NT and later we * can re-enable Ctrl-C handling by calling SetConsoleCtrlHandler() * with a NULL handler. This is not valid on Windows 9X. */ if (IsWinNT()) SetConsoleCtrlHandler(NULL,FALSE); /* Push our handler on top */ SetConsoleCtrlHandler(win32_ctrlhandler,TRUE); } } void Perl_sys_intern_clear(pTHX) { Safefree(w32_perlshell_tokens); Safefree(w32_perlshell_vec); /* NOTE: w32_fdpid is freed by sv_clean_all() */ Safefree(w32_children); if (w32_timerid) { KillTimer(w32_message_hwnd, w32_timerid); w32_timerid = 0; } if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE) DestroyWindow(w32_message_hwnd); # ifdef MULTIPLICITY if (my_perl == PL_curinterp) { # else { # endif SetConsoleCtrlHandler(win32_ctrlhandler,FALSE); } # ifdef USE_ITHREADS Safefree(w32_pseudo_children); # endif } # ifdef USE_ITHREADS void Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst) { PERL_ARGS_ASSERT_SYS_INTERN_DUP; dst->perlshell_tokens = NULL; dst->perlshell_vec = (char**)NULL; dst->perlshell_items = 0; dst->fdpid = newAV(); Newxz(dst->children, 1, child_tab); dst->pseudo_id = 0; Newxz(dst->pseudo_children, 1, pseudo_child_tab); dst->timerid = 0; dst->message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE); dst->poll_count = 0; Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t); } # endif /* USE_ITHREADS */ #endif /* HAVE_INTERP_INTERN */ perl-5.12.0-RC0/win32/wince.c0000444000175000017500000016320711325125742014353 0ustar jessejesse/* WINCE.C - stuff for Windows CE * * Time-stamp: <26/10/01 15:25:20 keuchel@keuchelnt> * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. */ #define WIN32_LEAN_AND_MEAN #define WIN32IO_IS_STDIO #include #include #define PERLIO_NOT_STDIO 0 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO) #define PerlIO FILE #endif #define wince_private #include "errno.h" #include "EXTERN.h" #include "perl.h" #define NO_XSLOCKS #define PERL_NO_GET_CONTEXT #include "XSUB.h" #include "win32iop.h" #include #include #include #include #include #define perl #include "celib_defs.h" #include "cewin32.h" #include "cecrt.h" #include "cewin32_defs.h" #include "cecrt_defs.h" #define GetCurrentDirectoryW XCEGetCurrentDirectoryW #ifdef PALM_SIZE #include "stdio-palmsize.h" #endif #define EXECF_EXEC 1 #define EXECF_SPAWN 2 #define EXECF_SPAWN_NOWAIT 3 #if defined(PERL_IMPLICIT_SYS) # undef win32_get_privlib # define win32_get_privlib g_win32_get_privlib # undef win32_get_sitelib # define win32_get_sitelib g_win32_get_sitelib # undef win32_get_vendorlib # define win32_get_vendorlib g_win32_get_vendorlib # undef do_spawn # define do_spawn g_do_spawn # undef getlogin # define getlogin g_getlogin #endif static void get_shell(void); static long tokenize(const char *str, char **dest, char ***destv); static int do_spawn2(pTHX_ char *cmd, int exectype); static BOOL has_shell_metachars(char *ptr); static long filetime_to_clock(PFILETIME ft); static BOOL filetime_from_time(PFILETIME ft, time_t t); static char * get_emd_part(SV **leading, STRLEN *const len, char *trailing, ...); static void remove_dead_process(long deceased); static long find_pid(int pid); static char * qualified_path(const char *cmd); static char * win32_get_xlib(const char *pl, const char *xlib, const char *libname, STRLEN *const len); #ifdef USE_ITHREADS static void remove_dead_pseudo_process(long child); static long find_pseudo_pid(int pid); #endif int _fmode = O_TEXT; /* celib do not provide _fmode, so we define it here */ START_EXTERN_C HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE; char w32_module_name[MAX_PATH+1]; END_EXTERN_C static DWORD w32_platform = (DWORD)-1; int IsWin95(void) { return (win32_os_id() == VER_PLATFORM_WIN32_WINDOWS); } int IsWinNT(void) { return (win32_os_id() == VER_PLATFORM_WIN32_NT); } int IsWinCE(void) { return (win32_os_id() == VER_PLATFORM_WIN32_CE); } EXTERN_C void set_w32_module_name(void) { char* ptr; XCEGetModuleFileNameA((HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE) ? XCEGetModuleHandleA(NULL) : w32_perldll_handle), w32_module_name, sizeof(w32_module_name)); /* normalize to forward slashes */ ptr = w32_module_name; while (*ptr) { if (*ptr == '\\') *ptr = '/'; ++ptr; } } /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */ static char* get_regstr_from(HKEY hkey, const char *valuename, SV **svp) { /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */ HKEY handle; DWORD type; const char *subkey = "Software\\Perl"; char *str = NULL; long retval; retval = XCERegOpenKeyExA(hkey, subkey, 0, KEY_READ, &handle); if (retval == ERROR_SUCCESS) { DWORD datalen; retval = XCERegQueryValueExA(handle, valuename, 0, &type, NULL, &datalen); if (retval == ERROR_SUCCESS && type == REG_SZ) { dTHX; if (!*svp) *svp = sv_2mortal(newSVpvn("",0)); SvGROW(*svp, datalen); retval = XCERegQueryValueExA(handle, valuename, 0, NULL, (PBYTE)SvPVX(*svp), &datalen); if (retval == ERROR_SUCCESS) { str = SvPVX(*svp); SvCUR_set(*svp,datalen-1); } } RegCloseKey(handle); } return str; } /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */ static char* get_regstr(const char *valuename, SV **svp) { char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp); if (!str) str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp); return str; } /* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */ static char * get_emd_part(SV **prev_pathp, STRLEN *const len, char *trailing_path, ...) { char base[10]; va_list ap; char mod_name[MAX_PATH+1]; char *ptr; char *optr; char *strip; int oldsize, newsize; STRLEN baselen; va_start(ap, trailing_path); strip = va_arg(ap, char *); sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION); baselen = strlen(base); if (!*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' && strncmp(strip, base, baselen) == 0 && strncmp(ptr+1, base, baselen) == 0)) { *optr = '/'; ptr = optr; } } strip = va_arg(ap, char *); } if (!ptr) { ptr = mod_name; *ptr++ = '.'; *ptr = '/'; } va_end(ap); strcpy(++ptr, trailing_path); /* only add directory if it exists */ if (XCEGetFileAttributesA(mod_name) != (DWORD) -1) { /* directory exists */ dTHX; if (!*prev_pathp) *prev_pathp = sv_2mortal(newSVpvn("",0)); sv_catpvn(*prev_pathp, ";", 1); sv_catpv(*prev_pathp, mod_name); if(len) *len = SvCUR(*prev_pathp); return SvPVX(*prev_pathp); } return NULL; } char * win32_get_privlib(const char *pl, STRLEN *const len) { dTHX; char *stdlib = "lib"; char buffer[MAX_PATH+1]; SV *sv = NULL; /* $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); /* $stdlib .= ";$EMD/../../lib" */ return get_emd_part(&sv, len, stdlib, ARCHNAME, "bin", NULL); } static char * win32_get_xlib(const char *pl, const char *xlib, const char *libname, STRLEN *const len) { dTHX; char regstr[40]; char pathstr[MAX_PATH+1]; DWORD datalen; int len, newsize; SV *sv1 = NULL; SV *sv2 = NULL; /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */ sprintf(regstr, "%s-%s", xlib, pl); (void)get_regstr(regstr, &sv1); /* $xlib .= * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */ sprintf(pathstr, "%s/%s/lib", libname, pl); (void)get_emd_part(&sv1, NULL, pathstr, ARCHNAME, "bin", pl, NULL); /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */ (void)get_regstr(xlib, &sv2); /* $xlib .= * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */ sprintf(pathstr, "%s/lib", libname); (void)get_emd_part(&sv2, NULL, pathstr, ARCHNAME, "bin", pl, NULL); if (!sv1 && !sv2) return NULL; if (!sv1) { sv1 = sv2; } else if (sv2) { sv_catpvn(sv1, ";", 1); sv_catsv(sv1, sv2); } if (len) *len = SvCUR(sv1); return SvPVX(sv1); } char * win32_get_sitelib(const char *pl, STRLEN *const len) { return win32_get_xlib(pl, "sitelib", "site", len); } #ifndef PERL_VENDORLIB_NAME # define PERL_VENDORLIB_NAME "vendor" #endif char * win32_get_vendorlib(const char *pl, STRLEN *const len) { return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME, len); } static BOOL has_shell_metachars(char *ptr) { int inquote = 0; char quote = '\0'; /* * Scan string looking for redirection (< or >) or pipe * characters (|) that are not in a quoted string. * 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; } return FALSE; } #if !defined(PERL_IMPLICIT_SYS) /* since the current process environment is being updated in util.c * the library functions will get the correct environment */ PerlIO * Perl_my_popen(pTHX_ const char *cmd, const char *mode) { printf("popen(%s)\n", cmd); Perl_croak(aTHX_ PL_no_func, "popen"); return NULL; } long Perl_my_pclose(pTHX_ PerlIO *fp) { Perl_croak(aTHX_ PL_no_func, "pclose"); return -1; } #endif DllExport unsigned long win32_os_id(void) { static OSVERSIONINFOA osver; if (osver.dwPlatformId != w32_platform) { memset(&osver, 0, sizeof(OSVERSIONINFOA)); osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA); XCEGetVersionExA(&osver); w32_platform = osver.dwPlatformId; } return (unsigned long)w32_platform; } DllExport int win32_getpid(void) { int pid; #ifdef USE_ITHREADS dTHX; if (w32_pseudo_id) return -((int)w32_pseudo_id); #endif pid = xcegetpid(); return pid; } /* Tokenize a string. Words are null-separated, and the list * ends with a doubled null. Any character (except null and * including backslash) may be escaped by preceding it with a * backslash (the backslash will be stripped). * Returns number of words in result buffer. */ static long tokenize(const char *str, char **dest, char ***destv) { char *retstart = NULL; char **retvstart = 0; int items = -1; if (str) { dTHX; int slen = strlen(str); register char *ret; register 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; return items; } DllExport int win32_pipe(int *pfd, unsigned int size, int mode) { dTHX; Perl_croak(aTHX_ PL_no_func, "pipe"); return -1; } DllExport int win32_times(struct tms *timebuf) { dTHX; Perl_croak(aTHX_ PL_no_func, "times"); return -1; } Sighandler_t win32_signal(int sig, Sighandler_t subcode) { return xcesignal(sig, subcode); } static void 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 = (IsWinNT() ? "cmd.exe /x/d/c" : "command.com /c"); const char *usershell = PerlEnv_getenv("PERL5SHELL"); w32_perlshell_items = tokenize(usershell ? usershell : defaultshell, &w32_perlshell_tokens, &w32_perlshell_vec); } } int Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp) { PERL_ARGS_ASSERT_DO_ASPAWN; Perl_croak(aTHX_ PL_no_func, "aspawn"); return -1; } /* returns pointer to the next unquoted space or the end of the string */ static char* 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++; } return (char*)s; } #if 1 static int do_spawn2(pTHX_ char *cmd, int exectype) { char **a; char *s; char **argv; int status = -1; BOOL needToTry = TRUE; char *cmd2; /* 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 = win32_spawnvp(P_NOWAIT, argv[0], (const char* const*)argv); 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++] = 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 = win32_spawnvp(P_NOWAIT, argv[0], (const char* const*)argv); break; case EXECF_EXEC: status = win32_execvp(argv[0], (const char* const*)argv); break; } cmd = argv[0]; Safefree(argv); } if (exectype == EXECF_SPAWN_NOWAIT) { if (IsWin95()) 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; } return (status); } int Perl_do_spawn(pTHX_ char *cmd) { PERL_ARGS_ASSERT_DO_SPAWN; return do_spawn2(aTHX_ cmd, EXECF_SPAWN); } int Perl_do_spawn_nowait(pTHX_ char *cmd) { PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT; return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT); } bool Perl_do_exec(pTHX_ const char *cmd) { PERL_ARGS_ASSERT_DO_EXEC; do_spawn2(aTHX_ cmd, EXECF_EXEC); return FALSE; } /* The idea here is to read all the directory names into a string table * (separated by nulls) and when one of the other dir functions is called * return the pointer to the current file name. */ DllExport DIR * win32_opendir(const char *filename) { dTHX; DIR *dirp; long len; long idx; char scanname[MAX_PATH+3]; Stat_t sbuf; WIN32_FIND_DATAA aFindData; WIN32_FIND_DATAW wFindData; HANDLE fh; char buffer[MAX_PATH*2]; WCHAR wbuffer[MAX_PATH+1]; char* ptr; len = strlen(filename); if (len > MAX_PATH) return NULL; /* check to see if filename is a directory */ if (win32_stat(filename, &sbuf) < 0 || !S_ISDIR(sbuf.st_mode)) return NULL; /* Get us a DIR structure */ Newxz(dirp, 1, DIR); /* Create the search pattern */ strcpy(scanname, filename); /* bare drive name means look in cwd for drive */ if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') { scanname[len++] = '.'; scanname[len++] = '/'; } else if (scanname[len-1] != '/' && scanname[len-1] != '\\') { scanname[len++] = '/'; } scanname[len++] = '*'; scanname[len] = '\0'; /* do the FindFirstFile call */ fh = FindFirstFile(PerlDir_mapA(scanname), &aFindData); dirp->handle = fh; if (fh == 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; } /* now allocate the first part of the string table for * the filenames that we find. */ ptr = aFindData.cFileName; idx = strlen(ptr)+1; if (idx < 256) dirp->size = 128; else dirp->size = idx; Newx(dirp->start, dirp->size, char); strcpy(dirp->start, ptr); dirp->nfiles++; dirp->end = dirp->curr = dirp->start; dirp->end += idx; return dirp; } /* Readdir just returns the current string pointer and bumps the * string pointer to the nDllExport entry. */ DllExport struct direct * 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; /* 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) { dTHX; char* ptr; BOOL res; WIN32_FIND_DATAW wFindData; WIN32_FIND_DATAA aFindData; char buffer[MAX_PATH*2]; /* finding the next file that matches the wildcard * (which should be all of them in this directory!). */ res = FindNextFile(dirp->handle, &aFindData); if (res) ptr = aFindData.cFileName; if (res) { long endpos = dirp->end - dirp->start; long newsize = endpos + strlen(ptr) + 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; dirp->size *= 2; Renew(dirp->start, dirp->size, char); dirp->curr = dirp->start + curpos; } strcpy(dirp->start + endpos, ptr); dirp->end = dirp->start + newsize; dirp->nfiles++; } else dirp->curr = NULL; } return &(dirp->dirstr); } else return NULL; } /* Telldir returns the current string pointer position */ DllExport long win32_telldir(DIR *dirp) { return (dirp->curr - dirp->start); } /* Seekdir moves the string pointer to a previously saved position * (returned by telldir). */ DllExport void win32_seekdir(DIR *dirp, long loc) { dirp->curr = dirp->start + loc; } /* Rewinddir resets the string pointer to the start */ DllExport void win32_rewinddir(DIR *dirp) { dirp->curr = dirp->start; } /* free the memory allocated by opendir */ DllExport int win32_closedir(DIR *dirp) { dTHX; if (dirp->handle != INVALID_HANDLE_VALUE) FindClose(dirp->handle); Safefree(dirp->start); Safefree(dirp); return 1; } #else /////!!!!!!!!!!! return here and do right stuff!!!! DllExport DIR * win32_opendir(const char *filename) { return opendir(filename); } DllExport struct direct * win32_readdir(DIR *dirp) { return readdir(dirp); } DllExport long win32_telldir(DIR *dirp) { dTHX; Perl_croak(aTHX_ PL_no_func, "telldir"); return -1; } DllExport void win32_seekdir(DIR *dirp, long loc) { dTHX; Perl_croak(aTHX_ PL_no_func, "seekdir"); } DllExport void win32_rewinddir(DIR *dirp) { dTHX; Perl_croak(aTHX_ PL_no_func, "rewinddir"); } DllExport int win32_closedir(DIR *dirp) { closedir(dirp); return 0; } #endif // 1 DllExport int win32_kill(int pid, int sig) { dTHX; Perl_croak(aTHX_ PL_no_func, "kill"); return -1; } DllExport int win32_stat(const char *path, struct stat *sbuf) { return xcestat(path, sbuf); } DllExport char * win32_longpath(char *path) { return path; } DllExport char * win32_getenv(const char *name) { return xcegetenv(name); } DllExport int win32_putenv(const char *name) { return xceputenv(name); } static long filetime_to_clock(PFILETIME ft) { __int64 qw = ft->dwHighDateTime; qw <<= 32; qw |= ft->dwLowDateTime; qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */ return (long) qw; } /* fix utime() so it works on directories in NT */ static BOOL filetime_from_time(PFILETIME pFileTime, time_t Time) { struct tm *pTM = localtime(&Time); SYSTEMTIME SystemTime; FILETIME LocalTime; if (pTM == NULL) return FALSE; SystemTime.wYear = pTM->tm_year + 1900; SystemTime.wMonth = pTM->tm_mon + 1; SystemTime.wDay = pTM->tm_mday; SystemTime.wHour = pTM->tm_hour; SystemTime.wMinute = pTM->tm_min; SystemTime.wSecond = pTM->tm_sec; SystemTime.wMilliseconds = 0; return SystemTimeToFileTime(&SystemTime, &LocalTime) && LocalFileTimeToFileTime(&LocalTime, pFileTime); } DllExport int win32_unlink(const char *filename) { return xceunlink(filename); } DllExport int win32_utime(const char *filename, struct utimbuf *times) { return xceutime(filename, (struct _utimbuf *) times); } DllExport int win32_gettimeofday(struct timeval *tp, void *not_used) { return xcegettimeofday(tp,not_used); } DllExport int win32_uname(struct utsname *name) { struct hostent *hep; STRLEN nodemax = sizeof(name->nodename)-1; OSVERSIONINFOA osver; memset(&osver, 0, sizeof(OSVERSIONINFOA)); osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA); if (XCEGetVersionExA(&osver)) { /* sysname */ switch (osver.dwPlatformId) { case VER_PLATFORM_WIN32_CE: strcpy(name->sysname, "Windows CE"); break; case VER_PLATFORM_WIN32_WINDOWS: strcpy(name->sysname, "Windows"); break; case VER_PLATFORM_WIN32_NT: strcpy(name->sysname, "Windows NT"); break; case VER_PLATFORM_WIN32s: strcpy(name->sysname, "Win32s"); break; default: strcpy(name->sysname, "Win32 Unknown"); break; } /* release */ sprintf(name->release, "%d.%d", osver.dwMajorVersion, osver.dwMinorVersion); /* version */ sprintf(name->version, "Build %d", osver.dwPlatformId == VER_PLATFORM_WIN32_NT ? osver.dwBuildNumber : (osver.dwBuildNumber & 0xffff)); if (osver.szCSDVersion[0]) { char *buf = name->version + strlen(name->version); sprintf(buf, " (%s)", osver.szCSDVersion); } } else { *name->sysname = '\0'; *name->version = '\0'; *name->release = '\0'; } /* 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'; } } else { DWORD sz = nodemax; if (!XCEGetComputerNameA(name->nodename, &sz)) *name->nodename = '\0'; } /* machine (architecture) */ { SYSTEM_INFO info; char *arch; GetSystemInfo(&info); switch (info.wProcessorArchitecture) { case PROCESSOR_ARCHITECTURE_INTEL: arch = "x86"; break; case PROCESSOR_ARCHITECTURE_MIPS: arch = "mips"; break; case PROCESSOR_ARCHITECTURE_ALPHA: arch = "alpha"; break; case PROCESSOR_ARCHITECTURE_PPC: arch = "ppc"; break; case PROCESSOR_ARCHITECTURE_ARM: arch = "arm"; break; case PROCESSOR_HITACHI_SH3: arch = "sh3"; break; case PROCESSOR_SHx_SH3: arch = "sh3"; break; default: arch = "unknown"; break; } strcpy(name->machine, arch); } return 0; } /* Timing related stuff */ 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) { #ifdef SIGCLD case SIGCLD: #endif #ifdef SIGCHLD case SIGCHLD: #endif case 0: return 0; case SIGTERM: default: break; } } } /* Tell caller to exit thread/process as approriate */ return 1; } void sig_terminate(pTHX_ int sig) { Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig); /* exit() seems to be safe, my_exit() or die() is a problem in ^C thread */ exit(sig); } DllExport int win32_async_check(pTHX) { MSG msg; int ours = 1; /* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages * and ignores window messages - should co-exist better with windows apps e.g. Tk */ while (PeekMessage(&msg, (HWND)-1, 0, 0, PM_REMOVE|PM_NOYIELD)) { int sig; switch(msg.message) { #if 0 /* Perhaps some other messages could map to signals ? ... */ case WM_CLOSE: case WM_QUIT: /* Treat WM_QUIT like SIGHUP? */ sig = SIGHUP; goto Raise; break; #endif /* We use WM_USER to fake kill() with other signals */ case WM_USER: { sig = msg.wParam; Raise: if (do_raise(aTHX_ sig)) { sig_terminate(aTHX_ sig); } break; } case WM_TIMER: { /* alarm() is a one-shot but SetTimer() repeats so kill it */ if (w32_timerid) { KillTimer(NULL,w32_timerid); w32_timerid=0; } /* Now fake a call to signal handler */ if (do_raise(aTHX_ 14)) { sig_terminate(aTHX_ 14); } break; } /* Otherwise do normal Win32 thing - in case it is useful */ default: TranslateMessage(&msg); DispatchMessage(&msg); ours = 0; break; } } w32_poll_count = 0; /* Above or other stuff may have set a signal flag */ if (PL_sig_pending) { despatch_signals(); } return ours; } /* This function will not return until the timeout has elapsed, or until * one of the handles is ready. */ DllExport DWORD win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp) { /* We may need several goes at this - so compute when we stop */ DWORD ticks = 0; if (timeout != INFINITE) { ticks = GetTickCount(); timeout += ticks; } while (1) { DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_ALLEVENTS); 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) { ticks = GetTickCount(); } if (result == WAIT_OBJECT_0 + count) { /* Message has arrived - check it */ (void)win32_async_check(aTHX); } else { /* Not timeout or message - one of handles is ready */ break; } } /* compute time left to wait */ ticks = timeout - ticks; /* If we are past the end say zero */ return (ticks > 0) ? ticks : 0; } static UINT timerid = 0; static VOID CALLBACK TimerProc(HWND win, UINT msg, UINT id, DWORD time) { dTHX; KillTimer(NULL,timerid); timerid=0; sighandler(14); } DllExport unsigned int win32_sleep(unsigned int t) { return xcesleep(t); } DllExport unsigned int win32_alarm(unsigned int sec) { /* * the 'obvious' implentation is SetTimer() with a callback * which does whatever receiving SIGALRM would do * we cannot use SIGALRM even via raise() as it is not * one of the supported codes in * * Snag is unless something is looking at the message queue * nothing happens :-( */ dTHX; if (sec) { timerid = SetTimer(NULL,timerid,sec*1000,(TIMERPROC)TimerProc); if (!timerid) Perl_croak_nocontext("Cannot set timer"); } else { if (timerid) { KillTimer(NULL,timerid); timerid=0; } } return 0; } #ifdef HAVE_DES_FCRYPT extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf); #endif DllExport char * win32_crypt(const char *txt, const char *salt) { dTHX; #ifdef HAVE_DES_FCRYPT dTHR; return des_fcrypt(txt, salt, w32_crypt_buffer); #else Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia."); return NULL; #endif } /* * redirected io subsystem for all XS modules * */ DllExport int * win32_errno(void) { return (&errno); } DllExport char *** win32_environ(void) { return (&(environ)); } /* the rest are the remapped stdio routines */ DllExport FILE * win32_stderr(void) { return (stderr); } char *g_getlogin() { return "no-getlogin"; } DllExport FILE * win32_stdin(void) { return (stdin); } DllExport FILE * win32_stdout() { return (stdout); } DllExport int win32_ferror(FILE *fp) { return (ferror(fp)); } DllExport int win32_feof(FILE *fp) { return (feof(fp)); } /* * Since the errors returned by the socket error function * WSAGetLastError() are not known by the library routine strerror * we have to roll our own. */ DllExport char * win32_strerror(int e) { return xcestrerror(e); } DllExport void win32_str_os_error(void *sv, DWORD dwErr) { dTHX; sv_setpvn((SV*)sv, "Error", 5); } DllExport int win32_fprintf(FILE *fp, const char *format, ...) { va_list marker; va_start(marker, format); /* Initialize variable arguments. */ return (vfprintf(fp, format, marker)); } DllExport int win32_printf(const char *format, ...) { va_list marker; va_start(marker, format); /* Initialize variable arguments. */ return (vprintf(format, marker)); } DllExport int win32_vfprintf(FILE *fp, const char *format, va_list args) { return (vfprintf(fp, format, args)); } DllExport int win32_vprintf(const char *format, va_list args) { return (vprintf(format, args)); } DllExport size_t win32_fread(void *buf, size_t size, size_t count, FILE *fp) { return fread(buf, size, count, fp); } DllExport size_t win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp) { return fwrite(buf, size, count, fp); } DllExport FILE * win32_fopen(const char *filename, const char *mode) { return xcefopen(filename, mode); } DllExport FILE * win32_fdopen(int handle, const char *mode) { return palm_fdopen(handle, mode); } DllExport FILE * win32_freopen(const char *path, const char *mode, FILE *stream) { return xcefreopen(path, mode, stream); } DllExport int win32_fclose(FILE *pf) { return xcefclose(pf); } DllExport int win32_fputs(const char *s,FILE *pf) { return fputs(s, pf); } DllExport int win32_fputc(int c,FILE *pf) { return fputc(c,pf); } DllExport int win32_ungetc(int c,FILE *pf) { return ungetc(c,pf); } DllExport int win32_getc(FILE *pf) { return getc(pf); } DllExport int win32_fileno(FILE *pf) { return palm_fileno(pf); } DllExport void win32_clearerr(FILE *pf) { clearerr(pf); return; } DllExport int win32_fflush(FILE *pf) { return fflush(pf); } DllExport long win32_ftell(FILE *pf) { return ftell(pf); } DllExport int win32_fseek(FILE *pf, Off_t offset,int origin) { return fseek(pf, offset, origin); } /* fpos_t seems to be int64 on hpc pro! Really stupid. */ /* But maybe someday there will be such large disks in a hpc... */ DllExport int win32_fgetpos(FILE *pf, fpos_t *p) { return fgetpos(pf, p); } DllExport int win32_fsetpos(FILE *pf, const fpos_t *p) { return fsetpos(pf, p); } DllExport void win32_rewind(FILE *pf) { fseek(pf, 0, SEEK_SET); return; } DllExport int win32_tmpfd(void) { dTHX; char prefix[MAX_PATH+1]; char filename[MAX_PATH+1]; DWORD len = GetTempPath(MAX_PATH, prefix); 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, 0); if (fd >= 0) { #if defined(__BORLANDC__) setmode(fd,O_BINARY); #endif DEBUG_p(PerlIO_printf(Perl_debug_log, "Created tmpfile=%s\n",filename)); return fd; } } } } return -1; } DllExport FILE* win32_tmpfile(void) { int fd = win32_tmpfd(); if (fd >= 0) return win32_fdopen(fd, "w+b"); return NULL; } DllExport void win32_abort(void) { xceabort(); return; } DllExport int win32_fstat(int fd, struct stat *sbufptr) { return xcefstat(fd, sbufptr); } DllExport int win32_link(const char *oldname, const char *newname) { dTHX; Perl_croak(aTHX_ PL_no_func, "link"); return -1; } DllExport int win32_rename(const char *oname, const char *newname) { return xcerename(oname, newname); } DllExport int win32_setmode(int fd, int mode) { /* currently 'celib' seem to have this function in src, but not * exported. When it will be, we'll uncomment following line. */ /* return xcesetmode(fd, mode); */ return 0; } DllExport int win32_chsize(int fd, Off_t size) { return chsize(fd, size); } DllExport long win32_lseek(int fd, Off_t offset, int origin) { return xcelseek(fd, offset, origin); } DllExport long win32_tell(int fd) { return xcelseek(fd, 0, SEEK_CUR); } DllExport int win32_open(const char *path, int flag, ...) { int pmode; va_list ap; va_start(ap, flag); pmode = va_arg(ap, int); va_end(ap); return xceopen(path, flag, pmode); } DllExport int win32_close(int fd) { return xceclose(fd); } DllExport int win32_eof(int fd) { dTHX; Perl_croak(aTHX_ PL_no_func, "eof"); return -1; } DllExport int win32_dup(int fd) { return xcedup(fd); /* from celib/ceio.c; requires some more work on it */ } DllExport int win32_dup2(int fd1,int fd2) { return xcedup2(fd1,fd2); } DllExport int win32_read(int fd, void *buf, unsigned int cnt) { return xceread(fd, buf, cnt); } DllExport int win32_write(int fd, const void *buf, unsigned int cnt) { return xcewrite(fd, (void *) buf, cnt); } DllExport int win32_mkdir(const char *dir, int mode) { return xcemkdir(dir); } DllExport int win32_rmdir(const char *dir) { return xcermdir(dir); } DllExport int win32_chdir(const char *dir) { return xcechdir(dir); } DllExport int win32_access(const char *path, int mode) { return xceaccess(path, mode); } DllExport int win32_chmod(const char *path, int mode) { return xcechmod(path, mode); } static char * create_command_line(char *cname, STRLEN clen, const char * const *args) { dTHX; int index, argc; char *cmd, *ptr; const char *arg; STRLEN len = 0; bool bat_file = FALSE; bool cmd_shell = FALSE; bool dumb_shell = FALSE; bool extra_quotes = FALSE; bool quote_next = FALSE; if (!cname) 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 * of the following is true: * 1. the /S switch was used * 2. there are more than two dquotes * 3. there is a special character from this set: &<>()@^| * 4. no whitespace characters within the two dquotes * 5. string between two dquotes isn't an executable file * To work around this, we always add a leading and trailing dquote * to the string, if the first argument is either "cmd.exe" or "cmd", * and there were at least two or more arguments passed to cmd.exe * (not including switches). * XXX the above rules (from "cmd /?") don't seem to be applied * always, making for the convolutions below :-( */ if (cname) { if (!clen) clen = strlen(cname); if (clen > 4 && (stricmp(&cname[clen-4], ".bat") == 0 || (IsWinNT() && 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; } } } 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)); } DEBUG_p(PerlIO_printf(Perl_debug_log, "\n")); argc = index; Newx(cmd, len, char); ptr = cmd; if (bat_file) { *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; } } } } if (extra_quotes) *ptr++ = '"'; *ptr = '\0'; return cmd; } static char * qualified_path(const char *cmd) { dTHX; char *pathstr; char *fullcmd, *curfullcmd; STRLEN cmdlen = 0; int has_slash = 0; if (!cmd) return NULL; fullcmd = (char*)cmd; while (*fullcmd) { if (*fullcmd == '/' || *fullcmd == '\\') has_slash++; fullcmd++; cmdlen++; } /* look in PATH */ pathstr = PerlEnv_getenv("PATH"); Newx(fullcmd, MAX_PATH+1, char); 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] != '.')) { strcpy(curfullcmd, ".exe"); 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 != '"') { if ((STRLEN)(curfullcmd-fullcmd) < MAX_PATH-cmdlen-5) *curfullcmd++ = *pathstr; pathstr++; } if (*pathstr) pathstr++; /* skip trailing '"' */ } else { if ((STRLEN)(curfullcmd-fullcmd) < MAX_PATH-cmdlen-5) *curfullcmd++ = *pathstr; pathstr++; } } if (*pathstr) pathstr++; /* skip trailing semi */ if (curfullcmd > fullcmd /* append a dir separator */ && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\') { *curfullcmd++ = '\\'; } } Safefree(fullcmd); return NULL; } /* The following are just place holders. * Some hosts may provide and environment that the OS is * not tracking, therefore, these host must provide that * environment and the current directory to CreateProcess */ DllExport void* win32_get_childenv(void) { return NULL; } DllExport void win32_free_childenv(void* d) { } DllExport void win32_clearenv(void) { char *envv = GetEnvironmentStrings(); char *cur = envv; STRLEN len; while (*cur) { char *end = strchr(cur,'='); if (end && end != cur) { *end = '\0'; xcesetenv(cur, "", 0); *end = '='; cur = end + strlen(end+1)+2; } else if ((len = strlen(cur))) cur += len+1; } FreeEnvironmentStrings(envv); } DllExport char* win32_get_childdir(void) { dTHX; char* ptr; char szfilename[MAX_PATH+1]; GetCurrentDirectoryA(MAX_PATH+1, szfilename); Newx(ptr, strlen(szfilename)+1, char); strcpy(ptr, szfilename); return ptr; } DllExport void win32_free_childdir(char* d) { dTHX; Safefree(d); } /* XXX this needs to be made more compatible with the spawnvp() * provided by the various RTLs. In particular, searching for * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented. * This doesn't significantly affect perl itself, because we * always invoke things using PERL5SHELL if a direct attempt to * spawn the executable fails. * * XXX splitting and rejoining the commandline between do_aspawn() * and win32_spawnvp() could also be avoided. */ DllExport int win32_spawnvp(int mode, const char *cmdname, const char *const *argv) { #ifdef USE_RTL_SPAWNVP return spawnvp(mode, cmdname, (char * const *)argv); #else dTHX; int ret; void* env; char* dir; child_IO_table tbl; STARTUPINFO StartupInfo; PROCESS_INFORMATION ProcessInformation; DWORD create = 0; char *cmd; char *fullcmd = NULL; char *cname = (char *)cmdname; 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'; } } cmd = create_command_line(cname, clen, argv); env = PerlEnv_get_childenv(); dir = PerlEnv_get_childdir(); 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() */ /* not supported on CE create |= CREATE_NEW_PROCESS_GROUP; */ /* FALL THROUGH */ case P_WAIT: /* synchronous execution */ break; default: /* invalid mode */ errno = EINVAL; ret = -1; goto RETVAL; } memset(&StartupInfo,0,sizeof(StartupInfo)); StartupInfo.cb = sizeof(StartupInfo); memset(&tbl,0,sizeof(tbl)); PerlEnv_get_child_IO(&tbl); StartupInfo.dwFlags = tbl.dwFlags; StartupInfo.dwX = tbl.dwX; StartupInfo.dwY = tbl.dwY; StartupInfo.dwXSize = tbl.dwXSize; StartupInfo.dwYSize = tbl.dwYSize; StartupInfo.dwXCountChars = tbl.dwXCountChars; StartupInfo.dwYCountChars = tbl.dwYCountChars; StartupInfo.dwFillAttribute = tbl.dwFillAttribute; StartupInfo.wShowWindow = tbl.wShowWindow; StartupInfo.hStdInput = tbl.childStdIn; StartupInfo.hStdOutput = tbl.childStdOut; StartupInfo.hStdError = tbl.childStdErr; if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE && StartupInfo.hStdOutput == INVALID_HANDLE_VALUE && StartupInfo.hStdError == INVALID_HANDLE_VALUE) { create |= CREATE_NEW_CONSOLE; } else { StartupInfo.dwFlags |= STARTF_USESTDHANDLES; } if (w32_use_showwindow) { StartupInfo.dwFlags |= STARTF_USESHOWWINDOW; StartupInfo.wShowWindow = w32_showwindow; } DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n", 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)) { /* 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); 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; if (IsWin95() && ret < 0) ret = -ret; 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 */ GetExitCodeProcess(ProcessInformation.hProcess, &status); ret = (int)status; CloseHandle(ProcessInformation.hProcess); } CloseHandle(ProcessInformation.hThread); RETVAL: PerlEnv_free_childenv(env); PerlEnv_free_childdir(dir); Safefree(cmd); if (cname != cmdname) Safefree(cname); return ret; #endif } DllExport int win32_execv(const char *cmdname, const char *const *argv) { dTHX; Perl_croak(aTHX_ PL_no_func, "execv"); return -1; } DllExport int win32_execvp(const char *cmdname, const char *const *argv) { dTHX; Perl_croak(aTHX_ PL_no_func, "execvp"); return -1; } DllExport void win32_perror(const char *str) { xceperror(str); } DllExport void win32_setbuf(FILE *pf, char *buf) { dTHX; Perl_croak(aTHX_ PL_no_func, "setbuf"); } DllExport int win32_setvbuf(FILE *pf, char *buf, int type, size_t size) { return setvbuf(pf, buf, type, size); } DllExport int win32_flushall(void) { return flushall(); } DllExport int win32_fcloseall(void) { return fcloseall(); } DllExport char* win32_fgets(char *s, int n, FILE *pf) { return fgets(s, n, pf); } DllExport char* win32_gets(char *s) { return gets(s); } DllExport int win32_fgetc(FILE *pf) { return fgetc(pf); } DllExport int win32_putc(int c, FILE *pf) { return putc(c,pf); } DllExport int win32_puts(const char *s) { return puts(s); } DllExport int win32_getchar(void) { return getchar(); } DllExport int win32_putchar(int c) { return putchar(c); } #ifdef MYMALLOC #ifndef USE_PERL_SBRK static char *committed = NULL; static char *base = NULL; static char *reserved = NULL; static char *brk = NULL; static DWORD pagesize = 0; static DWORD allocsize = 0; void * sbrk(int need) { void *result; if (!pagesize) {SYSTEM_INFO info; GetSystemInfo(&info); /* Pretend page size is larger so we don't perpetually * call the OS to commit just one page ... */ pagesize = info.dwPageSize << 3; allocsize = info.dwAllocationGranularity; } /* This scheme fails eventually if request for contiguous * block is denied so reserve big blocks - this is only * address space not memory ... */ if (brk+need >= reserved) { DWORD size = 64*1024*1024; char *addr; if (committed && reserved && committed < reserved) { /* Commit last of previous chunk cannot span allocations */ addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE); if (addr) committed = reserved; } /* Reserve some (more) space * Note this is a little sneaky, 1st call passes NULL as reserved * so lets system choose where we start, subsequent calls pass * the old end address so ask for a contiguous block */ addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS); if (addr) { reserved = addr+size; if (!base) base = addr; if (!committed) committed = base; if (!brk) brk = committed; } else { return (void *) -1; } } result = brk; brk += need; if (brk > committed) { DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize; char *addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE); if (addr) { committed += size; } else return (void *) -1; } return result; } #endif #endif DllExport void* win32_malloc(size_t size) { return malloc(size); } DllExport void* win32_calloc(size_t numitems, size_t size) { return calloc(numitems,size); } DllExport void* win32_realloc(void *block, size_t size) { return realloc(block,size); } DllExport void win32_free(void *block) { free(block); } int win32_open_osfhandle(intptr_t osfhandle, int flags) { int fh; char fileflags=0; /* _osfile flags */ Perl_croak_nocontext("win32_open_osfhandle() TBD on this platform"); return 0; } int win32_get_osfhandle(int fd) { int fh; char fileflags=0; /* _osfile flags */ Perl_croak_nocontext("win32_get_osfhandle() TBD on this platform"); return 0; } FILE * win32_fdupopen(FILE *pf) { FILE* pfdup; fpos_t pos; char mode[3]; int fileno = win32_dup(win32_fileno(pf)); int fmode = palm_fgetmode(pfdup); fprintf(stderr,"DEBUG for win32_fdupopen()\n"); /* open the file in the same mode */ if(fmode & O_RDONLY) { mode[0] = 'r'; mode[1] = 0; } else if(fmode & O_APPEND) { mode[0] = 'a'; mode[1] = 0; } else if(fmode & O_RDWR) { mode[0] = 'r'; mode[1] = '+'; mode[2] = 0; } /* it appears that the binmode is attached to the * file descriptor so binmode files will be handled * correctly */ pfdup = win32_fdopen(fileno, mode); /* move the file pointer to the same position */ if (!fgetpos(pf, &pos)) { fsetpos(pfdup, &pos); } return pfdup; } DllExport void* win32_dynaload(const char* filename) { dTHX; HMODULE hModule; hModule = XCELoadLibraryA(filename); return hModule; } /* this is needed by Cwd.pm... */ static XS(w32_GetCwd) { dXSARGS; char buf[MAX_PATH]; SV *sv = sv_newmortal(); xcegetcwd(buf, sizeof(buf)); sv_setpv(sv, xcestrdup(buf)); EXTEND(SP,1); SvPOK_on(sv); ST(0) = sv; #ifndef INCOMPLETE_TAINTS SvTAINTED_on(ST(0)); #endif XSRETURN(1); } static XS(w32_SetCwd) { dXSARGS; if (items != 1) Perl_croak(aTHX_ "usage: Win32::SetCwd($cwd)"); if (!xcechdir(SvPV_nolen(ST(0)))) XSRETURN_YES; XSRETURN_NO; } static XS(w32_GetTickCount) { dXSARGS; DWORD msec = GetTickCount(); EXTEND(SP,1); if ((IV)msec > 0) XSRETURN_IV(msec); XSRETURN_NV(msec); } static XS(w32_GetOSVersion) { dXSARGS; OSVERSIONINFOA osver; osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA); if (!XCEGetVersionExA(&osver)) { XSRETURN_EMPTY; } mXPUSHp(osver.szCSDVersion, strlen(osver.szCSDVersion)); mXPUSHi(osver.dwMajorVersion); mXPUSHi(osver.dwMinorVersion); mXPUSHi(osver.dwBuildNumber); /* WINCE = 3 */ mXPUSHi(osver.dwPlatformId); PUTBACK; } static XS(w32_IsWinNT) { dXSARGS; EXTEND(SP,1); XSRETURN_IV(IsWinNT()); } static XS(w32_IsWin95) { dXSARGS; EXTEND(SP,1); XSRETURN_IV(IsWin95()); } static XS(w32_IsWinCE) { dXSARGS; EXTEND(SP,1); XSRETURN_IV(IsWinCE()); } static XS(w32_GetOemInfo) { dXSARGS; wchar_t wbuf[126]; char buf[126]; if(SystemParametersInfoW(SPI_GETOEMINFO, sizeof(wbuf), wbuf, FALSE)) WideCharToMultiByte(CP_ACP, 0, wbuf, -1, buf, sizeof(buf), 0, 0); else sprintf(buf, "SystemParametersInfo failed: %d", GetLastError()); EXTEND(SP,1); XSRETURN_PV(buf); } static XS(w32_Sleep) { dXSARGS; if (items != 1) Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)"); Sleep(SvIV(ST(0))); XSRETURN_YES; } static XS(w32_CopyFile) { dXSARGS; BOOL bResult; if (items != 3) Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)"); { char szSourceFile[MAX_PATH+1]; strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0)))); bResult = XCECopyFileA(szSourceFile, SvPV_nolen(ST(1)), !SvTRUE(ST(2))); } if (bResult) XSRETURN_YES; XSRETURN_NO; } static XS(w32_MessageBox) { dXSARGS; char *txt; unsigned int res; unsigned int flags = MB_OK; txt = SvPV_nolen(ST(0)); if (items < 1 || items > 2) Perl_croak(aTHX_ "usage: Win32::MessageBox($txt, [$flags])"); if(items == 2) flags = SvIV(ST(1)); res = XCEMessageBoxA(NULL, txt, "Perl", flags); XSRETURN_IV(res); } static XS(w32_GetPowerStatus) { dXSARGS; SYSTEM_POWER_STATUS_EX sps; if(GetSystemPowerStatusEx(&sps, TRUE) == FALSE) { XSRETURN_EMPTY; } mXPUSHi(sps.ACLineStatus); mXPUSHi(sps.BatteryFlag); mXPUSHi(sps.BatteryLifePercent); mXPUSHi(sps.BatteryLifeTime); mXPUSHi(sps.BatteryFullLifeTime); mXPUSHi(sps.BackupBatteryFlag); mXPUSHi(sps.BackupBatteryLifePercent); mXPUSHi(sps.BackupBatteryLifeTime); mXPUSHi(sps.BackupBatteryFullLifeTime); PUTBACK; } #if UNDER_CE > 200 static XS(w32_ShellEx) { dXSARGS; char buf[126]; SHELLEXECUTEINFO si; char *file, *verb; wchar_t wfile[MAX_PATH]; wchar_t wverb[20]; if (items != 2) Perl_croak(aTHX_ "usage: Win32::ShellEx($file, $verb)"); file = SvPV_nolen(ST(0)); verb = SvPV_nolen(ST(1)); memset(&si, 0, sizeof(si)); si.cbSize = sizeof(si); si.fMask = SEE_MASK_FLAG_NO_UI; MultiByteToWideChar(CP_ACP, 0, verb, -1, wverb, sizeof(wverb)/2); si.lpVerb = (TCHAR *)wverb; MultiByteToWideChar(CP_ACP, 0, file, -1, wfile, sizeof(wfile)/2); si.lpFile = (TCHAR *)wfile; if(ShellExecuteEx(&si) == FALSE) { XSRETURN_NO; } XSRETURN_YES; } #endif void Perl_init_os_extras(void) { dTHX; char *file = __FILE__; dXSUB_SYS; w32_perlshell_tokens = NULL; w32_perlshell_items = -1; w32_fdpid = newAV(); /* XX needs to be in Perl_win32_init()? */ Newx(w32_children, 1, child_tab); w32_num_children = 0; newXS("Win32::GetCwd", w32_GetCwd, file); newXS("Win32::SetCwd", w32_SetCwd, file); newXS("Win32::GetTickCount", w32_GetTickCount, file); newXS("Win32::GetOSVersion", w32_GetOSVersion, file); #if UNDER_CE > 200 newXS("Win32::ShellEx", w32_ShellEx, file); #endif newXS("Win32::IsWinNT", w32_IsWinNT, file); newXS("Win32::IsWin95", w32_IsWin95, file); newXS("Win32::IsWinCE", w32_IsWinCE, file); newXS("Win32::CopyFile", w32_CopyFile, file); newXS("Win32::Sleep", w32_Sleep, file); newXS("Win32::MessageBox", w32_MessageBox, file); newXS("Win32::GetPowerStatus", w32_GetPowerStatus, file); newXS("Win32::GetOemInfo", w32_GetOemInfo, file); } void myexit(void) { char buf[126]; puts("Hit return"); fgets(buf, sizeof(buf), stdin); } void Perl_win32_init(int *argcp, char ***argvp) { #ifdef UNDER_CE char *p; if((p = xcegetenv("PERLDEBUG")) && (p[0] == 'y' || p[0] == 'Y')) atexit(myexit); #endif MALLOC_INIT; } DllExport void Perl_win32_term(void) { dTHX; HINTS_REFCNT_TERM; OP_REFCNT_TERM; PERLIO_TERM; MALLOC_TERM; } void win32_get_child_IO(child_IO_table* ptbl) { ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE); ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE); ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE); } win32_flock(int fd, int oper) { dTHX; Perl_croak(aTHX_ PL_no_func, "flock"); return -1; } DllExport int win32_waitpid(int pid, int *status, int flags) { dTHX; Perl_croak(aTHX_ PL_no_func, "waitpid"); return -1; } DllExport int win32_wait(int *status) { dTHX; Perl_croak(aTHX_ PL_no_func, "wait"); return -1; } int wce_reopen_stdout(char *fname) { if(xcefreopen(fname, "w", stdout) == NULL) return -1; return 0; } void wce_hitreturn() { char buf[126]; printf("Hit RETURN"); fflush(stdout); fgets(buf, sizeof(buf), stdin); return; } /* //////////////////////////////////////////////////////////////////// */ #undef getcwd char * getcwd(char *buf, size_t size) { return xcegetcwd(buf, size); } int isnan(double d) { return _isnan(d); } DllExport PerlIO* win32_popenlist(const char *mode, IV narg, SV **args) { dTHX; Perl_croak(aTHX_ "List form of pipe open not implemented"); return NULL; } /* * a popen() clone that respects PERL5SHELL * * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000 */ DllExport PerlIO* win32_popen(const char *command, const char *mode) { return _popen(command, mode); } /* * pclose() clone */ DllExport int win32_pclose(PerlIO *pf) { return _pclose(pf); } #ifdef HAVE_INTERP_INTERN static void win32_csighandler(int sig) { #if 0 dTHXa(PERL_GET_SIG_CONTEXT); Perl_warn(aTHX_ "Got signal %d",sig); #endif /* Does nothing */ } void Perl_sys_intern_init(pTHX) { int i; w32_perlshell_tokens = NULL; w32_perlshell_vec = (char**)NULL; w32_perlshell_items = 0; w32_fdpid = newAV(); Newx(w32_children, 1, child_tab); w32_num_children = 0; # ifdef USE_ITHREADS w32_pseudo_id = 0; Newx(w32_pseudo_children, 1, child_tab); w32_num_pseudo_children = 0; # endif w32_init_socktype = 0; w32_timerid = 0; w32_poll_count = 0; } void Perl_sys_intern_clear(pTHX) { Safefree(w32_perlshell_tokens); Safefree(w32_perlshell_vec); /* NOTE: w32_fdpid is freed by sv_clean_all() */ Safefree(w32_children); if (w32_timerid) { KillTimer(NULL,w32_timerid); w32_timerid=0; } # ifdef USE_ITHREADS Safefree(w32_pseudo_children); # endif } # ifdef USE_ITHREADS void Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst) { dst->perlshell_tokens = NULL; dst->perlshell_vec = (char**)NULL; dst->perlshell_items = 0; dst->fdpid = newAV(); Newxz(dst->children, 1, child_tab); dst->pseudo_id = 0; Newxz(dst->pseudo_children, 1, child_tab); dst->thr_intern.Winit_socktype = 0; dst->timerid = 0; dst->poll_count = 0; Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t); } # endif /* USE_ITHREADS */ #endif /* HAVE_INTERP_INTERN */ // added to remove undefied symbol error in CodeWarrior compilation int Perl_Ireentrant_buffer_ptr(aTHX) { return 0; } perl-5.12.0-RC0/win32/vmem.h0000444000175000017500000007520311325125742014215 0ustar jessejesse/* vmem.h * * (c) 1999 Microsoft Corporation. All rights reserved. * Portions (c) 1999 ActiveState Tool Corp, http://www.ActiveState.com/ * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * * Options: * * Defining _USE_MSVCRT_MEM_ALLOC will cause all memory allocations * to be forwarded to MSVCRT.DLL. Defining _USE_LINKED_LIST as well will * track all allocations in a doubly linked list, so that the host can * free all memory allocated when it goes away. * If _USE_MSVCRT_MEM_ALLOC is not defined then Knuth's boundary tag algorithm * is used; defining _USE_BUDDY_BLOCKS will use Knuth's algorithm R * (Buddy system reservation) * */ #ifndef ___VMEM_H_INC___ #define ___VMEM_H_INC___ #ifndef UNDER_CE #define _USE_MSVCRT_MEM_ALLOC #endif #define _USE_LINKED_LIST // #define _USE_BUDDY_BLOCKS // #define _DEBUG_MEM #ifdef _DEBUG_MEM #define ASSERT(f) if(!(f)) DebugBreak(); inline void MEMODS(char *str) { OutputDebugString(str); OutputDebugString("\n"); } inline void MEMODSlx(char *str, long x) { char szBuffer[512]; sprintf(szBuffer, "%s %lx\n", str, x); OutputDebugString(szBuffer); } #define WALKHEAP() WalkHeap(0) #define WALKHEAPTRACE() WalkHeap(1) #else #define ASSERT(f) #define MEMODS(x) #define MEMODSlx(x, y) #define WALKHEAP() #define WALKHEAPTRACE() #endif #ifdef _USE_MSVCRT_MEM_ALLOC #ifndef _USE_LINKED_LIST // #define _USE_LINKED_LIST #endif /* * Pass all memory requests throught to msvcrt.dll * optionaly track by using a doubly linked header */ typedef void (*LPFREE)(void *block); typedef void* (*LPMALLOC)(size_t size); typedef void* (*LPREALLOC)(void *block, size_t size); #ifdef _USE_LINKED_LIST class VMem; typedef struct _MemoryBlockHeader* PMEMORY_BLOCK_HEADER; typedef struct _MemoryBlockHeader { PMEMORY_BLOCK_HEADER pNext; PMEMORY_BLOCK_HEADER pPrev; VMem *owner; } MEMORY_BLOCK_HEADER, *PMEMORY_BLOCK_HEADER; #endif class VMem { public: VMem(); ~VMem(); virtual void* Malloc(size_t size); virtual void* Realloc(void* pMem, size_t size); virtual void Free(void* pMem); virtual void GetLock(void); virtual void FreeLock(void); virtual int IsLocked(void); virtual long Release(void); virtual long AddRef(void); inline BOOL CreateOk(void) { 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; ptr->owner = this; 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; } MEMORY_BLOCK_HEADER m_Dummy; #endif long m_lRefCount; // number of current users CRITICAL_SECTION m_cs; // access lock HINSTANCE m_hLib; LPFREE m_pfree; LPMALLOC m_pmalloc; LPREALLOC m_prealloc; }; VMem::VMem() { m_lRefCount = 1; InitializeCriticalSection(&m_cs); #ifdef _USE_LINKED_LIST m_Dummy.pNext = m_Dummy.pPrev = &m_Dummy; m_Dummy.owner = this; #endif m_hLib = LoadLibrary("msvcrt.dll"); if (m_hLib) { m_pfree = (LPFREE)GetProcAddress(m_hLib, "free"); m_pmalloc = (LPMALLOC)GetProcAddress(m_hLib, "malloc"); m_prealloc = (LPREALLOC)GetProcAddress(m_hLib, "realloc"); } } VMem::~VMem(void) { #ifdef _USE_LINKED_LIST while (m_Dummy.pNext != &m_Dummy) { Free(m_Dummy.pNext+1); } #endif if (m_hLib) FreeLibrary(m_hLib); DeleteCriticalSection(&m_cs); } void* VMem::Malloc(size_t size) { #ifdef _USE_LINKED_LIST GetLock(); PMEMORY_BLOCK_HEADER ptr = (PMEMORY_BLOCK_HEADER)m_pmalloc(size+sizeof(MEMORY_BLOCK_HEADER)); if (!ptr) { FreeLock(); return NULL; } LinkBlock(ptr); FreeLock(); return (ptr+1); #else return m_pmalloc(size); #endif } void* VMem::Realloc(void* pMem, size_t size) { #ifdef _USE_LINKED_LIST if (!pMem) return Malloc(size); if (!size) { Free(pMem); return NULL; } GetLock(); PMEMORY_BLOCK_HEADER ptr = (PMEMORY_BLOCK_HEADER)(((char*)pMem)-sizeof(MEMORY_BLOCK_HEADER)); UnlinkBlock(ptr); ptr = (PMEMORY_BLOCK_HEADER)m_prealloc(ptr, size+sizeof(MEMORY_BLOCK_HEADER)); if (!ptr) { FreeLock(); return NULL; } LinkBlock(ptr); FreeLock(); return (ptr+1); #else return m_prealloc(pMem, size); #endif } void VMem::Free(void* pMem) { #ifdef _USE_LINKED_LIST if (pMem) { PMEMORY_BLOCK_HEADER ptr = (PMEMORY_BLOCK_HEADER)(((char*)pMem)-sizeof(MEMORY_BLOCK_HEADER)); if (ptr->owner != this) { if (ptr->owner) { #if 1 dTHX; int *nowhere = NULL; Perl_warn(aTHX_ "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; } GetLock(); UnlinkBlock(ptr); ptr->owner = NULL; m_pfree(ptr); FreeLock(); } #else m_pfree(pMem); #endif } void VMem::GetLock(void) { EnterCriticalSection(&m_cs); } void VMem::FreeLock(void) { LeaveCriticalSection(&m_cs); } int VMem::IsLocked(void) { #if 0 /* XXX TryEnterCriticalSection() is not available in some versions * of Windows 95. Since this code is not used anywhere yet, we * skirt the issue for now. */ BOOL bAccessed = TryEnterCriticalSection(&m_cs); if(bAccessed) { LeaveCriticalSection(&m_cs); } return !bAccessed; #else ASSERT(0); /* alarm bells for when somebody calls this */ return 0; #endif } long VMem::Release(void) { long lCount = InterlockedDecrement(&m_lRefCount); if(!lCount) delete this; return lCount; } long VMem::AddRef(void) { long lCount = InterlockedIncrement(&m_lRefCount); return lCount; } #else /* _USE_MSVCRT_MEM_ALLOC */ /* * Knuth's boundary tag algorithm Vol #1, Page 440. * * Each block in the heap has tag words before and after it, * TAG * block * TAG * The size is stored in these tags as a long word, and includes the 8 bytes * of overhead that the boundary tags consume. Blocks are allocated on long * word boundaries, so the size is always multiples of long words. When the * block is allocated, bit 0, (the tag bit), of the size is set to 1. When * a block is freed, it is merged with adjacent free blocks, and the tag bit * is set to 0. * * A linked list is used to manage the free list. The first two long words of * the block contain double links. These links are only valid when the block * is freed, therefore space needs to be reserved for them. Thus, the minimum * block size (not counting the tags) is 8 bytes. * * Since memory allocation may occur on a single threaded, explict locks are not * provided. * */ const long lAllocStart = 0x00020000; /* start at 128K */ const long minBlockSize = sizeof(void*)*2; const long sizeofTag = sizeof(long); const long blockOverhead = sizeofTag*2; const long minAllocSize = minBlockSize+blockOverhead; #ifdef _USE_BUDDY_BLOCKS const long lSmallBlockSize = 1024; const size_t nListEntries = ((lSmallBlockSize-minAllocSize)/sizeof(long)); inline size_t CalcEntry(size_t size) { ASSERT((size&(sizeof(long)-1)) == 0); return ((size - minAllocSize) / sizeof(long)); } #endif typedef BYTE* PBLOCK; /* pointer to a memory block */ /* * Macros for accessing hidden fields in a memory block: * * SIZE size of this block (tag bit 0 is 1 if block is allocated) * PSIZE size of previous physical block */ #define SIZE(block) (*(ULONG*)(((PBLOCK)(block))-sizeofTag)) #define PSIZE(block) (*(ULONG*)(((PBLOCK)(block))-(blockOverhead))) inline void SetTags(PBLOCK block, long size) { SIZE(block) = size; PSIZE(block+(size&~1)) = size; } /* * Free list pointers * PREV pointer to previous block * NEXT pointer to next block */ #define PREV(block) (*(PBLOCK*)(block)) #define NEXT(block) (*(PBLOCK*)((block)+sizeof(PBLOCK))) inline void SetLink(PBLOCK block, PBLOCK prev, PBLOCK next) { PREV(block) = prev; NEXT(block) = next; } inline void Unlink(PBLOCK p) { PBLOCK next = NEXT(p); PBLOCK prev = PREV(p); NEXT(prev) = next; PREV(next) = prev; } #ifndef _USE_BUDDY_BLOCKS inline void AddToFreeList(PBLOCK block, PBLOCK pInList) { PBLOCK next = NEXT(pInList); NEXT(pInList) = block; SetLink(block, pInList, next); PREV(next) = block; } #endif /* Macro for rounding up to the next sizeof(long) */ #define ROUND_UP(n) (((ULONG)(n)+sizeof(long)-1)&~(sizeof(long)-1)) #define ROUND_UP64K(n) (((ULONG)(n)+0x10000-1)&~(0x10000-1)) #define ROUND_DOWN(n) ((ULONG)(n)&~(sizeof(long)-1)) /* * HeapRec - a list of all non-contiguous heap areas * * Each record in this array contains information about a non-contiguous heap area. */ const int maxHeaps = 32; /* 64 was overkill */ const long lAllocMax = 0x80000000; /* max size of allocation */ #ifdef _USE_BUDDY_BLOCKS typedef struct _FreeListEntry { BYTE Dummy[minAllocSize]; // dummy free block } FREE_LIST_ENTRY, *PFREE_LIST_ENTRY; #endif #ifndef _USE_BUDDY_BLOCKS #define USE_BIGBLOCK_ALLOC #endif /* * performance tuning * Use VirtualAlloc() for blocks bigger than nMaxHeapAllocSize since * Windows 95/98/Me have heap managers that are designed for memory * blocks smaller than four megabytes. */ #ifdef USE_BIGBLOCK_ALLOC const int nMaxHeapAllocSize = (1024*512); /* don't allocate anything larger than this from the heap */ #endif typedef struct _HeapRec { PBLOCK base; /* base of heap area */ ULONG len; /* size of heap area */ #ifdef USE_BIGBLOCK_ALLOC BOOL bBigBlock; /* was allocate using VirtualAlloc */ #endif } HeapRec; class VMem { public: VMem(); ~VMem(); virtual void* Malloc(size_t size); virtual void* Realloc(void* pMem, size_t size); virtual void Free(void* pMem); virtual void GetLock(void); virtual void FreeLock(void); virtual int IsLocked(void); virtual long Release(void); virtual long AddRef(void); inline BOOL CreateOk(void) { #ifdef _USE_BUDDY_BLOCKS return TRUE; #else return m_hHeap != NULL; #endif }; void ReInit(void); protected: void Init(void); int Getmem(size_t size); int HeapAdd(void* ptr, size_t size #ifdef USE_BIGBLOCK_ALLOC , BOOL bBigBlock #endif ); void* Expand(void* block, size_t size); #ifdef _USE_BUDDY_BLOCKS inline PBLOCK GetFreeListLink(int index) { if (index >= nListEntries) index = nListEntries-1; return &m_FreeList[index].Dummy[sizeofTag]; } inline PBLOCK GetOverSizeFreeList(void) { return &m_FreeList[nListEntries-1].Dummy[sizeofTag]; } inline PBLOCK GetEOLFreeList(void) { 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; } #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; } #ifdef _USE_BUDDY_BLOCKS FREE_LIST_ENTRY m_FreeList[nListEntries+1]; // free list with dummy end of list entry as well #else HANDLE m_hHeap; // memory heap for this script char m_FreeDummy[minAllocSize]; // dummy free block PBLOCK m_pFreeList; // pointer to first block on free list #endif PBLOCK m_pRover; // roving pointer into the free list HeapRec m_heaps[maxHeaps]; // list of all non-contiguous heap areas int m_nHeaps; // no. of heaps in m_heaps long m_lAllocSize; // current alloc size long m_lRefCount; // number of current users CRITICAL_SECTION m_cs; // access lock #ifdef _DEBUG_MEM void WalkHeap(int complete); void MemoryUsageMessage(char *str, long x, long y, int c); FILE* m_pLog; #endif }; 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 */ ASSERT(bRet); #endif InitializeCriticalSection(&m_cs); #ifdef _DEBUG_MEM m_pLog = 0; #endif Init(); } VMem::~VMem(void) { #ifndef _USE_BUDDY_BLOCKS ASSERT(HeapValidate(m_hHeap, HEAP_NO_SERIALIZE, NULL)); #endif WALKHEAPTRACE(); DeleteCriticalSection(&m_cs); #ifdef _USE_BUDDY_BLOCKS for(int index = 0; index < m_nHeaps; ++index) { 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); } } #endif BOOL bRet = HeapDestroy(m_hHeap); ASSERT(bRet); #endif /* _USE_BUDDY_BLOCKS */ } void VMem::ReInit(void) { for(int index = 0; index < m_nHeaps; ++index) { #ifdef _USE_BUDDY_BLOCKS 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 #endif HeapFree(m_hHeap, HEAP_NO_SERIALIZE, m_heaps[index].base); #endif /* _USE_BUDDY_BLOCKS */ } Init(); } void VMem::Init(void) { #ifdef _USE_BUDDY_BLOCKS PBLOCK pFreeList; /* * Initialize the free list by placing a dummy zero-length block on it. * Set the end of list marker. * Set the number of non-contiguous heaps to zero. * 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 = GetEOLFreeList(); SIZE(pFreeList) = PSIZE(pFreeList+minAllocSize) = 0; PREV(pFreeList) = NEXT(pFreeList) = NULL; m_pRover = GetOverSizeFreeList(); #else /* * Initialize the free list by placing a dummy zero-length block on it. * Set the number of non-contiguous heaps to zero. */ m_pFreeList = m_pRover = (PBLOCK)(&m_FreeDummy[sizeofTag]); PSIZE(m_pFreeList+minAllocSize) = SIZE(m_pFreeList) = 0; PREV(m_pFreeList) = NEXT(m_pFreeList) = m_pFreeList; #endif m_nHeaps = 0; m_lAllocSize = lAllocStart; } void* VMem::Malloc(size_t size) { WALKHEAP(); PBLOCK ptr; size_t lsize, rem; /* * Disallow negative or zero sizes. */ size_t realsize = CalcAllocSize(size); if((int)realsize < minAllocSize || size == 0) return NULL; #ifdef _USE_BUDDY_BLOCKS /* * Check the free list of small blocks if this is free use it * Otherwise check the rover if it has no blocks then * Scan the free list entries use the first free block * 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); } } } #endif /* * Start searching the free list at the rover. If we arrive back at rover without * finding anything, allocate some memory from the heap and try again. */ 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; } } } void* VMem::Realloc(void* block, size_t size) { WALKHEAP(); /* if size is zero, free the block. */ if(size == 0) { Free(block); return (NULL); } /* if block pointer is NULL, do a Malloc(). */ if(block == NULL) 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; size_t realsize = CalcAllocSize(size); if((int)realsize < minAllocSize) return NULL; /* * see if the previous block is free, and is it big enough to cover the new size * if merged with the current block. */ PBLOCK ptr = (PBLOCK)block; 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); #ifdef _USE_BUDDY_BLOCKS AddToFreeList(prev, rem); #else AddToFreeList(prev, m_pFreeList); #endif cursize = realsize; } /* 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); } return ((void *)ptr); } void VMem::Free(void* p) { WALKHEAP(); /* Ignore null pointer. */ if(p == NULL) 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; } size &= ~1; /* remove allocated tag */ /* if previous block is free, add this block to it. */ #ifndef _USE_BUDDY_BLOCKS int linked = FALSE; #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 */ #ifdef _USE_BUDDY_BLOCKS Unlink(ptr); #else linked = TRUE; /* it's already on the free list */ #endif } /* if the next physical block is free, merge it with this block. */ 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); /* unlink the next block from the free list. */ Unlink(next); /* merge the sizes of this block and the next block. */ size += nsize; } /* Set the boundary tags for the block; */ SetTags(ptr, size); /* Link the block to the head of the free list. */ #ifdef _USE_BUDDY_BLOCKS AddToFreeList(ptr, size); #else if(!linked) { AddToFreeList(ptr, m_pFreeList); } #endif } void VMem::GetLock(void) { EnterCriticalSection(&m_cs); } void VMem::FreeLock(void) { LeaveCriticalSection(&m_cs); } int VMem::IsLocked(void) { #if 0 /* XXX TryEnterCriticalSection() is not available in some versions * of Windows 95. Since this code is not used anywhere yet, we * skirt the issue for now. */ BOOL bAccessed = TryEnterCriticalSection(&m_cs); if(bAccessed) { LeaveCriticalSection(&m_cs); } return !bAccessed; #else ASSERT(0); /* alarm bells for when somebody calls this */ return 0; #endif } long VMem::Release(void) { long lCount = InterlockedDecrement(&m_lRefCount); if(!lCount) delete this; return lCount; } long VMem::AddRef(void) { long lCount = InterlockedIncrement(&m_lRefCount); return lCount; } int VMem::Getmem(size_t requestSize) { /* returns -1 is successful 0 if not */ #ifdef USE_BIGBLOCK_ALLOC BOOL bBigBlock; #endif void *ptr; /* Round up size to next multiple of 64K. */ size_t size = (size_t)ROUND_UP64K(requestSize); /* * if the size requested is smaller than our current allocation size * adjust up */ if(size < (unsigned long)m_lAllocSize) size = m_lAllocSize; /* Update the size to allocate on the next request */ if(m_lAllocSize != lAllocMax) m_lAllocSize <<= 2; #ifndef _USE_BUDDY_BLOCKS if(m_nHeaps != 0 #ifdef USE_BIGBLOCK_ALLOC && !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 #ifdef USE_BIGBLOCK_ALLOC , FALSE #endif ); return -1; } } #endif /* _USE_BUDDY_BLOCKS */ /* * if we didn't expand a block to cover the requested size * allocate a new Heap * the size of this block must include the additional dummy tags at either end * the above ROUND_UP64K may not have added any memory to include this. */ if(size == requestSize) size = (size_t)ROUND_UP64K(requestSize+(blockOverhead)); Restart: #ifdef _USE_BUDDY_BLOCKS ptr = VirtualAlloc(NULL, size, MEM_COMMIT, PAGE_READWRITE); #else #ifdef USE_BIGBLOCK_ALLOC bBigBlock = FALSE; if (size >= nMaxHeapAllocSize) { bBigBlock = TRUE; ptr = VirtualAlloc(NULL, size, MEM_COMMIT, PAGE_READWRITE); } else #endif ptr = HeapAlloc(m_hHeap, HEAP_NO_SERIALIZE, size); #endif /* _USE_BUDDY_BLOCKS */ if (!ptr) { /* try to allocate a smaller chunk */ size >>= 1; if(size > requestSize) goto Restart; } if(ptr == 0) { MEMODSlx("HeapAlloc failed on size!!!", size); return 0; } #ifdef _USE_BUDDY_BLOCKS if (HeapAdd(ptr, size)) { VirtualFree(ptr, 0, MEM_RELEASE); return 0; } #else #ifdef USE_BIGBLOCK_ALLOC if (HeapAdd(ptr, size, bBigBlock)) { if (bBigBlock) { VirtualFree(ptr, 0, MEM_RELEASE); } } #else HeapAdd(ptr, size); #endif #endif /* _USE_BUDDY_BLOCKS */ return -1; } int VMem::HeapAdd(void* p, size_t size #ifdef USE_BIGBLOCK_ALLOC , BOOL bBigBlock #endif ) { /* if the block can be succesfully added to the heap, returns 0; otherwise -1. */ int index; /* Check size, then round size down to next long word boundary. */ if(size < minAllocSize) return -1; size = (size_t)ROUND_DOWN(size); PBLOCK ptr = (PBLOCK)p; #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; } } #ifdef USE_BIGBLOCK_ALLOC } else { 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; #ifdef USE_BIGBLOCK_ALLOC 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 */ } /* * Convert the heap to one large block. Set up its boundary tags, and those of * marker block after it. The marker block before the heap will already have * been set up if this heap is not contiguous with the end of another heap. */ SetTags(ptr, size | 1); PBLOCK next = ptr + size; /* point to dummy end block */ SIZE(next) = 1; /* mark the dummy end block as allocated */ /* * Link the block to the start of the free list by calling free(). * This will merge the block with any adjacent free blocks. */ Free(ptr); return 0; } void* VMem::Expand(void* block, size_t size) { /* * Disallow negative or zero sizes. */ size_t realsize = CalcAllocSize(size); if((int)realsize < minAllocSize || size == 0) 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; } /* 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; } PBLOCK next = ptr + cursize; size_t nextsize = SIZE(next); /* 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); #ifdef _USE_BUDDY_BLOCKS AddToFreeList(next, rem); #else AddToFreeList(next, m_pFreeList); #endif cursize = realsize; } /* Set the boundary tags to mark it as allocated. */ SetTags(ptr, cursize | 1); return ((void *)ptr); } return NULL; } #ifdef _DEBUG_MEM #define LOG_FILENAME ".\\MemLog.txt" 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); } else { 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; #ifndef _USE_BUDDY_BLOCKS #ifdef USE_BIGBLOCK_ALLOC if (!m_heaps[m_nHeaps].bBigBlock) #endif 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); } } #endif /* _DEBUG_MEM */ #endif /* _USE_MSVCRT_MEM_ALLOC */ #endif /* ___VMEM_H_INC___ */ perl-5.12.0-RC0/win32/Makefile0000644000175000017500000012412611347250766014552 0ustar jessejesse# # Makefile to build perl on Windows NT using Microsoft NMAKE. # Supported compilers: # Visual C++ 2.0 or later # MS Platform SDK 64-bit compiler and tools # # This is set up to build a perl.exe that runs off a shared library # (perl512.dll). Also makes individual DLLs for the XS extensions. # ## ## Make sure you read README.win32 *before* you mess with anything here! ## ## ## Build configuration. Edit the values below to suit your needs. ## # # Set these to wherever you want "nmake install" to put your # newly built perl. # INST_DRV = c: INST_TOP = $(INST_DRV)\perl # # Uncomment if you want to build a 32-bit Perl using a 32-bit compiler # on a 64-bit version of Windows. #WIN64 = undef # # Comment this out if you DON'T want your perl installation to be versioned. # This means that the new installation will overwrite any files from the # old installation at the same INST_TOP location. Leaving it enabled is # the safest route, as perl adds the extra version directory to all the # locations it installs files to. If you disable it, an alternative # versioned installation can be obtained by setting INST_TOP above to a # path that includes an arbitrary version string. # #INST_VER = \5.12.0 # # Comment this out if you DON'T want your perl installation to have # architecture specific components. This means that architecture- # specific files will be installed along with the architecture-neutral # files. Leaving it enabled is safer and more flexible, in case you # want to build multiple flavors of perl and install them together in # the same location. Commenting it out gives you a simpler # installation that is easier to understand for beginners. # #INST_ARCH = \$(ARCHNAME) # # Uncomment this if you want perl to run # $Config{sitelibexp}\sitecustomize.pl # before anything else. This script can then be set up, for example, # to add additional entries to @INC. # #USE_SITECUST = define # # uncomment to enable multiple interpreters. This is need for fork() # emulation and for thread support. # USE_MULTI = define # # Beginnings of interpreter cloning/threads; now reasonably complete. # This should be enabled to get the fork() emulation. This needs # USE_MULTI as well. # USE_ITHREADS = define # # uncomment to enable the implicit "host" layer for all system calls # made by perl. This needs USE_MULTI above. This is also needed to # get fork(). # USE_IMP_SYS = define # # Comment out next assign to disable perl's I/O subsystem and use compiler's # stdio for IO - depending on your compiler vendor and run time library you may # then get a number of fails from make test i.e. bugs - complain to them not us ;-). # You will also be unable to take full advantage of perl5.8's support for multiple # encodings and may see lower IO performance. You have been warned. USE_PERLIO = define # # Comment this out if you don't want to enable large file support for # some reason. Should normally only be changed to maintain compatibility # with an older release of perl. USE_LARGE_FILES = define # # uncomment exactly one of the following # # Visual C++ 2.x #CCTYPE = MSVC20 # Visual C++ > 2.x and < 6.x #CCTYPE = MSVC # Visual C++ 6.x (aka Visual C++ 98) CCTYPE = MSVC60 # Visual C++ Toolkit 2003 (aka Visual C++ 7.x) (free command-line tools) #CCTYPE = MSVC70FREE # Visual C++ .NET 2003 (aka Visual C++ 7.x) (full version) #CCTYPE = MSVC70 # Visual C++ 2005 Express Edition (aka Visual C++ 8.x) (free version) #CCTYPE = MSVC80FREE # Visual C++ 2005 (aka Visual C++ 8.x) (full version) #CCTYPE = MSVC80 # Visual C++ 2008 Express Edition (aka Visual C++ 9.x) (free version) #CCTYPE = MSVC90FREE # Visual C++ 2008 (aka Visual C++ 9.x) (full version) #CCTYPE = MSVC90 # # uncomment next line if you want debug version of perl (big,slow) # If not enabled, we automatically try to use maximum optimization # with all compilers that are known to have a working optimizer. # #CFG = Debug # # uncomment to enable use of PerlCRT.DLL when using the Visual C compiler. # It has patches that fix known bugs in older versions of MSVCRT.DLL. # This currently requires VC 5.0 with Service Pack 3 or later. # Get it from CPAN at http://www.cpan.org/authors/id/D/DO/DOUGL/ # and follow the directions in the package to install. # # Not recommended if you have VC 6.x and you're not running Windows 9x. # #USE_PERLCRT = define # # uncomment to enable linking with setargv.obj under the Visual C # compiler. Setting this options enables perl to expand wildcards in # arguments, but it may be harder to use alternate methods like # File::DosGlob that are more powerful. This option is supported only with # Visual C. # #USE_SETARGV = define # # if you want to have the crypt() builtin function implemented, leave this or # CRYPT_LIB uncommented. The fcrypt.c file named here contains a suitable # version of des_fcrypt(). # CRYPT_SRC = fcrypt.c # # if you didn't set CRYPT_SRC and if you have des_fcrypt() available in a # library, uncomment this, and make sure the library exists (see README.win32) # Specify the full pathname of the library. # #CRYPT_LIB = fcrypt.lib # # set this if you wish to use perl's malloc # WARNING: Turning this on/off WILL break binary compatibility with extensions # you may have compiled with/without it. Be prepared to recompile all # extensions if you change the default. Currently, this cannot be enabled # if you ask for USE_IMP_SYS above. # #PERL_MALLOC = define # # set this to enable debugging mstats # This must be enabled to use the Devel::Peek::mstat() function. This cannot # be enabled without PERL_MALLOC as well. # #DEBUG_MSTATS = define # # set this to additionally provide a statically linked perl-static.exe. # Note that dynamic loading will not work with this perl, so you must # include required modules statically using the STATIC_EXT or ALL_STATIC # variables below. A static library perl512s.lib will also be created. # Ordinary perl.exe is not affected by this option. # #BUILD_STATIC = define # # in addition to BUILD_STATIC the option ALL_STATIC makes *every* # extension get statically built # This will result in a very large perl executable, but the main purpose # is to have proper linking set so as to be able to create miscellaneous # executables with different built-in extensions # #ALL_STATIC = define # # # set the install locations of the compiler include/libraries # Running VCVARS32.BAT is *required* when using Visual C. # Some versions of Visual C don't define MSVCDIR in the environment, # so you may have to set CCHOME explicitly (spaces in the path name should # not be quoted) # #CCHOME = f:\msvc20 CCHOME = $(MSVCDIR) CCINCDIR = $(CCHOME)\include CCLIBDIR = $(CCHOME)\lib # # Additional compiler flags can be specified here. # BUILDOPT = $(BUILDOPTEXTRA) # # Adding -DPERL_HASH_SEED_EXPLICIT will disable randomization of Perl's # internal hash function unless the PERL_HASH_SEED environment variable is set. # Alternatively, adding -DNO_HASH_SEED will completely disable the # randomization feature. # The latter is required to maintain binary compatibility with Perl 5.8.0. # #BUILDOPT = $(BUILDOPT) -DPERL_HASH_SEED_EXPLICIT #BUILDOPT = $(BUILDOPT) -DNO_HASH_SEED # # This should normally be disabled. Adding -DPERL_POLLUTE enables support # for old symbols by default, at the expense of extreme pollution. You most # probably just want to build modules that won't compile with # perl Makefile.PL POLLUTE=1 # instead of enabling this. Please report such modules to the respective # authors. # #BUILDOPT = $(BUILDOPT) -DPERL_POLLUTE # # This should normally be disabled. Enabling it will disable the File::Glob # implementation of CORE::glob. # #BUILDOPT = $(BUILDOPT) -DPERL_EXTERNAL_GLOB # # This should normally be disabled. Enabling it causes perl to read scripts # in text mode (which is the 5.005 behavior) and will break ByteLoader. # #BUILDOPT = $(BUILDOPT) -DPERL_TEXTMODE_SCRIPTS # # specify semicolon-separated list of extra directories that modules will # look for libraries (spaces in path names need not be quoted) # EXTRALIBDIRS = # # set this to your email address (perl will guess a value from # from your loginname and your hostname, which may not be right) # #EMAIL = ## ## Build configuration ends. ## ##################### CHANGE THESE ONLY IF YOU MUST ##################### !IF "$(CRYPT_SRC)$(CRYPT_LIB)" == "" D_CRYPT = undef !ELSE D_CRYPT = define CRYPT_FLAG = -DHAVE_DES_FCRYPT !ENDIF !IF "$(USE_IMP_SYS)" == "define" PERL_MALLOC = undef DEBUG_MSTATS = undef !ENDIF !IF "$(PERL_MALLOC)" == "" PERL_MALLOC = undef DEBUG_MSTATS = undef !ENDIF !IF "$(DEBUG_MSTATS)" == "" DEBUG_MSTATS = undef !ENDIF !IF "$(DEBUG_MSTATS)" == "define" BUILDOPT = $(BUILDOPT) -DPERL_DEBUGGING_MSTATS !ENDIF !IF "$(USE_SITECUST)" == "" USE_SITECUST = undef !ENDIF !IF "$(USE_MULTI)" == "" USE_MULTI = undef !ENDIF !IF "$(USE_ITHREADS)" == "" USE_ITHREADS = undef !ENDIF !IF "$(USE_IMP_SYS)" == "" USE_IMP_SYS = undef !ENDIF !IF "$(USE_PERLIO)" == "" USE_PERLIO = undef !ENDIF !IF "$(USE_LARGE_FILES)" == "" USE_LARGE_FILES = undef !ENDIF !IF "$(USE_PERLCRT)" == "" USE_PERLCRT = undef !ENDIF !IF "$(USE_IMP_SYS)$(USE_MULTI)" == "defineundef" USE_MULTI = define !ENDIF !IF "$(USE_ITHREADS)$(USE_MULTI)" == "defineundef" USE_MULTI = define !ENDIF !IF "$(USE_SITECUST)" == "define" BUILDOPT = $(BUILDOPT) -DUSE_SITECUSTOMIZE !ENDIF !IF "$(USE_MULTI)" != "undef" BUILDOPT = $(BUILDOPT) -DPERL_IMPLICIT_CONTEXT !ENDIF !IF "$(USE_IMP_SYS)" != "undef" BUILDOPT = $(BUILDOPT) -DPERL_IMPLICIT_SYS !ENDIF !IF "$(PROCESSOR_ARCHITECTURE)" == "" PROCESSOR_ARCHITECTURE = x86 !ENDIF !IF "$(WIN64)" == "" # When we are running from a 32bit cmd.exe on AMD64 then # PROCESSOR_ARCHITECTURE is set to x86 and PROCESSOR_ARCHITEW6432 # is set to AMD64 !IF "$(PROCESSOR_ARCHITEW6432)" != "" PROCESSOR_ARCHITECTURE = $(PROCESSOR_ARCHITEW6432) WIN64 = define !ELSE !IF "$(PROCESSOR_ARCHITECTURE)" == "AMD64" || "$(PROCESSOR_ARCHITECTURE)" == "IA64" WIN64 = define !ELSE WIN64 = undef !ENDIF !ENDIF !ENDIF ARCHITECTURE = $(PROCESSOR_ARCHITECTURE) !IF "$(ARCHITECTURE)" == "AMD64" ARCHITECTURE = x64 !ENDIF !IF "$(ARCHITECTURE)" == "IA64" ARCHITECTURE = ia64 !ENDIF !IF "$(USE_MULTI)" == "define" ARCHNAME = MSWin32-$(ARCHITECTURE)-multi !ELSE !IF "$(USE_PERLIO)" == "define" ARCHNAME = MSWin32-$(ARCHITECTURE)-perlio !ELSE ARCHNAME = MSWin32-$(ARCHITECTURE) !ENDIF !ENDIF !IF "$(USE_PERLIO)" == "define" BUILDOPT = $(BUILDOPT) -DUSE_PERLIO !ENDIF !IF "$(USE_ITHREADS)" == "define" ARCHNAME = $(ARCHNAME)-thread !ENDIF # Visual C++ 98, .NET 2003, 2005 and 2008 specific. # VC++ 6.x, 7.x, 8.x and 9.x can load DLL's on demand. Makes the test suite run # in about 10% less time. (The free version of 7.x can't do this, but the free # versions of 8.x and 9.x can.) !IF "$(CCTYPE)" == "MSVC60" || "$(CCTYPE)" == "MSVC70" || \ "$(CCTYPE)" == "MSVC80" || "$(CCTYPE)" == "MSVC80FREE" || \ "$(CCTYPE)" == "MSVC90" || "$(CCTYPE)" == "MSVC90FREE" DELAYLOAD = -DELAYLOAD:ws2_32.dll delayimp.lib !ENDIF # Visual C++ 2005 and 2008 (VC++ 8.x and 9.x) create manifest files for EXEs and # DLLs. These either need copying everywhere with the binaries, or else need # embedding in them otherwise MSVCR80.dll or MSVCR90.dll won't be found. For # simplicity, embed them if they exist (and delete them afterwards so that they # don't get installed too). EMBED_EXE_MANI = if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;1 && \ if exist $@.manifest del $@.manifest EMBED_DLL_MANI = if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;2 && \ if exist $@.manifest del $@.manifest ARCHDIR = ..\lib\$(ARCHNAME) COREDIR = ..\lib\CORE AUTODIR = ..\lib\auto LIBDIR = ..\lib EXTDIR = ..\ext DISTDIR = ..\dist CPANDIR = ..\cpan PODDIR = ..\pod EXTUTILSDIR = $(LIBDIR)\ExtUtils HTMLDIR = .\html # INST_SCRIPT = $(INST_TOP)$(INST_VER)\bin INST_BIN = $(INST_SCRIPT)$(INST_ARCH) INST_LIB = $(INST_TOP)$(INST_VER)\lib INST_ARCHLIB = $(INST_LIB)$(INST_ARCH) INST_COREDIR = $(INST_ARCHLIB)\CORE INST_HTML = $(INST_TOP)$(INST_VER)\html # # Programs to compile, build .lib files and link # CC = cl LINK32 = link LIB32 = $(LINK32) -lib RSC = rc # # Options # INCLUDES = -I$(COREDIR) -I.\include -I. -I.. #PCHFLAGS = -Fpc:\temp\vcmoduls.pch -YX DEFINES = -DWIN32 -D_CONSOLE -DNO_STRICT $(CRYPT_FLAG) LOCDEFS = -DPERLDLL -DPERL_CORE SUBSYS = console CXX_FLAG = -TP -EHsc !IF "$(USE_PERLCRT)" != "define" LIBC = msvcrt.lib !ELSE LIBC = PerlCRT.lib !ENDIF !IF "$(CFG)" == "Debug" ! IF "$(CCTYPE)" == "MSVC20" OPTIMIZE = -Od -MD -Z7 -DDEBUGGING ! ELSE OPTIMIZE = -Od -MD -Zi -DDEBUGGING ! ENDIF LINK_DBG = -debug !ELSE OPTIMIZE = -MD -Zi -DNDEBUG # we enable debug symbols in release builds also LINK_DBG = -debug -opt:ref,icf # you may want to enable this if you want COFF symbols in the executables # in addition to the PDB symbols. The default Dr. Watson that ships with # Windows can use the the former but not latter. The free WinDbg can be # installed to get better stack traces from just the PDB symbols, so we # avoid the bloat of COFF symbols by default. #LINK_DBG = $(LINK_DBG) -debugtype:both ! IF "$(WIN64)" == "define" # enable Whole Program Optimizations (WPO) and Link Time Code Generation (LTCG) OPTIMIZE = $(OPTIMIZE) -Ox -GL LINK_DBG = $(LINK_DBG) -ltcg ! ELSE # -O1 yields smaller code, which turns out to be faster than -O2 on x86 OPTIMIZE = $(OPTIMIZE) -O1 #OPTIMIZE = $(OPTIMIZE) -O2 ! ENDIF !ENDIF !IF "$(WIN64)" == "define" DEFINES = $(DEFINES) -DWIN64 -DCONSERVATIVE OPTIMIZE = $(OPTIMIZE) -Wp64 -fp:precise !ENDIF # For now, silence VC++ 8.x's and 9.x's warnings about "unsafe" CRT functions # and POSIX CRT function names being deprecated. !IF "$(CCTYPE)" == "MSVC80" || "$(CCTYPE)" == "MSVC80FREE" || \ "$(CCTYPE)" == "MSVC90" || "$(CCTYPE)" == "MSVC90FREE" DEFINES = $(DEFINES) -D_CRT_SECURE_NO_DEPRECATE -D_CRT_NONSTDC_NO_DEPRECATE !ENDIF # Use the MSVCRT read() fix if the PerlCRT was not chosen, but only when using # VC++ 6.x or earlier. Later versions use MSVCR70.dll, MSVCR71.dll, etc, which # do not require the fix. !IF "$(CCTYPE)" == "MSVC20" || "$(CCTYPE)" == "MSVC" || "$(CCTYPE)" == "MSVC60" ! IF "$(USE_PERLCRT)" != "define" BUILDOPT = $(BUILDOPT) -DPERL_MSVCRT_READFIX ! ENDIF !ENDIF LIBBASEFILES = $(CRYPT_LIB) \ oldnames.lib kernel32.lib user32.lib gdi32.lib winspool.lib \ comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib \ netapi32.lib uuid.lib ws2_32.lib mpr.lib winmm.lib \ version.lib odbc32.lib odbccp32.lib comctl32.lib # The 64 bit Platform SDK compilers contain a runtime library that doesn't # include the buffer overrun verification code used by the /GS switch. # Since the code links against libraries that are compiled with /GS, this # "security cookie verification" must be included via bufferoverlow.lib. !IF "$(WIN64)" == "define" LIBBASEFILES = $(LIBBASEFILES) bufferoverflowU.lib !ENDIF # we add LIBC here, since we may be using PerlCRT.dll LIBFILES = $(LIBBASEFILES) $(LIBC) #EXTRACFLAGS = -nologo -GF -W4 -wd4127 -wd4706 EXTRACFLAGS = -nologo -GF -W3 CFLAGS = $(EXTRACFLAGS) $(INCLUDES) $(DEFINES) $(LOCDEFS) \ $(PCHFLAGS) $(OPTIMIZE) LINK_FLAGS = -nologo -nodefaultlib $(LINK_DBG) \ -libpath:"$(INST_COREDIR)" \ -machine:$(PROCESSOR_ARCHITECTURE) LIB_FLAGS = -nologo OBJOUT_FLAG = -Fo EXEOUT_FLAG = -Fe CFLAGS_O = $(CFLAGS) $(BUILDOPT) !IF "$(CCTYPE)" == "MSVC80" || "$(CCTYPE)" == "MSVC80FREE" || \ "$(CCTYPE)" == "MSVC90" || "$(CCTYPE)" == "MSVC90FREE" LINK_FLAGS = $(LINK_FLAGS) "/manifestdependency:type='Win32' name='Microsoft.Windows.Common-Controls' version='6.0.0.0' processorArchitecture='*' publicKeyToken='6595b64144ccf1df' language='*'" !ELSE RSC_FLAGS = -DINCLUDE_MANIFEST !ENDIF #################### do not edit below this line ####################### ############# NO USER-SERVICEABLE PARTS BEYOND THIS POINT ############## o = .obj # # Rules # .SUFFIXES : .c $(o) .dll .lib .exe .rc .res .c$(o): $(CC) -c -I$( ..\config.sh # this target is for when changes to the main config.sh happen. # edit config.vc, then make perl in a minimal configuration (i.e. with MULTI, # ITHREADS, IMP_SYS, LARGE_FILES, PERLIO and CRYPT off), then make this target # to regenerate config_H.vc. # repeat for config.vc64 and config_H.vc64 if you have a suitable build # environment, otherwise hand-edit them to maintain the same differences with # config.vc and config_H.vc as before. # unfortunately, some further manual editing is also then required to restore all # the special __GNUC__ handling that is otherwise lost. regen_config_h: $(MINIPERL) -I..\lib config_sh.PL $(CFG_VARS) $(CFGSH_TMPL) > ..\config.sh $(MINIPERL) -I..\lib ..\configpm --chdir=.. -del /f $(CFGH_TMPL) -$(MINIPERL) -I..\lib $(ICWD) config_h.PL "INST_VER=$(INST_VER)" rename config.h $(CFGH_TMPL) $(CONFIGPM) : $(MINIPERL) ..\config.sh config_h.PL ..\minimod.pl $(MINIPERL) -I..\lib ..\configpm --chdir=.. if exist lib\* $(RCOPY) lib\*.* ..\lib\$(NULL) $(XCOPY) ..\*.h $(COREDIR)\*.* $(XCOPY) *.h $(COREDIR)\*.* $(XCOPY) ..\ext\re\re.pm $(LIBDIR)\*.* $(RCOPY) include $(COREDIR)\*.* -$(MINIPERL) -I..\lib $(ICWD) config_h.PL "INST_VER=$(INST_VER)" if errorlevel 1 $(MAKE) /$(MAKEFLAGS) $(CONFIGPM) $(MINIPERL) : $(MINIDIR) $(MINI_OBJ) $(LINK32) -subsystem:console -out:$@ @<< $(LINK_FLAGS) $(LIBFILES) $(MINI_OBJ) << $(EMBED_EXE_MANI) $(MINIDIR) : if not exist "$(MINIDIR)" mkdir "$(MINIDIR)" $(MINICORE_OBJ) : $(CORE_NOCFG_H) $(CC) -c $(CFLAGS) -DPERL_EXTERNAL_GLOB -DPERL_IS_MINIPERL $(OBJOUT_FLAG)$@ ..\$(*F).c $(MINIWIN32_OBJ) : $(CORE_NOCFG_H) $(CC) -c $(CFLAGS) $(OBJOUT_FLAG)$@ $(*F).c # -DPERL_IMPLICIT_SYS needs C++ for perllib.c # This is the only file that depends on perlhost.h, vmem.h, and vdir.h !IF "$(USE_IMP_SYS)" == "define" perllib$(o) : perllib.c .\perlhost.h .\vdir.h .\vmem.h $(CC) -c -I. $(CFLAGS_O) $(CXX_FLAG) $(OBJOUT_FLAG)$@ perllib.c !ENDIF # 1. we don't want to rebuild miniperl.exe when config.h changes # 2. we don't want to rebuild miniperl.exe with non-default config.h # 3. we can't have miniperl.exe depend on git_version.h, as miniperl creates it $(MINI_OBJ) : $(CORE_NOCFG_H) $(WIN32_OBJ) : $(CORE_H) $(CORE_OBJ) : $(CORE_H) $(DLL_OBJ) : $(CORE_H) $(X2P_OBJ) : $(CORE_H) perldll.def : $(MINIPERL) $(CONFIGPM) ..\global.sym ..\pp.sym ..\makedef.pl create_perllibst_h.pl $(MINIPERL) -I..\lib create_perllibst_h.pl $(MINIPERL) -I..\lib -w ..\makedef.pl PLATFORM=win32 $(OPTIMIZE) $(DEFINES) $(BUILDOPT) \ CCTYPE=$(CCTYPE) > perldll.def $(PERLDLL): perldll.def $(PERLDLL_OBJ) $(PERLDLL_RES) Extensions_static $(LINK32) -dll -def:perldll.def -base:0x28000000 -out:$@ @Extensions_static @<< $(LINK_FLAGS) $(DELAYLOAD) $(LIBFILES) $(PERLDLL_OBJ) $(PERLDLL_RES) << $(EMBED_DLL_MANI) $(XCOPY) $(PERLIMPLIB) $(COREDIR) $(PERLSTATICLIB): Extensions_static $(LIB32) $(LIB_FLAGS) -out:$@ @Extensions_static @<< $(PERLDLL_OBJ) << $(XCOPY) $(PERLSTATICLIB) $(COREDIR) $(PERLEXE_RES): perlexe.rc $(PERLEXE_MANIFEST) $(PERLEXE_ICO) $(MINIMOD) : $(MINIPERL) ..\minimod.pl cd .. miniperl minimod.pl > lib\ExtUtils\Miniperl.pm cd win32 ..\x2p\a2p$(o) : ..\x2p\a2p.c $(CC) -I..\x2p $(CFLAGS) $(OBJOUT_FLAG)$@ -c ..\x2p\a2p.c ..\x2p\hash$(o) : ..\x2p\hash.c $(CC) -I..\x2p $(CFLAGS) $(OBJOUT_FLAG)$@ -c ..\x2p\hash.c ..\x2p\str$(o) : ..\x2p\str.c $(CC) -I..\x2p $(CFLAGS) $(OBJOUT_FLAG)$@ -c ..\x2p\str.c ..\x2p\util$(o) : ..\x2p\util.c $(CC) -I..\x2p $(CFLAGS) $(OBJOUT_FLAG)$@ -c ..\x2p\util.c ..\x2p\walk$(o) : ..\x2p\walk.c $(CC) -I..\x2p $(CFLAGS) $(OBJOUT_FLAG)$@ -c ..\x2p\walk.c $(X2P) : $(MINIPERL) $(X2P_OBJ) Extensions $(MINIPERL) -I..\lib ..\x2p\find2perl.PL $(MINIPERL) -I..\lib ..\x2p\s2p.PL $(LINK32) -subsystem:console -out:$@ @<< $(LINK_FLAGS) $(LIBFILES) $(X2P_OBJ) << $(EMBED_EXE_MANI) $(MINIDIR)\globals$(o) : $(UUDMAP_H) $(BITCOUNT_H) $(UUDMAP_H) $(BITCOUNT_H) : $(GENUUDMAP) $(GENUUDMAP) $(UUDMAP_H) $(BITCOUNT_H) $(GENUUDMAP) : $(GENUUDMAP_OBJ) $(LINK32) -subsystem:console -out:$@ @<< $(LINK_FLAGS) $(LIBFILES) $(GENUUDMAP_OBJ) << $(EMBED_EXE_MANI) perlmain.c : runperl.c copy runperl.c perlmain.c perlmain$(o) : perlmain.c $(CC) $(CFLAGS_O:-DPERLDLL=-UPERLDLL) $(OBJOUT_FLAG)$@ -c perlmain.c perlmainst.c : runperl.c copy runperl.c perlmainst.c perlmainst$(o) : perlmainst.c $(CC) $(CFLAGS_O) $(OBJOUT_FLAG)$@ -c perlmainst.c $(PERLEXE): $(PERLDLL) $(CONFIGPM) $(PERLEXE_OBJ) $(PERLEXE_RES) $(LINK32) -subsystem:console -out:$@ -stack:0x1000000 $(LINK_FLAGS) \ $(LIBFILES) $(PERLEXE_OBJ) $(SETARGV_OBJ) $(PERLIMPLIB) $(PERLEXE_RES) $(EMBED_EXE_MANI) copy $(PERLEXE) $(WPERLEXE) $(MINIPERL) -I..\lib bin\exetype.pl $(WPERLEXE) WINDOWS $(PERLEXESTATIC): $(PERLSTATICLIB) $(CONFIGPM) $(PERLEXEST_OBJ) $(PERLEXE_RES) $(LINK32) -subsystem:console -out:$@ -stack:0x1000000 $(LINK_FLAGS) \ @Extensions_static $(PERLSTATICLIB) /PDB:NONE \ $(LIBFILES) $(PERLEXEST_OBJ) $(SETARGV_OBJ) $(PERLEXE_RES) $(EMBED_EXE_MANI) MakePPPort: $(MINIPERL) $(CONFIGPM) Extensions_nonxs $(MINIPERL) -I..\lib $(ICWD) ..\mkppport #------------------------------------------------------------------------------- # There's no direct way to mark a dependency on # DynaLoader.pm, so this will have to do Extensions: ..\make_ext.pl $(PERLDEP) $(CONFIGPM) $(DYNALOADER) $(XCOPY) ..\*.h $(COREDIR)\*.* $(MINIPERL) -I..\lib ..\make_ext.pl "MAKE=$(MAKE)" --dir=$(CPANDIR) --dir=$(DISTDIR) --dir=$(EXTDIR) --dynamic Extensions_reonly: ..\make_ext.pl $(PERLDEP) $(CONFIGPM) $(DYNALOADER) $(XCOPY) ..\*.h $(COREDIR)\*.* $(MINIPERL) -I..\lib ..\make_ext.pl "MAKE=$(MAKE)" --dir=$(CPANDIR) --dir=$(DISTDIR) --dir=$(EXTDIR) --dynamic +re Extensions_static : ..\make_ext.pl list_static_libs.pl $(PERLDEP) $(CONFIGPM) $(XCOPY) ..\*.h $(COREDIR)\*.* $(MINIPERL) -I..\lib ..\make_ext.pl "MAKE=$(MAKE)" --dir=$(CPANDIR) --dir=$(DISTDIR) --dir=$(EXTDIR) --static $(MINIPERL) -I..\lib list_static_libs.pl > Extensions_static Extensions_nonxs: ..\make_ext.pl $(PERLDEP) $(CONFIGPM) $(XCOPY) ..\*.h $(COREDIR)\*.* $(MINIPERL) -I..\lib ..\make_ext.pl "MAKE=$(MAKE)" --dir=$(CPANDIR) --dir=$(DISTDIR) --dir=$(EXTDIR) --nonxs $(DYNALOADER) : ..\make_ext.pl $(PERLDEP) $(CONFIGPM) Extensions_nonxs $(XCOPY) ..\*.h $(COREDIR)\*.* $(MINIPERL) -I..\lib ..\make_ext.pl "MAKE=$(MAKE)" --dir=$(EXTDIR) --dynaloader Extensions_clean: -if exist $(MINIPERL) $(MINIPERL) -I..\lib ..\make_ext.pl "MAKE=$(MAKE)" --dir=$(CPANDIR) --dir=$(DISTDIR) --dir=$(EXTDIR) --all --target=clean Extensions_realclean: -if exist $(MINIPERL) $(MINIPERL) -I..\lib ..\make_ext.pl "MAKE=$(MAKE)" --dir=$(CPANDIR) --dir=$(DISTDIR) --dir=$(EXTDIR) --all --target=realclean #------------------------------------------------------------------------------- doc: $(PERLEXE) ..\pod\perltoc.pod $(PERLEXE) -I..\lib ..\installhtml --podroot=.. --htmldir=$(HTMLDIR) \ --podpath=pod:lib:ext:utils --htmlroot="file://$(INST_HTML::=|)" \ --libpod=perlfunc:perlguts:perlvar:perlrun:perlop --recurse # Note that this next section is parsed (and regenerated) by pod/buildtoc # so please check that script before making structural changes here utils: $(PERLEXE) $(X2P) cd ..\utils $(MAKE) PERL=$(MINIPERL) cd ..\pod copy ..\README.aix ..\pod\perlaix.pod copy ..\README.amiga ..\pod\perlamiga.pod copy ..\README.apollo ..\pod\perlapollo.pod copy ..\README.beos ..\pod\perlbeos.pod copy ..\README.bs2000 ..\pod\perlbs2000.pod copy ..\README.ce ..\pod\perlce.pod copy ..\README.cn ..\pod\perlcn.pod copy ..\README.cygwin ..\pod\perlcygwin.pod copy ..\README.dgux ..\pod\perldgux.pod copy ..\README.dos ..\pod\perldos.pod copy ..\README.epoc ..\pod\perlepoc.pod copy ..\README.freebsd ..\pod\perlfreebsd.pod copy ..\README.haiku ..\pod\perlhaiku.pod copy ..\README.hpux ..\pod\perlhpux.pod copy ..\README.hurd ..\pod\perlhurd.pod copy ..\README.irix ..\pod\perlirix.pod copy ..\README.jp ..\pod\perljp.pod copy ..\README.ko ..\pod\perlko.pod copy ..\README.linux ..\pod\perllinux.pod copy ..\README.macos ..\pod\perlmacos.pod copy ..\README.macosx ..\pod\perlmacosx.pod copy ..\README.mpeix ..\pod\perlmpeix.pod copy ..\README.netware ..\pod\perlnetware.pod copy ..\README.openbsd ..\pod\perlopenbsd.pod copy ..\README.os2 ..\pod\perlos2.pod copy ..\README.os390 ..\pod\perlos390.pod copy ..\README.os400 ..\pod\perlos400.pod copy ..\README.plan9 ..\pod\perlplan9.pod copy ..\README.qnx ..\pod\perlqnx.pod copy ..\README.riscos ..\pod\perlriscos.pod copy ..\README.solaris ..\pod\perlsolaris.pod copy ..\README.symbian ..\pod\perlsymbian.pod copy ..\README.tru64 ..\pod\perltru64.pod copy ..\README.tw ..\pod\perltw.pod copy ..\README.uts ..\pod\perluts.pod copy ..\README.vmesa ..\pod\perlvmesa.pod copy ..\README.vos ..\pod\perlvos.pod copy ..\README.win32 ..\pod\perlwin32.pod copy ..\pod\perl5116delta.pod ..\pod\perldelta.pod $(MAKE) -f ..\win32\pod.mak converters cd ..\win32 $(PERLEXE) $(PL2BAT) $(UTILS) $(PERLEXE) $(ICWD) ..\autodoc.pl .. $(PERLEXE) $(ICWD) ..\pod\perlmodlib.pl -q ..\pod\perltoc.pod: $(PERLEXE) Extensions Extensions_nonxs $(PERLEXE) -f ..\pod\buildtoc --build-toc -q # Note that the pod cleanup in this next section is parsed (and regenerated # by pod/buildtoc so please check that script before making changes here distclean: realclean -del /f $(MINIPERL) $(PERLEXE) $(PERLDLL) $(GLOBEXE) \ $(PERLIMPLIB) ..\miniperl.lib $(MINIMOD) \ $(PERLEXESTATIC) $(PERLSTATICLIB) -del /f *.def *.map -del /f $(LIBDIR)\Encode.pm $(LIBDIR)\encoding.pm $(LIBDIR)\Errno.pm -del /f $(LIBDIR)\Config.pod $(LIBDIR)\POSIX.pod $(LIBDIR)\threads.pm -del /f $(LIBDIR)\.exists $(LIBDIR)\attributes.pm $(LIBDIR)\DynaLoader.pm -del /f $(LIBDIR)\Fcntl.pm $(LIBDIR)\IO.pm $(LIBDIR)\Opcode.pm -del /f $(LIBDIR)\ops.pm $(LIBDIR)\Safe.pm -del /f $(LIBDIR)\SDBM_File.pm $(LIBDIR)\Socket.pm $(LIBDIR)\POSIX.pm -del /f $(LIBDIR)\B.pm $(LIBDIR)\O.pm $(LIBDIR)\re.pm -del /f $(LIBDIR)\File\Glob.pm -del /f $(LIBDIR)\Storable.pm -del /f $(LIBDIR)\Sys\Hostname.pm -del /f $(LIBDIR)\Time\HiRes.pm -del /f $(LIBDIR)\Unicode\Normalize.pm -del /f $(LIBDIR)\Math\BigInt\FastCalc.pm -del /f $(LIBDIR)\Win32.pm -del /f $(LIBDIR)\Win32CORE.pm -del /f $(LIBDIR)\Win32API\File.pm -del /f $(LIBDIR)\Win32API\File\cFile.pc -del /f $(DISTDIR)\XSLoader\XSLoader.pm -if exist $(LIBDIR)\App rmdir /s /q $(LIBDIR)\App -if exist $(LIBDIR)\Archive rmdir /s /q $(LIBDIR)\Archive -if exist $(LIBDIR)\Attribute rmdir /s /q $(LIBDIR)\Attribute -if exist $(LIBDIR)\autodie rmdir /s /q $(LIBDIR)\autodie -if exist $(LIBDIR)\B rmdir /s /q $(LIBDIR)\B -if exist $(LIBDIR)\CGI rmdir /s /q $(LIBDIR)\CGI -if exist $(LIBDIR)\CPAN rmdir /s /q $(LIBDIR)\CPAN -if exist $(LIBDIR)\CPANPLUS rmdir /s /q $(LIBDIR)\CPANPLUS -if exist $(LIBDIR)\Compress rmdir /s /q $(LIBDIR)\Compress -if exist $(LIBDIR)\Data rmdir /s /q $(LIBDIR)\Data -if exist $(LIBDIR)\Devel rmdir /s /q $(LIBDIR)\Devel -if exist $(LIBDIR)\Digest rmdir /s /q $(LIBDIR)\Digest -if exist $(LIBDIR)\Encode rmdir /s /q $(LIBDIR)\Encode -if exist $(LIBDIR)\encoding rmdir /s /q $(LIBDIR)\encoding -if exist $(LIBDIR)\ExtUtils\CBuilder rmdir /s /q $(LIBDIR)\ExtUtils\CBuilder -if exist $(LIBDIR)\ExtUtils\Command rmdir /s /q $(LIBDIR)\ExtUtils\Command -if exist $(LIBDIR)\ExtUtils\Constant rmdir /s /q $(LIBDIR)\ExtUtils\Constant -if exist $(LIBDIR)\ExtUtils\Liblist rmdir /s /q $(LIBDIR)\ExtUtils\Liblist -if exist $(LIBDIR)\ExtUtils\MakeMaker rmdir /s /q $(LIBDIR)\ExtUtils\MakeMaker -if exist $(LIBDIR)\File\Spec rmdir /s /q $(LIBDIR)\File\Spec -if exist $(LIBDIR)\Filter rmdir /s /q $(LIBDIR)\Filter -if exist $(LIBDIR)\Hash rmdir /s /q $(LIBDIR)\Hash -if exist $(LIBDIR)\I18N\LangTags rmdir /s /q $(LIBDIR)\I18N\LangTags -if exist $(LIBDIR)\inc rmdir /s /q $(LIBDIR)\inc -if exist $(LIBDIR)\Module\Pluggable rmdir /s /q $(LIBDIR)\Module\Pluggable -if exist $(LIBDIR)\IO rmdir /s /q $(LIBDIR)\IO -if exist $(LIBDIR)\IPC rmdir /s /q $(LIBDIR)\IPC -if exist $(LIBDIR)\List rmdir /s /q $(LIBDIR)\List -if exist $(LIBDIR)\Locale rmdir /s /q $(LIBDIR)\Locale -if exist $(LIBDIR)\Log rmdir /s /q $(LIBDIR)\Log -if exist $(LIBDIR)\Math rmdir /s /q $(LIBDIR)\Math -if exist $(LIBDIR)\Memoize rmdir /s /q $(LIBDIR)\Memoize -if exist $(LIBDIR)\MIME rmdir /s /q $(LIBDIR)\MIME -if exist $(LIBDIR)\Module rmdir /s /q $(LIBDIR)\Module -if exist $(LIBDIR)\mro rmdir /s /q $(LIBDIR)\mro -if exist $(LIBDIR)\Net\FTP rmdir /s /q $(LIBDIR)\Net\FTP -if exist $(LIBDIR)\Object rmdir /s /q $(LIBDIR)\Object -if exist $(LIBDIR)\Package rmdir /s /q $(LIBDIR)\Package -if exist $(LIBDIR)\Params rmdir /s /q $(LIBDIR)\Params -if exist $(LIBDIR)\Parse rmdir /s /q $(LIBDIR)\Parse -if exist $(LIBDIR)\PerlIO rmdir /s /q $(LIBDIR)\PerlIO -if exist $(LIBDIR)\Pod\Perldoc rmdir /s /q $(LIBDIR)\Pod\Perldoc -if exist $(LIBDIR)\Pod\Simple rmdir /s /q $(LIBDIR)\Pod\Simple -if exist $(LIBDIR)\Pod\Text rmdir /s /q $(LIBDIR)\Pod\Text -if exist $(LIBDIR)\re rmdir /s /q $(LIBDIR)\re -if exist $(LIBDIR)\Scalar rmdir /s /q $(LIBDIR)\Scalar -if exist $(LIBDIR)\Sys rmdir /s /q $(LIBDIR)\Sys -if exist $(LIBDIR)\TAP rmdir /s /q $(LIBDIR)\TAP -if exist $(LIBDIR)\Term\UI rmdir /s /q $(LIBDIR)\Term\UI -if exist $(LIBDIR)\Test rmdir /s /q $(LIBDIR)\Test -if exist $(LIBDIR)\Thread rmdir /s /q $(LIBDIR)\Thread -if exist $(LIBDIR)\threads rmdir /s /q $(LIBDIR)\threads -if exist $(LIBDIR)\Unicode\Collate rmdir /s /q $(LIBDIR)\Unicode\Collate -if exist $(LIBDIR)\XS rmdir /s /q $(LIBDIR)\XS -if exist $(LIBDIR)\Win32API rmdir /s /q $(LIBDIR)\Win32API -cd $(PODDIR) && del /f *.html *.bat \ perlaix.pod perlamiga.pod perlapi.pod perlapollo.pod \ perlbeos.pod perlbs2000.pod perlce.pod perlcn.pod \ perlcygwin.pod perldelta.pod perldgux.pod perldos.pod \ perlepoc.pod perlfreebsd.pod perlhaiku.pod perlhpux.pod \ perlhurd.pod perlintern.pod perlirix.pod perljp.pod perlko.pod \ perllinux.pod perlmacos.pod perlmacosx.pod perlmodlib.pod \ perlmpeix.pod perlnetware.pod perlopenbsd.pod perlos2.pod \ perlos390.pod perlos400.pod perlplan9.pod perlqnx.pod \ perlriscos.pod perlsolaris.pod perlsymbian.pod perltoc.pod \ perltru64.pod perltw.pod perluniprops.pod perluts.pod \ perlvmesa.pod perlvos.pod perlwin32.pod \ pod2html pod2latex pod2man pod2text pod2usage \ podchecker podselect -cd ..\utils && del /f h2ph splain perlbug pl2pm c2ph pstruct h2xs \ perldoc perlivp dprofpp libnetcfg enc2xs piconv cpan *.bat \ xsubpp instmodsh prove ptar ptardiff cpanp-run-perl cpanp cpan2dist shasum corelist config_data -cd ..\x2p && del /f find2perl s2p psed *.bat -del /f ..\config.sh perlmain.c dlutils.c config.h.new \ perlmainst.c -del /f $(CONFIGPM) -del /f ..\lib\Config_git.pl -del /f bin\*.bat -del /f perllibst.h -del /f $(PERLEXE_RES) perl.base -cd .. && del /s *.lib *.map *.pdb *.ilk *.bs *$(o) .exists pm_to_blib ppport.h -cd $(EXTDIR) && del /s *.def Makefile Makefile.old -cd $(DISTDIR) && del /s *.def Makefile Makefile.old -cd $(CPANDIR) && del /s *.def Makefile Makefile.old -if exist $(AUTODIR) rmdir /s /q $(AUTODIR) -if exist $(COREDIR) rmdir /s /q $(COREDIR) -if exist pod2htmd.tmp del pod2htmd.tmp -if exist pod2htmi.tmp del pod2htmi.tmp -if exist $(HTMLDIR) rmdir /s /q $(HTMLDIR) -del /f ..\t\test_state install : all installbare installhtml installbare : utils ..\pod\perltoc.pod $(PERLEXE) ..\installperl if exist $(WPERLEXE) $(XCOPY) $(WPERLEXE) $(INST_BIN)\*.* if exist $(PERLEXESTATIC) $(XCOPY) $(PERLEXESTATIC) $(INST_BIN)\*.* $(XCOPY) $(GLOBEXE) $(INST_BIN)\*.* if exist ..\perl*.pdb $(XCOPY) ..\perl*.pdb $(INST_BIN)\*.* if exist ..\x2p\a2p.pdb $(XCOPY) ..\x2p\a2p.pdb $(INST_BIN)\*.* $(XCOPY) bin\*.bat $(INST_SCRIPT)\*.* installhtml : doc $(RCOPY) $(HTMLDIR)\*.* $(INST_HTML)\*.* inst_lib : $(CONFIGPM) $(RCOPY) ..\lib $(INST_LIB)\*.* $(UNIDATAFILES) ..\pod\perluniprops.pod : $(MINIPERL) $(CONFIGPM) ..\lib\unicore\mktables Extensions_nonxs cd ..\lib\unicore && \ ..\$(MINIPERL) -I.. -I..\..\cpan\Cwd\lib -I..\..\cpan\Cwd mktables -P ..\..\pod -maketest -makelist -p -check $@ $(FIRSTUNIFILE) minitest : $(MINIPERL) $(GLOBEXE) $(CONFIGPM) utils $(UNIDATAFILES) $(XCOPY) $(MINIPERL) ..\t\$(NULL) if exist ..\t\perl.exe del /f ..\t\perl.exe rename ..\t\miniperl.exe perl.exe $(XCOPY) $(GLOBEXE) ..\t\$(NULL) attrib -r ..\t\*.* cd ..\t && \ $(MINIPERL) -I..\lib harness base/*.t comp/*.t cmd/*.t io/*.t op/*.t pragma/*.t test-prep : all utils $(XCOPY) $(PERLEXE) ..\t\$(NULL) $(XCOPY) $(PERLDLL) ..\t\$(NULL) $(XCOPY) $(GLOBEXE) ..\t\$(NULL) test : test-prep cd ..\t $(PERLEXE) -I..\lib harness $(TEST_SWITCHES) $(TEST_FILES) cd ..\win32 test-reonly : reonly utils $(XCOPY) $(PERLEXE) ..\t\$(NULL) $(XCOPY) $(PERLDLL) ..\t\$(NULL) $(XCOPY) $(GLOBEXE) ..\t\$(NULL) cd ..\t $(PERLEXE) -I..\lib harness $(OPT) -re \bre\\/ $(EXTRA) cd ..\win32 regen : cd .. regen.pl cd win32 test-notty : test-prep set PERL_SKIP_TTY_TEST=1 cd ..\t $(PERLEXE) -I..\lib harness $(TEST_SWITCHES) $(TEST_FILES) cd ..\win32 _test : $(XCOPY) $(PERLEXE) ..\t\$(NULL) $(XCOPY) $(PERLDLL) ..\t\$(NULL) $(XCOPY) $(GLOBEXE) ..\t\$(NULL) cd ..\t $(PERLEXE) -I..\lib harness $(TEST_SWITCHES) $(TEST_FILES) cd ..\win32 _clean : -@$(DEL) miniperlmain$(o) -@$(DEL) $(MINIPERL) -@$(DEL) perlglob$(o) -@$(DEL) perlmain$(o) -@$(DEL) perlmainst$(o) -@$(DEL) config.w32 -@$(DEL) config.h -@$(DEL) ..\git_version.h -@$(DEL) $(GLOBEXE) -@$(DEL) $(PERLEXE) -@$(DEL) $(WPERLEXE) -@$(DEL) $(PERLEXESTATIC) -@$(DEL) $(PERLSTATICLIB) -@$(DEL) $(PERLDLL) -@$(DEL) $(CORE_OBJ) -@$(DEL) $(GENUUDMAP) $(GENUUDMAP_OBJ) $(UUDMAP_H) $(BITCOUNT_H) -if exist $(MINIDIR) rmdir /s /q $(MINIDIR) -if exist $(UNIDATADIR1) rmdir /s /q $(UNIDATADIR1) -if exist $(UNIDATADIR2) rmdir /s /q $(UNIDATADIR2) -@$(DEL) $(UNIDATAFILES) -@$(DEL) $(WIN32_OBJ) -@$(DEL) $(DLL_OBJ) -@$(DEL) $(X2P_OBJ) -@$(DEL) ..\*$(o) ..\*.lib ..\*.exp *$(o) *.lib *.exp *.res -@$(DEL) ..\t\*.exe ..\t\*.dll ..\t\*.bat -@$(DEL) ..\x2p\*.exe ..\x2p\*.bat -@$(DEL) *.ilk -@$(DEL) *.pdb -@$(DEL) Extensions_static clean : Extensions_clean _clean realclean : Extensions_realclean _clean # Handy way to run perlbug -ok without having to install and run the # installed perlbug. We don't re-run the tests here - we trust the user. # Please *don't* use this unless all tests pass. # If you want to report test failures, use "nmake nok" instead. ok: utils $(PERLEXE) -I..\lib ..\utils\perlbug -ok -s "(UNINSTALLED)" okfile: utils $(PERLEXE) -I..\lib ..\utils\perlbug -ok -s "(UNINSTALLED)" -F perl.ok nok: utils $(PERLEXE) -I..\lib ..\utils\perlbug -nok -s "(UNINSTALLED)" nokfile: utils $(PERLEXE) -I..\lib ..\utils\perlbug -nok -s "(UNINSTALLED)" -F perl.nok perl-5.12.0-RC0/win32/win32io.c0000444000175000017500000001667711325125742014550 0ustar jessejesse#define PERL_NO_GET_CONTEXT #define WIN32_LEAN_AND_MEAN #define WIN32IO_IS_STDIO #include #ifdef __GNUC__ #define Win32_Winsock #endif #include #include #include "EXTERN.h" #include "perl.h" #ifdef PERLIO_LAYERS #include "perliol.h" #define NO_XSLOCKS #include "XSUB.h" /* Bottom-most level for Win32 case */ typedef struct { struct _PerlIO base; /* The generic part */ HANDLE h; /* OS level handle */ IV refcnt; /* REFCNT for the "fd" this represents */ int fd; /* UNIX like file descriptor - index into fdtable */ } PerlIOWin32; PerlIOWin32 *fdtable[256]; IV max_open_fd = -1; IV PerlIOWin32_popped(pTHX_ PerlIO *f) { PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32); if (--s->refcnt > 0) { *f = PerlIOBase(f)->next; return 1; } fdtable[s->fd] = NULL; return 0; } IV PerlIOWin32_fileno(pTHX_ PerlIO *f) { return PerlIOSelf(f,PerlIOWin32)->fd; } IV PerlIOWin32_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) { IV code = PerlIOBase_pushed(aTHX_ f,mode,arg,tab); if (*PerlIONext(f)) { PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32); s->fd = PerlIO_fileno(PerlIONext(f)); } PerlIOBase(f)->flags |= PERLIO_F_OPEN; return code; } PerlIO * PerlIOWin32_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) { const char *tmode = mode; HANDLE h = INVALID_HANDLE_VALUE; if (f) { /* Close if already open */ if (PerlIOBase(f)->flags & PERLIO_F_OPEN) (*PerlIOBase(f)->tab->Close)(aTHX_ f); } if (narg > 0) { char *path = SvPV_nolen(*args); DWORD access = 0; DWORD share = 0; DWORD create = -1; DWORD attr = FILE_ATTRIBUTE_NORMAL; if (*mode == '#') { /* sysopen - imode is UNIX-like O_RDONLY etc. - do_open has converted that back to string form in mode as well - perm is UNIX like permissions */ mode++; } else { /* Normal open - decode mode string */ } switch(*mode) { case 'r': access = GENERIC_READ; create = OPEN_EXISTING; if (*++mode == '+') { access |= GENERIC_WRITE; create = OPEN_ALWAYS; mode++; } break; case 'w': access = GENERIC_WRITE; create = TRUNCATE_EXISTING; if (*++mode == '+') { access |= GENERIC_READ; mode++; } break; case 'a': access = GENERIC_WRITE; create = OPEN_ALWAYS; if (*++mode == '+') { access |= GENERIC_READ; mode++; } break; } if (*mode == 'b') { mode++; } else if (*mode == 't') { mode++; } if (*mode || create == -1) { SETERRNO(EINVAL,LIB$_INVARG); return NULL; } if (!(access & GENERIC_WRITE)) share = FILE_SHARE_READ; h = CreateFile(path,access,share,NULL,create,attr,NULL); if (h == INVALID_HANDLE_VALUE) { if (create == TRUNCATE_EXISTING) h = CreateFile(path,access,share,NULL,(create = OPEN_ALWAYS),attr,NULL); } } else { /* fd open */ h = INVALID_HANDLE_VALUE; if (fd >= 0 && fd <= max_open_fd) { PerlIOWin32 *s = fdtable[fd]; if (s) { s->refcnt++; if (!f) f = PerlIO_allocate(aTHX); *f = &s->base; return f; } } if (*mode == 'I') { mode++; switch(fd) { case 0: h = GetStdHandle(STD_INPUT_HANDLE); break; case 1: h = GetStdHandle(STD_OUTPUT_HANDLE); break; case 2: h = GetStdHandle(STD_ERROR_HANDLE); break; } } } if (h != INVALID_HANDLE_VALUE) fd = win32_open_osfhandle((intptr_t) h, PerlIOUnix_oflags(tmode)); if (fd >= 0) { PerlIOWin32 *s; if (!f) f = PerlIO_allocate(aTHX); s = PerlIOSelf(PerlIO_push(aTHX_ f,self,tmode,PerlIOArg),PerlIOWin32); s->h = h; s->fd = fd; s->refcnt = 1; if (fd >= 0) { fdtable[fd] = s; if (fd > max_open_fd) max_open_fd = fd; } return f; } if (f) { /* FIXME: pop layers ??? */ } return NULL; } SSize_t PerlIOWin32_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) { PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32); DWORD len; if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) return 0; if (ReadFile(s->h,vbuf,count,&len,NULL)) { return len; } else { if (GetLastError() != NO_ERROR) { PerlIOBase(f)->flags |= PERLIO_F_ERROR; return -1; } else { if (count != 0) PerlIOBase(f)->flags |= PERLIO_F_EOF; return 0; } } } SSize_t PerlIOWin32_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) { PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32); DWORD len; if (WriteFile(s->h,vbuf,count,&len,NULL)) { return len; } else { PerlIOBase(f)->flags |= PERLIO_F_ERROR; return -1; } } IV PerlIOWin32_seek(pTHX_ PerlIO *f, Off_t offset, int whence) { static const DWORD where[3] = { FILE_BEGIN, FILE_CURRENT, FILE_END }; PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32); #if Off_t_size >= 8 DWORD high = (DWORD)(offset >> 32); #else DWORD high = 0; #endif DWORD low = (DWORD) offset; DWORD res = SetFilePointer(s->h,(LONG)low,(LONG *)&high,where[whence]); if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR) { return 0; } else { return -1; } } Off_t PerlIOWin32_tell(pTHX_ PerlIO *f) { PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32); DWORD high = 0; DWORD res = SetFilePointer(s->h,0,(LONG *)&high,FILE_CURRENT); if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR) { #if Off_t_size >= 8 return ((Off_t) high << 32) | res; #else return res; #endif } return (Off_t) -1; } IV PerlIOWin32_close(pTHX_ PerlIO *f) { PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32); if (s->refcnt == 1) { IV code = 0; #if 0 /* This does not do pipes etc. correctly */ if (!CloseHandle(s->h)) { s->h = INVALID_HANDLE_VALUE; return -1; } #else PerlIOBase(f)->flags &= ~PERLIO_F_OPEN; return win32_close(s->fd); #endif } return 0; } PerlIO * PerlIOWin32_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *params, int flags) { PerlIOWin32 *os = PerlIOSelf(f,PerlIOWin32); HANDLE proc = GetCurrentProcess(); HANDLE new; if (DuplicateHandle(proc, os->h, proc, &new, 0, FALSE, DUPLICATE_SAME_ACCESS)) { char mode[8]; int fd = win32_open_osfhandle((intptr_t) new, PerlIOUnix_oflags(PerlIO_modestr(o,mode))); if (fd >= 0) { f = PerlIOBase_dup(aTHX_ f, o, params, flags); if (f) { PerlIOWin32 *fs = PerlIOSelf(f,PerlIOWin32); fs->h = new; fs->fd = fd; fs->refcnt = 1; fdtable[fd] = fs; if (fd > max_open_fd) max_open_fd = fd; } else { win32_close(fd); } } else { CloseHandle(new); } } return f; } PERLIO_FUNCS_DECL(PerlIO_win32) = { sizeof(PerlIO_funcs), "win32", sizeof(PerlIOWin32), PERLIO_K_RAW, PerlIOWin32_pushed, PerlIOWin32_popped, PerlIOWin32_open, PerlIOBase_binmode, NULL, /* getarg */ PerlIOWin32_fileno, PerlIOWin32_dup, PerlIOWin32_read, PerlIOBase_unread, PerlIOWin32_write, PerlIOWin32_seek, PerlIOWin32_tell, PerlIOWin32_close, PerlIOBase_noop_ok, /* flush */ PerlIOBase_noop_fail, /* fill */ PerlIOBase_eof, PerlIOBase_error, PerlIOBase_clearerr, PerlIOBase_setlinebuf, NULL, /* get_base */ NULL, /* get_bufsiz */ NULL, /* get_ptr */ NULL, /* get_cnt */ NULL, /* set_ptrcnt */ }; #endif perl-5.12.0-RC0/win32/list_static_libs.pl0000444000175000017500000000073311325125742016764 0ustar jessejesse#!perl -w use strict; # prints libraries for static linking and exits use Config; my @statics = split /\s+/, $Config{static_ext}; my %extralibs; for (@statics) { my $file = "..\\lib\\auto\\$_\\extralibs.ld"; open my $fh, '<', $file or die "can't open $file for reading: $!"; $extralibs{$_}++ for grep {/\S/} split /\s+/, join '', <$fh>; } print map {s|/|\\|g;m|([^\\]+)$|;"..\\lib\\auto\\$_\\$1$Config{_a} "} @statics; print map {"$_ "} sort keys %extralibs; perl-5.12.0-RC0/win32/perl.rc0000444000175000017500000000151111325125742014357 0ustar jessejesse#include LANGUAGE LANG_ENGLISH, SUBLANG_ENGLISH_US #pragma code_page(1252) 1 ICON DISCARDABLE "perl.ico" VS_VERSION_INFO VERSIONINFO FILEVERSION 5,6,0,0 PRODUCTVERSION 5,6,0,0 FILEFLAGSMASK 0x3FL FILEFLAGS 0x0L FILEOS 0x4L FILETYPE 0x1L FILESUBTYPE 0x0L BEGIN BLOCK "StringFileInfo" BEGIN BLOCK "040904B0" BEGIN VALUE "CompanyName", "Paranoyaxc Inc\0" VALUE "FileDescription", "Perl for WindowsCE\0" VALUE "FileVersion", "1, 0, 0, 0\0" VALUE "InternalName", "PerlCE\0" VALUE "LegalCopyright", "Copyright (C) Larry Wall\0" VALUE "OriginalFilename", "perl.exe" VALUE "ProductName", "Perl\0" VALUE "ProductVersion", "5, 7, 2, 0\0" VALUE "OLESelfRegister", "\0" END END BLOCK "VarFileInfo" BEGIN VALUE "Translation", 0x409, 1200 END END perl-5.12.0-RC0/win32/mdelete.bat0000444000175000017500000000103311143650501015167 0ustar jessejesse@echo off rem ! This is a batch file to delete all the files on its rem ! command line, to work around command.com's del command's rem ! braindeadness rem ! rem ! -- BKS, 11-11-2000 :nextfile set file=%1 shift if "%file%"=="" goto end del %file% goto nextfile :end @echo off rem ! This is a batch file to delete all the files on its rem ! command line, to work around command.com's del command's rem ! braindeadness rem ! rem ! -- BKS, 11-11-2000 :nextfile set file=%1 shift if "%file%"=="" goto end del %file% goto nextfile :end perl-5.12.0-RC0/win32/config_h.PL0000444000175000017500000000471311325127002015076 0ustar jessejesse# BEGIN { warn "Running ".__FILE__."\n" }; BEGIN { require "Config.pm"; die "Config.pm:$@" if $@; Config::->import; } use File::Compare qw(compare); use File::Copy qw(copy); use File::Basename qw(fileparse); my ($name, $dir) = fileparse($0); $name =~ s#^(.*)\.PL$#../$1.SH#; my %opt; while (@ARGV && $ARGV[0] =~ /^([\w_]+)=(.*)$/) { $opt{$1}=$2; shift(@ARGV); } $opt{CONFIG_H} ||= 'config.h'; $opt{CORE_DIR} ||= '../lib/CORE'; warn "Writing $opt{CONFIG_H}\n"; my $patchlevel = $opt{INST_VER}; $patchlevel =~ s|^[\\/]||; $patchlevel =~ s|~VERSION~|$Config{version}|g; $patchlevel ||= $Config{version}; $patchlevel = qq["$patchlevel"]; open(SH,"<$name") || die "Cannot open $name:$!"; while () { last if /^\s*sed/; } ($term,$file,$pat) = /^\s*sed\s+<<(\S+)\s+>(\S+)\s+(.*)$/; $file =~ s/^\$(\w+)$/$opt{$1}/g; my $str = "sub munge\n{\n"; while ($pat =~ s/-e\s+'([^']*)'\s*//) { my $e = $1; $e =~ s/\\([\(\)])/$1/g; $e =~ s/\\(\d)/\$$1/g; $str .= "$e;\n"; } $str .= "}\n"; eval $str; die "$str:$@" if $@; open(H,">$file.new") || die "Cannot open $file.new:$!"; #binmode H; # no CRs (which cause a spurious rebuild) while () { last if /^$term$/o; s/\$([\w_]+)/Config($1)/eg; s/`([^\`]*)`/BackTick($1)/eg; munge(); s/\\\$/\$/g; s#/[ *\*]*\*/#/**/#; s#(.)/\*\*/#$1/ **/# if(/^\/\*/); #avoid "/*" inside comments if (/^\s*#define\s+(PRIVLIB|SITELIB|VENDORLIB)_EXP/) { $_ = "#define ". $1 . "_EXP (win32_get_". lc($1) . "(PERL_VERSION_STRING, NULL))\t/**/\n"; } # incpush() handles archlibs, so disable them elsif (/^\s*#define\s+(ARCHLIB|SITEARCH|VENDORARCH)_EXP/) { $_ = "/*#define ". $1 . "_EXP \"\"\t/ **/\n"; } print H; } close(H); close(SH); chmod(0666,"$opt{CORE_DIR}/$opt{CONFIG_H}"); copy("$file.new","$opt{CORE_DIR}/$opt{CONFIG_H}") || die "Cannot copy:$!"; chmod(0444,"$opt{CORE_DIR}/$opt{CONFIG_H}"); if (compare("$file.new",$file)) { warn "$file has changed\n"; chmod(0666,$file); unlink($file); rename("$file.new",$file); #chmod(0444,$file); exit(1); } else { unlink ("$file.new"); exit(0); } sub Config { my $var = shift; my $val = $Config{$var}; $val = 'undef' unless defined $val; $val =~ s/\\/\\\\/g; return $val; } sub BackTick { my $cmd = shift; if ($cmd =~ /^echo\s+(.*?)\s*\|\s+sed\s+'(.*)'\s*$/) { local ($data,$pat) = ($1,$2); $data =~ s/\s+/ /g; eval "\$data =~ $pat"; return $data; } else { die "Cannot handle \`$cmd\`"; } return $cmd; } perl-5.12.0-RC0/win32/win32thread.h0000444000175000017500000001420111325125742015372 0ustar jessejesse#ifndef _WIN32THREAD_H #define _WIN32THREAD_H #include "win32.h" typedef struct win32_cond { LONG waiters; HANDLE sem; } perl_cond; typedef DWORD perl_key; typedef HANDLE perl_os_thread; #ifndef DONT_USE_CRITICAL_SECTION /* Critical Sections used instead of mutexes: lightweight, * but can't be communicated to child processes, and can't get * HANDLE to it for use elsewhere. */ typedef CRITICAL_SECTION perl_mutex; #define MUTEX_INIT(m) InitializeCriticalSection(m) #define MUTEX_LOCK(m) EnterCriticalSection(m) #define MUTEX_UNLOCK(m) LeaveCriticalSection(m) #define MUTEX_DESTROY(m) DeleteCriticalSection(m) #else typedef HANDLE perl_mutex; # define MUTEX_INIT(m) \ STMT_START { \ 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"); \ } STMT_END # define MUTEX_UNLOCK(m) \ STMT_START { \ 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"); \ } STMT_END #endif /* These macros assume that the mutex associated with the condition * will always be held before COND_{SIGNAL,BROADCAST,WAIT,DESTROY}, * so there's no separate mutex protecting access to (c)->waiters */ #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()); \ } 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()); \ } 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());\ } 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--; \ } STMT_END #define COND_DESTROY(c) \ STMT_START { \ (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"); \ } \ } STMT_END #define THREAD_CREATE(t, f) Perl_thread_create(t, f) #define THREAD_POST_CREATE(t) NOOP /* XXX Docs mention that the RTL versions of thread creation routines * should be used, but that advice only seems applicable when the RTL * is not in a DLL. RTL DLLs in both Borland and VC seem to do all of * the init/deinit required upon DLL_THREAD_ATTACH/DETACH. So we seem * to be completely safe using straight Win32 API calls, rather than * the much braindamaged RTL calls. * * _beginthread() in the RTLs call CloseHandle() just after the thread * function returns, which means: 1) we have a race on our hands * 2) it is impossible to implement join() semantics. * * IOW, do *NOT* turn on USE_RTL_THREAD_API! It is here * for experimental purposes only. GSAR 98-01-02 */ #ifdef USE_RTL_THREAD_API # include # if defined(__BORLANDC__) /* Borland RTL doesn't allow a return value from thread function! */ # define THREAD_RET_TYPE void _USERENTRY # define THREAD_RET_CAST(p) ((void)(thr->i.retv = (void *)(p))) # elif defined (_MSC_VER) # define THREAD_RET_TYPE unsigned __stdcall # define THREAD_RET_CAST(p) ((unsigned)(p)) # else /* CRTDLL.DLL doesn't allow a return value from thread function! */ # define THREAD_RET_TYPE void __cdecl # define THREAD_RET_CAST(p) ((void)(thr->i.retv = (void *)(p))) # endif #else /* !USE_RTL_THREAD_API */ # define THREAD_RET_TYPE DWORD WINAPI # define THREAD_RET_CAST(p) ((DWORD)(p)) #endif /* !USE_RTL_THREAD_API */ typedef THREAD_RET_TYPE thread_func_t(void *); START_EXTERN_C #if defined(PERLDLL) && defined(USE_DECLSPEC_THREAD) && (!defined(__BORLANDC__) || defined(_DLL)) extern __declspec(thread) void *PL_current_context; #define PERL_SET_CONTEXT(t) (PL_current_context = t) #define PERL_GET_CONTEXT PL_current_context #else #define PERL_GET_CONTEXT Perl_get_context() #define PERL_SET_CONTEXT(t) Perl_set_context(t) #endif 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); \ } \ } STMT_END #define FREE_THREAD_KEY \ STMT_START { \ TlsFree(PL_thr_key); \ } STMT_END #define PTHREAD_ATFORK(prepare,parent,child) NOOP #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); \ } 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"); \ } STMT_END #endif /* !USE_RTL_THREAD_API || _MSC_VER */ #define YIELD Sleep(0) #endif /* _WIN32THREAD_H */ perl-5.12.0-RC0/win32/fcrypt.c0000444000175000017500000004765111325125742014561 0ustar jessejesse/* fcrypt.c */ /* Copyright (C) 1993 Eric Young - see README for more details */ #include /* Eric Young. * This version of crypt has been developed from my MIT compatable * DES library. * The library is available at pub/DES at ftp.psy.uq.oz.au * eay@psych.psy.uq.oz.au */ #if defined(__BORLANDC__) #pragma warn -8004 /* "'foo' is assigned a value that is never used" */ #endif 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; #define _ ks._ } des_key_schedule[16]; #define DES_KEY_SZ (sizeof(des_cblock)) #define DES_ENCRYPT 1 #define DES_DECRYPT 0 #define ITERATIONS 16 #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) #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)) static unsigned long SPtrans[8][64]={ { /* nibble 0 */ 0x00820200, 0x00020000, 0x80800000, 0x80820200, 0x00800000, 0x80020200, 0x80020000, 0x80800000, 0x80020200, 0x00820200, 0x00820000, 0x80000200, 0x80800200, 0x00800000, 0x00000000, 0x80020000, 0x00020000, 0x80000000, 0x00800200, 0x00020200, 0x80820200, 0x00820000, 0x80000200, 0x00800200, 0x80000000, 0x00000200, 0x00020200, 0x80820000, 0x00000200, 0x80800200, 0x80820000, 0x00000000, 0x00000000, 0x80820200, 0x00800200, 0x80020000, 0x00820200, 0x00020000, 0x80000200, 0x00800200, 0x80820000, 0x00000200, 0x00020200, 0x80800000, 0x80020200, 0x80000000, 0x80800000, 0x00820000, 0x80820200, 0x00020200, 0x00820000, 0x80800200, 0x00800000, 0x80000200, 0x80020000, 0x00000000, 0x00020000, 0x00800000, 0x80800200, 0x00820200, 0x80000000, 0x80820000, 0x00000200, 0x80020200}, { /* nibble 1 */ 0x10042004, 0x00000000, 0x00042000, 0x10040000, 0x10000004, 0x00002004, 0x10002000, 0x00042000, 0x00002000, 0x10040004, 0x00000004, 0x10002000, 0x00040004, 0x10042000, 0x10040000, 0x00000004, 0x00040000, 0x10002004, 0x10040004, 0x00002000, 0x00042004, 0x10000000, 0x00000000, 0x00040004, 0x10002004, 0x00042004, 0x10042000, 0x10000004, 0x10000000, 0x00040000, 0x00002004, 0x10042004, 0x00040004, 0x10042000, 0x10002000, 0x00042004, 0x10042004, 0x00040004, 0x10000004, 0x00000000, 0x10000000, 0x00002004, 0x00040000, 0x10040004, 0x00002000, 0x10000000, 0x00042004, 0x10002004, 0x10042000, 0x00002000, 0x00000000, 0x10000004, 0x00000004, 0x10042004, 0x00042000, 0x10040000, 0x10040004, 0x00040000, 0x00002004, 0x10002000, 0x10002004, 0x00000004, 0x10040000, 0x00042000}, { /* nibble 2 */ 0x41000000, 0x01010040, 0x00000040, 0x41000040, 0x40010000, 0x01000000, 0x41000040, 0x00010040, 0x01000040, 0x00010000, 0x01010000, 0x40000000, 0x41010040, 0x40000040, 0x40000000, 0x41010000, 0x00000000, 0x40010000, 0x01010040, 0x00000040, 0x40000040, 0x41010040, 0x00010000, 0x41000000, 0x41010000, 0x01000040, 0x40010040, 0x01010000, 0x00010040, 0x00000000, 0x01000000, 0x40010040, 0x01010040, 0x00000040, 0x40000000, 0x00010000, 0x40000040, 0x40010000, 0x01010000, 0x41000040, 0x00000000, 0x01010040, 0x00010040, 0x41010000, 0x40010000, 0x01000000, 0x41010040, 0x40000000, 0x40010040, 0x41000000, 0x01000000, 0x41010040, 0x00010000, 0x01000040, 0x41000040, 0x00010040, 0x01000040, 0x00000000, 0x41010000, 0x40000040, 0x41000000, 0x40010040, 0x00000040, 0x01010000}, { /* nibble 3 */ 0x00100402, 0x04000400, 0x00000002, 0x04100402, 0x00000000, 0x04100000, 0x04000402, 0x00100002, 0x04100400, 0x04000002, 0x04000000, 0x00000402, 0x04000002, 0x00100402, 0x00100000, 0x04000000, 0x04100002, 0x00100400, 0x00000400, 0x00000002, 0x00100400, 0x04000402, 0x04100000, 0x00000400, 0x00000402, 0x00000000, 0x00100002, 0x04100400, 0x04000400, 0x04100002, 0x04100402, 0x00100000, 0x04100002, 0x00000402, 0x00100000, 0x04000002, 0x00100400, 0x04000400, 0x00000002, 0x04100000, 0x04000402, 0x00000000, 0x00000400, 0x00100002, 0x00000000, 0x04100002, 0x04100400, 0x00000400, 0x04000000, 0x04100402, 0x00100402, 0x00100000, 0x04100402, 0x00000002, 0x04000400, 0x00100402, 0x00100002, 0x00100400, 0x04100000, 0x04000402, 0x00000402, 0x04000000, 0x04000002, 0x04100400}, { /* nibble 4 */ 0x02000000, 0x00004000, 0x00000100, 0x02004108, 0x02004008, 0x02000100, 0x00004108, 0x02004000, 0x00004000, 0x00000008, 0x02000008, 0x00004100, 0x02000108, 0x02004008, 0x02004100, 0x00000000, 0x00004100, 0x02000000, 0x00004008, 0x00000108, 0x02000100, 0x00004108, 0x00000000, 0x02000008, 0x00000008, 0x02000108, 0x02004108, 0x00004008, 0x02004000, 0x00000100, 0x00000108, 0x02004100, 0x02004100, 0x02000108, 0x00004008, 0x02004000, 0x00004000, 0x00000008, 0x02000008, 0x02000100, 0x02000000, 0x00004100, 0x02004108, 0x00000000, 0x00004108, 0x02000000, 0x00000100, 0x00004008, 0x02000108, 0x00000100, 0x00000000, 0x02004108, 0x02004008, 0x02004100, 0x00000108, 0x00004000, 0x00004100, 0x02004008, 0x02000100, 0x00000108, 0x00000008, 0x00004108, 0x02004000, 0x02000008}, { /* nibble 5 */ 0x20000010, 0x00080010, 0x00000000, 0x20080800, 0x00080010, 0x00000800, 0x20000810, 0x00080000, 0x00000810, 0x20080810, 0x00080800, 0x20000000, 0x20000800, 0x20000010, 0x20080000, 0x00080810, 0x00080000, 0x20000810, 0x20080010, 0x00000000, 0x00000800, 0x00000010, 0x20080800, 0x20080010, 0x20080810, 0x20080000, 0x20000000, 0x00000810, 0x00000010, 0x00080800, 0x00080810, 0x20000800, 0x00000810, 0x20000000, 0x20000800, 0x00080810, 0x20080800, 0x00080010, 0x00000000, 0x20000800, 0x20000000, 0x00000800, 0x20080010, 0x00080000, 0x00080010, 0x20080810, 0x00080800, 0x00000010, 0x20080810, 0x00080800, 0x00080000, 0x20000810, 0x20000010, 0x20080000, 0x00080810, 0x00000000, 0x00000800, 0x20000010, 0x20000810, 0x20080800, 0x20080000, 0x00000810, 0x00000010, 0x20080010}, { /* nibble 6 */ 0x00001000, 0x00000080, 0x00400080, 0x00400001, 0x00401081, 0x00001001, 0x00001080, 0x00000000, 0x00400000, 0x00400081, 0x00000081, 0x00401000, 0x00000001, 0x00401080, 0x00401000, 0x00000081, 0x00400081, 0x00001000, 0x00001001, 0x00401081, 0x00000000, 0x00400080, 0x00400001, 0x00001080, 0x00401001, 0x00001081, 0x00401080, 0x00000001, 0x00001081, 0x00401001, 0x00000080, 0x00400000, 0x00001081, 0x00401000, 0x00401001, 0x00000081, 0x00001000, 0x00000080, 0x00400000, 0x00401001, 0x00400081, 0x00001081, 0x00001080, 0x00000000, 0x00000080, 0x00400001, 0x00000001, 0x00400080, 0x00000000, 0x00400081, 0x00400080, 0x00001080, 0x00000081, 0x00001000, 0x00401081, 0x00400000, 0x00401080, 0x00000001, 0x00001001, 0x00401081, 0x00400001, 0x00401080, 0x00401000, 0x00001001}, { /* nibble 7 */ 0x08200020, 0x08208000, 0x00008020, 0x00000000, 0x08008000, 0x00200020, 0x08200000, 0x08208020, 0x00000020, 0x08000000, 0x00208000, 0x00008020, 0x00208020, 0x08008020, 0x08000020, 0x08200000, 0x00008000, 0x00208020, 0x00200020, 0x08008000, 0x08208020, 0x08000020, 0x00000000, 0x00208000, 0x08000000, 0x00200000, 0x08008020, 0x08200020, 0x00200000, 0x00008000, 0x08208000, 0x00000020, 0x00200000, 0x00008000, 0x08000020, 0x08208020, 0x00008020, 0x08000000, 0x00000000, 0x00208000, 0x08200020, 0x08008020, 0x08008000, 0x00200020, 0x08208000, 0x00000020, 0x00200020, 0x08008000, 0x08208020, 0x00200000, 0x08200000, 0x08000020, 0x00208000, 0x00008020, 0x08008020, 0x08200000, 0x00000020, 0x08208000, 0x00208020, 0x00000000, 0x08000000, 0x08200020, 0x00008000, 0x00208020} }; static unsigned long skb[8][64]={ { /* for C bits (numbered as per FIPS 46) 1 2 3 4 5 6 */ 0x00000000,0x00000010,0x20000000,0x20000010, 0x00010000,0x00010010,0x20010000,0x20010010, 0x00000800,0x00000810,0x20000800,0x20000810, 0x00010800,0x00010810,0x20010800,0x20010810, 0x00000020,0x00000030,0x20000020,0x20000030, 0x00010020,0x00010030,0x20010020,0x20010030, 0x00000820,0x00000830,0x20000820,0x20000830, 0x00010820,0x00010830,0x20010820,0x20010830, 0x00080000,0x00080010,0x20080000,0x20080010, 0x00090000,0x00090010,0x20090000,0x20090010, 0x00080800,0x00080810,0x20080800,0x20080810, 0x00090800,0x00090810,0x20090800,0x20090810, 0x00080020,0x00080030,0x20080020,0x20080030, 0x00090020,0x00090030,0x20090020,0x20090030, 0x00080820,0x00080830,0x20080820,0x20080830, 0x00090820,0x00090830,0x20090820,0x20090830}, { /* for C bits (numbered as per FIPS 46) 7 8 10 11 12 13 */ 0x00000000,0x02000000,0x00002000,0x02002000, 0x00200000,0x02200000,0x00202000,0x02202000, 0x00000004,0x02000004,0x00002004,0x02002004, 0x00200004,0x02200004,0x00202004,0x02202004, 0x00000400,0x02000400,0x00002400,0x02002400, 0x00200400,0x02200400,0x00202400,0x02202400, 0x00000404,0x02000404,0x00002404,0x02002404, 0x00200404,0x02200404,0x00202404,0x02202404, 0x10000000,0x12000000,0x10002000,0x12002000, 0x10200000,0x12200000,0x10202000,0x12202000, 0x10000004,0x12000004,0x10002004,0x12002004, 0x10200004,0x12200004,0x10202004,0x12202004, 0x10000400,0x12000400,0x10002400,0x12002400, 0x10200400,0x12200400,0x10202400,0x12202400, 0x10000404,0x12000404,0x10002404,0x12002404, 0x10200404,0x12200404,0x10202404,0x12202404}, { /* for C bits (numbered as per FIPS 46) 14 15 16 17 19 20 */ 0x00000000,0x00000001,0x00040000,0x00040001, 0x01000000,0x01000001,0x01040000,0x01040001, 0x00000002,0x00000003,0x00040002,0x00040003, 0x01000002,0x01000003,0x01040002,0x01040003, 0x00000200,0x00000201,0x00040200,0x00040201, 0x01000200,0x01000201,0x01040200,0x01040201, 0x00000202,0x00000203,0x00040202,0x00040203, 0x01000202,0x01000203,0x01040202,0x01040203, 0x08000000,0x08000001,0x08040000,0x08040001, 0x09000000,0x09000001,0x09040000,0x09040001, 0x08000002,0x08000003,0x08040002,0x08040003, 0x09000002,0x09000003,0x09040002,0x09040003, 0x08000200,0x08000201,0x08040200,0x08040201, 0x09000200,0x09000201,0x09040200,0x09040201, 0x08000202,0x08000203,0x08040202,0x08040203, 0x09000202,0x09000203,0x09040202,0x09040203}, { /* for C bits (numbered as per FIPS 46) 21 23 24 26 27 28 */ 0x00000000,0x00100000,0x00000100,0x00100100, 0x00000008,0x00100008,0x00000108,0x00100108, 0x00001000,0x00101000,0x00001100,0x00101100, 0x00001008,0x00101008,0x00001108,0x00101108, 0x04000000,0x04100000,0x04000100,0x04100100, 0x04000008,0x04100008,0x04000108,0x04100108, 0x04001000,0x04101000,0x04001100,0x04101100, 0x04001008,0x04101008,0x04001108,0x04101108, 0x00020000,0x00120000,0x00020100,0x00120100, 0x00020008,0x00120008,0x00020108,0x00120108, 0x00021000,0x00121000,0x00021100,0x00121100, 0x00021008,0x00121008,0x00021108,0x00121108, 0x04020000,0x04120000,0x04020100,0x04120100, 0x04020008,0x04120008,0x04020108,0x04120108, 0x04021000,0x04121000,0x04021100,0x04121100, 0x04021008,0x04121008,0x04021108,0x04121108}, { /* for D bits (numbered as per FIPS 46) 1 2 3 4 5 6 */ 0x00000000,0x10000000,0x00010000,0x10010000, 0x00000004,0x10000004,0x00010004,0x10010004, 0x20000000,0x30000000,0x20010000,0x30010000, 0x20000004,0x30000004,0x20010004,0x30010004, 0x00100000,0x10100000,0x00110000,0x10110000, 0x00100004,0x10100004,0x00110004,0x10110004, 0x20100000,0x30100000,0x20110000,0x30110000, 0x20100004,0x30100004,0x20110004,0x30110004, 0x00001000,0x10001000,0x00011000,0x10011000, 0x00001004,0x10001004,0x00011004,0x10011004, 0x20001000,0x30001000,0x20011000,0x30011000, 0x20001004,0x30001004,0x20011004,0x30011004, 0x00101000,0x10101000,0x00111000,0x10111000, 0x00101004,0x10101004,0x00111004,0x10111004, 0x20101000,0x30101000,0x20111000,0x30111000, 0x20101004,0x30101004,0x20111004,0x30111004}, { /* for D bits (numbered as per FIPS 46) 8 9 11 12 13 14 */ 0x00000000,0x08000000,0x00000008,0x08000008, 0x00000400,0x08000400,0x00000408,0x08000408, 0x00020000,0x08020000,0x00020008,0x08020008, 0x00020400,0x08020400,0x00020408,0x08020408, 0x00000001,0x08000001,0x00000009,0x08000009, 0x00000401,0x08000401,0x00000409,0x08000409, 0x00020001,0x08020001,0x00020009,0x08020009, 0x00020401,0x08020401,0x00020409,0x08020409, 0x02000000,0x0A000000,0x02000008,0x0A000008, 0x02000400,0x0A000400,0x02000408,0x0A000408, 0x02020000,0x0A020000,0x02020008,0x0A020008, 0x02020400,0x0A020400,0x02020408,0x0A020408, 0x02000001,0x0A000001,0x02000009,0x0A000009, 0x02000401,0x0A000401,0x02000409,0x0A000409, 0x02020001,0x0A020001,0x02020009,0x0A020009, 0x02020401,0x0A020401,0x02020409,0x0A020409}, { /* for D bits (numbered as per FIPS 46) 16 17 18 19 20 21 */ 0x00000000,0x00000100,0x00080000,0x00080100, 0x01000000,0x01000100,0x01080000,0x01080100, 0x00000010,0x00000110,0x00080010,0x00080110, 0x01000010,0x01000110,0x01080010,0x01080110, 0x00200000,0x00200100,0x00280000,0x00280100, 0x01200000,0x01200100,0x01280000,0x01280100, 0x00200010,0x00200110,0x00280010,0x00280110, 0x01200010,0x01200110,0x01280010,0x01280110, 0x00000200,0x00000300,0x00080200,0x00080300, 0x01000200,0x01000300,0x01080200,0x01080300, 0x00000210,0x00000310,0x00080210,0x00080310, 0x01000210,0x01000310,0x01080210,0x01080310, 0x00200200,0x00200300,0x00280200,0x00280300, 0x01200200,0x01200300,0x01280200,0x01280300, 0x00200210,0x00200310,0x00280210,0x00280310, 0x01200210,0x01200310,0x01280210,0x01280310}, { /* for D bits (numbered as per FIPS 46) 22 23 24 25 27 28 */ 0x00000000,0x04000000,0x00040000,0x04040000, 0x00000002,0x04000002,0x00040002,0x04040002, 0x00002000,0x04002000,0x00042000,0x04042000, 0x00002002,0x04002002,0x00042002,0x04042002, 0x00000020,0x04000020,0x00040020,0x04040020, 0x00000022,0x04000022,0x00040022,0x04040022, 0x00002020,0x04002020,0x00042020,0x04042020, 0x00002022,0x04002022,0x00042022,0x04042022, 0x00000800,0x04000800,0x00040800,0x04040800, 0x00000802,0x04000802,0x00040802,0x04040802, 0x00002800,0x04002800,0x00042800,0x04042800, 0x00002802,0x04002802,0x00042802,0x04042802, 0x00000820,0x04000820,0x00040820,0x04040820, 0x00000822,0x04000822,0x00040822,0x04040822, 0x00002820,0x04002820,0x00042820,0x04042820, 0x00002822,0x04002822,0x00042822,0x04042822} }; /* 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))) #define HPERM_OP(a,t,n,m) ((t)=((((a)<<(16-(n)))^(a))&(m)),\ (a)=(a)^(t)^(t>>(16-(n))))\ static 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); static int des_set_key(des_cblock *key, des_key_schedule schedule) { register unsigned long c,d,t,s; register unsigned char *in; register unsigned long *k; register 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>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. ******************************************************************/ /* The changes to this macro may help or hinder, depending on the * compiler and the achitecture. gcc2 always seems to do well :-). * Inspired by Dana How * DO NOT use the alternative version on machines with 8 byte longs. */ #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)); #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]; #endif unsigned char con_salt[128]={ 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x01, 0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09, 0x0A,0x0B,0x05,0x06,0x07,0x08,0x09,0x0A, 0x0B,0x0C,0x0D,0x0E,0x0F,0x10,0x11,0x12, 0x13,0x14,0x15,0x16,0x17,0x18,0x19,0x1A, 0x1B,0x1C,0x1D,0x1E,0x1F,0x20,0x21,0x22, 0x23,0x24,0x25,0x20,0x21,0x22,0x23,0x24, 0x25,0x26,0x27,0x28,0x29,0x2A,0x2B,0x2C, 0x2D,0x2E,0x2F,0x30,0x31,0x32,0x33,0x34, 0x35,0x36,0x37,0x38,0x39,0x3A,0x3B,0x3C, 0x3D,0x3E,0x3F,0x00,0x00,0x00,0x00,0x00, }; unsigned char cov_2char[64]={ 0x2E,0x2F,0x30,0x31,0x32,0x33,0x34,0x35, 0x36,0x37,0x38,0x39,0x41,0x42,0x43,0x44, 0x45,0x46,0x47,0x48,0x49,0x4A,0x4B,0x4C, 0x4D,0x4E,0x4F,0x50,0x51,0x52,0x53,0x54, 0x55,0x56,0x57,0x58,0x59,0x5A,0x61,0x62, 0x63,0x64,0x65,0x66,0x67,0x68,0x69,0x6A, 0x6B,0x6C,0x6D,0x6E,0x6F,0x70,0x71,0x72, 0x73,0x74,0x75,0x76,0x77,0x78,0x79,0x7A }; 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; /* 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) { register unsigned long l,r,t,u,v; #ifdef ALT_ECB register unsigned char *des_SP=(unsigned char *)SPtrans; #endif register unsigned long *s; register int i,j; register 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); } perl-5.12.0-RC0/win32/ce-helpers/0000755000175000017500000000000011351321567015124 5ustar jessejesseperl-5.12.0-RC0/win32/ce-helpers/makedist.pl0000444000175000017500000002022711325125742017261 0ustar jessejesseuse strict; use Cwd; use File::Path; use File::Find; my %opts = ( #defaults 'verbose' => 1, # verbose level, in range from 0 to 2 'distdir' => 'distdir', 'unicode' => 1, # include unicode by default 'minimal' => 0, # minimal possible distribution. # actually this is just perl.exe and perlXX.dll # but can be extended by additional exts # ... (as soon as this will be implemented :) 'cross-name' => 'wince', 'strip-pod' => 0, # strip POD from perl modules 'adaptation' => 1, # do some adaptation, such as stripping such # occurences as "if ($^O eq 'VMS'){...}" for Dynaloader.pm 'zip' => 0, # perform zip 'clean-exts' => 0, #options itself (map {/^--([\-_\w]+)=(.*)$/} @ARGV), # --opt=smth (map {/^no-?(.*)$/i?($1=>0):($_=>1)} map {/^--([\-_\w]+)$/} @ARGV), # --opt --no-opt --noopt ); # TODO # -- error checking. When something goes wrong, just exit with rc!=0 # -- may be '--zip' option should be made differently? my $cwd = cwd; if ($opts{'clean-exts'}) { # unfortunately, unlike perl58.dll and like, extensions for different # platforms are built in same directory, therefore we must be able to clean # them often unlink '../config.sh'; # delete cache config file, which remembers our previous config chdir '../ext'; find({no_chdir=>1,wanted => sub{ unlink if /((?:\.obj|\/makefile|\/errno\.pm))$/i; } },'.'); exit; } # zip if ($opts{'zip'}) { if ($opts{'verbose'} >=1) { print STDERR "zipping...\n"; } chdir $opts{'distdir'}; unlink <*.zip>; `zip -R perl-$opts{'cross-name'} *`; exit; } my (%libexclusions, %extexclusions); my @lfiles; sub copy($$); # lib chdir '../lib'; find({no_chdir=>1,wanted=>sub{push @lfiles, $_ if /\.p[lm]$/}},'.'); chdir $cwd; # exclusions @lfiles = grep {!exists $libexclusions{$_}} @lfiles; #inclusions #... #copy them if ($opts{'verbose'} >=1) { print STDERR "Copying perl lib files...\n"; } for (@lfiles) { /^(.*)\/[^\/]+$/; mkpath "$opts{distdir}/lib/$1"; copy "../lib/$_", "$opts{distdir}/lib/$_"; } #ext my @efiles; chdir '../ext'; find({no_chdir=>1,wanted=>sub{push @efiles, $_ if /\.pm$/}},'.'); chdir $cwd; # exclusions #... #inclusions #... #copy them #{s[/(\w+)/\1\.pm][/$1.pm]} @efiles; if ($opts{'verbose'} >=1) { print STDERR "Copying perl core extensions...\n"; } for (@efiles) { if (m#^.*?/lib/(.*)$#) { copy "../ext/$_", "$opts{distdir}/lib/$1"; } else { /^(.*)\/([^\/]+)\/([^\/]+)$/; copy "../ext/$_", "$opts{distdir}/lib/$1/$3"; } } my ($dynaloader_pm); if ($opts{adaptation}) { # let's copy our Dynaloader.pm (make this optional?) open my $fhdyna, ">$opts{distdir}/lib/Dynaloader.pm"; print $fhdyna $dynaloader_pm; close $fhdyna; } # Config.pm, perl binaries if ($opts{'verbose'} >=1) { print STDERR "Copying Config.pm, perl.dll and perl.exe...\n"; } copy "../xlib/$opts{'cross-name'}/Config.pm", "$opts{distdir}/lib/Config.pm"; copy "$opts{'cross-name'}/perl.exe", "$opts{distdir}/bin/perl.exe"; copy "$opts{'cross-name'}/perl.dll", "$opts{distdir}/bin/perl.dll"; # how do we know exact name of perl.dll? # auto my %aexcl = (socket=>'Socket_1'); # Socket.dll and may be some other conflict with same file in \windows dir # on WinCE, %aexcl needed to replace it with a different name that however # will be found by Dynaloader my @afiles; chdir "../xlib/$opts{'cross-name'}/auto"; find({no_chdir=>1,wanted=>sub{push @afiles, $_ if /\.(dll|bs)$/}},'.'); chdir $cwd; if ($opts{'verbose'} >=1) { print STDERR "Copying binaries for perl core extensions...\n"; } for (@afiles) { if (/^(.*)\/(\w+)\.dll$/i && exists $aexcl{lc($2)}) { copy "../xlib/$opts{'cross-name'}/auto/$_", "$opts{distdir}/lib/auto/$1/$aexcl{lc($2)}.dll"; } else { copy "../xlib/$opts{'cross-name'}/auto/$_", "$opts{distdir}/lib/auto/$_"; } } sub copy($$) { my ($fnfrom, $fnto) = @_; open my $fh, "<$fnfrom" or die "can not open $fnfrom: $!"; binmode $fh; local $/; my $ffrom = <$fh>; if ($opts{'strip-pod'}) { # actually following regexp is suspicious to not work everywhere. # but we've checked on our set of modules, and it's fit for our purposes $ffrom =~ s/^=\w+.*?^=cut(?:\n|\Z)//msg; unless ($ffrom=~/\bAutoLoader\b/) { # this logic actually strip less than could be stripped, but we're # not risky. Just strip only of no mention of AutoLoader $ffrom =~ s/^__END__.*\Z//msg; } } mkpath $1 if $fnto=~/^(.*)\/([^\/]+)$/; open my $fhout, ">$fnto"; binmode $fhout; print $fhout $ffrom; if ($opts{'verbose'} >=2) { print STDERR "copying $fnfrom=>$fnto\n"; } } BEGIN { %libexclusions = map {$_=>1} split/\s/, <<"EOS"; abbrev.pl bigfloat.pl bigint.pl bigrat.pl cacheout.pl complete.pl ctime.pl dotsh.pl exceptions.pl fastcwd.pl flush.pl ftp.pl getcwd.pl getopt.pl getopts.pl hostname.pl look.pl newgetopt.pl pwd.pl termcap.pl EOS %extexclusions = map {$_=>1} split/\s/, <<"EOS"; EOS $dynaloader_pm=<<'EOS'; # This module designed *only* for WinCE # if you encounter a problem with this file, try using original Dynaloader.pm # from perl distribution, it's larger but essentially the same. package DynaLoader; our $VERSION = 1.04; $dl_debug ||= 0; @dl_require_symbols = (); # names of symbols we need #@dl_librefs = (); # things we have loaded #@dl_modules = (); # Modules we have loaded boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) && !defined(&dl_error); print STDERR "DynaLoader not linked into this perl\n" unless defined(&boot_DynaLoader); 1; # End of main code sub croak{require Carp;Carp::croak(@_)} sub bootstrap_inherit { my $module = $_[0]; local *isa = *{"$module\::ISA"}; local @isa = (@isa, 'DynaLoader'); bootstrap(@_); } sub bootstrap { # use local vars to enable $module.bs script to edit values local(@args) = @_; local($module) = $args[0]; local(@dirs, $file); unless ($module) { require Carp; Carp::confess("Usage: DynaLoader::bootstrap(module)"); } croak("Can't load module $module, dynamic loading not available in this perl.\n") unless defined(&dl_load_file); my @modparts = split(/::/,$module); my $modfname = $modparts[-1]; my $modpname = join('/',@modparts); for (@INC) { my $dir = "$_/auto/$modpname"; next unless -d $dir; my $try = "$dir/$modfname.dll"; last if $file = ( (-f $try) && $try); $try = "$dir/${modfname}_1.dll"; last if $file = ( (-f $try) && $try); push @dirs, $dir; } $file = dl_findfile(map("-L$_",@dirs,@INC), $modfname) unless $file; croak("Can't locate loadable object for module $module in \@INC (\@INC contains: @INC)") unless $file; (my $bootname = "boot_$module") =~ s/\W/_/g; @dl_require_symbols = ($bootname); # optional '.bootstrap' perl script my $bs = $file; $bs =~ s/(\.\w+)?(;\d*)?$/\.bs/; if (-s $bs) { # only read file if it's not empty do $bs; warn "$bs: $@\n" if $@; } my $libref = dl_load_file($file, 0) or croak("Can't load '$file' for module $module: ".dl_error()); push(@dl_librefs,$libref); # record loaded object my @unresolved = dl_undef_symbols(); if (@unresolved) { require Carp; Carp::carp("Undefined symbols present after loading $file: @unresolved\n"); } my $boot_symbol_ref = dl_find_symbol($libref, $bootname) or croak("Can't find '$bootname' symbol in $file\n"); push(@dl_modules, $module); boot: my $xs = dl_install_xsub("${module}::bootstrap", $boot_symbol_ref, $file); &$xs(@args); } sub dl_findfile { my (@args) = @_; my (@dirs, $dir); my (@found); arg: foreach(@args) { if (m:/: && -f $_) { push(@found,$_); last arg unless wantarray; next; } if (s:^-L::) {push(@dirs, $_); next;} if (m:/: && -d $_) {push(@dirs, $_); next;} for $dir (@dirs) { next unless -d $dir; for my $name (/\.dll$/i?($_):("$_.dll",$_)) { print STDERR " checking in $dir for $name\n" if $dl_debug; if (-f "$dir/$name") { push(@found, "$dir/$name"); next arg; } } } } return $found[0] unless wantarray; @found; } EOS } perl-5.12.0-RC0/win32/ce-helpers/cecopy-lib.pl0000444000175000017500000000772611325125742017517 0ustar jessejesse# just copy modules # TODO: copy tests and try to run them... # this file may be used as example on how to use comp.pl my @files; my %dirs; sub mk { my $r = shift; return if exists $dirs{$r}; if ($r=~/\//) { $r=~/^(.*)\/[^\/]*?$/; mk($1); } print STDERR "..\\miniperl.exe -MCross comp.pl --do cemkdir [p]\\lib\\$r\n"; system("..\\miniperl.exe -I..\\lib -MCross comp.pl --do cemkdir [p]\\lib\\$r"); $dirs{$r}++; } for (@files) { if (/\//) { /^(.*)\/[^\/]*?$/; mk($1); } # currently no stripping POD system("..\\miniperl.exe -I..\\lib -MCross comp.pl --copy pc:..\\lib\\$_ ce:[p]\\lib\\$_"); } sub BEGIN { @files = qw( attributes.pm AutoLoader.pm AutoSplit.pm autouse.pm base.pm Benchmark.pm bigint.pm bignum.pm bigrat.pm blib.pm bytes.pm Carp.pm charnames.pm Config.pm constant.pm Cwd.pm DB.pm diagnostics.pm Digest.pm DirHandle.pm Dumpvalue.pm DynaLoader.pm English.pm Env.pm Exporter.pm Fatal.pm fields.pm FileCache.pm FileHandle.pm filetest.pm FindBin.pm if.pm integer.pm less.pm locale.pm Memoize.pm NEXT.pm open.pm overload.pm PerlIO.pm re.pm SelectSaver.pm SelfLoader.pm Shell.pm sigtrap.pm sort.pm strict.pm subs.pm Switch.pm Symbol.pm Test.pm UNIVERSAL.pm utf8.pm vars.pm vmsish.pm warnings.pm XSLoader.pm warnings/register.pm Unicode/Collate.pm Unicode/UCD.pm Time/gmtime.pm Time/Local.pm Time/localtime.pm Time/tm.pm Tie/Array.pm Tie/File.pm Tie/Handle.pm Tie/Hash.pm Tie/Memoize.pm Tie/RefHash.pm Tie/Scalar.pm Tie/SubstrHash.pm Text/Abbrev.pm Text/Balanced.pm Text/ParseWords.pm Text/Soundex.pm Text/Tabs.pm Text/Wrap.pm Test/Builder.pm Test/Harness.pm Test/More.pm Test/Simple.pm Test/Harness/Assert.pm Test/Harness/Iterator.pm Test/Harness/Straps.pm Term/ANSIColor.pm Term/Cap.pm Term/Complete.pm Term/ReadLine.pm Search/Dict.pm Pod/Checker.pm Pod/Find.pm Pod/Functions.pm Pod/Html.pm Pod/InputObjects.pm Pod/LaTeX.pm Pod/Man.pm Pod/ParseLink.pm Pod/Parser.pm Pod/ParseUtils.pm Pod/Plainer.pm Pod/Select.pm Pod/Text.pm Pod/Usage.pm Pod/Text/Color.pm Pod/Text/Overstrike.pm Pod/Text/Termcap.pm Math/BigFloat.pm Math/BigInt.pm Math/BigRat.pm Math/Complex.pm Math/Trig.pm Math/BigInt/Calc.pm Math/BigInt/Trace.pm Math/BigFloat/Trace.pm Locale/Constants.pm Locale/Country.pm Locale/Currency.pm Locale/Language.pm Locale/Maketext.pm Locale/Script.pm IPC/Open2.pm IPC/Open3.pm I18N/Collate.pm I18N/LangTags.pm I18N/LangTags/List.pm Hash/Util.pm Getopt/Long.pm Getopt/Std.pm Filter/Simple.pm File/Basename.pm File/CheckTree.pm File/Compare.pm File/Copy.pm File/DosGlob.pm File/Find.pm File/Path.pm File/Spec.pm File/stat.pm File/Temp.pm File/Spec/Functions.pm File/Spec/Mac.pm File/Spec/Unix.pm File/Spec/Win32.pm ExtUtils/Command.pm ExtUtils/Constant.pm ExtUtils/Embed.pm ExtUtils/Install.pm ExtUtils/Installed.pm ExtUtils/Liblist.pm ExtUtils/MakeMaker.pm ExtUtils/Manifest.pm ExtUtils/Miniperl.pm ExtUtils/Mkbootstrap.pm ExtUtils/Mksymlists.pm ExtUtils/MM.pm ExtUtils/MM_Any.pm ExtUtils/MM_DOS.pm ExtUtils/MM_Unix.pm ExtUtils/MM_UWIN.pm ExtUtils/MM_Win32.pm ExtUtils/MM_Win95.pm ExtUtils/MY.pm ExtUtils/Packlist.pm ExtUtils/testlib.pm ExtUtils/Liblist/Kid.pm ExtUtils/Command/MM.pm Exporter/Heavy.pm Devel/SelfStubber.pm Class/ISA.pm Class/Struct.pm Carp/Heavy.pm Attribute/Handlers.pm Attribute/Handlers/demo/Demo.pm Attribute/Handlers/demo/Descriptions.pm Attribute/Handlers/demo/MyClass.pm ); } perl-5.12.0-RC0/win32/ce-helpers/registry.bat0000444000175000017500000000166611325125742017471 0ustar jessejesse@echo off ::- This script must be executed on the PC with an ActiveSync ::- connection. If it does not work, create the entries with ::- a remote registry editor or get a registry editor for your ::- devices. ::- ::- You need my cereg.exe program. ::- My paths... set perlexe=\speicherkarte2\bin\perl.exe set perllib=\speicherkarte2\usr\lib\perl5 ::- PERL5LIB cereg -k "HKLM\Environment" -n "PERL5LIB" -v "%perllib%" ::- For ShellExecute cereg -k "HKCR\.pl" -n "" -v "perlfile" cereg -k "HKCR\perlfile" -n "" -v "Perl Script" cereg -k "HKCR\perlfile\DefaultIcon" -n "" -v "%perlexe%,-1" ::- You might need to fix the quotes if your paths contain spaces! cereg -k "HKCR\perlfile\Shell\open\command" -n "" -v "%perlexe% %%1" cereg -k "HKLM\Environment" -n "ROWS" -v "10" cereg -k "HKLM\Environment" -n "COLS" -v "75" cereg -k "HKLM\Environment" -n "PATH" -v "/Speicherkarte2/bin" cereg -k "HKLM\Environment" -n "UNIXROOTDIR" -v "/Speicherkarte2" perl-5.12.0-RC0/win32/ce-helpers/comp.pl0000444000175000017500000000440311325127002016403 0ustar jessejesse=begin comment helper script to make life for PerlCE easier. There are different modes for running this script: perl comp.pl --run [any-command-line-arguments] and perl comp.pl --do [any-command-line-arguments] and perl comp.pl --copy pc:[pc-location] ce:[ce-location] --run executes this build of perl on CE device with arguments provided --run=test will display a predefined messagebox that say everything is ok. --do Executes on local computer command that is presented by arguments immediately following after --do Most reason why you may want to execute script in this mode is that arguments preprocessed to replace [p] occurrences into current perl location. Typically it is handy to run perl comp.pl --do cecopy pc:..\lib\Exporter.pm ce:[p]\lib --copy copies file to CE device here also [p] will be expanded to current PerlCE path, and additionally when --copy=compact specified then, if filename looks like perl module, then POD will be stripped away from that file modules =cut use strict; use Cross; use Config; # edit value of $inst_root variable to reflect your desired location of # built perl my $inst_root = $Config{prefix}; my %opts = ( # %known_opts enumerates allowed opts as well as specifies default and initial values my %known_opts = ( 'do' => '', 'run' => '', 'copy' => '', ), #options itself my %specified_opts = ( (map {/^--([\-_\w]+)=(.*)$/} @ARGV), # --opt=smth (map {/^no-?(.*)$/i?($1=>0):($_=>1)} map {/^--([\-_\w]+)$/} @ARGV), # --opt --no-opt --noopt ), ); die "option '$_' is not recognized" for grep {!exists $known_opts{$_}} keys %specified_opts; @ARGV = grep {!/^--/} @ARGV; if ($opts{'do'}) { s/\[p\]/$inst_root/g for @ARGV; system(@ARGV); } elsif ($opts{'run'}) { if ($opts{'run'} eq 'test') { system("ceexec","$inst_root\\bin\\perl","-we","Win32::MessageBox(\$].qq(\n).join'','cc'..'dx')"); } else { system("ceexec","$inst_root\\bin\\perl", map {/^".*"$/s?$_:"\"$_\""} @ARGV); } } elsif ($opts{'copy'}) { if ($opts{'copy'} eq 'compact') { die "todo"; } s/\[p\]/$inst_root/g for @ARGV; if ($ARGV[0]=~/^pc:/i) {system("cedel",$ARGV[1])} system("cecopy",@ARGV); } else { # todo } =head1 AUTHOR Vadim Konovalov. =cut perl-5.12.0-RC0/win32/ce-helpers/compile-all.bat0000444000175000017500000000476311325125742020020 0ustar jessejesse@echo off rem rem Normally you do not need to run this file. rem Instead you should edit and execute compile.bat . rem rem This file assumes that you have a set of appropriate rem bat-files that prepare environment variables for build process rem and execute commands passed as arguments rem call wcearm-300 compile.bat "MACHINE=wince-arm-hpc-wce300" call wcearm-300 compile.bat "MACHINE=wince-arm-hpc-wce300" zipdist ..\miniperl makedist.pl --clean-exts call wcearm-211 compile.bat "MACHINE=wince-arm-hpc-wce211" call wcearm-211 compile.bat "MACHINE=wince-arm-hpc-wce211" zipdist ..\miniperl makedist.pl --clean-exts call wcesh3-211 compile.bat "MACHINE=wince-sh3-hpc-wce211" call wcesh3-211 compile.bat "MACHINE=wince-sh3-hpc-wce211" zipdist ..\miniperl makedist.pl --clean-exts call wcemips-211 compile.bat "MACHINE=wince-mips-hpc-wce211" call wcemips-211 compile.bat "MACHINE=wince-mips-hpc-wce211" zipdist ..\miniperl makedist.pl --clean-exts rem TODO call wcesh3-200 compile.bat "MACHINE=wince-sh3-hpc-wce200" rem TODO call wcesh3-200 compile.bat "MACHINE=wince-sh3-hpc-wce200" zipdist rem TODO ..\miniperl makedist.pl --clean-exts rem TODO call compile.bat "MACHINE=wince-mips-hpc-wce200" rem TODO call compile.bat "MACHINE=wince-mips-hpc-wce200" zipdist rem TODO ..\miniperl makedist.pl --clean-exts call WCEARM-p300 compile.bat "MACHINE=wince-arm-pocket-wce300" call WCEARM-p300 compile.bat "MACHINE=wince-arm-pocket-wce300" zipdist ..\miniperl makedist.pl --clean-exts call WCEMIPS-300 compile.bat "MACHINE=wince-mips-pocket-wce300" call WCEMIPS-300 compile.bat "MACHINE=wince-mips-pocket-wce300" zipdist ..\miniperl makedist.pl --clean-exts call WCESH3-300 compile.bat "MACHINE=wince-sh3-pocket-wce300" call WCESH3-300 compile.bat "MACHINE=wince-sh3-pocket-wce300" zipdist ..\miniperl makedist.pl --clean-exts call WCEx86-300 compile.bat "MACHINE=wince-x86em-pocket-wce300" call WCEx86-300 compile.bat "MACHINE=wince-x86em-pocket-wce300" zipdist ..\miniperl makedist.pl --clean-exts call WCEMIPS-palm211 compile.bat "MACHINE=wince-mips-palm-wce211" call WCEMIPS-palm211 compile.bat "MACHINE=wince-mips-palm-wce211" zipdist ..\miniperl makedist.pl --clean-exts call WCESH3-palm211 compile.bat "MACHINE=wince-sh3-palm-wce211" call WCESH3-palm211 compile.bat "MACHINE=wince-sh3-palm-wce211" zipdist ..\miniperl makedist.pl --clean-exts call WCEx86-palm211 compile.bat "MACHINE=wince-x86em-palm-wce211" call WCEx86-palm211 compile.bat "MACHINE=wince-x86em-palm-wce211" zipdist ..\miniperl makedist.pl --clean-exts perl-5.12.0-RC0/win32/ce-helpers/compile.bat0000444000175000017500000000272411325125742017245 0ustar jessejesse@echo off rem rem edit ARG-xxx variable to reflect your system and run rem compile.bat [target] [additional parameters for nmake] rem set ARG-1=PV= set ARG-2=INST_VER= set ARG-3=INSTALL_ROOT=\Storage Card\perl58m set ARG-4=WCEROOT=%SDKROOT% set ARG-5=CEPATH=%WCEROOT% set ARG-6=CELIBDLLDIR=d:\personal\pocketPC\celib-palm-3.0 set ARG-7=CECONSOLEDIR=d:\personal\pocketPC\w32console rem Only for WIN2000 set ARG-8=YES=/y set ARG-9=CFG=RELEASE rem rem uncomment one of following lines that matches your configuration rem set ARG-10=MACHINE=wince-mips-pocket-wce300 rem set ARG-10=MACHINE=wince-arm-hpc-wce300 rem set ARG-10=MACHINE=wince-arm-hpc-wce211 rem set ARG-10=MACHINE=wince-sh3-hpc-wce211 rem set ARG-10=MACHINE=wince-mips-hpc-wce211 rem set ARG-10=MACHINE=wince-sh3-hpc-wce200 rem set ARG-10=MACHINE=wince-mips-hpc-wce200 rem set ARG-10=MACHINE=wince-arm-pocket-wce300 rem set ARG-10=MACHINE=wince-mips-pocket-wce300 rem set ARG-10=MACHINE=wince-sh3-pocket-wce300 rem set ARG-10=MACHINE=wince-x86em-pocket-wce300 rem set ARG-10=MACHINE=wince-mips-palm-wce211 rem set ARG-10=MACHINE=wince-sh3-palm-wce211 rem set ARG-10=MACHINE=wince-x86em-palm-wce211 set ARG-11=PERLCEDIR=$(MAKEDIR) set ARG-12=MSVCDIR=D:\MSVStudio\VC98 set ARG-13=CECOPY=$(HPERL) -I$(PERLCEDIR)\lib $(PERLCEDIR)\comp.pl --copy nmake -f Makefile.ce "%ARG-1%" "%ARG-2%" "%ARG-3%" "%ARG-4%" "%ARG-5%" "%ARG-6%" "%ARG-7%" "%ARG-8%" "%ARG-9%" "%ARG-10%" "%ARG-11%" "%ARG-12%" "%ARG-13%" %1 %2 %3 %4 %5 %6 %7 %8 %9 perl-5.12.0-RC0/win32/runperl.c0000444000175000017500000000111211325125742014717 0ustar jessejesse#include "EXTERN.h" #include "perl.h" #ifdef __GNUC__ /* Mingw32 defaults to globing command line * This is inconsistent with other Win32 ports and * seems to cause trouble with passing -DXSVERSION=\"1.6\" * So we turn it off like this, but only when compiling * perlmain.c: perlmainst.c is linked into the same executable * as win32.c, which also does this, so we mustn't do it twice * otherwise we get a multiple definition error. */ #ifndef PERLDLL int _CRT_glob = 0; #endif #endif int main(int argc, char **argv, char **env) { return RunPerl(argc, argv, env); } perl-5.12.0-RC0/win32/win32ceio.c0000444000175000017500000001676411325125742015055 0ustar jessejesse#define PERL_NO_GET_CONTEXT #define WIN32_LEAN_AND_MEAN #define WIN32IO_IS_STDIO #include #ifdef __GNUC__ #define Win32_Winsock #endif #include #include #include #include "EXTERN.h" #include "perl.h" #ifdef PERLIO_LAYERS #include "perliol.h" #define NO_XSLOCKS #include "XSUB.h" /* Bottom-most level for Win32 case */ typedef struct { struct _PerlIO base; /* The generic part */ HANDLE h; /* OS level handle */ IV refcnt; /* REFCNT for the "fd" this represents */ int fd; /* UNIX like file descriptor - index into fdtable */ } PerlIOWin32; PerlIOWin32 *fdtable[256]; IV max_open_fd = -1; IV PerlIOWin32_popped(pTHX_ PerlIO *f) { PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32); if (--s->refcnt > 0) { *f = PerlIOBase(f)->next; return 1; } fdtable[s->fd] = NULL; return 0; } IV PerlIOWin32_fileno(pTHX_ PerlIO *f) { return PerlIOSelf(f,PerlIOWin32)->fd; } IV PerlIOWin32_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) { IV code = PerlIOBase_pushed(aTHX_ f,mode,arg,tab); if (*PerlIONext(f)) { PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32); s->fd = PerlIO_fileno(PerlIONext(f)); } PerlIOBase(f)->flags |= PERLIO_F_OPEN; return code; } PerlIO * PerlIOWin32_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) { const char *tmode = mode; HANDLE h = INVALID_HANDLE_VALUE; if (f) { /* Close if already open */ if (PerlIOBase(f)->flags & PERLIO_F_OPEN) (*PerlIOBase(f)->tab->Close)(aTHX_ f); } if (narg > 0) { char *path = SvPV_nolen(*args); DWORD access = 0; DWORD share = 0; DWORD create = -1; DWORD attr = FILE_ATTRIBUTE_NORMAL; if (*mode == '#') { /* sysopen - imode is UNIX-like O_RDONLY etc. - do_open has converted that back to string form in mode as well - perm is UNIX like permissions */ mode++; } else { /* Normal open - decode mode string */ } switch(*mode) { case 'r': access = GENERIC_READ; create = OPEN_EXISTING; if (*++mode == '+') { access |= GENERIC_WRITE; create = OPEN_ALWAYS; mode++; } break; case 'w': access = GENERIC_WRITE; create = TRUNCATE_EXISTING; if (*++mode == '+') { access |= GENERIC_READ; mode++; } break; case 'a': access = GENERIC_WRITE; create = OPEN_ALWAYS; if (*++mode == '+') { access |= GENERIC_READ; mode++; } break; } if (*mode == 'b') { mode++; } else if (*mode == 't') { mode++; } if (*mode || create == -1) { //FIX-ME: SETERRNO(EINVAL,LIB$_INVARG); XCEMessageBoxA(NULL, "NEED TO IMPLEMENT a place in ../wince/win32io.c", "Perl(developer)", 0); return NULL; } if (!(access & GENERIC_WRITE)) share = FILE_SHARE_READ; h = CreateFileW(path,access,share,NULL,create,attr,NULL); if (h == INVALID_HANDLE_VALUE) { if (create == TRUNCATE_EXISTING) h = CreateFileW(path,access,share,NULL,(create = OPEN_ALWAYS),attr,NULL); } } else { /* fd open */ h = INVALID_HANDLE_VALUE; if (fd >= 0 && fd <= max_open_fd) { PerlIOWin32 *s = fdtable[fd]; if (s) { s->refcnt++; if (!f) f = PerlIO_allocate(aTHX); *f = &s->base; return f; } } if (*mode == 'I') { mode++; switch(fd) { case 0: h = XCEGetStdHandle(STD_INPUT_HANDLE); break; case 1: h = XCEGetStdHandle(STD_OUTPUT_HANDLE); break; case 2: h = XCEGetStdHandle(STD_ERROR_HANDLE); break; } } } if (h != INVALID_HANDLE_VALUE) fd = win32_open_osfhandle((intptr_t) h, PerlIOUnix_oflags(tmode)); if (fd >= 0) { PerlIOWin32 *s; if (!f) f = PerlIO_allocate(aTHX); s = PerlIOSelf(PerlIO_push(aTHX_ f,self,tmode,PerlIOArg),PerlIOWin32); s->h = h; s->fd = fd; s->refcnt = 1; if (fd >= 0) { fdtable[fd] = s; if (fd > max_open_fd) max_open_fd = fd; } return f; } if (f) { /* FIXME: pop layers ??? */ } return NULL; } SSize_t PerlIOWin32_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) { PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32); DWORD len; if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) return 0; if (ReadFile(s->h,vbuf,count,&len,NULL)) { return len; } else { if (GetLastError() != NO_ERROR) { PerlIOBase(f)->flags |= PERLIO_F_ERROR; return -1; } else { if (count != 0) PerlIOBase(f)->flags |= PERLIO_F_EOF; return 0; } } } SSize_t PerlIOWin32_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) { PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32); DWORD len; if (WriteFile(s->h,vbuf,count,&len,NULL)) { return len; } else { PerlIOBase(f)->flags |= PERLIO_F_ERROR; return -1; } } IV PerlIOWin32_seek(pTHX_ PerlIO *f, Off_t offset, int whence) { static const DWORD where[3] = { FILE_BEGIN, FILE_CURRENT, FILE_END }; PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32); DWORD high = (sizeof(offset) > sizeof(DWORD)) ? (DWORD)(offset >> 32) : 0; DWORD low = (DWORD) offset; DWORD res = SetFilePointer(s->h,low,&high,where[whence]); if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR) { return 0; } else { return -1; } } Off_t PerlIOWin32_tell(pTHX_ PerlIO *f) { PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32); DWORD high = 0; DWORD res = SetFilePointer(s->h,0,&high,FILE_CURRENT); if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR) { return ((Off_t) high << 32) | res; } return (Off_t) -1; } IV PerlIOWin32_close(pTHX_ PerlIO *f) { PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32); if (s->refcnt == 1) { IV code = 0; #if 0 /* This does not do pipes etc. correctly */ if (!CloseHandle(s->h)) { s->h = INVALID_HANDLE_VALUE; return -1; } #else PerlIOBase(f)->flags &= ~PERLIO_F_OPEN; return win32_close(s->fd); #endif } return 0; } PerlIO * PerlIOWin32_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *params, int flags) { PerlIOWin32 *os = PerlIOSelf(f,PerlIOWin32); HANDLE proc = GetCurrentProcess(); HANDLE new; if (DuplicateHandle(proc, os->h, proc, &new, 0, FALSE, DUPLICATE_SAME_ACCESS)) { char mode[8]; int fd = win32_open_osfhandle((intptr_t) new, PerlIOUnix_oflags(PerlIO_modestr(o,mode))); if (fd >= 0) { f = PerlIOBase_dup(aTHX_ f, o, params, flags); if (f) { PerlIOWin32 *fs = PerlIOSelf(f,PerlIOWin32); fs->h = new; fs->fd = fd; fs->refcnt = 1; fdtable[fd] = fs; if (fd > max_open_fd) max_open_fd = fd; } else { win32_close(fd); } } else { CloseHandle(new); } } return f; } PerlIO_funcs PerlIO_win32 = { sizeof(PerlIO_funcs), "win32", sizeof(PerlIOWin32), PERLIO_K_RAW, PerlIOWin32_pushed, PerlIOWin32_popped, PerlIOWin32_open, PerlIOBase_binmode, NULL, /* getarg */ PerlIOWin32_fileno, PerlIOWin32_dup, PerlIOWin32_read, PerlIOBase_unread, PerlIOWin32_write, PerlIOWin32_seek, PerlIOWin32_tell, PerlIOWin32_close, PerlIOBase_noop_ok, /* flush */ PerlIOBase_noop_fail, /* fill */ PerlIOBase_eof, PerlIOBase_error, PerlIOBase_clearerr, PerlIOBase_setlinebuf, NULL, /* get_base */ NULL, /* get_bufsiz */ NULL, /* get_ptr */ NULL, /* get_cnt */ NULL, /* set_ptrcnt */ }; #endif perl-5.12.0-RC0/win32/win32sck.c0000444000175000017500000004174311325127002014700 0ustar jessejesse/* win32sck.c * * (c) 1995 Microsoft Corporation. All rights reserved. * Developed by hip communications inc. * Portions (c) 1993 Intergraph Corporation. All rights reserved. * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. */ #define WIN32IO_IS_STDIO #define WIN32SCK_IS_STDSCK #define WIN32_LEAN_AND_MEAN #define PERLIO_NOT_STDIO 0 #ifdef __GNUC__ #define Win32_Winsock #endif #include #include #include "EXTERN.h" #include "perl.h" #include "Win32iop.h" #include #include #include #include #include /* thanks to Beverly Brown (beverly@datacube.com) */ #ifdef USE_SOCKETS_AS_HANDLES # define OPEN_SOCKET(x) win32_open_osfhandle(x,O_RDWR|O_BINARY) # define TO_SOCKET(x) _get_osfhandle(x) #else # define OPEN_SOCKET(x) (x) # define TO_SOCKET(x) (x) #endif /* USE_SOCKETS_AS_HANDLES */ #define StartSockets() \ STMT_START { \ if (!wsock_started) \ start_sockets(); \ } STMT_END #define SOCKET_TEST(x, y) \ STMT_START { \ StartSockets(); \ if((x) == (y)) \ errno = WSAGetLastError(); \ } STMT_END #define SOCKET_TEST_ERROR(x) SOCKET_TEST(x, SOCKET_ERROR) static struct servent* win32_savecopyservent(struct servent*d, struct servent*s, const char *proto); static int wsock_started = 0; EXTERN_C void EndSockets(void) { if (wsock_started) WSACleanup(); } void start_sockets(void) { dTHX; unsigned short version; WSADATA retdata; int ret; /* * initalize the winsock interface and insure that it is * cleaned up at exit. */ version = 0x2; if(ret = WSAStartup(version, &retdata)) 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"); /* atexit((void (*)(void)) EndSockets); */ wsock_started = 1; } #ifndef USE_SOCKETS_AS_HANDLES #undef fdopen FILE * my_fdopen(int fd, char *mode) { FILE *fp; char sockbuf[256]; int optlen = sizeof(sockbuf); int retval; if (!wsock_started) return(fdopen(fd, mode)); retval = getsockopt((SOCKET)fd, SOL_SOCKET, SO_TYPE, sockbuf, &optlen); if(retval == SOCKET_ERROR && WSAGetLastError() == WSAENOTSOCK) { return(fdopen(fd, mode)); } /* * If we get here, then fd is actually a socket. */ Newxz(fp, 1, FILE); /* XXX leak, good thing this code isn't used */ if(fp == NULL) { errno = ENOMEM; return NULL; } fp->_file = fd; if(*mode == 'r') fp->_flag = _IOREAD; else fp->_flag = _IOWRT; return fp; } #endif /* USE_SOCKETS_AS_HANDLES */ u_long win32_htonl(u_long hostlong) { StartSockets(); return htonl(hostlong); } u_short win32_htons(u_short hostshort) { StartSockets(); return htons(hostshort); } u_long win32_ntohl(u_long netlong) { StartSockets(); return ntohl(netlong); } u_short win32_ntohs(u_short netshort) { StartSockets(); return ntohs(netshort); } SOCKET win32_accept(SOCKET s, struct sockaddr *addr, int *addrlen) { SOCKET r; SOCKET_TEST((r = accept(TO_SOCKET(s), addr, addrlen)), INVALID_SOCKET); return OPEN_SOCKET(r); } int win32_bind(SOCKET s, const struct sockaddr *addr, int addrlen) { int r; SOCKET_TEST_ERROR(r = bind(TO_SOCKET(s), addr, addrlen)); return r; } int win32_connect(SOCKET s, const struct sockaddr *addr, int addrlen) { int r; SOCKET_TEST_ERROR(r = connect(TO_SOCKET(s), addr, addrlen)); return r; } int win32_getpeername(SOCKET s, struct sockaddr *addr, int *addrlen) { int r; SOCKET_TEST_ERROR(r = getpeername(TO_SOCKET(s), addr, addrlen)); return r; } int win32_getsockname(SOCKET s, struct sockaddr *addr, int *addrlen) { int r; SOCKET_TEST_ERROR(r = getsockname(TO_SOCKET(s), addr, addrlen)); return r; } int win32_getsockopt(SOCKET s, int level, int optname, char *optval, int *optlen) { int r; SOCKET_TEST_ERROR(r = getsockopt(TO_SOCKET(s), level, optname, optval, optlen)); return r; } int win32_ioctlsocket(SOCKET s, long cmd, u_long *argp) { int r; SOCKET_TEST_ERROR(r = ioctlsocket(TO_SOCKET(s), cmd, argp)); return r; } int win32_listen(SOCKET s, int backlog) { int r; SOCKET_TEST_ERROR(r = listen(TO_SOCKET(s), backlog)); return r; } int win32_recv(SOCKET s, char *buf, int len, int flags) { int r; SOCKET_TEST_ERROR(r = recv(TO_SOCKET(s), buf, len, flags)); return r; } int win32_recvfrom(SOCKET s, char *buf, int len, int flags, struct sockaddr *from, int *fromlen) { int r; int frombufsize = *fromlen; SOCKET_TEST_ERROR(r = recvfrom(TO_SOCKET(s), buf, len, flags, from, fromlen)); /* Winsock's recvfrom() only returns a valid 'from' when the socket * is connectionless. Perl expects a valid 'from' for all types * of sockets, so go the extra mile. */ if (r != SOCKET_ERROR && frombufsize == *fromlen) (void)win32_getpeername(s, from, fromlen); return r; } /* select contributed by Vincent R. Slyngstad (vrs@ibeam.intel.com) */ int win32_select(int nfds, Perl_fd_set* rd, Perl_fd_set* wr, Perl_fd_set* ex, const struct timeval* timeout) { int r; #ifdef USE_SOCKETS_AS_HANDLES int i, fd, save_errno = errno; FD_SET nrd, nwr, nex; bool just_sleep = TRUE; StartSockets(); FD_ZERO(&nrd); 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); just_sleep = FALSE; } 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); 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; } errno = save_errno; SOCKET_TEST_ERROR(r = select(nfds, &nrd, &nwr, &nex, timeout)); 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); } } errno = save_errno; #else SOCKET_TEST_ERROR(r = select(nfds, rd, wr, ex, timeout)); #endif return r; } int win32_send(SOCKET s, const char *buf, int len, int flags) { int r; SOCKET_TEST_ERROR(r = send(TO_SOCKET(s), buf, len, flags)); return r; } int win32_sendto(SOCKET s, const char *buf, int len, int flags, const struct sockaddr *to, int tolen) { int r; SOCKET_TEST_ERROR(r = sendto(TO_SOCKET(s), buf, len, flags, to, tolen)); return r; } int win32_setsockopt(SOCKET s, int level, int optname, const char *optval, int optlen) { int r; SOCKET_TEST_ERROR(r = setsockopt(TO_SOCKET(s), level, optname, optval, optlen)); return r; } int win32_shutdown(SOCKET s, int how) { int r; SOCKET_TEST_ERROR(r = shutdown(TO_SOCKET(s), how)); return r; } int win32_closesocket(SOCKET s) { int r; SOCKET_TEST_ERROR(r = closesocket(TO_SOCKET(s))); return r; } #ifdef USE_SOCKETS_AS_HANDLES #define WIN32_OPEN_SOCKET(af, type, protocol) open_ifs_socket(af, type, protocol) void convert_proto_info_w2a(WSAPROTOCOL_INFOW *in, WSAPROTOCOL_INFOA *out) { Copy(in, out, 1, WSAPROTOCOL_INFOA); wcstombs(out->szProtocol, in->szProtocol, sizeof(out->szProtocol)); } SOCKET open_ifs_socket(int af, int type, int protocol) { dTHX; char *s; unsigned long proto_buffers_len = 0; int error_code; SOCKET out = INVALID_SOCKET; if ((s = PerlEnv_getenv("PERL_ALLOW_NON_IFS_LSP")) && atoi(s)) return WSASocket(af, type, protocol, NULL, 0, 0); if (WSCEnumProtocols(NULL, NULL, &proto_buffers_len, &error_code) == SOCKET_ERROR && error_code == WSAENOBUFS) { WSAPROTOCOL_INFOW *proto_buffers; int protocols_available = 0; Newx(proto_buffers, proto_buffers_len / sizeof(WSAPROTOCOL_INFOW), WSAPROTOCOL_INFOW); if ((protocols_available = WSCEnumProtocols(NULL, proto_buffers, &proto_buffers_len, &error_code)) != SOCKET_ERROR) { int i; for (i = 0; i < protocols_available; i++) { WSAPROTOCOL_INFOA proto_info; if ((af != AF_UNSPEC && af != proto_buffers[i].iAddressFamily) || (type != proto_buffers[i].iSocketType) || (protocol != 0 && proto_buffers[i].iProtocol != 0 && protocol != proto_buffers[i].iProtocol)) continue; if ((proto_buffers[i].dwServiceFlags1 & XP1_IFS_HANDLES) == 0) continue; convert_proto_info_w2a(&(proto_buffers[i]), &proto_info); out = WSASocket(af, type, protocol, &proto_info, 0, 0); break; } } Safefree(proto_buffers); } return out; } #else #define WIN32_OPEN_SOCKET(af, type, protocol) socket(af, type, protocol) #endif SOCKET win32_socket(int af, int type, int protocol) { SOCKET s; #ifndef USE_SOCKETS_AS_HANDLES SOCKET_TEST(s = socket(af, type, protocol), INVALID_SOCKET); #else StartSockets(); if((s = WIN32_OPEN_SOCKET(af, type, protocol)) == INVALID_SOCKET) errno = WSAGetLastError(); else s = OPEN_SOCKET(s); #endif /* USE_SOCKETS_AS_HANDLES */ return s; } /* * close RTL fd while respecting sockets * added as temporary measure until PerlIO has real * Win32 native layer * -- BKS, 11-11-2000 */ int my_close(int fd) { int osf; if (!wsock_started) /* No WinSock? */ 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) { #if defined(USE_FIXED_OSFHANDLE) || defined(PERL_MSVCRT_READFIX) _set_osfhnd(fd, INVALID_HANDLE_VALUE); #endif (void)close(fd); /* handle already closed, ignore error */ return 0; } else if (err == SOCKET_ERROR) { err = WSAGetLastError(); if (err != WSAENOTSOCK) { (void)close(fd); errno = err; return EOF; } } } return close(fd); } #undef fclose int my_fclose (FILE *pf) { int osf; if (!wsock_started) /* No WinSock? */ 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) { #if defined(USE_FIXED_OSFHANDLE) || defined(PERL_MSVCRT_READFIX) _set_osfhnd(win32_fileno(pf), INVALID_HANDLE_VALUE); #endif (void)fclose(pf); /* handle already closed, ignore error */ return 0; } else if (err == SOCKET_ERROR) { err = WSAGetLastError(); if (err != WSAENOTSOCK) { (void)fclose(pf); errno = err; return EOF; } } } return fclose(pf); } #undef fstat int my_fstat(int fd, Stat_t *sbufptr) { /* This fixes a bug in fstat() on Windows 9x. fstat() uses the * GetFileType() win32 syscall, which will fail on Windows 9x. * So if we recognize a socket on Windows 9x, we return the * same results as on Windows NT/2000. * XXX this should be extended further to set S_IFSOCK on * sbufptr->st_mode. */ int osf; if (!wsock_started || IsWinNT()) { #if defined(WIN64) || defined(USE_LARGE_FILES) #if defined(__BORLANDC__) /* buk */ return win32_fstat(fd, sbufptr ); #else return _fstati64(fd, sbufptr); #endif #else return fstat(fd, sbufptr); #endif } osf = TO_SOCKET(fd); if (osf != -1) { char sockbuf[256]; int optlen = sizeof(sockbuf); int retval; retval = getsockopt((SOCKET)osf, SOL_SOCKET, SO_TYPE, sockbuf, &optlen); if (retval != SOCKET_ERROR || WSAGetLastError() != WSAENOTSOCK) { #if defined(__BORLANDC__)&&(__BORLANDC__<=0x520) sbufptr->st_mode = S_IFIFO; #else sbufptr->st_mode = _S_IFIFO; #endif sbufptr->st_rdev = sbufptr->st_dev = (dev_t)fd; sbufptr->st_nlink = 1; sbufptr->st_uid = sbufptr->st_gid = sbufptr->st_ino = 0; sbufptr->st_atime = sbufptr->st_mtime = sbufptr->st_ctime = 0; sbufptr->st_size = (Off_t)0; return 0; } } #if defined(WIN64) || defined(USE_LARGE_FILES) #if defined(__BORLANDC__) /* buk */ return win32_fstat(fd, sbufptr ); #else return _fstati64(fd, sbufptr); #endif #else return fstat(fd, sbufptr); #endif } struct hostent * win32_gethostbyaddr(const char *addr, int len, int type) { struct hostent *r; SOCKET_TEST(r = gethostbyaddr(addr, len, type), NULL); return r; } struct hostent * win32_gethostbyname(const char *name) { struct hostent *r; SOCKET_TEST(r = gethostbyname(name), NULL); return r; } int win32_gethostname(char *name, int len) { int r; SOCKET_TEST_ERROR(r = gethostname(name, len)); return r; } struct protoent * win32_getprotobyname(const char *name) { struct protoent *r; SOCKET_TEST(r = getprotobyname(name), NULL); return r; } struct protoent * win32_getprotobynumber(int num) { struct protoent *r; SOCKET_TEST(r = getprotobynumber(num), NULL); return r; } struct servent * win32_getservbyname(const char *name, const char *proto) { dTHX; struct servent *r; SOCKET_TEST(r = getservbyname(name, proto), NULL); if (r) { r = win32_savecopyservent(&w32_servent, r, proto); } return r; } struct servent * win32_getservbyport(int port, const char *proto) { dTHX; struct servent *r; SOCKET_TEST(r = getservbyport(port, proto), NULL); if (r) { r = win32_savecopyservent(&w32_servent, r, proto); } return r; } int win32_ioctl(int i, unsigned int u, char *data) { dTHX; u_long u_long_arg; int retval; if (!wsock_started) { Perl_croak_nocontext("ioctl implemented only on sockets"); /* NOTREACHED */ } /* mauke says using memcpy avoids alignment issues */ memcpy(&u_long_arg, data, sizeof u_long_arg); retval = ioctlsocket(TO_SOCKET(i), (long)u, &u_long_arg); memcpy(data, &u_long_arg, sizeof u_long_arg); if (retval == SOCKET_ERROR) { if (WSAGetLastError() == WSAENOTSOCK) { Perl_croak_nocontext("ioctl implemented only on sockets"); /* NOTREACHED */ } errno = WSAGetLastError(); } return retval; } char FAR * win32_inet_ntoa(struct in_addr in) { StartSockets(); return inet_ntoa(in); } unsigned long win32_inet_addr(const char FAR *cp) { StartSockets(); return inet_addr(cp); } /* * Networking stubs */ void win32_endhostent() { dTHX; Perl_croak_nocontext("endhostent not implemented!\n"); } void win32_endnetent() { dTHX; Perl_croak_nocontext("endnetent not implemented!\n"); } void win32_endprotoent() { dTHX; Perl_croak_nocontext("endprotoent not implemented!\n"); } void win32_endservent() { dTHX; Perl_croak_nocontext("endservent not implemented!\n"); } struct netent * win32_getnetent(void) { dTHX; Perl_croak_nocontext("getnetent not implemented!\n"); return (struct netent *) NULL; } struct netent * win32_getnetbyname(char *name) { dTHX; Perl_croak_nocontext("getnetbyname not implemented!\n"); return (struct netent *)NULL; } struct netent * win32_getnetbyaddr(long net, int type) { dTHX; Perl_croak_nocontext("getnetbyaddr not implemented!\n"); return (struct netent *)NULL; } struct protoent * win32_getprotoent(void) { dTHX; Perl_croak_nocontext("getprotoent not implemented!\n"); return (struct protoent *) NULL; } struct servent * win32_getservent(void) { dTHX; Perl_croak_nocontext("getservent not implemented!\n"); return (struct servent *) NULL; } void win32_sethostent(int stayopen) { dTHX; Perl_croak_nocontext("sethostent not implemented!\n"); } void win32_setnetent(int stayopen) { dTHX; Perl_croak_nocontext("setnetent not implemented!\n"); } void win32_setprotoent(int stayopen) { dTHX; Perl_croak_nocontext("setprotoent not implemented!\n"); } void win32_setservent(int stayopen) { dTHX; Perl_croak_nocontext("setservent not implemented!\n"); } static struct servent* win32_savecopyservent(struct servent*d, struct servent*s, const char *proto) { d->s_name = s->s_name; d->s_aliases = s->s_aliases; d->s_port = s->s_port; #ifndef __BORLANDC__ /* Buggy on Win95 and WinNT-with-Borland-WSOCK */ if (!IsWin95() && s->s_proto && strlen(s->s_proto)) d->s_proto = s->s_proto; else #endif if (proto && strlen(proto)) d->s_proto = (char *)proto; else d->s_proto = "tcp"; return d; } perl-5.12.0-RC0/win32/win32.h0000444000175000017500000004122611325127002014200 0ustar jessejesse/* WIN32.H * * (c) 1995 Microsoft Corporation. All rights reserved. * Developed by hip communications inc. * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. */ #ifndef _INC_WIN32_PERL5 #define _INC_WIN32_PERL5 #ifndef _WIN32_WINNT # define _WIN32_WINNT 0x0400 /* needed for TryEnterCriticalSection() etc. */ #endif #if defined(PERL_IMPLICIT_SYS) # define DYNAMIC_ENV_FETCH # define HAS_GETENV_LEN # define prime_env_iter() # define WIN32IO_IS_STDIO /* don't pull in custom stdio layer */ # define WIN32SCK_IS_STDSCK /* don't pull in custom wsock layer */ # ifdef PERL_GLOBAL_STRUCT # error PERL_GLOBAL_STRUCT cannot be defined with PERL_IMPLICIT_SYS # endif # define win32_get_privlib PerlEnv_lib_path # define win32_get_sitelib PerlEnv_sitelib_path # define win32_get_vendorlib PerlEnv_vendorlib_path #endif #ifdef __GNUC__ # ifndef __int64 /* some versions seem to #define it already */ # define __int64 long long # endif # define Win32_Winsock #ifdef __cplusplus /* Mingw32 gcc -xc++ objects to __attribute((unused)) at least */ #undef PERL_UNUSED_DECL #define PERL_UNUSED_DECL #endif #endif /* Define DllExport akin to perl's EXT, * If we are in the DLL or mimicing the DLL for Win95 work round * then Export the symbol, * otherwise import it. */ /* now even GCC supports __declspec() */ #if defined(PERLDLL) || defined(WIN95FIX) #define DllExport /*#define DllExport __declspec(dllexport)*/ /* noises with VC5+sp3 */ #else #define DllExport __declspec(dllimport) #endif #define WIN32_LEAN_AND_MEAN #include /* * Bug in winbase.h in mingw-w64 4.4.0-1 at least... they * do #define GetEnvironmentStringsA GetEnvironmentStrings and fail * to declare GetEnvironmentStringsA. */ #if defined(__MINGW64__) && defined(GetEnvironmentStringsA) && !defined(UNICODE) #ifdef __cplusplus extern "C" { #endif #undef GetEnvironmentStringsA WINBASEAPI LPCH WINAPI GetEnvironmentStringsA(VOID); #define GetEnvironmentStrings GetEnvironmentStringsA #ifdef __cplusplus } #endif #endif #ifdef WIN32_LEAN_AND_MEAN /* C file is NOT a Perl5 original. */ #define CONTEXT PERL_CONTEXT /* Avoid conflict of CONTEXT defs. */ #endif /*WIN32_LEAN_AND_MEAN */ #ifndef TLS_OUT_OF_INDEXES #define TLS_OUT_OF_INDEXES (DWORD)0xFFFFFFFF #endif #include #include #include #include #include #include #include #include #ifndef EXT #include "EXTERN.h" #endif struct tms { long tms_utime; long tms_stime; long tms_cutime; long tms_cstime; }; #ifndef SYS_NMLN #define SYS_NMLN 257 #endif struct utsname { char sysname[SYS_NMLN]; char nodename[SYS_NMLN]; char release[SYS_NMLN]; char version[SYS_NMLN]; char machine[SYS_NMLN]; }; #ifndef START_EXTERN_C #undef EXTERN_C #ifdef __cplusplus # define START_EXTERN_C extern "C" { # define END_EXTERN_C } # define EXTERN_C extern "C" #else # define START_EXTERN_C # define END_EXTERN_C # define EXTERN_C #endif #endif #define STANDARD_C 1 #define DOSISH 1 /* no escaping our roots */ #define OP_BINARY O_BINARY /* mistake in in pp_sys.c? */ /* Define USE_SOCKETS_AS_HANDLES to enable emulation of windows sockets as * real filehandles. XXX Should always be defined (the other version is untested) */ #define USE_SOCKETS_AS_HANDLES /* read() and write() aren't transparent for socket handles */ #define PERL_SOCK_SYSREAD_IS_RECV #define PERL_SOCK_SYSWRITE_IS_SEND #define PERL_NO_FORCE_LINK /* no need for PL_force_link_funcs */ /* Define USE_FIXED_OSFHANDLE to fix MSVCRT's _open_osfhandle() on W95. It now uses some black magic to work seamlessly with the DLL CRT and works with MSVC++ 4.0+ or GCC/Mingw32 -- BKS 1-24-2000 Only use this fix for VC++ 6.x or earlier (and for GCC, which we assume uses MSVCRT.DLL). Later versions use MSVCR70.dll, MSVCR71.dll, etc, which do not require the fix. */ #if (defined(_M_IX86) && _MSC_VER >= 1000 && _MSC_VER <= 1200) || defined(__MINGW32__) #define USE_FIXED_OSFHANDLE #endif /* Define PERL_WIN32_SOCK_DLOAD to have Perl dynamically load the winsock DLL when needed. Don't use if your compiler supports delayloading (ie, VC++ 6.0) -- BKS 5-29-2000 */ #if !(defined(_M_IX86) && _MSC_VER >= 1200) #define PERL_WIN32_SOCK_DLOAD #endif #define ENV_IS_CASELESS #define PIPESOCK_MODE "b" /* pipes, sockets default to binmode */ #ifndef VER_PLATFORM_WIN32_WINDOWS /* VC-2.0 headers don't have this */ #define VER_PLATFORM_WIN32_WINDOWS 1 #endif #ifndef FILE_SHARE_DELETE /* VC-4.0 headers don't have this */ #define FILE_SHARE_DELETE 0x00000004 #endif /* access() mode bits */ #ifndef R_OK # define R_OK 4 # define W_OK 2 # define X_OK 1 # define F_OK 0 #endif /* for waitpid() */ #ifndef WNOHANG # define WNOHANG 1 #endif #define PERL_GET_CONTEXT_DEFINED /* Compiler-specific stuff. */ #if defined(_MSC_VER) || defined(__MINGW32__) /* VC uses non-standard way to determine the size and alignment if bit-fields */ /* MinGW will compiler with -mms-bitfields, so should use the same types */ # define PERL_BITFIELD8 unsigned char # define PERL_BITFIELD16 unsigned short # define PERL_BITFIELD32 unsigned int #endif #ifdef __BORLANDC__ /* Borland C++ */ #if (__BORLANDC__ <= 0x520) #define _access access #define _chdir chdir #endif #define _getpid getpid #define wcsicmp _wcsicmp #include #ifndef DllMain #define DllMain DllEntryPoint #endif #pragma warn -8004 /* "'foo' is assigned a value that is never used" */ #pragma warn -8008 /* "condition is always true/false" */ #pragma warn -8012 /* "comparing signed and unsigned values" */ #pragma warn -8027 /* "functions containing %s are not expanded inline" */ #pragma warn -8057 /* "parameter 'foo' is never used" */ #pragma warn -8060 /* "possibly incorrect assignment" */ #pragma warn -8066 /* "unreachable code" */ #pragma warn -8071 /* "conversion may lose significant digits" */ #pragma warn -8080 /* "'foo' is declared but never used" */ /* Borland C thinks that a pointer to a member variable is 12 bytes in size. */ #define PERL_MEMBER_PTR_SIZE 12 #define isnan _isnan #endif #ifdef _MSC_VER /* Microsoft Visual C++ */ #ifndef UNDER_CE typedef long uid_t; typedef long gid_t; typedef unsigned short mode_t; #endif #pragma warning(disable: 4102) /* "unreferenced label" */ /* Visual C thinks that a pointer to a member variable is 16 bytes in size. */ #define PERL_MEMBER_PTR_SIZE 16 #define isnan _isnan #define snprintf _snprintf #define vsnprintf _vsnprintf #if _MSC_VER < 1300 /* VC6 has broken NaN semantics: NaN == NaN returns true instead of false */ #define NAN_COMPARE_BROKEN 1 #endif #endif /* _MSC_VER */ #ifdef __MINGW32__ /* Minimal Gnu-Win32 */ typedef long uid_t; typedef long gid_t; #ifndef _environ #define _environ environ #endif #define flushall _flushall #define fcloseall _fcloseall #ifndef isnan #define isnan _isnan /* ...same libraries as MSVC */ #endif #ifndef _O_NOINHERIT # define _O_NOINHERIT 0x0080 # ifndef _NO_OLDNAMES # define O_NOINHERIT _O_NOINHERIT # endif #endif /* , pulled in by as of mingw-runtime-3.3, typedef's * (u)intptr_t but doesn't set the _(U)INTPTR_T_DEFINED defines */ #ifdef _STDINT_H # ifndef _INTPTR_T_DEFINED # define _INTPTR_T_DEFINED # endif # ifndef _UINTPTR_T_DEFINED # define _UINTPTR_T_DEFINED # endif #endif #endif /* __MINGW32__ */ /* both GCC/Mingw32 and MSVC++ 4.0 are missing this, so we put it here */ #ifndef CP_UTF8 # define CP_UTF8 65001 #endif /* compatibility stuff for other compilers goes here */ #ifndef _INTPTR_T_DEFINED typedef int intptr_t; # define _INTPTR_T_DEFINED #endif #ifndef _UINTPTR_T_DEFINED typedef unsigned int uintptr_t; # define _UINTPTR_T_DEFINED #endif START_EXTERN_C /* For UNIX compatibility. */ extern uid_t getuid(void); extern gid_t getgid(void); extern uid_t geteuid(void); extern gid_t getegid(void); extern int setuid(uid_t uid); extern int setgid(gid_t gid); extern int kill(int pid, int sig); extern int killpg(int pid, int sig); #ifndef USE_PERL_SBRK extern void *sbrk(ptrdiff_t need); # define HAS_SBRK_PROTO #endif extern char * getlogin(void); extern int chown(const char *p, uid_t o, gid_t g); extern int mkstemp(const char *path); #undef Stat #define Stat win32_stat #undef init_os_extras #define init_os_extras Perl_init_os_extras DllExport void Perl_win32_init(int *argcp, char ***argvp); DllExport void Perl_win32_term(void); DllExport void Perl_init_os_extras(void); DllExport void win32_str_os_error(void *sv, DWORD err); DllExport int RunPerl(int argc, char **argv, char **env); typedef struct { HANDLE childStdIn; HANDLE childStdOut; HANDLE childStdErr; /* * the following correspond to the fields of the same name * in the STARTUPINFO structure. Embedders can use these to * control the spawning process' look. * Example - to hide the window of the spawned process: * dwFlags = STARTF_USESHOWWINDOW; * wShowWindow = SW_HIDE; */ DWORD dwFlags; DWORD dwX; DWORD dwY; DWORD dwXSize; DWORD dwYSize; DWORD dwXCountChars; DWORD dwYCountChars; DWORD dwFillAttribute; WORD wShowWindow; } child_IO_table; DllExport void win32_get_child_IO(child_IO_table* ptr); DllExport HWND win32_create_message_window(void); #ifndef USE_SOCKETS_AS_HANDLES extern FILE * my_fdopen(int, char *); #endif extern int my_fclose(FILE *); extern int my_fstat(int fd, Stat_t *sbufptr); extern char * win32_get_privlib(const char *pl, STRLEN *const len); extern char * win32_get_sitelib(const char *pl, STRLEN *const len); extern char * win32_get_vendorlib(const char *pl, STRLEN *const len); extern int IsWin95(void); extern int IsWinNT(void); #ifdef PERL_IMPLICIT_SYS extern void win32_delete_internal_host(void *h); #endif extern char * staticlinkmodules[]; END_EXTERN_C typedef char * caddr_t; /* In malloc.c (core address). */ /* * handle socket stuff, assuming socket is always available */ #include #include #ifdef MYMALLOC #define EMBEDMYMALLOC /**/ /* #define USE_PERL_SBRK /**/ /* #define PERL_SBRK_VIA_MALLOC /**/ #endif #ifdef PERL_TEXTMODE_SCRIPTS # define PERL_SCRIPT_MODE "r" #else # define PERL_SCRIPT_MODE "rb" #endif /* * Now Win32 specific per-thread data stuff */ /* Leave the first couple ids after WM_USER unused because they * might be used by an embedding application, and on Windows * version before 2000 we might end up eating those messages * if they were not meant for us. */ #define WM_USER_MIN (WM_USER+30) #define WM_USER_MESSAGE (WM_USER_MIN) #define WM_USER_KILL (WM_USER_MIN+1) #define WM_USER_MAX (WM_USER_MIN+1) struct thread_intern { /* XXX can probably use one buffer instead of several */ char Wstrerror_buffer[512]; struct servent Wservent; char Wgetlogin_buffer[128]; # ifdef USE_SOCKETS_AS_HANDLES int Winit_socktype; # endif # ifdef HAVE_DES_FCRYPT char Wcrypt_buffer[30]; # endif # ifdef USE_RTL_THREAD_API void * retv; /* slot for thread return value */ # endif BOOL Wuse_showwindow; WORD Wshowwindow; }; #define HAVE_INTERP_INTERN typedef struct { long num; DWORD pids[MAXIMUM_WAIT_OBJECTS]; HANDLE handles[MAXIMUM_WAIT_OBJECTS]; } child_tab; #ifdef USE_ITHREADS typedef struct { long num; DWORD pids[MAXIMUM_WAIT_OBJECTS]; HANDLE handles[MAXIMUM_WAIT_OBJECTS]; HWND message_hwnds[MAXIMUM_WAIT_OBJECTS]; } pseudo_child_tab; #endif #ifndef Sighandler_t typedef Signal_t (*Sighandler_t) (int); #define Sighandler_t Sighandler_t #endif struct interp_intern { char * perlshell_tokens; char ** perlshell_vec; long perlshell_items; struct av * fdpid; child_tab * children; #ifdef USE_ITHREADS DWORD pseudo_id; pseudo_child_tab * pseudo_children; #endif void * internal_host; struct thread_intern thr_intern; HWND message_hwnd; UINT timerid; unsigned poll_count; Sighandler_t sigtable[SIG_SIZE]; }; DllExport int win32_async_check(pTHX); #define WIN32_POLL_INTERVAL 32768 #define PERL_ASYNC_CHECK() if (w32_do_async || PL_sig_pending) win32_async_check(aTHX) #define w32_perlshell_tokens (PL_sys_intern.perlshell_tokens) #define w32_perlshell_vec (PL_sys_intern.perlshell_vec) #define w32_perlshell_items (PL_sys_intern.perlshell_items) #define w32_fdpid (PL_sys_intern.fdpid) #define w32_children (PL_sys_intern.children) #define w32_num_children (w32_children->num) #define w32_child_pids (w32_children->pids) #define w32_child_handles (w32_children->handles) #define w32_pseudo_id (PL_sys_intern.pseudo_id) #define w32_pseudo_children (PL_sys_intern.pseudo_children) #define w32_num_pseudo_children (w32_pseudo_children->num) #define w32_pseudo_child_pids (w32_pseudo_children->pids) #define w32_pseudo_child_handles (w32_pseudo_children->handles) #define w32_pseudo_child_message_hwnds (w32_pseudo_children->message_hwnds) #define w32_internal_host (PL_sys_intern.internal_host) #define w32_timerid (PL_sys_intern.timerid) #define w32_message_hwnd (PL_sys_intern.message_hwnd) #define w32_sighandler (PL_sys_intern.sigtable) #define w32_poll_count (PL_sys_intern.poll_count) #define w32_do_async (w32_poll_count++ > WIN32_POLL_INTERVAL) #define w32_strerror_buffer (PL_sys_intern.thr_intern.Wstrerror_buffer) #define w32_getlogin_buffer (PL_sys_intern.thr_intern.Wgetlogin_buffer) #define w32_crypt_buffer (PL_sys_intern.thr_intern.Wcrypt_buffer) #define w32_servent (PL_sys_intern.thr_intern.Wservent) #define w32_init_socktype (PL_sys_intern.thr_intern.Winit_socktype) #define w32_use_showwindow (PL_sys_intern.thr_intern.Wuse_showwindow) #define w32_showwindow (PL_sys_intern.thr_intern.Wshowwindow) #ifdef USE_ITHREADS # define PERL_WAIT_FOR_CHILDREN \ STMT_START { \ if (w32_pseudo_children && w32_num_pseudo_children) { \ long children = w32_num_pseudo_children; \ WaitForMultipleObjects(children, \ w32_pseudo_child_handles, \ TRUE, INFINITE); \ while (children) \ CloseHandle(w32_pseudo_child_handles[--children]); \ } \ } STMT_END #endif #if defined(USE_FIXED_OSFHANDLE) || defined(PERL_MSVCRT_READFIX) #ifdef PERL_CORE /* C doesn't like repeat struct definitions */ #if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION>=3) #undef _CRTIMP #endif #ifndef _CRTIMP #define _CRTIMP __declspec(dllimport) #endif /* * Control structure for lowio file handles */ typedef struct { intptr_t osfhnd;/* underlying OS file HANDLE */ char osfile; /* attributes of file (e.g., open in text mode?) */ char pipech; /* one char buffer for handles opened on pipes */ int lockinitflag; CRITICAL_SECTION lock; } ioinfo; /* * Array of arrays of control structures for lowio files. */ EXTERN_C _CRTIMP ioinfo* __pioinfo[]; /* * Definition of IOINFO_L2E, the log base 2 of the number of elements in each * array of ioinfo structs. */ #define IOINFO_L2E 5 /* * Definition of IOINFO_ARRAY_ELTS, the number of elements in ioinfo array */ #define IOINFO_ARRAY_ELTS (1 << IOINFO_L2E) /* * Access macros for getting at an ioinfo struct and its fields from a * file handle */ #define _pioinfo(i) (__pioinfo[(i) >> IOINFO_L2E] + ((i) & (IOINFO_ARRAY_ELTS - 1))) #define _osfhnd(i) (_pioinfo(i)->osfhnd) #define _osfile(i) (_pioinfo(i)->osfile) #define _pipech(i) (_pioinfo(i)->pipech) /* since we are not doing a dup2(), this works fine */ #define _set_osfhnd(fh, osfh) (void)(_osfhnd(fh) = (intptr_t)osfh) #endif #endif /* IO.xs and POSIX.xs define PERLIO_NOT_STDIO to 1 */ #if defined(PERL_EXT_IO) || defined(PERL_EXT_POSIX) #undef PERLIO_NOT_STDIO #endif #define PERLIO_NOT_STDIO 0 #include "perlio.h" /* * This provides a layer of functions and macros to ensure extensions will * get to use the same RTL functions as the core. */ #include "win32iop.h" #define EXEC_ARGV_CAST(x) ((const char *const *) x) #if !defined(ECONNABORTED) && defined(WSAECONNABORTED) #define ECONNABORTED WSAECONNABORTED #endif #if !defined(ECONNRESET) && defined(WSAECONNRESET) #define ECONNRESET WSAECONNRESET #endif #if !defined(EAFNOSUPPORT) && defined(WSAEAFNOSUPPORT) #define EAFNOSUPPORT WSAEAFNOSUPPORT #endif /* Why not needed for ECONNREFUSED? --abe */ DllExport void *win32_signal_context(void); #define PERL_GET_SIG_CONTEXT win32_signal_context() #ifdef UNDER_CE #define Win_GetModuleHandle XCEGetModuleHandleA #define Win_GetProcAddress XCEGetProcAddressA #define Win_GetModuleFileName XCEGetModuleFileNameA #define Win_CreateSemaphore CreateSemaphoreW #else #define Win_GetModuleHandle GetModuleHandle #define Win_GetProcAddress GetProcAddress #define Win_GetModuleFileName GetModuleFileName #define Win_CreateSemaphore CreateSemaphore #endif #endif /* _INC_WIN32_PERL5 */ perl-5.12.0-RC0/win32/bin/0000755000175000017500000000000011351321567013645 5ustar jessejesseperl-5.12.0-RC0/win32/bin/pl2bat.pl0000444000175000017500000003077311325127002015363 0ustar jessejesse eval 'exec perl -x -S "$0" ${1+"$@"}' if 0; # In case running under some shell require 5; use Getopt::Std; use Config; $0 =~ s|.*[/\\]||; my $usage = <nul goto endofperl \@rem '; EOT } $head =~ s/^\t//gm; my $headlines = 2 + ($head =~ tr/\n/\n/); my $tail = "\n__END__\n:endofperl\n"; @ARGV = ('-') unless @ARGV; foreach ( @ARGV ) { process($_); } sub process { my( $file )= @_; my $myhead = $head; my $linedone = 0; my $taildone = 0; my $linenum = 0; my $skiplines = 0; my $line; my $start= $Config{startperl}; $start= "#!perl" unless $start =~ /^#!.*perl/; open( FILE, $file ) or die "$0: Can't open $file: $!"; @file = ; foreach $line ( @file ) { $linenum++; if ( $line =~ /^:endofperl\b/ ) { if( ! exists $OPT{'u'} ) { warn "$0: $file has already been converted to a batch file!\n"; return; } $taildone++; } if ( not $linedone and $line =~ /^#!.*perl/ ) { if( exists $OPT{'u'} ) { $skiplines = $linenum - 1; $line .= "#line ".(1+$headlines)."\n"; } else { $line .= "#line ".($linenum+$headlines)."\n"; } $linedone++; } if ( $line =~ /^#\s*line\b/ and $linenum == 2 + $skiplines ) { $line = ""; } } close( FILE ); $file =~ s/$OPT{'s'}$//oi; $file .= '.bat' unless $file =~ /\.bat$/i or $file =~ /^-$/; open( FILE, ">$file" ) or die "Can't open $file: $!"; print FILE $myhead; print FILE $start, ( $OPT{'w'} ? " -w" : "" ), "\n#line ", ($headlines+1), "\n" unless $linedone; print FILE @file[$skiplines..$#file]; print FILE $tail unless $taildone; close( FILE ); } __END__ =head1 NAME pl2bat - wrap perl code into a batch file =head1 SYNOPSIS B B<-h> B [B<-w>] S<[B<-a> I]> S<[B<-s> I]> [files] B [B<-w>] S<[B<-n> I]> S<[B<-o> I]> S<[B<-s> I]> [files] =head1 DESCRIPTION This utility converts a perl script into a batch file that can be executed on DOS-like operating systems. This is intended to allow you to use a Perl script like regular programs and batch files where you just enter the name of the script [probably minus the extension] plus any command-line arguments and the script is found in your B and run. =head2 ADVANTAGES There are several alternatives to this method of running a Perl script. They each have disadvantages that help you understand the motivation for using B. =over =item 1 C:> perl x:/path/to/script.pl [args] =item 2 C:> perl -S script.pl [args] =item 3 C:> perl -S script [args] =item 4 C:> ftype Perl=perl.exe "%1" %* C:> assoc .pl=Perl then C:> script.pl [args] =item 5 C:> ftype Perl=perl.exe "%1" %* C:> assoc .pl=Perl C:> set PathExt=%PathExt%;.PL then C:> script [args] =back B<1> and B<2> are the most basic invocation methods that should work on any system [DOS-like or not]. They require extra typing and require that the script user know that the script is written in Perl. This is a pain when you have lots of scripts, some written in Perl and some not. It can be quite difficult to keep track of which scripts need to be run through Perl and which do not. Even worse, scripts often get rewritten from simple batch files into more powerful Perl scripts in which case these methods would require all existing users of the scripts be updated. B<3> works on modern Win32 versions of Perl. It allows the user to omit the ".pl" or ".bat" file extension, which is a minor improvement. B<4> and B<5> work on some Win32 operating systems with some command shells. One major disadvantage with both is that you can't use them in pipelines nor with file redirection. For example, none of the following will work properly if you used method B<4> or B<5>: C:> script.pl script.pl >outfile C:> echo y | script.pl C:> script.pl | more This is due to a Win32 bug which Perl has no control over. This bug is the major motivation for B [which was originally written for DOS] being used on Win32 systems. Note also that B<5> works on a smaller range of combinations of Win32 systems and command shells while B<4> requires that the user know that the script is a Perl script [because the ".pl" extension must be entered]. This makes it hard to standardize on either of these methods. =head2 DISADVANTAGES There are several potential traps you should be aware of when you use B. The generated batch file is initially processed as a batch file each time it is run. This means that, to use it from within another batch file you should precede it with C or else the calling batch file will not run any commands after the script: call script [args] Except under Windows NT, if you specify more than 9 arguments to the generated batch file then the 10th and subsequent arguments are silently ignored. Except when using F under Windows NT, if F is not in your B, then trying to run the script will give you a generic "Command not found"-type of error message that will probably make you think that the script itself is not in your B. When using F under Windows NT, the generic error message is followed by "You do not have Perl in your PATH", to make this clearer. On most DOS-like operating systems, the only way to exit a batch file is to "fall off the end" of the file. B implements this by doing C and adding C<__END__> and C<:endofperl> as the last two lines of the generated batch file. This means: =over =item No line of your script should start with a colon. In particular, for this version of B, C<:endofperl>, C<:WinNT>, and C<:script_failed_so_exit_with_non_zero_val> should not be used. =item Care must be taken when using C<__END__> and the C file handle. One approach is: . #!perl . while( ) { . last if /^__END__$/; . [...] . } . __END__ . lines of data . to be processed . __END__ . :endofperl The dots in the first column are only there to prevent F to interpret the C<:endofperl> line in this documentation. Otherwise F itself wouldn't work. See the previous item. :-) =item The batch file always "succeeds" The following commands illustrate the problem: C:> echo exit(99); >fail.pl C:> pl2bat fail.pl C:> perl -e "print system('perl fail.pl')" 99 C:> perl -e "print system('fail.bat')" 0 So F always reports that it completed successfully. Actually, under Windows NT, we have: C:> perl -e "print system('fail.bat')" 1 So, for Windows NT, F fails when the Perl script fails, but the return code is always C<1>, not the return code from the Perl script. =back =head2 FUNCTION By default, the ".pl" suffix will be stripped before adding a ".bat" suffix to the supplied file names. This can be controlled with the C<-s> option. The default behavior is to have the batch file compare the C environment variable against C<"Windows_NT">. If they match, it uses the C<%*> construct to refer to all the command line arguments that were given to it, so you'll need to make sure that works on your variant of the command shell. It is known to work in the F shell under Windows NT. 4DOS/NT users will want to put a C line in their initialization file, or execute C in the shell startup file. On Windows95 and other platforms a nine-argument limit is imposed on command-line arguments given to the generated batch file, since they may not support C<%*> in batch files. These can be overridden using the C<-n> and C<-o> options or the deprecated C<-a> option. =head1 OPTIONS =over 8 =item B<-n> I Arguments to invoke perl with in generated batch file when run from Windows NT (or Windows 98, probably). Defaults to S<'-x -S %0 %*'>. =item B<-o> I Arguments to invoke perl with in generated batch file except when run from Windows NT (ie. when run from DOS, Windows 3.1, or Windows 95). Defaults to S<'-x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9'>. =item B<-a> I Arguments to invoke perl with in generated batch file. Specifying B<-a> prevents the batch file from checking the C environment variable to determine which operating system it is being run from. =item B<-s> I Strip a suffix string from file name before appending a ".bat" suffix. The suffix is not case-sensitive. It can be a regex if it begins with `/' (the trailing '/' is optional and a trailing C<$> is always assumed). Defaults to C. =item B<-w> If no line matching C is found in the script, then such a line is inserted just after the new preamble. The exact line depends on C<$Config{startperl}> [see L]. With the B<-w> option, C<" -w"> is added after the value of C<$Config{startperl}>. If a line matching C already exists in the script, then it is not changed and the B<-w> option is ignored. =item B<-u> If the script appears to have already been processed by B, then the script is skipped and not processed unless B<-u> was specified. If B<-u> is specified, the existing preamble is replaced. =item B<-h> Show command line usage. =back =head1 EXAMPLES C:\> pl2bat foo.pl bar.PM [..creates foo.bat, bar.PM.bat..] C:\> pl2bat -s "/\.pl|\.pm/" foo.pl bar.PM [..creates foo.bat, bar.bat..] C:\> pl2bat < somefile > another.bat C:\> pl2bat > another.bat print scalar reverse "rekcah lrep rehtona tsuj\n"; ^Z [..another.bat is now a certified japh application..] C:\> ren *.bat *.pl C:\> pl2bat -u *.pl [..updates the wrapping of some previously wrapped scripts..] C:\> pl2bat -u -s .bat *.bat [..same as previous example except more dangerous..] =head1 BUGS C<$0> will contain the full name, including the ".bat" suffix when the generated batch file runs. If you don't like this, see runperl.bat for an alternative way to invoke perl scripts. Default behavior is to invoke Perl with the B<-S> flag, so Perl will search the B to find the script. This may have undesirable effects. On really old versions of Win32 Perl, you can't run the script via C:> script.bat [args] and must use C:> script [args] A loop should be used to build up the argument list when not on Windows NT so more than 9 arguments can be processed. See also L. =head1 SEE ALSO perl, perlwin32, runperl.bat =cut perl-5.12.0-RC0/win32/bin/search.pl0000444000175000017500000015240111325127002015435 0ustar jessejesse#!/usr/local/bin/perl -w 'di'; 'ig00'; ############################################################################## ## ## search ## ## Jeffrey Friedl (jfriedl@omron.co.jp), Dec 1994. ## Copyright 19.... ah hell, just take it. ## ## BLURB: ## A combo of find and grep -- more or less do a 'grep' on a whole ## directory tree. Fast, with lots of options. Much more powerful than ## the simple "find ... | xargs grep ....". Has a full man page. ## Powerfully customizable. ## ## This file is big, but mostly comments and man page. ## ## See man page for usage info. ## Return value: 2=error, 1=nothing found, 0=something found. ## $version = "950918.5"; ## ## "950918.5"; ## Changed all 'sysread' to 'read' because Linux perl's don't seem ## to like sysread() ## ## "941227.4"; ## Added -n, -u ## ## "941222.3" ## Added -nice (due to Lionel Cons ) ## Removed any leading "./" from name. ## Added default flags for ~/.search, including TTY, -nice, -list, etc. ## Program name now has path removed when printed in diagnostics. ## Added simple tilde-expansion to -dir arg. ## Added -dskip, etc. Fixed -iregex bug. ## Changed -dir to be additive, adding -ddir. ## Now screen out devices, pipes, and sockets. ## More tidying and lots of expanding of the man page ## ## ## "941217.2"; ## initial release. $stripped=0; &init; if (exists $ENV{'HOME'}) { $rc_file = join('/', $ENV{'HOME'}, ".search"); } else { $rc_file = ""; } &check_args; ## Make sure we've got a regex. ## Don't need one if -find or -showrc was specified. $!=2, die "expecting regex arguments.\n" if $FIND_ONLY == 0 && $showrc == 0 && @ARGV == 0; &prepare_to_search($rc_file); &import_program if !defined &dodir; ## BIG key to speed. ## do search while there are directories to be done. &dodir(shift(@todo)) while @todo; &clear_message if $VERBOSE && $STDERR_IS_TTY; exit($retval); ############################################################################### sub init { ## initialize variables that might be reset by command-line args $DOREP=0; ## set true by -dorep (redo multi-hardlink files) $DOREP=1 if $^O eq 'MSWin32'; $DO_SORT=0; ## set by -sort (sort files in a dir before checking) $FIND_ONLY=0; ## set by -find (don't search files) $LIST_ONLY=0; ## set true by -l (list filenames only) $NEWER=0; ## set by -newer, "-mtime -###" $NICE=0; ## set by -nice (print human-readable output) $NOLINKS=0; ## set true by -nolinks (don't follow symlinks) $OLDER=0; ## set by -older, "-mtime ###" $PREPEND_FILENAME=1; ## set false by -h (don't prefix lines with filename) $REPORT_LINENUM=0; ## set true by -n (show line numbers) $VERBOSE=0; ## set to a value by -v, -vv, etc. (verbose messages) $WHY=0; ## set true by -why, -vvv+ (report why skipped) $XDEV=0; ## set true by -xdev (stay on one filesystem) $all=0; ## set true by -all (don't skip many kinds of files) $iflag = ''; ## set to 'i' by -i (ignore case); $norc=0; ## set by -norc (don't load rc file) $showrc=0; ## set by -showrc (show what happens with rc file) $underlineOK=0; ## set true by -u (watch for underline stuff) $words=0; ## set true by -w (match whole-words only) $DELAY=0; ## inter-file delay (seconds) $retval=1; ## will set to 0 if we find anything. ## various elements of stat() that we might access $STAT_DEV = 1; $STAT_INODE = 2; $STAT_MTIME = 9; $VV_PRINT_COUNT = 50; ## with -vv, print every VV_PRINT_COUNT files, or... $VV_SIZE = 1024*1024; ## ...every VV_SIZE bytes searched $vv_print = $vv_size = 0; ## running totals. ## set default options, in case the rc file wants them $opt{'TTY'}= 1 if -t STDOUT; ## want to know this for debugging message stuff $STDERR_IS_TTY = -t STDERR ? 1 : 0; $STDERR_SCREWS_STDOUT = ($STDERR_IS_TTY && -t STDOUT) ? 1 : 0; $0 =~ s,.*/,,; ## clean up $0 for any diagnostics we'll be printing. } ## ## Check arguments. ## sub check_args { while (@ARGV && $ARGV[0] =~ m/^-/) { $arg = shift(@ARGV); if ($arg eq '-version' || ($VERBOSE && $arg eq '-help')) { print qq/Jeffrey's file search, version "$version".\n/; exit(0) unless $arg eq '-help'; } if ($arg eq '-help') { print < # days ago (-# for < # days old) -newer FILE consider files modified more recently than FILE (also -older) -name GLOB consider files whose name matches pattern (also -regex). -skip GLOB opposite of -name: identifies files to not consider. -path GLOB like -name, but for files whose whole path is described. -dpath/-dregex/-dskip versions for selecting or pruning directories. -all don't skip any files marked to be skipped by the startup file. -x (see manual, and/or try -showrc). -why report why a file isn't checked (also implied by -vvvv). OPTIONS TELLING WHAT TO DO WITH FILES THAT WILL BE CONSIDERED: -f | -find just list files (PerlRegex ignored). Default is to grep them. -ff | -ffind Does a faster -find (implies -find -all -dorep) OPTIONS CONTROLLING HOW THE SEARCH IS DONE (AND WHAT IS PRINTED): -l | -list only list files with matches, not the lines themselves. -nice | -nnice print more "human readable" output. -n prefix each output line with its line number in the file. -h don't prefix output lines with file name. -u also look "inside" manpage-style underlined text -i do case-insensitive searching. -w match words only (as defined by perl's \\b). OTHER OPTIONS: -v, -vv, -vvv various levels of message verbosity. -e end of options (in case a regex looks like an option). -showrc show what the rc file sets, then exit. -norc don't load the rc file. -dorep check files with multiple hard links multiple times. INLINE_LITERAL_TEXT print "Use -v -help for more verbose help.\n" unless $VERBOSE; print "This script file is also a man page.\n" unless $stripped; print < $time; } next; } if ($arg =~ m/-mtime/) { $! = 2, die "$0: expecting numerical arg to -$arg\n" unless @ARGV; local($days) = shift(@ARGV); $! = 2, die qq/$0: inappropriate arg ($days) to $arg\n/ if $days==0; $days *= 3600 * 24; if ($days < 0) { local($time) = $^T + $days; $NEWER = $time if $NEWER < $time; } else { local($time) = $^T - $days; $OLDER = $time if $OLDER == 0 || $OLDER > $time; } next; } ## special user options if ($arg =~ m/^-x(.+)/) { foreach (split(/[\s,]+/, $1)) { $user_opt{$_} = $opt{$_}= 1; } next; } $! = 2, die "$0: unknown arg [$arg]\n"; } } ## ## Given a filename glob, return a regex. ## If the glob has no globbing chars (no * ? or [..]), then ## prepend an effective '*' to it. ## sub glob_to_regex { local($glob) = @_; local(@parts) = $glob =~ m/\\.|[*?]|\[]?[^]]*]|[^[\\*?]+/g; local($trueglob)=0; foreach (@parts) { if ($_ eq '*' || $_ eq '?') { $_ = ".$_"; $trueglob=1; ## * and ? are a real glob } elsif (substr($_, 0, 1) eq '[') { $trueglob=1; ## [..] is a real glob } else { s/^\\//; ## remove any leading backslash; s/\W/\\$&/g; ## now quote anything dangerous; } } unshift(@parts, '.*') unless $trueglob; join('', '^', @parts, '$'); } sub prepare_to_search { local($rc_file) = @_; $HEADER_BYTES=0; ## Might be set nonzero in &read_rc; $last_message_length = 0; ## For &message and &clear_message. &read_rc($rc_file, $showrc) unless $norc; exit(0) if $showrc; $NEXT_DIR_ENTRY = $DO_SORT ? 'shift @files' : 'readdir(DIR)'; $WHY = 1 if $VERBOSE > 3; ## Arg -vvvv or above implies -why. @todo = ('.') if @todo == 0; ## Where we'll start looking ## see if any user options were specified that weren't accounted for foreach $opt (keys %user_opt) { next if defined $seen_opt{$opt}; warn "warning: -x$opt never considered.\n"; } die "$0: multiple time constraints exclude all possible files.\n" if ($NEWER && $OLDER) && ($NEWER > $OLDER); ## ## Process any -skip/-iskip args that had been given ## local(@skip_test); foreach $glob (keys %skip) { $i = defined($iskip{$glob}) ? 'i': ''; push(@skip_test, '$name =~ m/'. &glob_to_regex($glob). "/$i"); } if (@skip_test) { $SKIP_TEST = join('||',@skip_test); $DO_SKIP_TEST = 1; } else { $DO_SKIP_TEST = $SKIP_TEST = 0; } ## ## Process any -dskip/-idskip args that had been given ## local(@dskip_test); foreach $glob (keys %dskip) { $i = defined($idskip{$glob}) ? 'i': ''; push(@dskip_test, '$name =~ m/'. &glob_to_regex($glob). "/$i"); } if (@dskip_test) { $DSKIP_TEST = join('||',@dskip_test); $DO_DSKIP_TEST = 1; } else { $DO_DSKIP_TEST = $DSKIP_TEST = 0; } ## ## Process any -name, -path, -regex, etc. args that had been given. ## undef @name_test; undef @dname_test; foreach $key (keys %name) { local($type, $pat) = split(/,/, $key, 2); local($i) = defined($iname{$key}) ? 'i' : ''; if ($type =~ /regex/) { $pat =~ s/!/\\!/g; $test = "\$name =~ m!^$pat\$!$i"; } else { local($var) = $type eq 'name' ? '$name' : '$file'; $test = "$var =~ m/". &glob_to_regex($pat). "/$i"; } if ($type =~ m/^-i?d/) { push(@dname_test, $test); } else { push(@name_test, $test); } } if (@name_test) { $GLOB_TESTS = join('||', @name_test); $DO_GLOB_TESTS = 1; } else { $GLOB_TESTS = $DO_GLOB_TESTS = 0; } if (@dname_test) { $DGLOB_TESTS = join('||', @dname_test); $DO_DGLOB_TESTS = 1; } else { $DGLOB_TESTS = $DO_DGLOB_TESTS = 0; } ## ## Process any 'magic' things from the startup file. ## if (@magic_tests && $HEADER_BYTES) { ## the $magic' one is for when &dodir is not inlined $tests = join('||',@magic_tests); $MAGIC_TESTS = " { package magic; \$val = ($tests) }"; $DO_MAGIC_TESTS = 1; } else { $MAGIC_TESTS = 1; $DO_MAGIC_TESTS = 0; } ## ## Prepare regular expressions. ## { local(@regex_tests); if ($LIST_ONLY) { $mflag = ''; ## need to have $* set, but perl5 just won''t shut up about it. if ($] >= 5) { $mflag = 'm'; } else { eval ' $* = 1 '; } } ## ## Until I figure out a better way to deal with it, ## We have to worry about a regex like [^xyz] when doing $LIST_ONLY. ## Such a regex *will* match \n, and if I'm pulling in multiple ## lines, it can allow lines to match that would otherwise not match. ## ## Therefore, if there is a '[^' in a regex, we can NOT take a chance ## an use the fast listonly. ## $CAN_USE_FAST_LISTONLY = $LIST_ONLY; local(@extra); local($underline_glue) = ($] >= 5) ? '(:?_\cH)?' : '(_\cH)?'; while (@ARGV) { $regex = shift(@ARGV); ## ## If watching for underlined things too, add another regex. ## if ($underlineOK) { if ($regex =~ m/[?*+{}()\\.|^\$[]/) { warn "$0: warning, can't underline-safe ``$regex''.\n"; } else { $regex = join($underline_glue, split(//, $regex)); } } ## If nothing special in the regex, just use index... ## is quite a bit faster. if (($iflag eq '') && ($words == 0) && $regex !~ m/[?*+{}()\\.|^\$[]/) { push(@regex_tests, "(index(\$_, q+$regex+)>=0)"); } else { $regex =~ s#[\$\@\/]\w#\\$&#; if ($words) { if ($regex =~ m/\|/) { ## could be dangerous -- see if we can wrap in parens. if ($regex =~ m/\\\d/) { warn "warning: -w and a | in a regex is dangerous.\n" } else { $regex = join($regex, '(', ')'); } } $regex = join($regex, '\b', '\b'); } $CAN_USE_FAST_LISTONLY = 0 if substr($regex, "[^") >= 0; push(@regex_tests, "m/$regex/$iflag$mflag"); } ## If we're done, but still have @extra to do, get set for that. if (@ARGV == 0 && @extra) { @ARGV = @extra; ## now deal with the extra stuff. $underlineOK = 0; ## but no more of this. undef @extra; ## or this. } } if (@regex_tests) { $REGEX_TEST = join('||', @regex_tests); ## print STDERR $REGEX_TEST, "\n"; exit; } else { ## must be doing -find -- just give something syntactically correct. $REGEX_TEST = 1; } } ## ## Make sure we can read the first item(s). ## foreach $start (@todo) { $! = 2, die qq/$0: can't stat "$start"\n/ unless ($dev,$inode) = (stat($start))[$STAT_DEV,$STAT_INODE]; if (defined $dir_done{"$dev,$inode"}) { ## ignore the repeat. warn(qq/ignoring "$start" (same as "$dir_done{"$dev,$inode"}").\n/) if $VERBOSE; next; } ## if -xdev was given, remember the device. $xdev{$dev} = 1 if $XDEV; ## Note that we won't want to do it again $dir_done{"$dev,$inode"} = $start; } } ## ## See the comment above the __END__ above the 'sub dodir' below. ## sub import_program { sub bad { print STDERR "$0: internal error (@_)\n"; exit 2; } ## Read from data, up to next __END__. This will be &dodir. local($/) = "\n__END__"; $prog = ; close(DATA); $prog =~ s/\beval\b//g; ## remove any 'eval' ## Inline uppercase $-variables by their current values. if ($] >= 5) { $prog =~ s/\$([A-Z][A-Z0-9_]{2,}\b)/ &bad($1) if !defined ${$main::{$1}}; ${$main::{$1}};/eg; } else { $prog =~ s/\$([A-Z][A-Z0-9_]{2,}\b)/local(*VAR) = $_main{$1}; &bad($1) if !defined $VAR; $VAR;/eg; } eval $prog; ## now do it. This will define &dodir; $!=2, die "$0 internal error: $@\n" if $@; } ########################################################################### ## ## Read the .search file: ## Blank lines and lines that are only #-comments ignored. ## Newlines may be escaped to create long lines ## Other lines are directives. ## ## A directive may begin with an optional tag in the form <...> ## Things inside the <...> are evaluated as with: ## <(this || that) && must> ## will be true if ## -xmust -xthis or -xmust -xthat ## were specified on the command line (order doesn't matter, though) ## A directive is not done if there is a tag and it's false. ## Any characters but whitespace and &|()>,! may appear after an -x ## (although "-xdev" is special). -xmust,this is the same as -xmust -xthis. ## Something like -x~ would make <~> true, and false. ## ## Directives are in the form: ## option: STRING ## magic : NUMBYTES : EXPR ## ## With option: ## The STRING is parsed like a Bourne shell command line, and the ## options are used as if given on the command line. ## No comments are allowed on 'option' lines. ## Examples: ## # skip objects and libraries ## option: -skip '.o .a' ## # skip emacs *~ and *# files, unless -x~ given: ## option: -skip '~ #' ## ## With magic: ## EXPR can be pretty much any perl (comments allowed!). ## If it evaluates to true for any particular file, it is skipped. ## The only info you'll have about a file is the variable $H, which ## will have at least the first NUMBYTES of the file (less if the file ## is shorter than that, of course, and maybe more). You'll also have ## any variables you set in previous 'magic' lines. ## Examples: ## magic: 6 : ($x6 = substr($H, 0, 6)) eq 'GIF87a' ## magic: 6 : $x6 eq 'GIF89a' ## ## magic: 6 : (($x6 = substr($H, 0, 6)) eq 'GIF87a' ## old gif \ ## || $x6 eq 'GIF89a' ## new gif ## (the above two sets are the same) ## ## Check the first 32 bytes for "binarish" looking bytes. ## ## Don't blindly dump on any high-bit set, as non-ASCII text ## ## often has them set. \x80 and \xff seem to be special, though. ## ## Require two in a row to not get things like perl's $^T. ## ## This is known to get *.Z, *.gz, pkzip, *.elc and about any ## ## executable you'll find. ## magic: 32 : $H =~ m/[\x00-\x06\x10-\x1a\x1c-\x1f\x80\xff]{2}/ ## sub read_rc { local($file, $show) = @_; local($line_num, $ln, $tag) = 0; local($use_default, @default) = 0; { package magic; $^W= 0; } ## turn off warnings for when we run EXPR's unless (open(RC, "$file")) { $use_default=1; $file = ""; ## no RC file -- use this default. @default = split(/\n/,<<'--------INLINE_LITERAL_TEXT'); magic: 32 : $H =~ m/[\x00-\x06\x10-\x1a\x1c-\x1f\x80\xff]{2}/ option: -skip '.a .elc .gz .o .pbm .xbm .dvi' option: -iskip '.com .exe .lib .pdb .tarz .zip .z .lzh .jpg .jpeg .gif .uu' option: -skip '~ #' --------INLINE_LITERAL_TEXT } ## ## Make an eval error pretty. ## sub clean_eval_error { local($_) = @_; s/ in file \(eval\) at line \d+,//g; ## perl4-style error s/ at \(eval \d+\) line \d+,//g; ## perl5-style error $_ = $` if m/\n/; ## remove all but first line "$_\n"; } print "reading RC file: $file\n" if $show; while (defined($_ = ($use_default ? shift(@default) : ))) { $ln = ++$line_num; ## note starting line num. $_ .= , $line_num++ while s/\\\n?$/\n/; ## allow continuations next if /^\s*(#.*)?$/; ## skip blank or comment-only lines. $do = ''; ## look for an initial <...> tag. if (s/^\s*<([^>]*)>//) { ## This simple s// will make the tag ready to eval. ($tag = $msg = $1) =~ s/[^\s&|(!)]+/ $seen_opt{$&}=1; ## note seen option "defined(\$opt{q>$&>})" ## (q>> is safe quoting here) /eg; ## see if the tag is true or not, abort this line if not. $dothis = (eval $tag); $!=2, die "$file $ln <$msg>: $_".&clean_eval_error($@) if $@; if ($show) { $msg =~ s/[^\s&|(!)]+/-x$&/; $msg =~ s/\s*!\s*/ no /g; $msg =~ s/\s*&&\s*/ and /g; $msg =~ s/\s*\|\|\s*/ or /g; $msg =~ s/^\s+//; $msg =~ s/\s+$//; $do = $dothis ? "(doing because $msg)" : "(do if $msg)"; } elsif (!$dothis) { next; } } if (m/^\s*option\s*:\s*/) { next if $all && !$show; ## -all turns off these checks; local($_) = $'; s/\n$//; local($orig) = $_; print " $do option: $_\n" if $show; local($0) = "$0 ($file)"; ## for any error message. local(@ARGV); local($this); ## ## Parse $_ as a Bourne shell line -- fill @ARGV ## while (length) { if (s/^\s+//) { push(@ARGV, $this) if defined $this; undef $this; next; } $this = '' if !defined $this; $this .= $1 while s/^'([^']*)'// || s/^"([^"]*)"// || s/^([^'"\s\\]+)//|| s/^(\\[\D\d])//; die "$file $ln: error parsing $orig at $_\n" if m/^\S/; } push(@ARGV, $this) if defined $this; &check_args; die qq/$file $ln: unused arg "@ARGV".\n/ if @ARGV; next; } if (m/^\s*magic\s*:\s*(\d+)\s*:\s*/) { next if $all && !$show; ## -all turns off these checks; local($bytes, $check) = ($1, $'); if ($show) { $check =~ s/\n?$/\n/; print " $do contents: $check"; } ## Check to make sure the thing at least compiles. eval "package magic; (\$H = '1'x \$main'bytes) && (\n$check\n)\n"; $! = 2, die "$file $ln: ".&clean_eval_error($@) if $@; $HEADER_BYTES = $bytes if $bytes > $HEADER_BYTES; push(@magic_tests, "(\n$check\n)"); next; } $! = 2, die "$file $ln: unknown command\n"; } close(RC); } sub message { if (!$STDERR_IS_TTY) { print STDERR $_[0], "\n"; } else { local($text) = @_; $thislength = length($text); if ($thislength >= $last_message_length) { print STDERR $text, "\r"; } else { print STDERR $text, ' 'x ($last_message_length-$thislength),"\r"; } $last_message_length = $thislength; } } sub clear_message { print STDERR ' ' x $last_message_length, "\r" if $last_message_length; $vv_print = $vv_size = $last_message_length = 0; } ## ## Output a copy of this program with comments, extra whitespace, and ## the trailing man page removed. On an ultra slow machine, such a copy ## might load faster (but I can't tell any difference on my machine). ## sub strip { seek(DATA, 0, 0) || die "$0: can't reset internal pointer.\n"; while() { print, next if /INLINE_LITERAL_TEXT/.../INLINE_LITERAL_TEXT/; ## must mention INLINE_LITERAL_TEXT on this line! s/\#\#.*|^\s+|\s+$//; ## remove cruft last if $_ eq '.00;'; next if ($_ eq '') || ($_ eq "'di'") || ($_ eq "'ig00'"); s/\$stripped=0;/\$stripped=1;/; s/\s\s+/ /; ## squish multiple whitespaces down to one. print $_, "\n"; } exit(0); } ## ## Just to shut up -w. Never executed. ## sub dummy { 1 || &dummy || &dir_done || &bad || &message || $NEXT_DIR_ENTRY || $DELAY || $VV_SIZE || $VV_PRINT_COUNT || $STDERR_SCREWS_STDOUT || @files || @files || $magic'H || $magic'H || $xdev{''} || &clear_message; } ## ## If the following __END__ is in place, what follows will be ## inlined when the program first starts up. Any $ variable name ## all in upper case, specifically, any string matching ## \$([A-Z][A-Z0-9_]{2,}\b ## will have the true value for that variable inlined. Also, any 'eval' is ## removed ## ## The idea is that when the whole thing is then eval'ed to define &dodir, ## the perl optimizer will make all the decisions that are based upon ## command-line options (such as $VERBOSE), since they'll be inlined as ## constants ## ## Also, and here's the big win, the tests for matching the regex, and a ## few others, are all inlined. Should be blinding speed here. ## ## See the read from above for where all this takes place. ## But all-in-all, you *want* the __END__ here. Comment it out only for ## debugging.... ## __END__ ## ## Given a directory, check all "appropriate" files in it. ## Shove any subdirectories into the global @todo, so they'll be done ## later. ## ## Be careful about adding any upper-case variables, as they are subject ## to being inlined. See comments above the __END__ above. ## sub dodir { local($dir) = @_; $dir =~ s,/+$,,; ## remove any trailing slash. unless (opendir(DIR, "$dir/.")) { &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT; warn qq($0: can't opendir "$dir/".\n); return; } if ($VERBOSE) { &message($dir); $vv_print = $vv_size = 0; } @files = sort readdir(DIR) if $DO_SORT; while (defined($name = eval $NEXT_DIR_ENTRY)) { next if $name eq '.' || $name eq '..'; ## never follow these. ## create full relative pathname. $file = $dir eq '.' ? $name : "$dir/$name"; ## if link and skipping them, do so. if ($NOLINKS && -l $file) { warn qq/skip (symlink): $file\n/ if $WHY; next; } ## skip things unless files or directories unless (-f $file || -d _) { if ($WHY) { $why = (-S _ && "socket") || (-p _ && "pipe") || (-b _ && "block special")|| (-c _ && "char special") || "somekinda special"; warn qq/skip ($why): $file\n/; } next; } ## skip things we can't read unless (-r _) { if ($WHY) { $why = (-l $file) ? "follow" : "read"; warn qq/skip (can't $why): $file\n/; } next; } ## skip things that are empty unless (-s _ || -d _) { warn qq/skip (empty): $file\n/ if $WHY; next; } ## Note file device & inode. If -xdev, skip if appropriate. ($dev, $inode) = (stat(_))[$STAT_DEV, $STAT_INODE]; if ($XDEV && defined $xdev{$dev}) { warn qq/skip (other device): $file\n/ if $WHY; next; } $id = "$dev,$inode"; ## special work for a directory if (-d _) { ## Do checks for directory file endings. if ($DO_DSKIP_TEST && (eval $DSKIP_TEST)) { warn qq/skip (-dskip): $file\n/ if $WHY; next; } ## do checks for -name/-regex/-path tests if ($DO_DGLOB_TESTS && !(eval $DGLOB_TESTS)) { warn qq/skip (dirname): $file\n/ if $WHY; next; } ## _never_ redo a directory if (defined $dir_done{$id} and $^O ne 'MSWin32') { warn qq/skip (did as "$dir_done{$id}"): $file\n/ if $WHY; next; } $dir_done{$id} = $file; ## mark it done. unshift(@todo, $file); ## add to the list to do. next; } if ($WHY == 0 && $VERBOSE > 1) { if ($VERBOSE>2||$vv_print++>$VV_PRINT_COUNT||($vv_size+=-s _)>$VV_SIZE){ &message($file); $vv_print = $vv_size = 0; } } ## do time-related tests if ($NEWER || $OLDER) { $_ = (stat(_))[$STAT_MTIME]; if ($NEWER && $_ < $NEWER) { warn qq/skip (too old): $file\n/ if $WHY; next; } if ($OLDER && $_ > $OLDER) { warn qq/skip (too new): $file\n/ if $WHY; next; } } ## do checks for file endings if ($DO_SKIP_TEST && (eval $SKIP_TEST)) { warn qq/skip (-skip): $file\n/ if $WHY; next; } ## do checks for -name/-regex/-path tests if ($DO_GLOB_TESTS && !(eval $GLOB_TESTS)) { warn qq/skip (filename): $file\n/ if $WHY; next; } ## If we're not repeating files, ## skip this one if we've done it, or note we're doing it. unless ($DOREP) { if (defined $file_done{$id}) { warn qq/skip (did as "$file_done{$id}"): $file\n/ if $WHY; next; } $file_done{$id} = $file; } if ($DO_MAGIC_TESTS) { if (!open(FILE_IN, $file)) { &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT; warn qq/$0: can't open: $file\n/; next; } unless (read(FILE_IN, $magic'H, $HEADER_BYTES)) { &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT; warn qq/$0: can't read from "$file"\n"/; close(FILE_IN); next; } eval $MAGIC_TESTS; if ($magic'val) { close(FILE_IN); warn qq/skip (magic): $file\n/ if $WHY; next; } seek(FILE_IN, 0, 0); ## reset for later } if ($WHY != 0 && $VERBOSE > 1) { if ($VERBOSE>2||$vv_print++>$VV_PRINT_COUNT||($vv_size+=-s _)>$VV_SIZE){ &message($file); $vv_print = $vv_size = 0; } } if ($DELAY) { sleep($DELAY); } if ($FIND_ONLY) { &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT; print $file, "\n"; $retval=0; ## we've found something close(FILE_IN) if $DO_MAGIC_TESTS; next; } else { ## if we weren't doing magic tests, file won't be open yet... if (!$DO_MAGIC_TESTS && !open(FILE_IN, $file)) { &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT; warn qq/$0: can't open: $file\n/; next; } if ($LIST_ONLY && $CAN_USE_FAST_LISTONLY) { ## ## This is rather complex, but buys us a LOT when we're just ## listing files and not the individual internal lines. ## local($size) = 4096; ## block-size in which to do reads local($nl); ## will point to $_'s ending newline. local($read); ## will be how many bytes read. local($_) = ''; ## Starts out empty local($hold); ## (see below) while (($read = read(FILE_IN,$_,$size,length($_)))||length($_)) { undef @parts; ## if read a full block, but no newline, need to read more. while ($read == $size && ($nl = rindex($_, "\n")) < 0) { push(@parts, $_); ## save that part $read = read(FILE_IN, $_, $size); ## keep trying } ## ## If we had to save parts, must now combine them together. ## adjusting $nl to reflect the now-larger $_. This should ## be a lot more efficient than using any kind of .= in the ## loop above. ## if (@parts) { local($lastlen) = length($_); #only need if $nl >= 0 $_ = join('', @parts, $_); $nl = length($_) - ($lastlen - $nl) if $nl >= 0; } ## ## If we're at the end of the file, then we can use $_ as ## is. Otherwise, we need to remove the final partial-line ## and save it so that it'll be at the beginning of the ## next read (where the rest of the line will be layed in ## right after it). $hold will be what we should save ## until next time. ## if ($read != $size || $nl < 0) { $hold = ''; } else { $hold = substr($_, $nl + 1); substr($_, $nl + 1) = ''; } ## ## Now have a bunch of full lines in $_. Use it. ## if (eval $REGEX_TEST) { &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT; print $file, "\n"; $retval=0; ## we've found something last; } ## Prepare for next read.... $_ = $hold; } } else { ## else not using faster block scanning..... $lines_printed = 0 if $NICE; while () { study; next unless (eval $REGEX_TEST); ## ## We found a matching line. ## $retval=0; &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT; if ($LIST_ONLY) { print $file, "\n"; last; } else { ## prepare to print line. if ($NICE && $lines_printed++ == 0) { print '-' x 70, "\n" if $NICE > 1; print $file, ":\n"; } ## ## Print all the prelim stuff. This looks less efficient ## than it needs to be, but that's so that when the eval ## is compiled (and the tests are optimized away), the ## result will be less actual PRINTs than the more natural ## way of doing these tests.... ## if ($NICE) { if ($REPORT_LINENUM) { print " line $.: "; } else { print " "; } } elsif ($REPORT_LINENUM && $PREPEND_FILENAME) { print "$file,:$.: "; } elsif ($PREPEND_FILENAME) { print "$file: "; } elsif ($REPORT_LINENUM) { print "$.: "; } print $_; print "\n" unless m/\n$/; } } print "\n" if ($NICE > 1) && $lines_printed; } close(FILE_IN); } } closedir(DIR); } __END__ .00; ## finish .ig 'di \" finish diversion--previous line must be blank .nr nl 0-1 \" fake up transition to first page again .nr % 0 \" start at page 1 .\"__________________NORMAL_MAN_PAGE_BELOW_________________ .ll+10n .TH search 1 "Dec 17, 1994" .SH SEARCH search \- search files (a'la grep) in a whole directory tree. .SH SYNOPSIS search [ grep-like and find-like options] [regex ....] .SH DESCRIPTION .I Search is more or less a combo of 'find' and 'grep' (although the regular expression flavor is that of the perl being used, which is closer to egrep's than grep's). .I Search does generally the same kind of thing that .nf find | xargs egrep .fi does, but is .I much more powerful and efficient (and intuitive, I think). This manual describes .I search as of version "941227.4". .SH "QUICK EXAMPLE" Basic use is simple: .nf % search jeff .fi will search files in the current directory, and all sub directories, for files that have "jeff" in them. The lines will be listed with the containing file's name prepended. .PP If you list more than one regex, such as with .nf % search jeff Larry Randal+ 'Stoc?k' 'C.*son' .fi then a line containing any of the regexes will be listed. This makes it effectively the same as .nf % search 'jeff|Larry|Randal+|Stoc?k|C.*son' .fi However, listing them separately is much more efficient (and is easier to type). .PP Note that in the case of these examples, the .B \-w (list whole-words only) option would be useful. .PP Normally, various kinds of files are automatically removed from consideration. If it has has a certain ending (such as ".tar", ".Z", ".o", .etc), or if the beginning of the file looks like a binary, it'll be excluded. You can control exactly how this works -- see below. One quick way to override this is to use the .B \-all option, which means to consider all the files that would normally be automatically excluded. Or, if you're curious, you can use .B \-why to have notes about what files are skipped (and why) printed to stderr. .SH "BASIC OVERVIEW" Normally, the search starts in the current directory, considering files in all subdirectories. You can use the .I ~/.search file to control ways to automatically exclude files. If you don't have this file, a default one will kick in, which automatically add .nf -skip .o .Z .gif .fi (among others) to exclude those kinds of files (which you probably want to skip when searching for text, as is normal). Files that look to be be binary will also be excluded. Files ending with "#" and "~" will also be excluded unless the .B -x~ option is given. You can use .B -showrc to show what kinds of files will normally be skipped. See the section on the startup file for more info. You can use the .B -all option to indicate you want to consider all files that would otherwise be skipped by the startup file. Based upon various other flags (see "WHICH FILES TO CONSIDER" below), more files might be removed from consideration. For example .nf -mtime 3 .fi will exclude files that aren't at least three days old (change the 3 to -3 to exclude files that are more than three days old), while .nf -skip .* .fi would exclude any file beginning with a dot (of course, '.' and '..' are special and always excluded). If you'd like to see what files are being excluded, and why, you can get the list via the .B \-why option. If a file makes it past all the checks, it is then "considered". This usually means it is greped for the regular expressions you gave on the command line. If any of the regexes match a line, the line is printed. However, if .B -list is given, just the filename is printed. Or, if .B -nice is given, a somewhat more (human-)readable output is generated. If you're searching a huge tree and want to keep informed about how the search is progressing, .B -v will print (to stderr) the current directory being searched. Using .B -vv will also print the current file "every so often", which could be useful if a directory is huge. Using .B -vvv will print the update with every file. Below is the full listing of options. .SH "OPTIONS TELLING *WHERE* TO SEARCH" .TP .BI -dir " DIR" Start searching at the named directory instead of the current directory. If multiple .B -dir arguments are given, multiple trees will be searched. .TP .BI -ddir " DIR" Like .B -dir except it flushes any previous .B -dir directories (i.e. "-dir A -dir B -dir C" will search A, B, and C, while "-dir A -ddir B -dir C" will search only B and C. This might be of use in the startup file (see that section below). .TP .B -xdev Stay on the same filesystem as the starting directory/directories. .TP .B -sort Sort the items in a directory before processing them. Normally they are processed in whatever order they happen to be read from the directory. .TP .B -nolinks Don't follow symbolic links. Normally they're followed. .SH "OPTIONS CONTROLLING WHICH FILES TO CONSIDER AND EXCLUDE" .TP .BI -mtime " NUM" Only consider files that were last changed more than .I NUM days ago (less than .I NUM days if .I NUM has '-' prepended, i.e. "-mtime -2.5" means to consider files that have been changed in the last two and a half days). .TP .B -older FILE Only consider files that have not changed since .I FILE was last changed. If there is any upper case in the "-older", "or equal" is added to the sense of the test. Therefore, "search -older ./file regex" will never consider "./file", while "search -Older ./file regex" will. If a file is a symbolic link, the time used is that of the file and not the link. .TP .BI -newer " FILE" Opposite of .BR -older . .TP .BI -name " GLOB" Only consider files that match the shell filename pattern .IR GLOB . The check is only done on a file's name (use .B -path to check the whole path, and use .B -dname to check directory names). Multiple specifications can be given by separating them with spaces, a'la .nf -name '*.c *.h' .fi to consider C source and header files. If .I GLOB doesn't contain any special pattern characters, a '*' is prepended. This last example could have been given as .nf -name '.c .h' .fi It could also be given as .nf -name .c -name .h .fi or .nf -name '*.c' -name '*.h' .fi or .nf -name '*.[ch]' .fi (among others) but in this last case, you have to be sure to supply the leading '*'. .TP .BI -path " GLOB" Like .B -name except the entire path is checked against the pattern. .TP .B -regex " REGEX" Considers files whose names (not paths) match the given perl regex exactly. .TP .BI -iname " GLOB" Case-insensitive version of .BR -name . .TP .BI -ipath " GLOB" Case-insensitive version of .BR -path . .TP .BI -iregex " REGEX" Case-insensitive version of .BR -regex . .TP .BI -dpath " GLOB" Only search down directories whose path matches the given pattern (this doesn't apply to the initial directory given by .BI -dir , of course). Something like .nf -dir /usr/man -dpath /usr/man/man* .fi would completely skip "/usr/man/cat1", "/usr/man/cat2", etc. .TP .BI -dskip " GLOB" Skips directories whose name (not path) matches the given pattern. Something like .nf -dir /usr/man -dskip cat* .fi would completely skip any directory in the tree whose name begins with "cat" (including "/usr/man/cat1", "/usr/man/cat2", etc.). .TP .BI -dregex " REGEX" Like .BI -dpath , but the pattern is a full perl regex. Note that this quite different from .B -regex which considers only file names (not paths). This option considers full directory paths (not just names). It's much more useful this way. Sorry if it's confusing. .TP .BI -dpath " GLOB" This option exists, but is probably not very useful. It probably wants to be like the '-below' or something I mention in the "TODO" section. .TP .BI -idpath " GLOB" Case-insensitive version of .BR -dpath . .TP .BI -idskip " GLOB" Case-insensitive version of .BR -dskip . .TP .BI -idregex " REGEX" Case-insensitive version of .BR -dregex . .TP .B -all Ignore any 'magic' or 'option' lines in the startup file. The effect is that all files that would otherwise be automatically excluded are considered. .TP .BI -x SPECIAL Arguments starting with .B -x (except .BR -xdev , explained elsewhere) do special interaction with the .I ~/.search startup file. Something like .nf -xflag1 -xflag2 .fi will turn on "flag1" and "flag2" in the startup file (and is the same as "-xflag1,flag2"). You can use this to write your own rules for what kinds of files are to be considered. For example, the internal-default startup file contains the line .nf option: -skip '~ #' .fi This means that if the .B -x~ flag is .I not seen, the option .nf -skip '~ #' .fi should be done. The effect is that emacs temp and backup files are not normally considered, but you can included them with the -x~ flag. You can write your own rules to customize .I search in powerful ways. See the STARTUP FILE section below. .TP .B -why Print a message (to stderr) when and why a file is not considered. .SH "OPTIONS TELLING WHAT TO DO WITH FILES THAT WILL BE CONSIDERED" .TP .B -find (you can use .B -f as well). This option changes the basic action of .IR search . Normally, if a file is considered, it is searched for the regular expressions as described earlier. However, if this option is given, the filename is printed and no searching takes place. This turns .I search into a 'find' of some sorts. In this case, no regular expressions are needed on the command line (any that are there are silently ignored). This is not intended to be a replacement for the 'find' program, but to aid you in understanding just what files are getting past the exclusion checks. If you really want to use it as a sort of replacement for the 'find' program, you might want to use .B -all so that it doesn't waste time checking to see if the file is binary, etc (unless you really want that, of course). If you use .BR -find , none of the "GREP-LIKE OPTIONS" (below) matter. As a replacement for 'find', .I search is probably a bit slower (or in the case of GNU find, a lot slower -- GNU find is .I unbelievably fast). However, "search -ffind" might be more useful than 'find' when options such as .B -skip are used (at least until 'find' gets such functionality). .TP .B -ffind (or .BR -ff ) A faster more 'find'-like find. Does .nf -find -all -dorep .fi .SH "GREP-LIKE OPTIONS" These options control how a searched file is accessed, and how things are printed. .TP .B -i Ignore letter case when matching. .TP .B -w Consider only whole-word matches ("whole word" as defined by perl's "\\b" regex). .TP .B -u If the regex(es) is/are simple, try to modify them so that they'll work in manpage-like underlined text (i.e. like _^Ht_^Hh_^Hi_^Hs). This is very rudimentary at the moment. .TP .B -list (you can use .B -l too). Don't print matching lines, but the names of files that contain matching lines. This will likely be *much* faster, as special optimizations are made -- particularly with large files. .TP .B -n Pepfix each line by its line number. .TP .B -nice Not a grep-like option, but similar to .BR -list , so included here. .B -nice will have the output be a bit more human-readable, with matching lines printed slightly indented after the filename, a'la .nf % search foo somedir/somefile: line with foo in it somedir/somefile: some food for thought anotherdir/x: don't be a buffoon! % .fi will become .nf % search -nice foo somedir/somefile: line with foo in it some food for thought anotherdir/x: don't be a buffoon! % .fi This option due to Lionel Cons. .TP .B -nnice Be a bit nicer than .BR -nice . Prefix each file's output by a rule line, and follow with an extra blank line. .TP .B -h Don't prepend each output line with the name of the file (meaningless when .B -find or .B -l are given). .SH "OTHER OPTIONS" .TP .B -help Print the usage information. .TP .B -version Print the version information and quit. .TP .B -v Set the level of message verbosity. .B -v will print a note whenever a new directory is entered. .B -vv will also print a note "every so often". This can be useful to see what's happening when searching huge directories. .B -vvv will print a new with every file. .B -vvvv is -vvv plus .BR -why . .TP .B -e This ends the options, and can be useful if the regex begins with '-'. .TP .B -showrc Shows what is being considered in the startup file, then exits. .TP .B -dorep Normally, an identical file won't be checked twice (even with multiple hard or symbolic links). If you're just trying to do a fast .BR -find , the bookkeeping to remember which files have been seen is not desirable, so you can eliminate the bookkeeping with this flag. .SH "STARTUP FILE" When .I search starts up, it processes the directives in .IR ~/.search . If no such file exists, a default internal version is used. The internal version looks like: .nf magic: 32 : $H =~ m/[\ex00-\ex06\ex10-\ex1a\ex1c-\ex1f\ex80\exff]{2}/ option: -skip '.a .COM .elc .EXE .gz .o .pbm .xbm .dvi' option: -iskip '.tarz .zip .z .lzh .jpg .jpeg .gif .uu' option: -skip '~ #' .fi If you wish to create your own "~/.search", you might consider copying the above, and then working from there. There are two kinds of directives in a startup file: "magic" and "option". .RS 0n .TP OPTION Option lines will automatically do the command-line options given. For example, the line .nf option: -v .fi in you startup file will turn on -v every time, without needing to type it on the command line. The text on the line after the "option:" directive is processed like the Bourne shell, so make sure to pay attention to quoting. .nf option: -skip .exe .com .fi will give an error (".com" by itself isn't a valid option), while .nf option: -skip ".exe .com" .fi will properly include it as part of -skip's argument. .TP MAGIC Magic lines are used to determine if a file should be considered a binary or not (the term "magic" refers to checking a file's magic number). These are described in more detail below. .RE Blank lines and comments (lines beginning with '#') are allowed. If a line begins with <...>, then it's a check to see if the directive on the line should be done or not. The stuff inside the <...> can contain perl's && (and), || (or), ! (not), and parens for grouping, along with "flags" that might be indicated by the user with .BI -x flag options. For example, using "-xfoo" will cause "foo" to be true inside the <...> blocks. Therefore, a line beginning with "" would be done only when "-xfoo" had been specified, while a line beginning with "" would be done only when "-xfoo" is not specified (of course, a line without any <...> is done in either case). A realistic example might be .nf -vv .fi This will cause -vv messages to be the default, but allow "-xv" to override. There are a few flags that are set automatically: .RS .TP .B TTY true if the output is to the screen (as opposed to being redirected to a file). You can force this (as with all the other automatic flags) with -xTTY. .TP .B -v True if -v was specified. If -vv was specified, both .B -v and .B -vv flags are true (and so on). .TP .B -nice True if -nice was specified. Same thing about -nnice as for -vv. .PP .TP .B -list true if -list (or -l) was given. .TP .B -dir true if -dir was given. .RE Using this info, you might change the last example to .nf option: -vv .fi The added "&& !-v" means "and if the '-v' option not given". This will allow you to use "-v" alone on the command line, and not have this directive add the more verbose "-vv" automatically. .RS 0 Some other examples: .TP option: -dir ~/ Effectively make the default directory your home directory (instead of the current directory). Using -dir or -xhere will undo this. .TP option: -name .tex -dir ~/pub Create '-xtex' to search only "*.tex" files in your ~/pub directory tree. Actually, this could be made a bit better. If you combine '-xtex' and '-dir' on the command line, this directive will add ~/pub to the list, when you probably want to use the -dir directory only. You could do .nf option: -name .tex option: -dir ~/pub .fi to will allow '-xtex' to work as before, but allow a command-line "-dir" to take precedence with respect to ~/pub. .TP option: -nnice -sort -i -vvv Combine a few user-friendly options into one '-xfluff' option. .TP option: -ddir /usr/man -v -w When the '-xman' option is given, search "/usr/man" for whole-words (of whatever regex or regexes are given on the command line), with -v. .RE The lines in the startup file are executed from top to bottom, so something like .nf option: -xflag1 -xflag2 option: ...whatever... option: ...whatever... .fi will allow '-xboth' to be the same as '-xflag1 -xflag2' (or '-xflag1,flag2' for that matter). However, if you put the "" line below the others, they will not be true when encountered, so the result would be different (and probably undesired). The "magic" directives are used to determine if a file looks to be binary or not. The form of a magic line is .nf magic: \fISIZE\fP : \fIPERLCODE\fP .fi where .I SIZE is the number of bytes of the file you need to check, and .I PERLCODE is the code to do the check. Within .IR PERLCODE , the variable $H will hold at least the first .I SIZE bytes of the file (unless the file is shorter than that, of course). It might hold more bytes. The perl should evaluate to true if the file should be considered a binary. An example might be .nf magic: 6 : substr($H, 0, 6) eq 'GIF87a' .fi to test for a GIF ("-iskip .gif" is better, but this might be useful if you have images in files without the ".gif" extension). Since the startup file is checked from top to bottom, you can be a bit efficient: .nf magic: 6 : ($x6 = substr($H, 0, 6)) eq 'GIF87a' magic: 6 : $x6 eq 'GIF89a' .fi You could also write the same thing as .nf magic: 6 : (($x6 = substr($H, 0, 6)) eq 'GIF87a') || ## an old gif, or.. \e $x6 eq 'GIF89a' ## .. a new one. .fi since newlines may be escaped. The default internal startup file includes .nf magic: 32 : $H =~ m/[\ex00-\ex06\ex10-\ex1a\ex1c-\ex1f\ex80\exff]{2}/ .fi which checks for certain non-printable characters, and catches a large number of binary files, including most system's executables, linkable objects, compressed, tarred, and otherwise folded, spindled, and mutilated files. Another example might be .nf ## an archive library magic: 17 : substr($H, 0, 17) eq "!\en__.SYMDEF" .fi .SH "RETURN VALUE" .I Search returns zero if lines (or files, if appropriate) were found, or if no work was requested (such as with .BR -help ). Returns 1 if no lines (or files) were found. Returns 2 on error. .SH TODO Things I'd like to add some day: .nf + show surrounding lines (context). + highlight matched portions of lines. + add '-and', which can go between regexes to override the default logical or of the regexes. + add something like -below GLOB which will examine a tree and only consider files that lie in a directory deeper than one named by the pattern. + add 'warning' and 'error' directives. + add 'help' directive. .fi .SH BUGS If -xdev and multiple -dir arguments are given, any file in any of the target filesystems are allowed. It would be better to allow each filesystem for each separate tree. Multiple -dir args might also cause some confusing effects. Doing .nf -dir some/dir -dir other .fi will search "some/dir" completely, then search "other" completely. This is good. However, something like .nf -dir some/dir -dir some/dir/more/specific .fi will search "some/dir" completely *except for* "some/dir/more/specific", after which it will return and be searched. Not really a bug, but just sort of odd. File times (for -newer, etc.) of symbolic links are for the file, not the link. This could cause some misunderstandings. Probably more. Please let me know. .SH AUTHOR Jeffrey Friedl, Omron Corp (jfriedl@omron.co.jp) .br http://www.wg.omron.co.jp/cgi-bin/j-e/jfriedl.html .SH "LATEST SOURCE" See http://www.wg.omron.co.jp/~jfriedl/perl/index.html perl-5.12.0-RC0/win32/bin/runperl.pl0000444000175000017500000000363511143650501015666 0ustar jessejesse#!perl -w $0 =~ s|\.bat||i; unless (-f $0) { $0 =~ s|.*[/\\]||; for (".", split ';', $ENV{PATH}) { $_ = "." if $_ eq ""; $0 = "$_/$0" , goto doit if -f "$_/$0"; } die "`$0' not found.\n"; } doit: exec "perl", "-x", $0, @ARGV; die "Failed to exec `$0': $!"; __END__ =head1 NAME runperl.bat - "universal" batch file to run perl scripts =head1 SYNOPSIS C:\> copy runperl.bat foo.bat C:\> foo [..runs the perl script `foo'..] C:\> foo.bat [..runs the perl script `foo'..] =head1 DESCRIPTION This file can be copied to any file name ending in the ".bat" suffix. When executed on a DOS-like operating system, it will invoke the perl script of the same name, but without the ".bat" suffix. It will look for the script in the same directory as itself, and then in the current directory, and then search the directories in your PATH. It relies on the C operator, so you will need to make sure that works in your perl. This method of invoking perl scripts has some advantages over batch-file wrappers like C: it avoids duplication of all the code; it ensures C<$0> contains the same name as the executing file, without any egregious ".bat" suffix; it allows you to separate your perl scripts from the wrapper used to run them; since the wrapper is generic, you can use symbolic links to simply link to C, if you are serving your files on a filesystem that supports that. On the other hand, if the batch file is invoked with the ".bat" suffix, it does an extra C. This may be a performance issue. You can avoid this by running it without specifying the ".bat" suffix. Perl is invoked with the -x flag, so the script must contain a C<#!perl> line. Any flags found on that line will be honored. =head1 BUGS Perl is invoked with the -S flag, so it will search the PATH to find the script. This may have undesirable effects. =head1 SEE ALSO perl, perlwin32, pl2bat.bat =cut perl-5.12.0-RC0/win32/bin/exetype.pl0000444000175000017500000000526311143650501015661 0ustar jessejesse#!perl -w use strict; # All the IMAGE_* structures are defined in the WINNT.H file # of the Microsoft Platform SDK. my %subsys = (NATIVE => 1, WINDOWS => 2, CONSOLE => 3, POSIX => 7, WINDOWSCE => 9); unless (0 < @ARGV && @ARGV < 3) { printf "Usage: $0 exefile [%s]\n", join '|', sort keys %subsys; exit; } $ARGV[1] = uc $ARGV[1] if $ARGV[1]; unless (@ARGV == 1 || defined $subsys{$ARGV[1]}) { (my $subsys = join(', ', sort keys %subsys)) =~ s/, (\w+)$/ or $1/; print "Invalid subsystem $ARGV[1], please use $subsys\n"; exit; } my ($record,$magic,$signature,$offset,$size); open EXE, "+< $ARGV[0]" or die "Cannot open $ARGV[0]: $!\n"; binmode EXE; # read IMAGE_DOS_HEADER structure read EXE, $record, 64; ($magic,$offset) = unpack "Sx58L", $record; die "$ARGV[0] is not an MSDOS executable file.\n" unless $magic == 0x5a4d; # "MZ" # read signature, IMAGE_FILE_HEADER and first WORD of IMAGE_OPTIONAL_HEADER seek EXE, $offset, 0; read EXE, $record, 4+20+2; ($signature,$size,$magic) = unpack "Lx16Sx2S", $record; die "PE header not found" unless $signature == 0x4550; # "PE\0\0" die "Optional header is neither in NT32 nor in NT64 format" unless ($size == 224 && $magic == 0x10b) || # IMAGE_NT_OPTIONAL_HDR32_MAGIC ($size == 240 && $magic == 0x20b); # IMAGE_NT_OPTIONAL_HDR64_MAGIC # Offset 68 in the IMAGE_OPTIONAL_HEADER(32|64) is the 16 bit subsystem code seek EXE, $offset+4+20+68, 0; if (@ARGV == 1) { read EXE, $record, 2; my ($subsys) = unpack "S", $record; $subsys = {reverse %subsys}->{$subsys} || "UNKNOWN($subsys)"; print "$ARGV[0] uses the $subsys subsystem.\n"; } else { print EXE pack "S", $subsys{$ARGV[1]}; } close EXE; __END__ =head1 NAME exetype - Change executable subsystem type between "Console" and "Windows" =head1 SYNOPSIS C:\perl\bin> copy perl.exe guiperl.exe C:\perl\bin> exetype guiperl.exe windows =head1 DESCRIPTION This program edits an executable file to indicate which subsystem the operating system must invoke for execution. You can specify any of the following subsystems: =over =item CONSOLE The CONSOLE subsystem handles a Win32 character-mode application that use a console supplied by the operating system. =item WINDOWS The WINDOWS subsystem handles an application that does not require a console and creates its own windows, if required. =item NATIVE The NATIVE subsystem handles a Windows NT device driver. =item WINDOWSCE The WINDOWSCE subsystem handles Windows CE consumer electronics applications. =item POSIX The POSIX subsystem handles a POSIX application in Windows NT. =back =head1 AUTHOR Jan Dubois =cut perl-5.12.0-RC0/win32/bin/perlglob.pl0000444000175000017500000000222311143650501015775 0ustar jessejesse#!perl -w use File::DosGlob; $| = 1; while (@ARGV) { my $arg = shift; my @m = File::DosGlob::doglob(1,$arg); print (@m ? join("\0", sort @m) : $arg); print "\0" if @ARGV; } __END__ =head1 NAME perlglob.bat - a more capable perlglob.exe replacement =head1 SYNOPSIS @perlfiles = glob "..\\pe?l/*.p?"; print <..\\pe?l/*.p?>; # more efficient version > perl -MFile::DosGlob=glob -e "print <../pe?l/*.p?>" =head1 DESCRIPTION This file is a portable replacement for perlglob.exe. It is largely compatible with perlglob.exe (the Microsoft setargv.obj version) in all but one respect--it understands wildcards in directory components. It prints null-separated filenames to standard output. For details of the globbing features implemented, see L. While one may replace perlglob.exe with this, usage by overriding CORE::glob with File::DosGlob::glob should be much more efficient, because it avoids launching a separate process, and is therefore strongly recommended. See L for details of overriding builtins. =head1 AUTHOR Gurusamy Sarathy =head1 SEE ALSO perl File::DosGlob =cut perl-5.12.0-RC0/win32/config_H.gc640000444000175000017500000043520511325127002015272 0ustar jessejesse/* * This file was produced by running the config_h.SH script, which * gets its values from undef, which is generally produced by * running Configure. * * Feel free to modify any of this as the need arises. Note, however, * that running config_h.SH again will wipe out any changes you've made. * For a more permanent change edit undef and rerun config_h.SH. * * $Id: Config_h.U 1 2006-08-24 12:32:52Z rmanfredi $ */ /* * Package name : perl5 * Source directory : * Configuration time: Sun Jan 10 19:53:56 2010 * Configured by : Steve * Target system : */ #ifndef _config_h_ #define _config_h_ /* LOC_SED: * This symbol holds the complete pathname to the sed program. */ #define LOC_SED "" /**/ /* HAS_ALARM: * This symbol, if defined, indicates that the alarm routine is * available. */ #define HAS_ALARM /**/ /* HAS_BCMP: * This symbol is defined if the bcmp() routine is available to * compare blocks of memory. */ /*#define HAS_BCMP / **/ /* HAS_BCOPY: * This symbol is defined if the bcopy() routine is available to * copy blocks of memory. */ /*#define HAS_BCOPY / **/ /* HAS_BZERO: * This symbol is defined if the bzero() routine is available to * set a memory block to 0. */ /*#define HAS_BZERO / **/ /* HAS_CHOWN: * This symbol, if defined, indicates that the chown routine is * available. */ /*#define HAS_CHOWN / **/ /* HAS_CHROOT: * This symbol, if defined, indicates that the chroot routine is * available. */ /*#define HAS_CHROOT / **/ /* HAS_CHSIZE: * This symbol, if defined, indicates that the chsize routine is available * to truncate files. You might need a -lx to get this routine. */ #define HAS_CHSIZE /**/ /* HAS_CRYPT: * This symbol, if defined, indicates that the crypt routine is available * to encrypt passwords and the like. */ /*#define HAS_CRYPT / **/ /* HAS_CTERMID: * This symbol, if defined, indicates that the ctermid routine is * available to generate filename for terminal. */ /*#define HAS_CTERMID / **/ /* HAS_CUSERID: * This symbol, if defined, indicates that the cuserid routine is * available to get character login names. */ /*#define HAS_CUSERID / **/ /* HAS_DBL_DIG: * This symbol, if defined, indicates that this system's * or defines the symbol DBL_DIG, which is the number * of significant digits in a double precision number. If this * symbol is not defined, a guess of 15 is usually pretty good. */ #define HAS_DBL_DIG /**/ /* HAS_DIFFTIME: * This symbol, if defined, indicates that the difftime routine is * available. */ #define HAS_DIFFTIME /**/ /* HAS_DLERROR: * This symbol, if defined, indicates that the dlerror routine is * available to return a string describing the last error that * occurred from a call to dlopen(), dlclose() or dlsym(). */ #define HAS_DLERROR /**/ /* HAS_DUP2: * This symbol, if defined, indicates that the dup2 routine is * available to duplicate file descriptors. */ #define HAS_DUP2 /**/ /* HAS_FCHMOD: * This symbol, if defined, indicates that the fchmod routine is available * to change mode of opened files. If unavailable, use chmod(). */ /*#define HAS_FCHMOD / **/ /* HAS_FCHOWN: * This symbol, if defined, indicates that the fchown routine is available * to change ownership of opened files. If unavailable, use chown(). */ /*#define HAS_FCHOWN / **/ /* HAS_FCNTL: * This symbol, if defined, indicates to the C program that * the fcntl() function exists. */ /*#define HAS_FCNTL / **/ /* HAS_FGETPOS: * This symbol, if defined, indicates that the fgetpos routine is * available to get the file position indicator, similar to ftell(). */ #define HAS_FGETPOS /**/ /* HAS_FLOCK: * This symbol, if defined, indicates that the flock routine is * available to do file locking. */ #define HAS_FLOCK /**/ /* HAS_FORK: * This symbol, if defined, indicates that the fork routine is * available. */ /*#define HAS_FORK / **/ /* HAS_FSETPOS: * This symbol, if defined, indicates that the fsetpos routine is * available to set the file position indicator, similar to fseek(). */ #define HAS_FSETPOS /**/ /* HAS_GETTIMEOFDAY: * This symbol, if defined, indicates that the gettimeofday() system * call is available for a sub-second accuracy clock. Usually, the file * needs to be included (see I_SYS_RESOURCE). * The type "Timeval" should be used to refer to "struct timeval". */ #define HAS_GETTIMEOFDAY /**/ #ifdef HAS_GETTIMEOFDAY #define Timeval struct timeval /* Structure used by gettimeofday() */ #endif /* HAS_GETGROUPS: * This symbol, if defined, indicates that the getgroups() routine is * available to get the list of process groups. If unavailable, multiple * groups are probably not supported. */ /*#define HAS_GETGROUPS / **/ /* HAS_GETLOGIN: * This symbol, if defined, indicates that the getlogin routine is * available to get the login name. */ #define HAS_GETLOGIN /**/ /* HAS_GETPGID: * This symbol, if defined, indicates to the C program that * the getpgid(pid) function is available to get the * process group id. */ /*#define HAS_GETPGID / **/ /* HAS_GETPGRP2: * This symbol, if defined, indicates that the getpgrp2() (as in DG/UX) * routine is available to get the current process group. */ /*#define HAS_GETPGRP2 / **/ /* HAS_GETPPID: * This symbol, if defined, indicates that the getppid routine is * available to get the parent process ID. */ /*#define HAS_GETPPID / **/ /* HAS_GETPRIORITY: * This symbol, if defined, indicates that the getpriority routine is * available to get a process's priority. */ /*#define HAS_GETPRIORITY / **/ /* HAS_INET_ATON: * This symbol, if defined, indicates to the C program that the * inet_aton() function is available to parse IP address "dotted-quad" * strings. */ /*#define HAS_INET_ATON / **/ /* HAS_KILLPG: * This symbol, if defined, indicates that the killpg routine is available * to kill process groups. If unavailable, you probably should use kill * with a negative process number. */ #define HAS_KILLPG /**/ /* HAS_LINK: * This symbol, if defined, indicates that the link routine is * available to create hard links. */ #define HAS_LINK /**/ /* HAS_LOCALECONV: * This symbol, if defined, indicates that the localeconv routine is * available for numeric and monetary formatting conventions. */ #define HAS_LOCALECONV /**/ /* HAS_LOCKF: * This symbol, if defined, indicates that the lockf routine is * available to do file locking. */ /*#define HAS_LOCKF / **/ /* HAS_LSTAT: * This symbol, if defined, indicates that the lstat routine is * available to do file stats on symbolic links. */ /*#define HAS_LSTAT / **/ /* HAS_MBLEN: * This symbol, if defined, indicates that the mblen routine is available * to find the number of bytes in a multibye character. */ #define HAS_MBLEN /**/ /* HAS_MBSTOWCS: * This symbol, if defined, indicates that the mbstowcs routine is * available to covert a multibyte string into a wide character string. */ #define HAS_MBSTOWCS /**/ /* HAS_MBTOWC: * This symbol, if defined, indicates that the mbtowc routine is available * to covert a multibyte to a wide character. */ #define HAS_MBTOWC /**/ /* HAS_MEMCMP: * This symbol, if defined, indicates that the memcmp routine is available * to compare blocks of memory. */ #define HAS_MEMCMP /**/ /* HAS_MEMCPY: * This symbol, if defined, indicates that the memcpy routine is available * to copy blocks of memory. */ #define HAS_MEMCPY /**/ /* HAS_MEMMOVE: * This symbol, if defined, indicates that the memmove routine is available * to copy potentially overlapping blocks of memory. This should be used * only when HAS_SAFE_BCOPY is not defined. If neither is there, roll your * own version. */ #define HAS_MEMMOVE /**/ /* HAS_MEMSET: * This symbol, if defined, indicates that the memset routine is available * to set blocks of memory. */ #define HAS_MEMSET /**/ /* HAS_MKDIR: * This symbol, if defined, indicates that the mkdir routine is available * to create directories. Otherwise you should fork off a new process to * exec /bin/mkdir. */ #define HAS_MKDIR /**/ /* HAS_MKFIFO: * This symbol, if defined, indicates that the mkfifo routine is * available to create FIFOs. Otherwise, mknod should be able to * do it for you. However, if mkfifo is there, mknod might require * super-user privileges which mkfifo will not. */ /*#define HAS_MKFIFO / **/ /* HAS_MKTIME: * This symbol, if defined, indicates that the mktime routine is * available. */ #define HAS_MKTIME /**/ /* HAS_MSYNC: * This symbol, if defined, indicates that the msync system call is * available to synchronize a mapped file. */ /*#define HAS_MSYNC / **/ /* HAS_MUNMAP: * This symbol, if defined, indicates that the munmap system call is * available to unmap a region, usually mapped by mmap(). */ /*#define HAS_MUNMAP / **/ /* HAS_NICE: * This symbol, if defined, indicates that the nice routine is * available. */ /*#define HAS_NICE / **/ /* HAS_PATHCONF: * This symbol, if defined, indicates that pathconf() is available * to determine file-system related limits and options associated * with a given filename. */ /* HAS_FPATHCONF: * This symbol, if defined, indicates that pathconf() is available * to determine file-system related limits and options associated * with a given open file descriptor. */ /*#define HAS_PATHCONF / **/ /*#define HAS_FPATHCONF / **/ /* HAS_PAUSE: * This symbol, if defined, indicates that the pause routine is * available to suspend a process until a signal is received. */ #define HAS_PAUSE /**/ /* HAS_PIPE: * This symbol, if defined, indicates that the pipe routine is * available to create an inter-process channel. */ #define HAS_PIPE /**/ /* HAS_POLL: * This symbol, if defined, indicates that the poll routine is * available to poll active file descriptors. Please check I_POLL and * I_SYS_POLL to know which header should be included as well. */ /*#define HAS_POLL / **/ /* HAS_READDIR: * This symbol, if defined, indicates that the readdir routine is * available to read directory entries. You may have to include * . See I_DIRENT. */ #define HAS_READDIR /**/ /* HAS_SEEKDIR: * This symbol, if defined, indicates that the seekdir routine is * available. You may have to include . See I_DIRENT. */ #define HAS_SEEKDIR /**/ /* HAS_TELLDIR: * This symbol, if defined, indicates that the telldir routine is * available. You may have to include . See I_DIRENT. */ #define HAS_TELLDIR /**/ /* HAS_REWINDDIR: * This symbol, if defined, indicates that the rewinddir routine is * available. You may have to include . See I_DIRENT. */ #define HAS_REWINDDIR /**/ /* HAS_READLINK: * This symbol, if defined, indicates that the readlink routine is * available to read the value of a symbolic link. */ /*#define HAS_READLINK / **/ /* HAS_RENAME: * This symbol, if defined, indicates that the rename routine is available * to rename files. Otherwise you should do the unlink(), link(), unlink() * trick. */ #define HAS_RENAME /**/ /* HAS_RMDIR: * This symbol, if defined, indicates that the rmdir routine is * available to remove directories. Otherwise you should fork off a * new process to exec /bin/rmdir. */ #define HAS_RMDIR /**/ /* HAS_SELECT: * This symbol, if defined, indicates that the select routine is * available to select active file descriptors. If the timeout field * is used, may need to be included. */ #define HAS_SELECT /**/ /* HAS_SETEGID: * This symbol, if defined, indicates that the setegid routine is available * to change the effective gid of the current program. */ /*#define HAS_SETEGID / **/ /* HAS_SETEUID: * This symbol, if defined, indicates that the seteuid routine is available * to change the effective uid of the current program. */ /*#define HAS_SETEUID / **/ /* HAS_SETGROUPS: * This symbol, if defined, indicates that the setgroups() routine is * available to set the list of process groups. If unavailable, multiple * groups are probably not supported. */ /*#define HAS_SETGROUPS / **/ /* HAS_SETLINEBUF: * This symbol, if defined, indicates that the setlinebuf routine is * available to change stderr or stdout from block-buffered or unbuffered * to a line-buffered mode. */ /*#define HAS_SETLINEBUF / **/ /* HAS_SETLOCALE: * This symbol, if defined, indicates that the setlocale routine is * available to handle locale-specific ctype implementations. */ #define HAS_SETLOCALE /**/ /* HAS_SETPGID: * This symbol, if defined, indicates that the setpgid(pid, gpid) * routine is available to set process group ID. */ /*#define HAS_SETPGID / **/ /* HAS_SETPGRP2: * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX) * routine is available to set the current process group. */ /*#define HAS_SETPGRP2 / **/ /* HAS_SETPRIORITY: * This symbol, if defined, indicates that the setpriority routine is * available to set a process's priority. */ /*#define HAS_SETPRIORITY / **/ /* HAS_SETREGID: * This symbol, if defined, indicates that the setregid routine is * available to change the real and effective gid of the current * process. */ /* HAS_SETRESGID: * This symbol, if defined, indicates that the setresgid routine is * available to change the real, effective and saved gid of the current * process. */ /*#define HAS_SETREGID / **/ /*#define HAS_SETRESGID / **/ /* HAS_SETREUID: * This symbol, if defined, indicates that the setreuid routine is * available to change the real and effective uid of the current * process. */ /* HAS_SETRESUID: * This symbol, if defined, indicates that the setresuid routine is * available to change the real, effective and saved uid of the current * process. */ /*#define HAS_SETREUID / **/ /*#define HAS_SETRESUID / **/ /* HAS_SETRGID: * This symbol, if defined, indicates that the setrgid routine is available * to change the real gid of the current program. */ /*#define HAS_SETRGID / **/ /* HAS_SETRUID: * This symbol, if defined, indicates that the setruid routine is available * to change the real uid of the current program. */ /*#define HAS_SETRUID / **/ /* HAS_SETSID: * This symbol, if defined, indicates that the setsid routine is * available to set the process group ID. */ /*#define HAS_SETSID / **/ /* HAS_STRCHR: * This symbol is defined to indicate that the strchr()/strrchr() * functions are available for string searching. If not, try the * index()/rindex() pair. */ /* HAS_INDEX: * This symbol is defined to indicate that the index()/rindex() * functions are available for string searching. */ #define HAS_STRCHR /**/ /*#define HAS_INDEX / **/ /* HAS_STRCOLL: * This symbol, if defined, indicates that the strcoll routine is * available to compare strings using collating information. */ #define HAS_STRCOLL /**/ /* HAS_STRTOD: * This symbol, if defined, indicates that the strtod routine is * available to provide better numeric string conversion than atof(). */ #define HAS_STRTOD /**/ /* HAS_STRTOL: * This symbol, if defined, indicates that the strtol routine is available * to provide better numeric string conversion than atoi() and friends. */ #define HAS_STRTOL /**/ /* HAS_STRXFRM: * This symbol, if defined, indicates that the strxfrm() routine is * available to transform strings. */ #define HAS_STRXFRM /**/ /* HAS_SYMLINK: * This symbol, if defined, indicates that the symlink routine is available * to create symbolic links. */ /*#define HAS_SYMLINK / **/ /* HAS_SYSCALL: * This symbol, if defined, indicates that the syscall routine is * available to call arbitrary system calls. If undefined, that's tough. */ /*#define HAS_SYSCALL / **/ /* HAS_SYSCONF: * This symbol, if defined, indicates that sysconf() is available * to determine system related limits and options. */ /*#define HAS_SYSCONF / **/ /* HAS_SYSTEM: * This symbol, if defined, indicates that the system routine is * available to issue a shell command. */ #define HAS_SYSTEM /**/ /* HAS_TCGETPGRP: * This symbol, if defined, indicates that the tcgetpgrp routine is * available to get foreground process group ID. */ /*#define HAS_TCGETPGRP / **/ /* HAS_TCSETPGRP: * This symbol, if defined, indicates that the tcsetpgrp routine is * available to set foreground process group ID. */ /*#define HAS_TCSETPGRP / **/ /* HAS_TRUNCATE: * This symbol, if defined, indicates that the truncate routine is * available to truncate files. */ /*#define HAS_TRUNCATE / **/ /* HAS_TZNAME: * This symbol, if defined, indicates that the tzname[] array is * available to access timezone names. */ #define HAS_TZNAME /**/ /* HAS_UMASK: * This symbol, if defined, indicates that the umask routine is * available to set and get the value of the file creation mask. */ #define HAS_UMASK /**/ /* HAS_USLEEP: * This symbol, if defined, indicates that the usleep routine is * available to let the process sleep on a sub-second accuracy. */ /*#define HAS_USLEEP / **/ /* HAS_WAIT4: * This symbol, if defined, indicates that wait4() exists. */ /*#define HAS_WAIT4 / **/ /* HAS_WAITPID: * This symbol, if defined, indicates that the waitpid routine is * available to wait for child process. */ #define HAS_WAITPID /**/ /* HAS_WCSTOMBS: * This symbol, if defined, indicates that the wcstombs routine is * available to convert wide character strings to multibyte strings. */ #define HAS_WCSTOMBS /**/ /* HAS_WCTOMB: * This symbol, if defined, indicates that the wctomb routine is available * to covert a wide character to a multibyte. */ #define HAS_WCTOMB /**/ /* Groups_t: * This symbol holds the type used for the second argument to * getgroups() and setgroups(). Usually, this is the same as * gidtype (gid_t) , but sometimes it isn't. * It can be int, ushort, gid_t, etc... * It may be necessary to include to get any * typedef'ed information. This is only required if you have * getgroups() or setgroups().. */ #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS) #define Groups_t gid_t /* Type for 2nd arg to [sg]etgroups() */ #endif /* I_ARPA_INET: * This symbol, if defined, indicates to the C program that it should * include to get inet_addr and friends declarations. */ #define I_ARPA_INET /**/ /* I_DBM: * This symbol, if defined, indicates that exists and should * be included. */ /* I_RPCSVC_DBM: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_DBM / **/ #define I_RPCSVC_DBM /**/ /* I_DLFCN: * This symbol, if defined, indicates that exists and should * be included. */ #define I_DLFCN /**/ /* I_FCNTL: * This manifest constant tells the C program to include . */ #define I_FCNTL /**/ /* I_FLOAT: * This symbol, if defined, indicates to the C program that it should * include to get definition of symbols like DBL_MAX or * DBL_MIN, i.e. machine dependent floating point values. */ #define I_FLOAT /**/ /* I_GDBM: * This symbol, if defined, indicates that exists and should * be included. */ /*#define I_GDBM / **/ /* I_LIMITS: * This symbol, if defined, indicates to the C program that it should * include to get definition of symbols like WORD_BIT or * LONG_MAX, i.e. machine dependant limitations. */ #define I_LIMITS /**/ /* I_LOCALE: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_LOCALE /**/ /* I_MATH: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_MATH /**/ /* I_MEMORY: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_MEMORY / **/ /* I_NETINET_IN: * This symbol, if defined, indicates to the C program that it should * include . Otherwise, you may try . */ /*#define I_NETINET_IN / **/ /* I_SFIO: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SFIO / **/ /* I_STDDEF: * This symbol, if defined, indicates that exists and should * be included. */ #define I_STDDEF /**/ /* I_STDLIB: * This symbol, if defined, indicates that exists and should * be included. */ #define I_STDLIB /**/ /* I_STRING: * This symbol, if defined, indicates to the C program that it should * include (USG systems) instead of (BSD systems). */ #define I_STRING /**/ /* I_SYS_DIR: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_DIR / **/ /* I_SYS_FILE: * This symbol, if defined, indicates to the C program that it should * include to get definition of R_OK and friends. */ /*#define I_SYS_FILE / **/ /* I_SYS_IOCTL: * This symbol, if defined, indicates that exists and should * be included. Otherwise, include or . */ /* I_SYS_SOCKIO: * This symbol, if defined, indicates the should be included * to get socket ioctl options, like SIOCATMARK. */ /*#define I_SYS_IOCTL / **/ /*#define I_SYS_SOCKIO / **/ /* I_SYS_NDIR: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_NDIR / **/ /* I_SYS_PARAM: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_PARAM / **/ /* I_SYS_POLL: * This symbol, if defined, indicates that the program may include * . When I_POLL is also defined, it's probably safest * to only include . */ /*#define I_SYS_POLL / **/ /* I_SYS_RESOURCE: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_RESOURCE / **/ /* I_SYS_SELECT: * This symbol, if defined, indicates to the C program that it should * include in order to get definition of struct timeval. */ /*#define I_SYS_SELECT / **/ /* I_SYS_STAT: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_STAT /**/ /* I_SYS_TIMES: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_TIMES / **/ /* I_SYS_TYPES: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_TYPES /**/ /* I_SYS_UN: * This symbol, if defined, indicates to the C program that it should * include to get UNIX domain socket definitions. */ /*#define I_SYS_UN / **/ /* I_SYS_WAIT: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_WAIT / **/ /* I_TERMIO: * This symbol, if defined, indicates that the program should include * rather than . There are also differences in * the ioctl() calls that depend on the value of this symbol. */ /* I_TERMIOS: * This symbol, if defined, indicates that the program should include * the POSIX termios.h rather than sgtty.h or termio.h. * There are also differences in the ioctl() calls that depend on the * value of this symbol. */ /* I_SGTTY: * This symbol, if defined, indicates that the program should include * rather than . There are also differences in * the ioctl() calls that depend on the value of this symbol. */ /*#define I_TERMIO / **/ /*#define I_TERMIOS / **/ /*#define I_SGTTY / **/ /* I_UNISTD: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_UNISTD / **/ /* I_UTIME: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_UTIME /**/ /* I_VALUES: * This symbol, if defined, indicates to the C program that it should * include to get definition of symbols like MINFLOAT or * MAXLONG, i.e. machine dependant limitations. Probably, you * should use instead, if it is available. */ /*#define I_VALUES / **/ /* I_VFORK: * This symbol, if defined, indicates to the C program that it should * include vfork.h. */ /*#define I_VFORK / **/ /* CAN_VAPROTO: * This variable is defined on systems supporting prototype declaration * of functions with a variable number of arguments. */ /* _V: * This macro is used to declare function parameters in prototypes for * functions with a variable number of parameters. Use double parentheses. * For example: * * int printf _V((char *fmt, ...)); * * Remember to use the plain simple _() macro when declaring a function * with no variable number of arguments, since it might be possible to * have a non-effect _V() macro and still get prototypes via _(). */ /*#define CAN_VAPROTO / **/ #ifdef CAN_VAPROTO #define _V(args) args #else #define _V(args) () #endif /* INTSIZE: * This symbol contains the value of sizeof(int) so that the C * preprocessor can make decisions based on it. */ /* LONGSIZE: * This symbol contains the value of sizeof(long) so that the C * preprocessor can make decisions based on it. */ /* SHORTSIZE: * This symbol contains the value of sizeof(short) so that the C * preprocessor can make decisions based on it. */ #define INTSIZE 4 /**/ #define LONGSIZE 4 /**/ #define SHORTSIZE 2 /**/ /* MULTIARCH: * This symbol, if defined, signifies that the build * process will produce some binary files that are going to be * used in a cross-platform environment. This is the case for * example with the NeXT "fat" binaries that contain executables * for several CPUs. */ /*#define MULTIARCH / **/ /* HAS_QUAD: * This symbol, if defined, tells that there's a 64-bit integer type, * Quad_t, and its unsigned counterpar, Uquad_t. QUADKIND will be one * of QUAD_IS_INT, QUAD_IS_LONG, QUAD_IS_LONG_LONG, QUAD_IS_INT64_T, * or QUAD_IS___INT64. */ #define HAS_QUAD /**/ #ifdef HAS_QUAD # ifdef _MSC_VER # define Quad_t __int64 /**/ # define Uquad_t unsigned __int64 /**/ # define QUADKIND 5 /**/ # else /* gcc presumably */ # define Quad_t long long /**/ # define Uquad_t unsigned long long /**/ # define QUADKIND 3 /**/ # endif # define QUAD_IS_INT 1 # define QUAD_IS_LONG 2 # define QUAD_IS_LONG_LONG 3 # define QUAD_IS_INT64_T 4 # define QUAD_IS___INT64 5 #endif /* OSNAME: * This symbol contains the name of the operating system, as determined * by Configure. You shouldn't rely on it too much; the specific * feature tests from Configure are generally more reliable. */ /* OSVERS: * This symbol contains the version of the operating system, as determined * by Configure. You shouldn't rely on it too much; the specific * feature tests from Configure are generally more reliable. */ #define OSNAME "MSWin32" /**/ #define OSVERS "5.1" /**/ /* ARCHLIB: * This variable, if defined, holds the name of the directory in * which the user wants to put architecture-dependent public * library files for perl5. It is most often a local directory * such as /usr/local/lib. Programs using this variable must be * prepared to deal with filename expansion. If ARCHLIB is the * same as PRIVLIB, it is not defined, since presumably the * program already searches PRIVLIB. */ /* ARCHLIB_EXP: * This symbol contains the ~name expanded version of ARCHLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ #define ARCHLIB "c:\\perl\\lib" /**/ /*#define ARCHLIB_EXP "" / **/ /* ARCHNAME: * This symbol holds a string representing the architecture name. * It may be used to construct an architecture-dependant pathname * where library files may be held under a private library, for * instance. */ #define ARCHNAME "MSWin32-x64" /**/ /* BIN: * This symbol holds the path of the bin directory where the package will * be installed. Program must be prepared to deal with ~name substitution. */ /* BIN_EXP: * This symbol is the filename expanded version of the BIN symbol, for * programs that do not want to deal with that at run-time. */ /* PERL_RELOCATABLE_INC: * This symbol, if defined, indicates that we'd like to relocate entries * in @INC at run time based on the location of the perl binary. */ #define BIN "c:\\perl\\bin" /**/ #define BIN_EXP "c:\\perl\\bin" /**/ #define PERL_RELOCATABLE_INC "undef" /**/ /* CAT2: * This macro concatenates 2 tokens together. */ /* STRINGIFY: * This macro surrounds its token with double quotes. */ #if 42 == 1 #define CAT2(a,b) a/**/b #undef STRINGIFY #define STRINGIFY(a) "a" #endif #if 42 == 42 #define PeRl_CaTiFy(a, b) a ## b #define PeRl_StGiFy(a) #a #define CAT2(a,b) PeRl_CaTiFy(a,b) #define StGiFy(a) PeRl_StGiFy(a) #undef STRINGIFY #define STRINGIFY(a) PeRl_StGiFy(a) #endif #if 42 != 1 && 42 != 42 #include "Bletch: How does this C preprocessor concatenate tokens?" #endif /* CPPSTDIN: * This symbol contains the first part of the string which will invoke * the C preprocessor on the standard input and produce to standard * output. Typical value of "cc -E" or "/lib/cpp", but it can also * call a wrapper. See CPPRUN. */ /* CPPMINUS: * This symbol contains the second part of the string which will invoke * the C preprocessor on the standard input and produce to standard * output. This symbol will have the value "-" if CPPSTDIN needs a minus * to specify standard input, otherwise the value is "". */ /* CPPRUN: * This symbol contains the string which will invoke a C preprocessor on * the standard input and produce to standard output. It needs to end * with CPPLAST, after all other preprocessor flags have been specified. * The main difference with CPPSTDIN is that this program will never be a * pointer to a shell wrapper, i.e. it will be empty if no preprocessor is * available directly to the user. Note that it may well be different from * the preprocessor used to compile the C program. */ /* CPPLAST: * This symbol is intended to be used along with CPPRUN in the same manner * symbol CPPMINUS is used with CPPSTDIN. It contains either "-" or "". */ #ifdef _MSC_VER # define CPPSTDIN "cppstdin" # define CPPMINUS "" # define CPPRUN "cl -nologo -E" #else # define CPPSTDIN "x86_64-w64-mingw32-gcc -E" # define CPPMINUS "-" # define CPPRUN "x86_64-w64-mingw32-gcc -E" #endif #define CPPLAST "" /* HAS_ACCESS: * This manifest constant lets the C program know that the access() * system call is available to check for accessibility using real UID/GID. * (always present on UNIX.) */ #define HAS_ACCESS /**/ /* HAS_ACCESSX: * This symbol, if defined, indicates that the accessx routine is * available to do extended access checks. */ /*#define HAS_ACCESSX / **/ /* HAS_ASCTIME_R: * This symbol, if defined, indicates that the asctime_r routine * is available to asctime re-entrantly. */ /* ASCTIME_R_PROTO: * This symbol encodes the prototype of asctime_r. * It is zero if d_asctime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_asctime_r * is defined. */ /*#define HAS_ASCTIME_R / **/ #define ASCTIME_R_PROTO 0 /**/ /* The HASATTRIBUTE_* defines are left undefined here because they vary from * one version of GCC to another. Instead, they are defined on the basis of * the compiler version in . */ /* HASATTRIBUTE_FORMAT: * Can we handle GCC attribute for checking printf-style formats */ /* PRINTF_FORMAT_NULL_OK: * Allows __printf__ format to be null when checking printf-style */ /* HASATTRIBUTE_MALLOC: * Can we handle GCC attribute for malloc-style functions. */ /* HASATTRIBUTE_NONNULL: * Can we handle GCC attribute for nonnull function parms. */ /* HASATTRIBUTE_NORETURN: * Can we handle GCC attribute for functions that do not return */ /* HASATTRIBUTE_PURE: * Can we handle GCC attribute for pure functions */ /* HASATTRIBUTE_UNUSED: * Can we handle GCC attribute for unused variables and arguments */ /* HASATTRIBUTE_DEPRECATED: * Can we handle GCC attribute for marking deprecated APIs */ /* HASATTRIBUTE_WARN_UNUSED_RESULT: * Can we handle GCC attribute for warning on unused results */ /*#define HASATTRIBUTE_DEPRECATED / **/ /*#define HASATTRIBUTE_FORMAT / **/ /*#define PRINTF_FORMAT_NULL_OK / **/ /*#define HASATTRIBUTE_NORETURN / **/ /*#define HASATTRIBUTE_MALLOC / **/ /*#define HASATTRIBUTE_NONNULL / **/ /*#define HASATTRIBUTE_PURE / **/ /*#define HASATTRIBUTE_UNUSED / **/ /*#define HASATTRIBUTE_WARN_UNUSED_RESULT / **/ /* HASCONST: * This symbol, if defined, indicates that this C compiler knows about * the const type. There is no need to actually test for that symbol * within your programs. The mere use of the "const" keyword will * trigger the necessary tests. */ #define HASCONST /**/ #ifndef HASCONST #define const #endif /* HAS_CRYPT_R: * This symbol, if defined, indicates that the crypt_r routine * is available to crypt re-entrantly. */ /* CRYPT_R_PROTO: * This symbol encodes the prototype of crypt_r. * It is zero if d_crypt_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_crypt_r * is defined. */ /*#define HAS_CRYPT_R / **/ #define CRYPT_R_PROTO 0 /**/ /* HAS_CSH: * This symbol, if defined, indicates that the C-shell exists. */ /* CSH: * This symbol, if defined, contains the full pathname of csh. */ /*#define HAS_CSH / **/ #ifdef HAS_CSH #define CSH "" /**/ #endif /* HAS_CTERMID_R: * This symbol, if defined, indicates that the ctermid_r routine * is available to ctermid re-entrantly. */ /* CTERMID_R_PROTO: * This symbol encodes the prototype of ctermid_r. * It is zero if d_ctermid_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ctermid_r * is defined. */ /*#define HAS_CTERMID_R / **/ #define CTERMID_R_PROTO 0 /**/ /* HAS_CTIME_R: * This symbol, if defined, indicates that the ctime_r routine * is available to ctime re-entrantly. */ /* CTIME_R_PROTO: * This symbol encodes the prototype of ctime_r. * It is zero if d_ctime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ctime_r * is defined. */ /*#define HAS_CTIME_R / **/ #define CTIME_R_PROTO 0 /**/ /* HAS_DRAND48_R: * This symbol, if defined, indicates that the drand48_r routine * is available to drand48 re-entrantly. */ /* DRAND48_R_PROTO: * This symbol encodes the prototype of drand48_r. * It is zero if d_drand48_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_drand48_r * is defined. */ /*#define HAS_DRAND48_R / **/ #define DRAND48_R_PROTO 0 /**/ /* HAS_DRAND48_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the drand48() function. Otherwise, it is up * to the program to supply one. A good guess is * extern double drand48(void); */ /*#define HAS_DRAND48_PROTO / **/ /* HAS_EACCESS: * This symbol, if defined, indicates that the eaccess routine is * available to do extended access checks. */ /*#define HAS_EACCESS / **/ /* HAS_ENDGRENT: * This symbol, if defined, indicates that the getgrent routine is * available for finalizing sequential access of the group database. */ /*#define HAS_ENDGRENT / **/ /* HAS_ENDGRENT_R: * This symbol, if defined, indicates that the endgrent_r routine * is available to endgrent re-entrantly. */ /* ENDGRENT_R_PROTO: * This symbol encodes the prototype of endgrent_r. * It is zero if d_endgrent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endgrent_r * is defined. */ /*#define HAS_ENDGRENT_R / **/ #define ENDGRENT_R_PROTO 0 /**/ /* HAS_ENDHOSTENT: * This symbol, if defined, indicates that the endhostent() routine is * available to close whatever was being used for host queries. */ /*#define HAS_ENDHOSTENT / **/ /* HAS_ENDHOSTENT_R: * This symbol, if defined, indicates that the endhostent_r routine * is available to endhostent re-entrantly. */ /* ENDHOSTENT_R_PROTO: * This symbol encodes the prototype of endhostent_r. * It is zero if d_endhostent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endhostent_r * is defined. */ /*#define HAS_ENDHOSTENT_R / **/ #define ENDHOSTENT_R_PROTO 0 /**/ /* HAS_ENDNETENT: * This symbol, if defined, indicates that the endnetent() routine is * available to close whatever was being used for network queries. */ /*#define HAS_ENDNETENT / **/ /* HAS_ENDNETENT_R: * This symbol, if defined, indicates that the endnetent_r routine * is available to endnetent re-entrantly. */ /* ENDNETENT_R_PROTO: * This symbol encodes the prototype of endnetent_r. * It is zero if d_endnetent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endnetent_r * is defined. */ /*#define HAS_ENDNETENT_R / **/ #define ENDNETENT_R_PROTO 0 /**/ /* HAS_ENDPROTOENT: * This symbol, if defined, indicates that the endprotoent() routine is * available to close whatever was being used for protocol queries. */ /*#define HAS_ENDPROTOENT / **/ /* HAS_ENDPROTOENT_R: * This symbol, if defined, indicates that the endprotoent_r routine * is available to endprotoent re-entrantly. */ /* ENDPROTOENT_R_PROTO: * This symbol encodes the prototype of endprotoent_r. * It is zero if d_endprotoent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endprotoent_r * is defined. */ /*#define HAS_ENDPROTOENT_R / **/ #define ENDPROTOENT_R_PROTO 0 /**/ /* HAS_ENDPWENT: * This symbol, if defined, indicates that the getgrent routine is * available for finalizing sequential access of the passwd database. */ /*#define HAS_ENDPWENT / **/ /* HAS_ENDPWENT_R: * This symbol, if defined, indicates that the endpwent_r routine * is available to endpwent re-entrantly. */ /* ENDPWENT_R_PROTO: * This symbol encodes the prototype of endpwent_r. * It is zero if d_endpwent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endpwent_r * is defined. */ /*#define HAS_ENDPWENT_R / **/ #define ENDPWENT_R_PROTO 0 /**/ /* HAS_ENDSERVENT: * This symbol, if defined, indicates that the endservent() routine is * available to close whatever was being used for service queries. */ /*#define HAS_ENDSERVENT / **/ /* HAS_ENDSERVENT_R: * This symbol, if defined, indicates that the endservent_r routine * is available to endservent re-entrantly. */ /* ENDSERVENT_R_PROTO: * This symbol encodes the prototype of endservent_r. * It is zero if d_endservent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endservent_r * is defined. */ /*#define HAS_ENDSERVENT_R / **/ #define ENDSERVENT_R_PROTO 0 /**/ /* FLEXFILENAMES: * This symbol, if defined, indicates that the system supports filenames * longer than 14 characters. */ #define FLEXFILENAMES /**/ /* HAS_GETGRENT: * This symbol, if defined, indicates that the getgrent routine is * available for sequential access of the group database. */ /*#define HAS_GETGRENT / **/ /* HAS_GETGRENT_R: * This symbol, if defined, indicates that the getgrent_r routine * is available to getgrent re-entrantly. */ /* GETGRENT_R_PROTO: * This symbol encodes the prototype of getgrent_r. * It is zero if d_getgrent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrent_r * is defined. */ /*#define HAS_GETGRENT_R / **/ #define GETGRENT_R_PROTO 0 /**/ /* HAS_GETGRGID_R: * This symbol, if defined, indicates that the getgrgid_r routine * is available to getgrgid re-entrantly. */ /* GETGRGID_R_PROTO: * This symbol encodes the prototype of getgrgid_r. * It is zero if d_getgrgid_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrgid_r * is defined. */ /*#define HAS_GETGRGID_R / **/ #define GETGRGID_R_PROTO 0 /**/ /* HAS_GETGRNAM_R: * This symbol, if defined, indicates that the getgrnam_r routine * is available to getgrnam re-entrantly. */ /* GETGRNAM_R_PROTO: * This symbol encodes the prototype of getgrnam_r. * It is zero if d_getgrnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrnam_r * is defined. */ /*#define HAS_GETGRNAM_R / **/ #define GETGRNAM_R_PROTO 0 /**/ /* HAS_GETHOSTBYADDR: * This symbol, if defined, indicates that the gethostbyaddr() routine is * available to look up hosts by their IP addresses. */ #define HAS_GETHOSTBYADDR /**/ /* HAS_GETHOSTBYNAME: * This symbol, if defined, indicates that the gethostbyname() routine is * available to look up host names in some data base or other. */ #define HAS_GETHOSTBYNAME /**/ /* HAS_GETHOSTENT: * This symbol, if defined, indicates that the gethostent() routine is * available to look up host names in some data base or another. */ /*#define HAS_GETHOSTENT / **/ /* HAS_GETHOSTNAME: * This symbol, if defined, indicates that the C program may use the * gethostname() routine to derive the host name. See also HAS_UNAME * and PHOSTNAME. */ /* HAS_UNAME: * This symbol, if defined, indicates that the C program may use the * uname() routine to derive the host name. See also HAS_GETHOSTNAME * and PHOSTNAME. */ /* PHOSTNAME: * This symbol, if defined, indicates the command to feed to the * popen() routine to derive the host name. See also HAS_GETHOSTNAME * and HAS_UNAME. Note that the command uses a fully qualified path, * so that it is safe even if used by a process with super-user * privileges. */ /* HAS_PHOSTNAME: * This symbol, if defined, indicates that the C program may use the * contents of PHOSTNAME as a command to feed to the popen() routine * to derive the host name. */ #define HAS_GETHOSTNAME /**/ #define HAS_UNAME /**/ /*#define HAS_PHOSTNAME / **/ #ifdef HAS_PHOSTNAME #define PHOSTNAME "" /* How to get the host name */ #endif /* HAS_GETHOSTBYADDR_R: * This symbol, if defined, indicates that the gethostbyaddr_r routine * is available to gethostbyaddr re-entrantly. */ /* GETHOSTBYADDR_R_PROTO: * This symbol encodes the prototype of gethostbyaddr_r. * It is zero if d_gethostbyaddr_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostbyaddr_r * is defined. */ /*#define HAS_GETHOSTBYADDR_R / **/ #define GETHOSTBYADDR_R_PROTO 0 /**/ /* HAS_GETHOSTBYNAME_R: * This symbol, if defined, indicates that the gethostbyname_r routine * is available to gethostbyname re-entrantly. */ /* GETHOSTBYNAME_R_PROTO: * This symbol encodes the prototype of gethostbyname_r. * It is zero if d_gethostbyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostbyname_r * is defined. */ /*#define HAS_GETHOSTBYNAME_R / **/ #define GETHOSTBYNAME_R_PROTO 0 /**/ /* HAS_GETHOSTENT_R: * This symbol, if defined, indicates that the gethostent_r routine * is available to gethostent re-entrantly. */ /* GETHOSTENT_R_PROTO: * This symbol encodes the prototype of gethostent_r. * It is zero if d_gethostent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostent_r * is defined. */ /*#define HAS_GETHOSTENT_R / **/ #define GETHOSTENT_R_PROTO 0 /**/ /* HAS_GETHOST_PROTOS: * This symbol, if defined, indicates that includes * prototypes for gethostent(), gethostbyname(), and * gethostbyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ #define HAS_GETHOST_PROTOS /**/ /* HAS_GETLOGIN_R: * This symbol, if defined, indicates that the getlogin_r routine * is available to getlogin re-entrantly. */ /* GETLOGIN_R_PROTO: * This symbol encodes the prototype of getlogin_r. * It is zero if d_getlogin_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getlogin_r * is defined. */ /*#define HAS_GETLOGIN_R / **/ #define GETLOGIN_R_PROTO 0 /**/ /* HAS_GETNETBYADDR: * This symbol, if defined, indicates that the getnetbyaddr() routine is * available to look up networks by their IP addresses. */ /*#define HAS_GETNETBYADDR / **/ /* HAS_GETNETBYNAME: * This symbol, if defined, indicates that the getnetbyname() routine is * available to look up networks by their names. */ /*#define HAS_GETNETBYNAME / **/ /* HAS_GETNETENT: * This symbol, if defined, indicates that the getnetent() routine is * available to look up network names in some data base or another. */ /*#define HAS_GETNETENT / **/ /* HAS_GETNETBYADDR_R: * This symbol, if defined, indicates that the getnetbyaddr_r routine * is available to getnetbyaddr re-entrantly. */ /* GETNETBYADDR_R_PROTO: * This symbol encodes the prototype of getnetbyaddr_r. * It is zero if d_getnetbyaddr_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetbyaddr_r * is defined. */ /*#define HAS_GETNETBYADDR_R / **/ #define GETNETBYADDR_R_PROTO 0 /**/ /* HAS_GETNETBYNAME_R: * This symbol, if defined, indicates that the getnetbyname_r routine * is available to getnetbyname re-entrantly. */ /* GETNETBYNAME_R_PROTO: * This symbol encodes the prototype of getnetbyname_r. * It is zero if d_getnetbyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetbyname_r * is defined. */ /*#define HAS_GETNETBYNAME_R / **/ #define GETNETBYNAME_R_PROTO 0 /**/ /* HAS_GETNETENT_R: * This symbol, if defined, indicates that the getnetent_r routine * is available to getnetent re-entrantly. */ /* GETNETENT_R_PROTO: * This symbol encodes the prototype of getnetent_r. * It is zero if d_getnetent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetent_r * is defined. */ /*#define HAS_GETNETENT_R / **/ #define GETNETENT_R_PROTO 0 /**/ /* HAS_GETNET_PROTOS: * This symbol, if defined, indicates that includes * prototypes for getnetent(), getnetbyname(), and * getnetbyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ /*#define HAS_GETNET_PROTOS / **/ /* HAS_GETPROTOENT: * This symbol, if defined, indicates that the getprotoent() routine is * available to look up protocols in some data base or another. */ /*#define HAS_GETPROTOENT / **/ /* HAS_GETPGRP: * This symbol, if defined, indicates that the getpgrp routine is * available to get the current process group. */ /* USE_BSD_GETPGRP: * This symbol, if defined, indicates that getpgrp needs one * arguments whereas USG one needs none. */ /*#define HAS_GETPGRP / **/ /*#define USE_BSD_GETPGRP / **/ /* HAS_GETPROTOBYNAME: * This symbol, if defined, indicates that the getprotobyname() * routine is available to look up protocols by their name. */ /* HAS_GETPROTOBYNUMBER: * This symbol, if defined, indicates that the getprotobynumber() * routine is available to look up protocols by their number. */ #define HAS_GETPROTOBYNAME /**/ #define HAS_GETPROTOBYNUMBER /**/ /* HAS_GETPROTOBYNAME_R: * This symbol, if defined, indicates that the getprotobyname_r routine * is available to getprotobyname re-entrantly. */ /* GETPROTOBYNAME_R_PROTO: * This symbol encodes the prototype of getprotobyname_r. * It is zero if d_getprotobyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotobyname_r * is defined. */ /*#define HAS_GETPROTOBYNAME_R / **/ #define GETPROTOBYNAME_R_PROTO 0 /**/ /* HAS_GETPROTOBYNUMBER_R: * This symbol, if defined, indicates that the getprotobynumber_r routine * is available to getprotobynumber re-entrantly. */ /* GETPROTOBYNUMBER_R_PROTO: * This symbol encodes the prototype of getprotobynumber_r. * It is zero if d_getprotobynumber_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotobynumber_r * is defined. */ /*#define HAS_GETPROTOBYNUMBER_R / **/ #define GETPROTOBYNUMBER_R_PROTO 0 /**/ /* HAS_GETPROTOENT_R: * This symbol, if defined, indicates that the getprotoent_r routine * is available to getprotoent re-entrantly. */ /* GETPROTOENT_R_PROTO: * This symbol encodes the prototype of getprotoent_r. * It is zero if d_getprotoent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotoent_r * is defined. */ /*#define HAS_GETPROTOENT_R / **/ #define GETPROTOENT_R_PROTO 0 /**/ /* HAS_GETPROTO_PROTOS: * This symbol, if defined, indicates that includes * prototypes for getprotoent(), getprotobyname(), and * getprotobyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ #define HAS_GETPROTO_PROTOS /**/ /* HAS_GETPWENT: * This symbol, if defined, indicates that the getpwent routine is * available for sequential access of the passwd database. * If this is not available, the older getpw() function may be available. */ /*#define HAS_GETPWENT / **/ /* HAS_GETPWENT_R: * This symbol, if defined, indicates that the getpwent_r routine * is available to getpwent re-entrantly. */ /* GETPWENT_R_PROTO: * This symbol encodes the prototype of getpwent_r. * It is zero if d_getpwent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwent_r * is defined. */ /*#define HAS_GETPWENT_R / **/ #define GETPWENT_R_PROTO 0 /**/ /* HAS_GETPWNAM_R: * This symbol, if defined, indicates that the getpwnam_r routine * is available to getpwnam re-entrantly. */ /* GETPWNAM_R_PROTO: * This symbol encodes the prototype of getpwnam_r. * It is zero if d_getpwnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwnam_r * is defined. */ /*#define HAS_GETPWNAM_R / **/ #define GETPWNAM_R_PROTO 0 /**/ /* HAS_GETPWUID_R: * This symbol, if defined, indicates that the getpwuid_r routine * is available to getpwuid re-entrantly. */ /* GETPWUID_R_PROTO: * This symbol encodes the prototype of getpwuid_r. * It is zero if d_getpwuid_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwuid_r * is defined. */ /*#define HAS_GETPWUID_R / **/ #define GETPWUID_R_PROTO 0 /**/ /* HAS_GETSERVENT: * This symbol, if defined, indicates that the getservent() routine is * available to look up network services in some data base or another. */ /*#define HAS_GETSERVENT / **/ /* HAS_GETSERVBYNAME_R: * This symbol, if defined, indicates that the getservbyname_r routine * is available to getservbyname re-entrantly. */ /* GETSERVBYNAME_R_PROTO: * This symbol encodes the prototype of getservbyname_r. * It is zero if d_getservbyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservbyname_r * is defined. */ /*#define HAS_GETSERVBYNAME_R / **/ #define GETSERVBYNAME_R_PROTO 0 /**/ /* HAS_GETSERVBYPORT_R: * This symbol, if defined, indicates that the getservbyport_r routine * is available to getservbyport re-entrantly. */ /* GETSERVBYPORT_R_PROTO: * This symbol encodes the prototype of getservbyport_r. * It is zero if d_getservbyport_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservbyport_r * is defined. */ /*#define HAS_GETSERVBYPORT_R / **/ #define GETSERVBYPORT_R_PROTO 0 /**/ /* HAS_GETSERVENT_R: * This symbol, if defined, indicates that the getservent_r routine * is available to getservent re-entrantly. */ /* GETSERVENT_R_PROTO: * This symbol encodes the prototype of getservent_r. * It is zero if d_getservent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservent_r * is defined. */ /*#define HAS_GETSERVENT_R / **/ #define GETSERVENT_R_PROTO 0 /**/ /* HAS_GETSERV_PROTOS: * This symbol, if defined, indicates that includes * prototypes for getservent(), getservbyname(), and * getservbyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ #define HAS_GETSERV_PROTOS /**/ /* HAS_GETSPNAM_R: * This symbol, if defined, indicates that the getspnam_r routine * is available to getspnam re-entrantly. */ /* GETSPNAM_R_PROTO: * This symbol encodes the prototype of getspnam_r. * It is zero if d_getspnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getspnam_r * is defined. */ /*#define HAS_GETSPNAM_R / **/ #define GETSPNAM_R_PROTO 0 /**/ /* HAS_GETSERVBYNAME: * This symbol, if defined, indicates that the getservbyname() * routine is available to look up services by their name. */ /* HAS_GETSERVBYPORT: * This symbol, if defined, indicates that the getservbyport() * routine is available to look up services by their port. */ #define HAS_GETSERVBYNAME /**/ #define HAS_GETSERVBYPORT /**/ /* HAS_GMTIME_R: * This symbol, if defined, indicates that the gmtime_r routine * is available to gmtime re-entrantly. */ /* GMTIME_R_PROTO: * This symbol encodes the prototype of gmtime_r. * It is zero if d_gmtime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gmtime_r * is defined. */ /*#define HAS_GMTIME_R / **/ #define GMTIME_R_PROTO 0 /**/ /* HAS_HTONL: * This symbol, if defined, indicates that the htonl() routine (and * friends htons() ntohl() ntohs()) are available to do network * order byte swapping. */ /* HAS_HTONS: * This symbol, if defined, indicates that the htons() routine (and * friends htonl() ntohl() ntohs()) are available to do network * order byte swapping. */ /* HAS_NTOHL: * This symbol, if defined, indicates that the ntohl() routine (and * friends htonl() htons() ntohs()) are available to do network * order byte swapping. */ /* HAS_NTOHS: * This symbol, if defined, indicates that the ntohs() routine (and * friends htonl() htons() ntohl()) are available to do network * order byte swapping. */ #define HAS_HTONL /**/ #define HAS_HTONS /**/ #define HAS_NTOHL /**/ #define HAS_NTOHS /**/ /* HAS_LOCALTIME_R: * This symbol, if defined, indicates that the localtime_r routine * is available to localtime re-entrantly. */ /* LOCALTIME_R_NEEDS_TZSET: * Many libc's localtime_r implementations do not call tzset, * making them differ from localtime(), and making timezone * changes using \undef{TZ} without explicitly calling tzset * impossible. This symbol makes us call tzset before localtime_r */ /*#define LOCALTIME_R_NEEDS_TZSET / **/ #ifdef LOCALTIME_R_NEEDS_TZSET #define L_R_TZSET tzset(), #else #define L_R_TZSET #endif /* LOCALTIME_R_PROTO: * This symbol encodes the prototype of localtime_r. * It is zero if d_localtime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_localtime_r * is defined. */ /*#define HAS_LOCALTIME_R / **/ #define LOCALTIME_R_PROTO 0 /**/ /* HAS_LONG_DOUBLE: * This symbol will be defined if the C compiler supports long * doubles. */ /* LONG_DOUBLESIZE: * This symbol contains the size of a long double, so that the * C preprocessor can make decisions based on it. It is only * defined if the system supports long doubles. */ #define HAS_LONG_DOUBLE /**/ #ifdef HAS_LONG_DOUBLE # ifdef _MSC_VER # define LONG_DOUBLESIZE 8 /**/ # else # define LONG_DOUBLESIZE 12 /**/ # endif #endif /* HAS_LONG_LONG: * This symbol will be defined if the C compiler supports long long. */ /* LONGLONGSIZE: * This symbol contains the size of a long long, so that the * C preprocessor can make decisions based on it. It is only * defined if the system supports long long. */ #ifdef __GNUC__ # define HAS_LONG_LONG /**/ #endif #ifdef HAS_LONG_LONG #define LONGLONGSIZE 8 /**/ #endif /* HAS_LSEEK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the lseek() function. Otherwise, it is up * to the program to supply one. A good guess is * extern off_t lseek(int, off_t, int); */ #define HAS_LSEEK_PROTO /**/ /* HAS_MEMCHR: * This symbol, if defined, indicates that the memchr routine is available * to locate characters within a C string. */ #define HAS_MEMCHR /**/ /* HAS_MKSTEMP: * This symbol, if defined, indicates that the mkstemp routine is * available to exclusively create and open a uniquely named * temporary file. */ /*#define HAS_MKSTEMP / **/ /* HAS_MMAP: * This symbol, if defined, indicates that the mmap system call is * available to map a file into memory. */ /* Mmap_t: * This symbol holds the return type of the mmap() system call * (and simultaneously the type of the first argument). * Usually set to 'void *' or 'caddr_t'. */ /*#define HAS_MMAP / **/ #define Mmap_t void * /**/ /* HAS_MSG: * This symbol, if defined, indicates that the entire msg*(2) library is * supported (IPC mechanism based on message queues). */ /*#define HAS_MSG / **/ /* OLD_PTHREAD_CREATE_JOINABLE: * This symbol, if defined, indicates how to create pthread * in joinable (aka undetached) state. NOTE: not defined * if pthread.h already has defined PTHREAD_CREATE_JOINABLE * (the new version of the constant). * If defined, known values are PTHREAD_CREATE_UNDETACHED * and __UNDETACHED. */ /*#define OLD_PTHREAD_CREATE_JOINABLE / **/ /* HAS_PTHREAD_ATFORK: * This symbol, if defined, indicates that the pthread_atfork routine * is available to setup fork handlers. */ /*#define HAS_PTHREAD_ATFORK / **/ /* HAS_PTHREAD_YIELD: * This symbol, if defined, indicates that the pthread_yield * routine is available to yield the execution of the current * thread. sched_yield is preferable to pthread_yield. */ /* SCHED_YIELD: * This symbol defines the way to yield the execution of * the current thread. Known ways are sched_yield, * pthread_yield, and pthread_yield with NULL. */ /* HAS_SCHED_YIELD: * This symbol, if defined, indicates that the sched_yield * routine is available to yield the execution of the current * thread. sched_yield is preferable to pthread_yield. */ /*#define HAS_PTHREAD_YIELD / **/ #define SCHED_YIELD /**/ /*#define HAS_SCHED_YIELD / **/ /* HAS_RANDOM_R: * This symbol, if defined, indicates that the random_r routine * is available to random re-entrantly. */ /* RANDOM_R_PROTO: * This symbol encodes the prototype of random_r. * It is zero if d_random_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_random_r * is defined. */ /*#define HAS_RANDOM_R / **/ #define RANDOM_R_PROTO 0 /**/ /* HAS_READDIR64_R: * This symbol, if defined, indicates that the readdir64_r routine * is available to readdir64 re-entrantly. */ /* READDIR64_R_PROTO: * This symbol encodes the prototype of readdir64_r. * It is zero if d_readdir64_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_readdir64_r * is defined. */ /*#define HAS_READDIR64_R / **/ #define READDIR64_R_PROTO 0 /**/ /* HAS_READDIR_R: * This symbol, if defined, indicates that the readdir_r routine * is available to readdir re-entrantly. */ /* READDIR_R_PROTO: * This symbol encodes the prototype of readdir_r. * It is zero if d_readdir_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_readdir_r * is defined. */ /*#define HAS_READDIR_R / **/ #define READDIR_R_PROTO 0 /**/ /* HAS_SEM: * This symbol, if defined, indicates that the entire sem*(2) library is * supported. */ /*#define HAS_SEM / **/ /* HAS_SETGRENT: * This symbol, if defined, indicates that the setgrent routine is * available for initializing sequential access of the group database. */ /*#define HAS_SETGRENT / **/ /* HAS_SETGRENT_R: * This symbol, if defined, indicates that the setgrent_r routine * is available to setgrent re-entrantly. */ /* SETGRENT_R_PROTO: * This symbol encodes the prototype of setgrent_r. * It is zero if d_setgrent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setgrent_r * is defined. */ /*#define HAS_SETGRENT_R / **/ #define SETGRENT_R_PROTO 0 /**/ /* HAS_SETHOSTENT: * This symbol, if defined, indicates that the sethostent() routine is * available. */ /*#define HAS_SETHOSTENT / **/ /* HAS_SETHOSTENT_R: * This symbol, if defined, indicates that the sethostent_r routine * is available to sethostent re-entrantly. */ /* SETHOSTENT_R_PROTO: * This symbol encodes the prototype of sethostent_r. * It is zero if d_sethostent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_sethostent_r * is defined. */ /*#define HAS_SETHOSTENT_R / **/ #define SETHOSTENT_R_PROTO 0 /**/ /* HAS_SETLOCALE_R: * This symbol, if defined, indicates that the setlocale_r routine * is available to setlocale re-entrantly. */ /* SETLOCALE_R_PROTO: * This symbol encodes the prototype of setlocale_r. * It is zero if d_setlocale_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setlocale_r * is defined. */ /*#define HAS_SETLOCALE_R / **/ #define SETLOCALE_R_PROTO 0 /**/ /* HAS_SETNETENT: * This symbol, if defined, indicates that the setnetent() routine is * available. */ /*#define HAS_SETNETENT / **/ /* HAS_SETNETENT_R: * This symbol, if defined, indicates that the setnetent_r routine * is available to setnetent re-entrantly. */ /* SETNETENT_R_PROTO: * This symbol encodes the prototype of setnetent_r. * It is zero if d_setnetent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setnetent_r * is defined. */ /*#define HAS_SETNETENT_R / **/ #define SETNETENT_R_PROTO 0 /**/ /* HAS_SETPROTOENT: * This symbol, if defined, indicates that the setprotoent() routine is * available. */ /*#define HAS_SETPROTOENT / **/ /* HAS_SETPGRP: * This symbol, if defined, indicates that the setpgrp routine is * available to set the current process group. */ /* USE_BSD_SETPGRP: * This symbol, if defined, indicates that setpgrp needs two * arguments whereas USG one needs none. See also HAS_SETPGID * for a POSIX interface. */ /*#define HAS_SETPGRP / **/ /*#define USE_BSD_SETPGRP / **/ /* HAS_SETPROTOENT_R: * This symbol, if defined, indicates that the setprotoent_r routine * is available to setprotoent re-entrantly. */ /* SETPROTOENT_R_PROTO: * This symbol encodes the prototype of setprotoent_r. * It is zero if d_setprotoent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setprotoent_r * is defined. */ /*#define HAS_SETPROTOENT_R / **/ #define SETPROTOENT_R_PROTO 0 /**/ /* HAS_SETPWENT: * This symbol, if defined, indicates that the setpwent routine is * available for initializing sequential access of the passwd database. */ /*#define HAS_SETPWENT / **/ /* HAS_SETPWENT_R: * This symbol, if defined, indicates that the setpwent_r routine * is available to setpwent re-entrantly. */ /* SETPWENT_R_PROTO: * This symbol encodes the prototype of setpwent_r. * It is zero if d_setpwent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setpwent_r * is defined. */ /*#define HAS_SETPWENT_R / **/ #define SETPWENT_R_PROTO 0 /**/ /* HAS_SETSERVENT: * This symbol, if defined, indicates that the setservent() routine is * available. */ /*#define HAS_SETSERVENT / **/ /* HAS_SETSERVENT_R: * This symbol, if defined, indicates that the setservent_r routine * is available to setservent re-entrantly. */ /* SETSERVENT_R_PROTO: * This symbol encodes the prototype of setservent_r. * It is zero if d_setservent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setservent_r * is defined. */ /*#define HAS_SETSERVENT_R / **/ #define SETSERVENT_R_PROTO 0 /**/ /* HAS_SETVBUF: * This symbol, if defined, indicates that the setvbuf routine is * available to change buffering on an open stdio stream. * to a line-buffered mode. */ #define HAS_SETVBUF /**/ /* HAS_SHM: * This symbol, if defined, indicates that the entire shm*(2) library is * supported. */ /*#define HAS_SHM / **/ /* Shmat_t: * This symbol holds the return type of the shmat() system call. * Usually set to 'void *' or 'char *'. */ /* HAS_SHMAT_PROTOTYPE: * This symbol, if defined, indicates that the sys/shm.h includes * a prototype for shmat(). Otherwise, it is up to the program to * guess one. Shmat_t shmat(int, Shmat_t, int) is a good guess, * but not always right so it should be emitted by the program only * when HAS_SHMAT_PROTOTYPE is not defined to avoid conflicting defs. */ #define Shmat_t void * /**/ /*#define HAS_SHMAT_PROTOTYPE / **/ /* HAS_SOCKET: * This symbol, if defined, indicates that the BSD socket interface is * supported. */ /* HAS_SOCKETPAIR: * This symbol, if defined, indicates that the BSD socketpair() call is * supported. */ /* HAS_MSG_CTRUNC: * This symbol, if defined, indicates that the MSG_CTRUNC is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_DONTROUTE: * This symbol, if defined, indicates that the MSG_DONTROUTE is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_OOB: * This symbol, if defined, indicates that the MSG_OOB is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_PEEK: * This symbol, if defined, indicates that the MSG_PEEK is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_PROXY: * This symbol, if defined, indicates that the MSG_PROXY is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_SCM_RIGHTS: * This symbol, if defined, indicates that the SCM_RIGHTS is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ #define HAS_SOCKET /**/ /*#define HAS_SOCKETPAIR / **/ /*#define HAS_MSG_CTRUNC / **/ /*#define HAS_MSG_DONTROUTE / **/ /*#define HAS_MSG_OOB / **/ /*#define HAS_MSG_PEEK / **/ /*#define HAS_MSG_PROXY / **/ /*#define HAS_SCM_RIGHTS / **/ /* HAS_SRAND48_R: * This symbol, if defined, indicates that the srand48_r routine * is available to srand48 re-entrantly. */ /* SRAND48_R_PROTO: * This symbol encodes the prototype of srand48_r. * It is zero if d_srand48_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_srand48_r * is defined. */ /*#define HAS_SRAND48_R / **/ #define SRAND48_R_PROTO 0 /**/ /* HAS_SRANDOM_R: * This symbol, if defined, indicates that the srandom_r routine * is available to srandom re-entrantly. */ /* SRANDOM_R_PROTO: * This symbol encodes the prototype of srandom_r. * It is zero if d_srandom_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_srandom_r * is defined. */ /*#define HAS_SRANDOM_R / **/ #define SRANDOM_R_PROTO 0 /**/ /* USE_STAT_BLOCKS: * This symbol is defined if this system has a stat structure declaring * st_blksize and st_blocks. */ #ifndef USE_STAT_BLOCKS /*#define USE_STAT_BLOCKS / **/ #endif /* USE_STRUCT_COPY: * This symbol, if defined, indicates that this C compiler knows how * to copy structures. If undefined, you'll need to use a block copy * routine of some sort instead. */ #define USE_STRUCT_COPY /**/ /* HAS_STRERROR: * This symbol, if defined, indicates that the strerror routine is * available to translate error numbers to strings. See the writeup * of Strerror() in this file before you try to define your own. */ /* HAS_SYS_ERRLIST: * This symbol, if defined, indicates that the sys_errlist array is * available to translate error numbers to strings. The extern int * sys_nerr gives the size of that table. */ /* Strerror: * This preprocessor symbol is defined as a macro if strerror() is * not available to translate error numbers to strings but sys_errlist[] * array is there. */ #define HAS_STRERROR /**/ #define HAS_SYS_ERRLIST /**/ #define Strerror(e) strerror(e) /* HAS_STRERROR_R: * This symbol, if defined, indicates that the strerror_r routine * is available to strerror re-entrantly. */ /* STRERROR_R_PROTO: * This symbol encodes the prototype of strerror_r. * It is zero if d_strerror_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_strerror_r * is defined. */ /*#define HAS_STRERROR_R / **/ #define STRERROR_R_PROTO 0 /**/ /* HAS_STRTOUL: * This symbol, if defined, indicates that the strtoul routine is * available to provide conversion of strings to unsigned long. */ #define HAS_STRTOUL /**/ /* HAS_TIME: * This symbol, if defined, indicates that the time() routine exists. */ /* Time_t: * This symbol holds the type returned by time(). It can be long, * or time_t on BSD sites (in which case should be * included). */ #define HAS_TIME /**/ #define Time_t time_t /* Time type */ /* HAS_TIMES: * This symbol, if defined, indicates that the times() routine exists. * Note that this became obsolete on some systems (SUNOS), which now * use getrusage(). It may be necessary to include . */ #define HAS_TIMES /**/ /* HAS_TMPNAM_R: * This symbol, if defined, indicates that the tmpnam_r routine * is available to tmpnam re-entrantly. */ /* TMPNAM_R_PROTO: * This symbol encodes the prototype of tmpnam_r. * It is zero if d_tmpnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_tmpnam_r * is defined. */ /*#define HAS_TMPNAM_R / **/ #define TMPNAM_R_PROTO 0 /**/ /* HAS_TTYNAME_R: * This symbol, if defined, indicates that the ttyname_r routine * is available to ttyname re-entrantly. */ /* TTYNAME_R_PROTO: * This symbol encodes the prototype of ttyname_r. * It is zero if d_ttyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ttyname_r * is defined. */ /*#define HAS_TTYNAME_R / **/ #define TTYNAME_R_PROTO 0 /**/ /* HAS_UNION_SEMUN: * This symbol, if defined, indicates that the union semun is * defined by including . If not, the user code * probably needs to define it as: * union semun { * int val; * struct semid_ds *buf; * unsigned short *array; * } */ /* USE_SEMCTL_SEMUN: * This symbol, if defined, indicates that union semun is * used for semctl IPC_STAT. */ /* USE_SEMCTL_SEMID_DS: * This symbol, if defined, indicates that struct semid_ds * is * used for semctl IPC_STAT. */ #define HAS_UNION_SEMUN /**/ /*#define USE_SEMCTL_SEMUN / **/ /*#define USE_SEMCTL_SEMID_DS / **/ /* HAS_VFORK: * This symbol, if defined, indicates that vfork() exists. */ /*#define HAS_VFORK / **/ /* HAS_PSEUDOFORK: * This symbol, if defined, indicates that an emulation of the * fork routine is available. */ /*#define HAS_PSEUDOFORK / **/ /* Signal_t: * This symbol's value is either "void" or "int", corresponding to the * appropriate return type of a signal handler. Thus, you can declare * a signal handler using "Signal_t (*handler)()", and define the * handler using "Signal_t handler(sig)". */ #define Signal_t void /* Signal handler's return type */ /* HASVOLATILE: * This symbol, if defined, indicates that this C compiler knows about * the volatile declaration. */ #define HASVOLATILE /**/ #ifndef HASVOLATILE #define volatile #endif /* Fpos_t: * This symbol holds the type used to declare file positions in libc. * It can be fpos_t, long, uint, etc... It may be necessary to include * to get any typedef'ed information. */ #define Fpos_t fpos_t /* File position type */ /* Gid_t_f: * This symbol defines the format string used for printing a Gid_t. */ #define Gid_t_f "ld" /**/ /* Gid_t_sign: * This symbol holds the signedess of a Gid_t. * 1 for unsigned, -1 for signed. */ #define Gid_t_sign -1 /* GID sign */ /* Gid_t_size: * This symbol holds the size of a Gid_t in bytes. */ #define Gid_t_size 4 /* GID size */ /* Gid_t: * This symbol holds the return type of getgid() and the type of * argument to setrgid() and related functions. Typically, * it is the type of group ids in the kernel. It can be int, ushort, * gid_t, etc... It may be necessary to include to get * any typedef'ed information. */ #define Gid_t gid_t /* Type for getgid(), etc... */ /* I_DIRENT: * This symbol, if defined, indicates to the C program that it should * include . Using this symbol also triggers the definition * of the Direntry_t define which ends up being 'struct dirent' or * 'struct direct' depending on the availability of . */ /* DIRNAMLEN: * This symbol, if defined, indicates to the C program that the length * of directory entry names is provided by a d_namlen field. Otherwise * you need to do strlen() on the d_name field. */ /* Direntry_t: * This symbol is set to 'struct direct' or 'struct dirent' depending on * whether dirent is available or not. You should use this pseudo type to * portably declare your directory entries. */ #define I_DIRENT /**/ #define DIRNAMLEN /**/ #define Direntry_t struct direct /* I_GRP: * This symbol, if defined, indicates to the C program that it should * include . */ /* GRPASSWD: * This symbol, if defined, indicates to the C program that struct group * in contains gr_passwd. */ /*#define I_GRP / **/ /*#define GRPASSWD / **/ /* I_MACH_CTHREADS: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_MACH_CTHREADS / **/ /* I_NDBM: * This symbol, if defined, indicates that exists and should * be included. */ /* I_GDBMNDBM: * This symbol, if defined, indicates that exists and should * be included. This was the location of the ndbm.h compatibility file * in RedHat 7.1. */ /* I_GDBM_NDBM: * This symbol, if defined, indicates that exists and should * be included. This is the location of the ndbm.h compatibility file * in Debian 4.0. */ /* NDBM_H_USES_PROTOTYPES: * This symbol, if defined, indicates that uses real ANSI C * prototypes instead of K&R style function declarations without any * parameter information. While ANSI C prototypes are supported in C++, * K&R style function declarations will yield errors. */ /* GDBMNDBM_H_USES_PROTOTYPES: * This symbol, if defined, indicates that uses real ANSI C * prototypes instead of K&R style function declarations without any * parameter information. While ANSI C prototypes are supported in C++, * K&R style function declarations will yield errors. */ /* GDBM_NDBM_H_USES_PROTOTYPES: * This symbol, if defined, indicates that uses real ANSI C * prototypes instead of K&R style function declarations without any * parameter information. While ANSI C prototypes are supported in C++, * K&R style function declarations will yield errors. */ /*#define I_NDBM / **/ /*#define I_GDBMNDBM / **/ /*#define I_GDBM_NDBM / **/ /*#define NDBM_H_USES_PROTOTYPES / **/ /*#define GDBMNDBM_H_USES_PROTOTYPES / **/ /*#define GDBM_NDBM_H_USES_PROTOTYPES / **/ /* I_NETDB: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_NETDB / **/ /* I_NET_ERRNO: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_NET_ERRNO / **/ /* I_PTHREAD: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_PTHREAD / **/ /* I_PWD: * This symbol, if defined, indicates to the C program that it should * include . */ /* PWQUOTA: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_quota. */ /* PWAGE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_age. */ /* PWCHANGE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_change. */ /* PWCLASS: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_class. */ /* PWEXPIRE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_expire. */ /* PWCOMMENT: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_comment. */ /* PWGECOS: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_gecos. */ /* PWPASSWD: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_passwd. */ /*#define I_PWD / **/ /*#define PWQUOTA / **/ /*#define PWAGE / **/ /*#define PWCHANGE / **/ /*#define PWCLASS / **/ /*#define PWEXPIRE / **/ /*#define PWCOMMENT / **/ /*#define PWGECOS / **/ /*#define PWPASSWD / **/ /* I_SYS_ACCESS: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_ACCESS / **/ /* I_SYS_SECURITY: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_SECURITY / **/ /* I_SYSUIO: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSUIO / **/ /* I_STDARG: * This symbol, if defined, indicates that exists and should * be included. */ /* I_VARARGS: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_STDARG /**/ /*#define I_VARARGS / **/ /* PERL_INC_VERSION_LIST: * This variable specifies the list of subdirectories in over * which perl.c:incpush() and lib/lib.pm will automatically * search when adding directories to @INC, in a format suitable * for a C initialization string. See the inc_version_list entry * in Porting/Glossary for more details. */ /*#define PERL_INC_VERSION_LIST 0 / **/ /* INSTALL_USR_BIN_PERL: * This symbol, if defined, indicates that Perl is to be installed * also as /usr/bin/perl. */ /*#define INSTALL_USR_BIN_PERL / **/ /* Off_t: * This symbol holds the type used to declare offsets in the kernel. * It can be int, long, off_t, etc... It may be necessary to include * to get any typedef'ed information. */ /* LSEEKSIZE: * This symbol holds the number of bytes used by the Off_t. */ /* Off_t_size: * This symbol holds the number of bytes used by the Off_t. */ #ifdef _MSC_VER # define Off_t __int64 /* type */ #else # define Off_t long long /* type */ #endif #define LSEEKSIZE 8 /* size */ #define Off_t_size 8 /* size */ /* Free_t: * This variable contains the return type of free(). It is usually * void, but occasionally int. */ /* Malloc_t: * This symbol is the type of pointer returned by malloc and realloc. */ #define Malloc_t void * /**/ #define Free_t void /**/ /* PERL_MALLOC_WRAP: * This symbol, if defined, indicates that we'd like malloc wrap checks. */ #define PERL_MALLOC_WRAP /**/ /* MYMALLOC: * This symbol, if defined, indicates that we're using our own malloc. */ /*#define MYMALLOC / **/ /* Mode_t: * This symbol holds the type used to declare file modes * for systems calls. It is usually mode_t, but may be * int or unsigned short. It may be necessary to include * to get any typedef'ed information. */ #define Mode_t mode_t /* file mode parameter for system calls */ /* Netdb_host_t: * This symbol holds the type used for the 1st argument * to gethostbyaddr(). */ /* Netdb_hlen_t: * This symbol holds the type used for the 2nd argument * to gethostbyaddr(). */ /* Netdb_name_t: * This symbol holds the type used for the argument to * gethostbyname(). */ /* Netdb_net_t: * This symbol holds the type used for the 1st argument to * getnetbyaddr(). */ #define Netdb_host_t char * /**/ #define Netdb_hlen_t int /**/ #define Netdb_name_t char * /**/ #define Netdb_net_t long /**/ /* PERL_OTHERLIBDIRS: * This variable contains a colon-separated set of paths for the perl * binary to search for additional library files or modules. * These directories will be tacked to the end of @INC. * Perl will automatically search below each path for version- * and architecture-specific directories. See PERL_INC_VERSION_LIST * for more details. */ /*#define PERL_OTHERLIBDIRS "" / **/ /* Pid_t: * This symbol holds the type used to declare process ids in the kernel. * It can be int, uint, pid_t, etc... It may be necessary to include * to get any typedef'ed information. */ #define Pid_t int /* PID type */ /* PRIVLIB: * This symbol contains the name of the private library for this package. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. The program * should be prepared to do ~ expansion. */ /* PRIVLIB_EXP: * This symbol contains the ~name expanded version of PRIVLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ #define PRIVLIB "c:\\perl\\lib" /**/ #define PRIVLIB_EXP (win32_get_privlib(PERL_VERSION_STRING)) /**/ /* CAN_PROTOTYPE: * If defined, this macro indicates that the C compiler can handle * function prototypes. */ /* _: * This macro is used to declare function parameters for folks who want * to make declarations with prototypes using a different style than * the above macros. Use double parentheses. For example: * * int main _((int argc, char *argv[])); */ #define CAN_PROTOTYPE /**/ #ifdef CAN_PROTOTYPE #define _(args) args #else #define _(args) () #endif /* Select_fd_set_t: * This symbol holds the type used for the 2nd, 3rd, and 4th * arguments to select. Usually, this is 'fd_set *', if HAS_FD_SET * is defined, and 'int *' otherwise. This is only useful if you * have select(), of course. */ #define Select_fd_set_t Perl_fd_set * /**/ /* SH_PATH: * This symbol contains the full pathname to the shell used on this * on this system to execute Bourne shell scripts. Usually, this will be * /bin/sh, though it's possible that some systems will have /bin/ksh, * /bin/pdksh, /bin/ash, /bin/bash, or even something such as * D:/bin/sh.exe. */ #define SH_PATH "cmd /x /c" /**/ /* SIG_NAME: * This symbol contains a list of signal names in order of * signal number. This is intended * to be used as a static array initialization, like this: * char *sig_name[] = { SIG_NAME }; * The signals in the list are separated with commas, and each signal * is surrounded by double quotes. There is no leading SIG in the signal * name, i.e. SIGQUIT is known as "QUIT". * Gaps in the signal numbers (up to NSIG) are filled in with NUMnn, * etc., where nn is the actual signal number (e.g. NUM37). * The signal number for sig_name[i] is stored in sig_num[i]. * The last element is 0 to terminate the list with a NULL. This * corresponds to the 0 at the end of the sig_name_init list. * Note that this variable is initialized from the sig_name_init, * not from sig_name (which is unused). */ /* SIG_NUM: * This symbol contains a list of signal numbers, in the same order as the * SIG_NAME list. It is suitable for static array initialization, as in: * int sig_num[] = { SIG_NUM }; * The signals in the list are separated with commas, and the indices * within that list and the SIG_NAME list match, so it's easy to compute * the signal name from a number or vice versa at the price of a small * dynamic linear lookup. * Duplicates are allowed, but are moved to the end of the list. * The signal number corresponding to sig_name[i] is sig_number[i]. * if (i < NSIG) then sig_number[i] == i. * The last element is 0, corresponding to the 0 at the end of * the sig_name_init list. * Note that this variable is initialized from the sig_num_init, * not from sig_num (which is unused). */ /* SIG_SIZE: * This variable contains the number of elements of the SIG_NAME * and SIG_NUM arrays, excluding the final NULL entry. */ #define SIG_NAME "ZERO", "HUP", "INT", "QUIT", "ILL", "NUM05", "NUM06", "NUM07", "FPE", "KILL", "NUM10", "SEGV", "NUM12", "PIPE", "ALRM", "TERM", "NUM16", "NUM17", "NUM18", "NUM19", "CHLD", "BREAK", "ABRT", "STOP", "NUM24", "CONT", "CLD", 0 /**/ #define SIG_NUM 0, 1, 2, 21, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 20, 0 /**/ #define SIG_SIZE 27 /**/ /* SITEARCH: * This symbol contains the name of the private library for this package. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. The program * should be prepared to do ~ expansion. * The standard distribution will put nothing in this directory. * After perl has been installed, users may install their own local * architecture-dependent modules in this directory with * MakeMaker Makefile.PL * or equivalent. See INSTALL for details. */ /* SITEARCH_EXP: * This symbol contains the ~name expanded version of SITEARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ #define SITEARCH "c:\\perl\\site\\lib" /**/ /*#define SITEARCH_EXP "" / **/ /* SITELIB: * This symbol contains the name of the private library for this package. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. The program * should be prepared to do ~ expansion. * The standard distribution will put nothing in this directory. * After perl has been installed, users may install their own local * architecture-independent modules in this directory with * MakeMaker Makefile.PL * or equivalent. See INSTALL for details. */ /* SITELIB_EXP: * This symbol contains the ~name expanded version of SITELIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ /* SITELIB_STEM: * This define is SITELIB_EXP with any trailing version-specific component * removed. The elements in inc_version_list (inc_version_list.U) can * be tacked onto this variable to generate a list of directories to search. */ #define SITELIB "c:\\perl\\site\\lib" /**/ #define SITELIB_EXP (win32_get_sitelib(PERL_VERSION_STRING)) /**/ #define SITELIB_STEM "" /**/ /* Size_t_size: * This symbol holds the size of a Size_t in bytes. */ #define Size_t_size 8 /**/ /* Size_t: * This symbol holds the type used to declare length parameters * for string functions. It is usually size_t, but may be * unsigned long, int, etc. It may be necessary to include * to get any typedef'ed information. */ #define Size_t size_t /* length paramater for string functions */ /* Sock_size_t: * This symbol holds the type used for the size argument of * various socket calls (just the base type, not the pointer-to). */ #define Sock_size_t int /**/ /* STDCHAR: * This symbol is defined to be the type of char used in stdio.h. * It has the values "unsigned char" or "char". */ #define STDCHAR char /**/ /* Uid_t_f: * This symbol defines the format string used for printing a Uid_t. */ #define Uid_t_f "ld" /**/ /* Uid_t_sign: * This symbol holds the signedess of a Uid_t. * 1 for unsigned, -1 for signed. */ #define Uid_t_sign -1 /* UID sign */ /* Uid_t_size: * This symbol holds the size of a Uid_t in bytes. */ #define Uid_t_size 4 /* UID size */ /* Uid_t: * This symbol holds the type used to declare user ids in the kernel. * It can be int, ushort, uid_t, etc... It may be necessary to include * to get any typedef'ed information. */ #define Uid_t uid_t /* UID type */ /* USE_ITHREADS: * This symbol, if defined, indicates that Perl should be built to * use the interpreter-based threading implementation. */ /* USE_5005THREADS: * This symbol, if defined, indicates that Perl should be built to * use the 5.005-based threading implementation. * Only valid up to 5.8.x. */ /* OLD_PTHREADS_API: * This symbol, if defined, indicates that Perl should * be built to use the old draft POSIX threads API. */ /* USE_REENTRANT_API: * This symbol, if defined, indicates that Perl should * try to use the various _r versions of library functions. * This is extremely experimental. */ /*#define USE_5005THREADS / **/ /*#define USE_ITHREADS / **/ #if defined(USE_5005THREADS) && !defined(USE_ITHREADS) #define USE_THREADS /* until src is revised*/ #endif /*#define OLD_PTHREADS_API / **/ /*#define USE_REENTRANT_API / **/ /* PERL_VENDORARCH: * If defined, this symbol contains the name of a private library. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. * It may have a ~ on the front. * The standard distribution will put nothing in this directory. * Vendors who distribute perl may wish to place their own * architecture-dependent modules and extensions in this directory with * MakeMaker Makefile.PL INSTALLDIRS=vendor * or equivalent. See INSTALL for details. */ /* PERL_VENDORARCH_EXP: * This symbol contains the ~name expanded version of PERL_VENDORARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ /*#define PERL_VENDORARCH "" / **/ /*#define PERL_VENDORARCH_EXP "" / **/ /* PERL_VENDORLIB_EXP: * This symbol contains the ~name expanded version of VENDORLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ /* PERL_VENDORLIB_STEM: * This define is PERL_VENDORLIB_EXP with any trailing version-specific component * removed. The elements in inc_version_list (inc_version_list.U) can * be tacked onto this variable to generate a list of directories to search. */ /*#define PERL_VENDORLIB_EXP "" / **/ /*#define PERL_VENDORLIB_STEM "" / **/ /* VOIDFLAGS: * This symbol indicates how much support of the void type is given by this * compiler. What various bits mean: * * 1 = supports declaration of void * 2 = supports arrays of pointers to functions returning void * 4 = supports comparisons between pointers to void functions and * addresses of void functions * 8 = suports declaration of generic void pointers * * The package designer should define VOIDUSED to indicate the requirements * of the package. This can be done either by #defining VOIDUSED before * including config.h, or by defining defvoidused in Myinit.U. If the * latter approach is taken, only those flags will be tested. If the * level of void support necessary is not present, defines void to int. */ #ifndef VOIDUSED #define VOIDUSED 15 #endif #define VOIDFLAGS 15 #if (VOIDFLAGS & VOIDUSED) != VOIDUSED #define void int /* is void to be avoided? */ #define M_VOID /* Xenix strikes again */ #endif /* USE_CROSS_COMPILE: * This symbol, if defined, indicates that Perl is being cross-compiled. */ /* PERL_TARGETARCH: * This symbol, if defined, indicates the target architecture * Perl has been cross-compiled to. Undefined if not a cross-compile. */ #ifndef USE_CROSS_COMPILE /*#define USE_CROSS_COMPILE / **/ #define PERL_TARGETARCH "" /**/ #endif /* MEM_ALIGNBYTES: * This symbol contains the number of bytes required to align a * double, or a long double when applicable. Usual values are 2, * 4 and 8. The default is eight, for safety. */ #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH) # define MEM_ALIGNBYTES 8 #else #define MEM_ALIGNBYTES 8 #endif /* BYTEORDER: * This symbol holds the hexadecimal constant defined in byteorder, * in a UV, i.e. 0x1234 or 0x4321 or 0x12345678, etc... * If the compiler supports cross-compiling or multiple-architecture * binaries (eg. on NeXT systems), use compiler-defined macros to * determine the byte order. * On NeXT 3.2 (and greater), you can build "Fat" Multiple Architecture * Binaries (MAB) on either big endian or little endian machines. * The endian-ness is available at compile-time. This only matters * for perl, where the config.h can be generated and installed on * one system, and used by a different architecture to build an * extension. Older versions of NeXT that might not have * defined either *_ENDIAN__ were all on Motorola 680x0 series, * so the default case (for NeXT) is big endian to catch them. * This might matter for NeXT 3.0. */ #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH) # ifdef __LITTLE_ENDIAN__ # if LONGSIZE == 4 # define BYTEORDER 0x1234 # else # if LONGSIZE == 8 # define BYTEORDER 0x12345678 # endif # endif # else # ifdef __BIG_ENDIAN__ # if LONGSIZE == 4 # define BYTEORDER 0x4321 # else # if LONGSIZE == 8 # define BYTEORDER 0x87654321 # endif # endif # endif # endif # if !defined(BYTEORDER) && (defined(NeXT) || defined(__NeXT__)) # define BYTEORDER 0x4321 # endif #else #define BYTEORDER 0x1234 /* large digits for MSB */ #endif /* NeXT */ /* CHARBITS: * This symbol contains the size of a char, so that the C preprocessor * can make decisions based on it. */ #define CHARBITS 8 /**/ /* CASTI32: * This symbol is defined if the C compiler can cast negative * or large floating point numbers to 32-bit ints. */ #ifndef _MSC_VER # define CASTI32 /**/ #endif /* CASTNEGFLOAT: * This symbol is defined if the C compiler can cast negative * numbers to unsigned longs, ints and shorts. */ /* CASTFLAGS: * This symbol contains flags that say what difficulties the compiler * has casting odd floating values to unsigned long: * 0 = ok * 1 = couldn't cast < 0 * 2 = couldn't cast >= 0x80000000 * 4 = couldn't cast in argument expression list */ #define CASTNEGFLOAT /**/ #define CASTFLAGS 0 /**/ /* VOID_CLOSEDIR: * This symbol, if defined, indicates that the closedir() routine * does not return a value. */ /*#define VOID_CLOSEDIR / **/ /* HAS_FD_SET: * This symbol, when defined, indicates presence of the fd_set typedef * in */ #define HAS_FD_SET /**/ /* Gconvert: * This preprocessor macro is defined to convert a floating point * number to a string without a trailing decimal point. This * emulates the behavior of sprintf("%g"), but is sometimes much more * efficient. If gconvert() is not available, but gcvt() drops the * trailing decimal point, then gcvt() is used. If all else fails, * a macro using sprintf("%g") is used. Arguments for the Gconvert * macro are: value, number of digits, whether trailing zeros should * be retained, and the output buffer. * The usual values are: * d_Gconvert='gconvert((x),(n),(t),(b))' * d_Gconvert='gcvt((x),(n),(b))' * d_Gconvert='sprintf((b),"%.*g",(n),(x))' * The last two assume trailing zeros should not be kept. */ #define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(x)) /* HAS_GETPAGESIZE: * This symbol, if defined, indicates that the getpagesize system call * is available to get system page size, which is the granularity of * many memory management calls. */ /*#define HAS_GETPAGESIZE / **/ /* HAS_GNULIBC: * This symbol, if defined, indicates to the C program that * the GNU C library is being used. A better check is to use * the __GLIBC__ and __GLIBC_MINOR__ symbols supplied with glibc. */ /*#define HAS_GNULIBC / **/ #if defined(HAS_GNULIBC) && !defined(_GNU_SOURCE) # define _GNU_SOURCE #endif /* HAS_ISASCII: * This manifest constant lets the C program know that isascii * is available. */ #define HAS_ISASCII /**/ /* HAS_LCHOWN: * This symbol, if defined, indicates that the lchown routine is * available to operate on a symbolic link (instead of following the * link). */ /*#define HAS_LCHOWN / **/ /* HAS_OPEN3: * This manifest constant lets the C program know that the three * argument form of open(2) is available. */ /*#define HAS_OPEN3 / **/ /* HAS_SAFE_BCOPY: * This symbol, if defined, indicates that the bcopy routine is available * to copy potentially overlapping memory blocks. Normally, you should * probably use memmove() or memcpy(). If neither is defined, roll your * own version. */ /*#define HAS_SAFE_BCOPY / **/ /* HAS_SAFE_MEMCPY: * This symbol, if defined, indicates that the memcpy routine is available * to copy potentially overlapping memory blocks. If you need to * copy overlapping memory blocks, you should check HAS_MEMMOVE and * use memmove() instead, if available. */ /*#define HAS_SAFE_MEMCPY / **/ /* HAS_SANE_MEMCMP: * This symbol, if defined, indicates that the memcmp routine is available * and can be used to compare relative magnitudes of chars with their high * bits set. If it is not defined, roll your own version. */ #define HAS_SANE_MEMCMP /**/ /* HAS_SIGACTION: * This symbol, if defined, indicates that Vr4's sigaction() routine * is available. */ /*#define HAS_SIGACTION / **/ /* HAS_SIGSETJMP: * This variable indicates to the C program that the sigsetjmp() * routine is available to save the calling process's registers * and stack environment for later use by siglongjmp(), and * to optionally save the process's signal mask. See * Sigjmp_buf, Sigsetjmp, and Siglongjmp. */ /* Sigjmp_buf: * This is the buffer type to be used with Sigsetjmp and Siglongjmp. */ /* Sigsetjmp: * This macro is used in the same way as sigsetjmp(), but will invoke * traditional setjmp() if sigsetjmp isn't available. * See HAS_SIGSETJMP. */ /* Siglongjmp: * This macro is used in the same way as siglongjmp(), but will invoke * traditional longjmp() if siglongjmp isn't available. * See HAS_SIGSETJMP. */ /*#define HAS_SIGSETJMP / **/ #ifdef HAS_SIGSETJMP #define Sigjmp_buf sigjmp_buf #define Sigsetjmp(buf,save_mask) sigsetjmp((buf),(save_mask)) #define Siglongjmp(buf,retval) siglongjmp((buf),(retval)) #else #define Sigjmp_buf jmp_buf #define Sigsetjmp(buf,save_mask) setjmp((buf)) #define Siglongjmp(buf,retval) longjmp((buf),(retval)) #endif /* USE_STDIO_PTR: * This symbol is defined if the _ptr and _cnt fields (or similar) * of the stdio FILE structure can be used to access the stdio buffer * for a file handle. If this is defined, then the FILE_ptr(fp) * and FILE_cnt(fp) macros will also be defined and should be used * to access these fields. */ /* FILE_ptr: * This macro is used to access the _ptr field (or equivalent) of the * FILE structure pointed to by its argument. This macro will always be * defined if USE_STDIO_PTR is defined. */ /* STDIO_PTR_LVALUE: * This symbol is defined if the FILE_ptr macro can be used as an * lvalue. */ /* FILE_cnt: * This macro is used to access the _cnt field (or equivalent) of the * FILE structure pointed to by its argument. This macro will always be * defined if USE_STDIO_PTR is defined. */ /* STDIO_CNT_LVALUE: * This symbol is defined if the FILE_cnt macro can be used as an * lvalue. */ /* STDIO_PTR_LVAL_SETS_CNT: * This symbol is defined if using the FILE_ptr macro as an lvalue * to increase the pointer by n has the side effect of decreasing the * value of File_cnt(fp) by n. */ /* STDIO_PTR_LVAL_NOCHANGE_CNT: * This symbol is defined if using the FILE_ptr macro as an lvalue * to increase the pointer by n leaves File_cnt(fp) unchanged. */ #define USE_STDIO_PTR /**/ #ifdef USE_STDIO_PTR #define FILE_ptr(fp) ((fp)->_ptr) #define STDIO_PTR_LVALUE /**/ #define FILE_cnt(fp) ((fp)->_cnt) #define STDIO_CNT_LVALUE /**/ /*#define STDIO_PTR_LVAL_SETS_CNT / **/ #define STDIO_PTR_LVAL_NOCHANGE_CNT /**/ #endif /* USE_STDIO_BASE: * This symbol is defined if the _base field (or similar) of the * stdio FILE structure can be used to access the stdio buffer for * a file handle. If this is defined, then the FILE_base(fp) macro * will also be defined and should be used to access this field. * Also, the FILE_bufsiz(fp) macro will be defined and should be used * to determine the number of bytes in the buffer. USE_STDIO_BASE * will never be defined unless USE_STDIO_PTR is. */ /* FILE_base: * This macro is used to access the _base field (or equivalent) of the * FILE structure pointed to by its argument. This macro will always be * defined if USE_STDIO_BASE is defined. */ /* FILE_bufsiz: * This macro is used to determine the number of bytes in the I/O * buffer pointed to by _base field (or equivalent) of the FILE * structure pointed to its argument. This macro will always be defined * if USE_STDIO_BASE is defined. */ #define USE_STDIO_BASE /**/ #ifdef USE_STDIO_BASE #define FILE_base(fp) ((fp)->_base) #define FILE_bufsiz(fp) ((fp)->_cnt + (fp)->_ptr - (fp)->_base) #endif /* HAS_VPRINTF: * This symbol, if defined, indicates that the vprintf routine is available * to printf with a pointer to an argument list. If unavailable, you * may need to write your own, probably in terms of _doprnt(). */ /* USE_CHAR_VSPRINTF: * This symbol is defined if this system has vsprintf() returning type * (char*). The trend seems to be to declare it as "int vsprintf()". It * is up to the package author to declare vsprintf correctly based on the * symbol. */ #define HAS_VPRINTF /**/ /*#define USE_CHAR_VSPRINTF / **/ /* DOUBLESIZE: * This symbol contains the size of a double, so that the C preprocessor * can make decisions based on it. */ #define DOUBLESIZE 8 /**/ /* I_TIME: * This symbol, if defined, indicates to the C program that it should * include . */ /* I_SYS_TIME: * This symbol, if defined, indicates to the C program that it should * include . */ /* I_SYS_TIME_KERNEL: * This symbol, if defined, indicates to the C program that it should * include with KERNEL defined. */ /* HAS_TM_TM_ZONE: * This symbol, if defined, indicates to the C program that * the struct tm has a tm_zone field. */ /* HAS_TM_TM_GMTOFF: * This symbol, if defined, indicates to the C program that * the struct tm has a tm_gmtoff field. */ #define I_TIME /**/ /*#define I_SYS_TIME / **/ /*#define I_SYS_TIME_KERNEL / **/ /*#define HAS_TM_TM_ZONE / **/ /*#define HAS_TM_TM_GMTOFF / **/ /* VAL_O_NONBLOCK: * This symbol is to be used during open() or fcntl(F_SETFL) to turn on * non-blocking I/O for the file descriptor. Note that there is no way * back, i.e. you cannot turn it blocking again this way. If you wish to * alternatively switch between blocking and non-blocking, use the * ioctl(FIOSNBIO) call instead, but that is not supported by all devices. */ /* VAL_EAGAIN: * This symbol holds the errno error code set by read() when no data was * present on the non-blocking file descriptor. */ /* RD_NODATA: * This symbol holds the return code from read() when no data is present * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is * not defined, then you can't distinguish between no data and EOF by * issuing a read(). You'll have to find another way to tell for sure! */ /* EOF_NONBLOCK: * This symbol, if defined, indicates to the C program that a read() on * a non-blocking file descriptor will return 0 on EOF, and not the value * held in RD_NODATA (-1 usually, in that case!). */ #define VAL_O_NONBLOCK O_NONBLOCK #define VAL_EAGAIN EAGAIN #define RD_NODATA -1 #define EOF_NONBLOCK /* PTRSIZE: * This symbol contains the size of a pointer, so that the C preprocessor * can make decisions based on it. It will be sizeof(void *) if * the compiler supports (void *); otherwise it will be * sizeof(char *). */ #define PTRSIZE 8 /**/ /* Drand01: * This macro is to be used to generate uniformly distributed * random numbers over the range [0., 1.[. You may have to supply * an 'extern double drand48();' in your program since SunOS 4.1.3 * doesn't provide you with anything relevant in its headers. * See HAS_DRAND48_PROTO. */ /* Rand_seed_t: * This symbol defines the type of the argument of the * random seed function. */ /* seedDrand01: * This symbol defines the macro to be used in seeding the * random number generator (see Drand01). */ /* RANDBITS: * This symbol indicates how many bits are produced by the * function used to generate normalized random numbers. * Values include 15, 16, 31, and 48. */ #define Drand01() (rand()/(double)((unsigned)1< or * to get any typedef'ed information. * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t). */ #ifdef _MSC_VER # define SSize_t __int64 /* signed count of bytes */ #else # define SSize_t long long /* signed count of bytes */ #endif /* EBCDIC: * This symbol, if defined, indicates that this system uses * EBCDIC encoding. */ /*#define EBCDIC / **/ /* SETUID_SCRIPTS_ARE_SECURE_NOW: * This symbol, if defined, indicates that the bug that prevents * setuid scripts from being secure is not present in this kernel. */ /* DOSUID: * This symbol, if defined, indicates that the C program should * check the script that it is executing for setuid/setgid bits, and * attempt to emulate setuid/setgid on systems that have disabled * setuid #! scripts because the kernel can't do it securely. * It is up to the package designer to make sure that this emulation * is done securely. Among other things, it should do an fstat on * the script it just opened to make sure it really is a setuid/setgid * script, it should make sure the arguments passed correspond exactly * to the argument on the #! line, and it should not trust any * subprocesses to which it must pass the filename rather than the * file descriptor of the script to be executed. */ /*#define SETUID_SCRIPTS_ARE_SECURE_NOW / **/ /*#define DOSUID / **/ /* PERL_USE_DEVEL: * This symbol, if defined, indicates that Perl was configured with * -Dusedevel, to enable development features. This should not be * done for production builds. */ /*#define PERL_USE_DEVEL / **/ /* HAS_ATOLF: * This symbol, if defined, indicates that the atolf routine is * available to convert strings into long doubles. */ /*#define HAS_ATOLF / **/ /* HAS_ATOLL: * This symbol, if defined, indicates that the atoll routine is * available to convert strings into long longs. */ #define HAS_ATOLL /**/ /* HAS__FWALK: * This symbol, if defined, indicates that the _fwalk system call is * available to apply a function to all the file handles. */ /*#define HAS__FWALK / **/ /* HAS_AINTL: * This symbol, if defined, indicates that the aintl routine is * available. If copysignl is also present we can emulate modfl. */ /*#define HAS_AINTL / **/ /* HAS_BUILTIN_CHOOSE_EXPR: * Can we handle GCC builtin for compile-time ternary-like expressions */ /* HAS_BUILTIN_EXPECT: * Can we handle GCC builtin for telling that certain values are more * likely */ /*#define HAS_BUILTIN_EXPECT / **/ /*#define HAS_BUILTIN_CHOOSE_EXPR / **/ /* HAS_C99_VARIADIC_MACROS: * If defined, the compiler supports C99 variadic macros. */ /*#define HAS_C99_VARIADIC_MACROS / **/ /* HAS_CLASS: * This symbol, if defined, indicates that the class routine is * available to classify doubles. Available for example in AIX. * The returned values are defined in and are: * * FP_PLUS_NORM Positive normalized, nonzero * FP_MINUS_NORM Negative normalized, nonzero * FP_PLUS_DENORM Positive denormalized, nonzero * FP_MINUS_DENORM Negative denormalized, nonzero * FP_PLUS_ZERO +0.0 * FP_MINUS_ZERO -0.0 * FP_PLUS_INF +INF * FP_MINUS_INF -INF * FP_NANS Signaling Not a Number (NaNS) * FP_NANQ Quiet Not a Number (NaNQ) */ /*#define HAS_CLASS / **/ /* HAS_CLEARENV: * This symbol, if defined, indicates that the clearenv () routine is * available for use. */ /*#define HAS_CLEARENV / **/ /* HAS_STRUCT_CMSGHDR: * This symbol, if defined, indicates that the struct cmsghdr * is supported. */ /*#define HAS_STRUCT_CMSGHDR / **/ /* HAS_COPYSIGNL: * This symbol, if defined, indicates that the copysignl routine is * available. If aintl is also present we can emulate modfl. */ /*#define HAS_COPYSIGNL / **/ /* USE_CPLUSPLUS: * This symbol, if defined, indicates that a C++ compiler was * used to compiled Perl and will be used to compile extensions. */ /*#define USE_CPLUSPLUS / **/ /* HAS_DBMINIT_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the dbminit() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int dbminit(char *); */ /*#define HAS_DBMINIT_PROTO / **/ /* HAS_DIR_DD_FD: * This symbol, if defined, indicates that the the DIR* dirstream * structure contains a member variable named dd_fd. */ /*#define HAS_DIR_DD_FD / **/ /* HAS_DIRFD: * This manifest constant lets the C program know that dirfd * is available. */ /*#define HAS_DIRFD / **/ /* DLSYM_NEEDS_UNDERSCORE: * This symbol, if defined, indicates that we need to prepend an * underscore to the symbol name before calling dlsym(). This only * makes sense if you *have* dlsym, which we will presume is the * case if you're using dl_dlopen.xs. */ /*#define DLSYM_NEEDS_UNDERSCORE / **/ /* HAS_FAST_STDIO: * This symbol, if defined, indicates that the "fast stdio" * is available to manipulate the stdio buffers directly. */ #define HAS_FAST_STDIO /**/ /* HAS_FCHDIR: * This symbol, if defined, indicates that the fchdir routine is * available to change directory using a file descriptor. */ /*#define HAS_FCHDIR / **/ /* FCNTL_CAN_LOCK: * This symbol, if defined, indicates that fcntl() can be used * for file locking. Normally on Unix systems this is defined. * It may be undefined on VMS. */ /*#define FCNTL_CAN_LOCK / **/ /* HAS_FINITE: * This symbol, if defined, indicates that the finite routine is * available to check whether a double is finite (non-infinity non-NaN). */ /*#define HAS_FINITE / **/ /* HAS_FINITEL: * This symbol, if defined, indicates that the finitel routine is * available to check whether a long double is finite * (non-infinity non-NaN). */ /*#define HAS_FINITEL / **/ /* HAS_FLOCK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the flock() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int flock(int, int); */ #define HAS_FLOCK_PROTO /**/ /* HAS_FP_CLASS: * This symbol, if defined, indicates that the fp_class routine is * available to classify doubles. Available for example in Digital UNIX. * The returned values are defined in and are: * * FP_SNAN Signaling NaN (Not-a-Number) * FP_QNAN Quiet NaN (Not-a-Number) * FP_POS_INF +infinity * FP_NEG_INF -infinity * FP_POS_NORM Positive normalized * FP_NEG_NORM Negative normalized * FP_POS_DENORM Positive denormalized * FP_NEG_DENORM Negative denormalized * FP_POS_ZERO +0.0 (positive zero) * FP_NEG_ZERO -0.0 (negative zero) */ /*#define HAS_FP_CLASS / **/ /* HAS_FPCLASS: * This symbol, if defined, indicates that the fpclass routine is * available to classify doubles. Available for example in Solaris/SVR4. * The returned values are defined in and are: * * FP_SNAN signaling NaN * FP_QNAN quiet NaN * FP_NINF negative infinity * FP_PINF positive infinity * FP_NDENORM negative denormalized non-zero * FP_PDENORM positive denormalized non-zero * FP_NZERO negative zero * FP_PZERO positive zero * FP_NNORM negative normalized non-zero * FP_PNORM positive normalized non-zero */ /*#define HAS_FPCLASS / **/ /* HAS_FPCLASSIFY: * This symbol, if defined, indicates that the fpclassify routine is * available to classify doubles. Available for example in HP-UX. * The returned values are defined in and are * * FP_NORMAL Normalized * FP_ZERO Zero * FP_INFINITE Infinity * FP_SUBNORMAL Denormalized * FP_NAN NaN * */ /*#define HAS_FPCLASSIFY / **/ /* HAS_FPCLASSL: * This symbol, if defined, indicates that the fpclassl routine is * available to classify long doubles. Available for example in IRIX. * The returned values are defined in and are: * * FP_SNAN signaling NaN * FP_QNAN quiet NaN * FP_NINF negative infinity * FP_PINF positive infinity * FP_NDENORM negative denormalized non-zero * FP_PDENORM positive denormalized non-zero * FP_NZERO negative zero * FP_PZERO positive zero * FP_NNORM negative normalized non-zero * FP_PNORM positive normalized non-zero */ /*#define HAS_FPCLASSL / **/ /* HAS_FPOS64_T: * This symbol will be defined if the C compiler supports fpos64_t. */ /*#define HAS_FPOS64_T / **/ /* HAS_FREXPL: * This symbol, if defined, indicates that the frexpl routine is * available to break a long double floating-point number into * a normalized fraction and an integral power of 2. */ /*#define HAS_FREXPL / **/ /* HAS_STRUCT_FS_DATA: * This symbol, if defined, indicates that the struct fs_data * to do statfs() is supported. */ /*#define HAS_STRUCT_FS_DATA / **/ /* HAS_FSEEKO: * This symbol, if defined, indicates that the fseeko routine is * available to fseek beyond 32 bits (useful for ILP32 hosts). */ /*#define HAS_FSEEKO / **/ /* HAS_FSTATFS: * This symbol, if defined, indicates that the fstatfs routine is * available to stat filesystems by file descriptors. */ /*#define HAS_FSTATFS / **/ /* HAS_FSYNC: * This symbol, if defined, indicates that the fsync routine is * available to write a file's modified data and attributes to * permanent storage. */ /*#define HAS_FSYNC / **/ /* HAS_FTELLO: * This symbol, if defined, indicates that the ftello routine is * available to ftell beyond 32 bits (useful for ILP32 hosts). */ /*#define HAS_FTELLO / **/ /* HAS_FUTIMES: * This symbol, if defined, indicates that the futimes routine is * available to change file descriptor time stamps with struct timevals. */ /*#define HAS_FUTIMES / **/ /* HAS_GETADDRINFO: * This symbol, if defined, indicates that the getaddrinfo() function * is available for use. */ /*#define HAS_GETADDRINFO / **/ /* HAS_GETCWD: * This symbol, if defined, indicates that the getcwd routine is * available to get the current working directory. */ #define HAS_GETCWD /**/ /* HAS_GETESPWNAM: * This symbol, if defined, indicates that the getespwnam system call is * available to retrieve enchanced (shadow) password entries by name. */ /*#define HAS_GETESPWNAM / **/ /* HAS_GETFSSTAT: * This symbol, if defined, indicates that the getfsstat routine is * available to stat filesystems in bulk. */ /*#define HAS_GETFSSTAT / **/ /* HAS_GETITIMER: * This symbol, if defined, indicates that the getitimer routine is * available to return interval timers. */ /*#define HAS_GETITIMER / **/ /* HAS_GETMNT: * This symbol, if defined, indicates that the getmnt routine is * available to get filesystem mount info by filename. */ /*#define HAS_GETMNT / **/ /* HAS_GETMNTENT: * This symbol, if defined, indicates that the getmntent routine is * available to iterate through mounted file systems to get their info. */ /*#define HAS_GETMNTENT / **/ /* HAS_GETNAMEINFO: * This symbol, if defined, indicates that the getnameinfo() function * is available for use. */ /*#define HAS_GETNAMEINFO / **/ /* HAS_GETPRPWNAM: * This symbol, if defined, indicates that the getprpwnam system call is * available to retrieve protected (shadow) password entries by name. */ /*#define HAS_GETPRPWNAM / **/ /* HAS_GETSPNAM: * This symbol, if defined, indicates that the getspnam system call is * available to retrieve SysV shadow password entries by name. */ /*#define HAS_GETSPNAM / **/ /* HAS_HASMNTOPT: * This symbol, if defined, indicates that the hasmntopt routine is * available to query the mount options of file systems. */ /*#define HAS_HASMNTOPT / **/ /* HAS_ILOGBL: * This symbol, if defined, indicates that the ilogbl routine is * available. If scalbnl is also present we can emulate frexpl. */ /*#define HAS_ILOGBL / **/ /* HAS_INETNTOP: * This symbol, if defined, indicates that the inet_ntop() function * is available to parse IPv4 and IPv6 strings. */ /*#define HAS_INETNTOP / **/ /* HAS_INETPTON: * This symbol, if defined, indicates that the inet_pton() function * is available to parse IPv4 and IPv6 strings. */ /*#define HAS_INETPTON / **/ /* HAS_INT64_T: * This symbol will defined if the C compiler supports int64_t. * Usually the needs to be included, but sometimes * is enough. */ /*#define HAS_INT64_T / **/ /* HAS_ISFINITE: * This symbol, if defined, indicates that the isfinite routine is * available to check whether a double is finite (non-infinity non-NaN). */ /*#define HAS_ISFINITE / **/ /* HAS_ISINF: * This symbol, if defined, indicates that the isinf routine is * available to check whether a double is an infinity. */ /*#define HAS_ISINF / **/ /* HAS_ISNAN: * This symbol, if defined, indicates that the isnan routine is * available to check whether a double is a NaN. */ #define HAS_ISNAN /**/ /* HAS_ISNANL: * This symbol, if defined, indicates that the isnanl routine is * available to check whether a long double is a NaN. */ /*#define HAS_ISNANL / **/ /* HAS_LDBL_DIG: * This symbol, if defined, indicates that this system's * or defines the symbol LDBL_DIG, which is the number * of significant digits in a long double precision number. Unlike * for DBL_DIG, there's no good guess for LDBL_DIG if it is undefined. */ #define HAS_LDBL_DIG /**/ /* LIBM_LIB_VERSION: * This symbol, if defined, indicates that libm exports _LIB_VERSION * and that math.h defines the enum to manipulate it. */ /*#define LIBM_LIB_VERSION / **/ /* HAS_MADVISE: * This symbol, if defined, indicates that the madvise system call is * available to map a file into memory. */ /*#define HAS_MADVISE / **/ /* HAS_MALLOC_SIZE: * This symbol, if defined, indicates that the malloc_size * routine is available for use. */ /*#define HAS_MALLOC_SIZE / **/ /* HAS_MALLOC_GOOD_SIZE: * This symbol, if defined, indicates that the malloc_good_size * routine is available for use. */ /*#define HAS_MALLOC_GOOD_SIZE / **/ /* HAS_MKDTEMP: * This symbol, if defined, indicates that the mkdtemp routine is * available to exclusively create a uniquely named temporary directory. */ /*#define HAS_MKDTEMP / **/ /* HAS_MKSTEMPS: * This symbol, if defined, indicates that the mkstemps routine is * available to excluslvely create and open a uniquely named * (with a suffix) temporary file. */ /*#define HAS_MKSTEMPS / **/ /* HAS_MODFL: * This symbol, if defined, indicates that the modfl routine is * available to split a long double x into a fractional part f and * an integer part i such that |f| < 1.0 and (f + i) = x. */ /* HAS_MODFL_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the modfl() function. Otherwise, it is up * to the program to supply one. */ /* HAS_MODFL_POW32_BUG: * This symbol, if defined, indicates that the modfl routine is * broken for long doubles >= pow(2, 32). * For example from 4294967303.150000 one would get 4294967302.000000 * and 1.150000. The bug has been seen in certain versions of glibc, * release 2.2.2 is known to be okay. */ /*#define HAS_MODFL / **/ /*#define HAS_MODFL_PROTO / **/ /*#define HAS_MODFL_POW32_BUG / **/ /* HAS_MPROTECT: * This symbol, if defined, indicates that the mprotect system call is * available to modify the access protection of a memory mapped file. */ /*#define HAS_MPROTECT / **/ /* HAS_STRUCT_MSGHDR: * This symbol, if defined, indicates that the struct msghdr * is supported. */ /*#define HAS_STRUCT_MSGHDR / **/ /* HAS_NL_LANGINFO: * This symbol, if defined, indicates that the nl_langinfo routine is * available to return local data. You will also need * and therefore I_LANGINFO. */ /*#define HAS_NL_LANGINFO / **/ /* HAS_OFF64_T: * This symbol will be defined if the C compiler supports off64_t. */ /*#define HAS_OFF64_T / **/ /* HAS_PROCSELFEXE: * This symbol is defined if PROCSELFEXE_PATH is a symlink * to the absolute pathname of the executing program. */ /* PROCSELFEXE_PATH: * If HAS_PROCSELFEXE is defined this symbol is the filename * of the symbolic link pointing to the absolute pathname of * the executing program. */ /*#define HAS_PROCSELFEXE / **/ #if defined(HAS_PROCSELFEXE) && !defined(PROCSELFEXE_PATH) #define PROCSELFEXE_PATH /**/ #endif /* HAS_PTHREAD_ATTR_SETSCOPE: * This symbol, if defined, indicates that the pthread_attr_setscope * system call is available to set the contention scope attribute of * a thread attribute object. */ /*#define HAS_PTHREAD_ATTR_SETSCOPE / **/ /* HAS_READV: * This symbol, if defined, indicates that the readv routine is * available to do gather reads. You will also need * and there I_SYSUIO. */ /*#define HAS_READV / **/ /* HAS_RECVMSG: * This symbol, if defined, indicates that the recvmsg routine is * available to send structured socket messages. */ /*#define HAS_RECVMSG / **/ /* HAS_SBRK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the sbrk() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern void* sbrk(int); * extern void* sbrk(size_t); */ /*#define HAS_SBRK_PROTO / **/ /* HAS_SCALBNL: * This symbol, if defined, indicates that the scalbnl routine is * available. If ilogbl is also present we can emulate frexpl. */ /*#define HAS_SCALBNL / **/ /* HAS_SENDMSG: * This symbol, if defined, indicates that the sendmsg routine is * available to send structured socket messages. */ /*#define HAS_SENDMSG / **/ /* HAS_SETITIMER: * This symbol, if defined, indicates that the setitimer routine is * available to set interval timers. */ /*#define HAS_SETITIMER / **/ /* HAS_SETPROCTITLE: * This symbol, if defined, indicates that the setproctitle routine is * available to set process title. */ /*#define HAS_SETPROCTITLE / **/ /* USE_SFIO: * This symbol, if defined, indicates that sfio should * be used. */ /*#define USE_SFIO / **/ /* HAS_SIGNBIT: * This symbol, if defined, indicates that the signbit routine is * available to check if the given number has the sign bit set. * This should include correct testing of -0.0. This will only be set * if the signbit() routine is safe to use with the NV type used internally * in perl. Users should call Perl_signbit(), which will be #defined to * the system's signbit() function or macro if this symbol is defined. */ /*#define HAS_SIGNBIT / **/ /* HAS_SIGPROCMASK: * This symbol, if defined, indicates that the sigprocmask * system call is available to examine or change the signal mask * of the calling process. */ /*#define HAS_SIGPROCMASK / **/ /* USE_SITECUSTOMIZE: * This symbol, if defined, indicates that sitecustomize should * be used. */ #ifndef USE_SITECUSTOMIZE /*#define USE_SITECUSTOMIZE / **/ #endif /* HAS_SNPRINTF: * This symbol, if defined, indicates that the snprintf () library * function is available for use. */ /* HAS_VSNPRINTF: * This symbol, if defined, indicates that the vsnprintf () library * function is available for use. */ #define HAS_SNPRINTF /**/ #define HAS_VSNPRINTF /**/ /* HAS_SOCKATMARK: * This symbol, if defined, indicates that the sockatmark routine is * available to test whether a socket is at the out-of-band mark. */ /*#define HAS_SOCKATMARK / **/ /* HAS_SOCKATMARK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the sockatmark() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int sockatmark(int); */ /*#define HAS_SOCKATMARK_PROTO / **/ /* HAS_SOCKS5_INIT: * This symbol, if defined, indicates that the socks5_init routine is * available to initialize SOCKS 5. */ /*#define HAS_SOCKS5_INIT / **/ /* SPRINTF_RETURNS_STRLEN: * This variable defines whether sprintf returns the length of the string * (as per the ANSI spec). Some C libraries retain compatibility with * pre-ANSI C and return a pointer to the passed in buffer; for these * this variable will be undef. */ #define SPRINTF_RETURNS_STRLEN /**/ /* HAS_SQRTL: * This symbol, if defined, indicates that the sqrtl routine is * available to do long double square roots. */ /*#define HAS_SQRTL / **/ /* HAS_SETRESGID_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the setresgid() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern int setresgid(uid_t ruid, uid_t euid, uid_t suid); */ /*#define HAS_SETRESGID_PROTO / **/ /* HAS_SETRESUID_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the setresuid() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern int setresuid(uid_t ruid, uid_t euid, uid_t suid); */ /*#define HAS_SETRESUID_PROTO / **/ /* HAS_STRUCT_STATFS_F_FLAGS: * This symbol, if defined, indicates that the struct statfs * does have the f_flags member containing the mount flags of * the filesystem containing the file. * This kind of struct statfs is coming from (BSD 4.3), * not from (SYSV). Older BSDs (like Ultrix) do not * have statfs() and struct statfs, they have ustat() and getmnt() * with struct ustat and struct fs_data. */ /*#define HAS_STRUCT_STATFS_F_FLAGS / **/ /* HAS_STRUCT_STATFS: * This symbol, if defined, indicates that the struct statfs * to do statfs() is supported. */ /*#define HAS_STRUCT_STATFS / **/ /* HAS_FSTATVFS: * This symbol, if defined, indicates that the fstatvfs routine is * available to stat filesystems by file descriptors. */ /*#define HAS_FSTATVFS / **/ /* HAS_STRFTIME: * This symbol, if defined, indicates that the strftime routine is * available to do time formatting. */ #define HAS_STRFTIME /**/ /* HAS_STRLCAT: * This symbol, if defined, indicates that the strlcat () routine is * available to do string concatenation. */ /*#define HAS_STRLCAT / **/ /* HAS_STRLCPY: * This symbol, if defined, indicates that the strlcpy () routine is * available to do string copying. */ /*#define HAS_STRLCPY / **/ /* HAS_STRTOLD: * This symbol, if defined, indicates that the strtold routine is * available to convert strings to long doubles. */ /*#define HAS_STRTOLD / **/ /* HAS_STRTOLL: * This symbol, if defined, indicates that the strtoll routine is * available to convert strings to long longs. */ #define HAS_STRTOLL /**/ /* HAS_STRTOQ: * This symbol, if defined, indicates that the strtoq routine is * available to convert strings to long longs (quads). */ /*#define HAS_STRTOQ / **/ /* HAS_STRTOULL: * This symbol, if defined, indicates that the strtoull routine is * available to convert strings to unsigned long longs. */ #define HAS_STRTOULL /**/ /* HAS_STRTOUQ: * This symbol, if defined, indicates that the strtouq routine is * available to convert strings to unsigned long longs (quads). */ /*#define HAS_STRTOUQ / **/ /* HAS_SYSCALL_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the syscall() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern int syscall(int, ...); * extern int syscall(long, ...); */ /*#define HAS_SYSCALL_PROTO / **/ /* HAS_TELLDIR_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the telldir() function. Otherwise, it is up * to the program to supply one. A good guess is * extern long telldir(DIR*); */ #define HAS_TELLDIR_PROTO /**/ /* HAS_CTIME64: * This symbol, if defined, indicates that the ctime64 () routine is * available to do the 64bit variant of ctime () */ /* HAS_LOCALTIME64: * This symbol, if defined, indicates that the localtime64 () routine is * available to do the 64bit variant of localtime () */ /* HAS_GMTIME64: * This symbol, if defined, indicates that the gmtime64 () routine is * available to do the 64bit variant of gmtime () */ /* HAS_MKTIME64: * This symbol, if defined, indicates that the mktime64 () routine is * available to do the 64bit variant of mktime () */ /* HAS_DIFFTIME64: * This symbol, if defined, indicates that the difftime64 () routine is * available to do the 64bit variant of difftime () */ /* HAS_ASCTIME64: * This symbol, if defined, indicates that the asctime64 () routine is * available to do the 64bit variant of asctime () */ /*#define HAS_CTIME64 / **/ /*#define HAS_LOCALTIME64 / **/ /*#define HAS_GMTIME64 / **/ /*#define HAS_MKTIME64 / **/ /*#define HAS_DIFFTIME64 / **/ /*#define HAS_ASCTIME64 / **/ /* HAS_TIMEGM: * This symbol, if defined, indicates that the timegm routine is * available to do the opposite of gmtime () */ /*#define HAS_TIMEGM / **/ /* U32_ALIGNMENT_REQUIRED: * This symbol, if defined, indicates that you must access * character data through U32-aligned pointers. */ #ifndef U32_ALIGNMENT_REQUIRED #define U32_ALIGNMENT_REQUIRED /**/ #endif /* HAS_UALARM: * This symbol, if defined, indicates that the ualarm routine is * available to do alarms with microsecond granularity. */ /*#define HAS_UALARM / **/ /* HAS_UNORDERED: * This symbol, if defined, indicates that the unordered routine is * available to check whether two doubles are unordered * (effectively: whether either of them is NaN) */ /*#define HAS_UNORDERED / **/ /* HAS_UNSETENV: * This symbol, if defined, indicates that the unsetenv () routine is * available for use. */ /*#define HAS_UNSETENV / **/ /* HAS_USLEEP_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the usleep() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int usleep(useconds_t); */ /*#define HAS_USLEEP_PROTO / **/ /* HAS_USTAT: * This symbol, if defined, indicates that the ustat system call is * available to query file system statistics by dev_t. */ /*#define HAS_USTAT / **/ /* HAS_WRITEV: * This symbol, if defined, indicates that the writev routine is * available to do scatter writes. */ /*#define HAS_WRITEV / **/ /* USE_DYNAMIC_LOADING: * This symbol, if defined, indicates that dynamic loading of * some sort is available. */ #define USE_DYNAMIC_LOADING /**/ /* FFLUSH_NULL: * This symbol, if defined, tells that fflush(NULL) does flush * all pending stdio output. */ /* FFLUSH_ALL: * This symbol, if defined, tells that to flush * all pending stdio output one must loop through all * the stdio file handles stored in an array and fflush them. * Note that if fflushNULL is defined, fflushall will not * even be probed for and will be left undefined. */ #define FFLUSH_NULL /**/ /*#define FFLUSH_ALL / **/ /* I_ASSERT: * This symbol, if defined, indicates that exists and * could be included by the C program to get the assert() macro. */ #define I_ASSERT /**/ /* I_CRYPT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_CRYPT / **/ /* DB_Prefix_t: * This symbol contains the type of the prefix structure element * in the header file. In older versions of DB, it was * int, while in newer ones it is u_int32_t. */ /* DB_Hash_t: * This symbol contains the type of the prefix structure element * in the header file. In older versions of DB, it was * int, while in newer ones it is size_t. */ /* DB_VERSION_MAJOR_CFG: * This symbol, if defined, defines the major version number of * Berkeley DB found in the header when Perl was configured. */ /* DB_VERSION_MINOR_CFG: * This symbol, if defined, defines the minor version number of * Berkeley DB found in the header when Perl was configured. * For DB version 1 this is always 0. */ /* DB_VERSION_PATCH_CFG: * This symbol, if defined, defines the patch version number of * Berkeley DB found in the header when Perl was configured. * For DB version 1 this is always 0. */ #define DB_Hash_t int /**/ #define DB_Prefix_t int /**/ #define DB_VERSION_MAJOR_CFG 0 /**/ #define DB_VERSION_MINOR_CFG 0 /**/ #define DB_VERSION_PATCH_CFG 0 /**/ /* I_FP: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_FP / **/ /* I_FP_CLASS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_FP_CLASS / **/ /* I_IEEEFP: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_IEEEFP / **/ /* I_INTTYPES: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_INTTYPES / **/ /* I_LANGINFO: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_LANGINFO / **/ /* I_LIBUTIL: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_LIBUTIL / **/ /* I_MALLOCMALLOC: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_MALLOCMALLOC / **/ /* I_MNTENT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_MNTENT / **/ /* I_NETINET_TCP: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_NETINET_TCP / **/ /* I_POLL: * This symbol, if defined, indicates that exists and * should be included. (see also HAS_POLL) */ /*#define I_POLL / **/ /* I_PROT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_PROT / **/ /* I_SHADOW: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SHADOW / **/ /* I_SOCKS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SOCKS / **/ /* I_SUNMATH: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SUNMATH / **/ /* I_SYSLOG: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSLOG / **/ /* I_SYSMODE: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSMODE / **/ /* I_SYS_MOUNT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYS_MOUNT / **/ /* I_SYS_STATFS: * This symbol, if defined, indicates that exists. */ /*#define I_SYS_STATFS / **/ /* I_SYS_STATVFS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYS_STATVFS / **/ /* I_SYSUTSNAME: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSUTSNAME / **/ /* I_SYS_VFS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYS_VFS / **/ /* I_USTAT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_USTAT / **/ /* PERL_PRIfldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'f') for output. */ /* PERL_PRIgldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'g') for output. */ /* PERL_PRIeldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'e') for output. */ /* PERL_SCNfldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'f') for input. */ /*#define PERL_PRIfldbl "f" / **/ /*#define PERL_PRIgldbl "g" / **/ /*#define PERL_PRIeldbl "e" / **/ /*#define PERL_SCNfldbl "f" / **/ /* PERL_MAD: * This symbol, if defined, indicates that the Misc Attribution * Declaration code should be conditionally compiled. */ /*#define PERL_MAD / **/ /* NEED_VA_COPY: * This symbol, if defined, indicates that the system stores * the variable argument list datatype, va_list, in a format * that cannot be copied by simple assignment, so that some * other means must be used when copying is required. * As such systems vary in their provision (or non-provision) * of copying mechanisms, handy.h defines a platform- * independent macro, Perl_va_copy(src, dst), to do the job. */ /*#define NEED_VA_COPY / **/ /* IVTYPE: * This symbol defines the C type used for Perl's IV. */ /* UVTYPE: * This symbol defines the C type used for Perl's UV. */ /* I8TYPE: * This symbol defines the C type used for Perl's I8. */ /* U8TYPE: * This symbol defines the C type used for Perl's U8. */ /* I16TYPE: * This symbol defines the C type used for Perl's I16. */ /* U16TYPE: * This symbol defines the C type used for Perl's U16. */ /* I32TYPE: * This symbol defines the C type used for Perl's I32. */ /* U32TYPE: * This symbol defines the C type used for Perl's U32. */ /* I64TYPE: * This symbol defines the C type used for Perl's I64. */ /* U64TYPE: * This symbol defines the C type used for Perl's U64. */ /* NVTYPE: * This symbol defines the C type used for Perl's NV. */ /* IVSIZE: * This symbol contains the sizeof(IV). */ /* UVSIZE: * This symbol contains the sizeof(UV). */ /* I8SIZE: * This symbol contains the sizeof(I8). */ /* U8SIZE: * This symbol contains the sizeof(U8). */ /* I16SIZE: * This symbol contains the sizeof(I16). */ /* U16SIZE: * This symbol contains the sizeof(U16). */ /* I32SIZE: * This symbol contains the sizeof(I32). */ /* U32SIZE: * This symbol contains the sizeof(U32). */ /* I64SIZE: * This symbol contains the sizeof(I64). */ /* U64SIZE: * This symbol contains the sizeof(U64). */ /* NVSIZE: * This symbol contains the sizeof(NV). */ /* NV_PRESERVES_UV: * This symbol, if defined, indicates that a variable of type NVTYPE * can preserve all the bits of a variable of type UVTYPE. */ /* NV_PRESERVES_UV_BITS: * This symbol contains the number of bits a variable of type NVTYPE * can preserve of a variable of type UVTYPE. */ /* NV_OVERFLOWS_INTEGERS_AT: * This symbol gives the largest integer value that NVs can hold. This * value + 1.0 cannot be stored accurately. It is expressed as constant * floating point expression to reduce the chance of decimale/binary * conversion issues. If it can not be determined, the value 0 is given. */ /* NV_ZERO_IS_ALLBITS_ZERO: * This symbol, if defined, indicates that a variable of type NVTYPE * stores 0.0 in memory as all bits zero. */ #ifdef _MSC_VER # define IVTYPE __int64 /**/ # define UVTYPE unsigned __int64 /**/ #else # define IVTYPE long long /**/ # define UVTYPE unsigned long long /**/ #endif #define I8TYPE char /**/ #define U8TYPE unsigned char /**/ #define I16TYPE short /**/ #define U16TYPE unsigned short /**/ #define I32TYPE long /**/ #define U32TYPE unsigned long /**/ #ifdef HAS_QUAD # ifdef _MSC_VER # define I64TYPE __int64 /**/ # define U64TYPE unsigned __int64 /**/ # else # define I64TYPE long long /**/ # define U64TYPE unsigned long long /**/ # endif #endif #define NVTYPE double /**/ #define IVSIZE 8 /**/ #define UVSIZE 8 /**/ #define I8SIZE 1 /**/ #define U8SIZE 1 /**/ #define I16SIZE 2 /**/ #define U16SIZE 2 /**/ #define I32SIZE 4 /**/ #define U32SIZE 4 /**/ #ifdef HAS_QUAD #define I64SIZE 8 /**/ #define U64SIZE 8 /**/ #endif #define NVSIZE 8 /**/ #undef NV_PRESERVES_UV #define NV_PRESERVES_UV_BITS 53 #define NV_OVERFLOWS_INTEGERS_AT 256.0*256.0*256.0*256.0*256.0*256.0*2.0*2.0*2.0*2.0*2.0 #define NV_ZERO_IS_ALLBITS_ZERO #if UVSIZE == 8 # ifdef BYTEORDER # if BYTEORDER == 0x1234 # undef BYTEORDER # define BYTEORDER 0x12345678 # else # if BYTEORDER == 0x4321 # undef BYTEORDER # define BYTEORDER 0x87654321 # endif # endif # endif #endif /* IVdf: * This symbol defines the format string used for printing a Perl IV * as a signed decimal integer. */ /* UVuf: * This symbol defines the format string used for printing a Perl UV * as an unsigned decimal integer. */ /* UVof: * This symbol defines the format string used for printing a Perl UV * as an unsigned octal integer. */ /* UVxf: * This symbol defines the format string used for printing a Perl UV * as an unsigned hexadecimal integer in lowercase abcdef. */ /* UVXf: * This symbol defines the format string used for printing a Perl UV * as an unsigned hexadecimal integer in uppercase ABCDEF. */ /* NVef: * This symbol defines the format string used for printing a Perl NV * using %e-ish floating point format. */ /* NVff: * This symbol defines the format string used for printing a Perl NV * using %f-ish floating point format. */ /* NVgf: * This symbol defines the format string used for printing a Perl NV * using %g-ish floating point format. */ #define IVdf "I64d" /**/ #define UVuf "I64u" /**/ #define UVof "I64o" /**/ #define UVxf "I64x" /**/ #define UVXf "I64X" /**/ #define NVef "e" /**/ #define NVff "f" /**/ #define NVgf "g" /**/ /* SELECT_MIN_BITS: * This symbol holds the minimum number of bits operated by select. * That is, if you do select(n, ...), how many bits at least will be * cleared in the masks if some activity is detected. Usually this * is either n or 32*ceil(n/32), especially many little-endians do * the latter. This is only useful if you have select(), naturally. */ #define SELECT_MIN_BITS 32 /**/ /* STARTPERL: * This variable contains the string to put in front of a perl * script to make sure (one hopes) that it runs with perl and not * some shell. */ #define STARTPERL "#!perl" /**/ /* HAS_STDIO_STREAM_ARRAY: * This symbol, if defined, tells that there is an array * holding the stdio streams. */ /* STDIO_STREAM_ARRAY: * This symbol tells the name of the array holding the stdio streams. * Usual values include _iob, __iob, and __sF. */ /*#define HAS_STDIO_STREAM_ARRAY / **/ #ifdef HAS_STDIO_STREAM_ARRAY #define STDIO_STREAM_ARRAY #endif /* GMTIME_MAX: * This symbol contains the maximum value for the time_t offset that * the system function gmtime () accepts, and defaults to 0 */ /* GMTIME_MIN: * This symbol contains the minimum value for the time_t offset that * the system function gmtime () accepts, and defaults to 0 */ /* LOCALTIME_MAX: * This symbol contains the maximum value for the time_t offset that * the system function localtime () accepts, and defaults to 0 */ /* LOCALTIME_MIN: * This symbol contains the minimum value for the time_t offset that * the system function localtime () accepts, and defaults to 0 */ #define GMTIME_MAX 2147483647 /**/ #define GMTIME_MIN 0 /**/ #define LOCALTIME_MAX 2147483647 /**/ #define LOCALTIME_MIN 0 /**/ /* USE_64_BIT_INT: * This symbol, if defined, indicates that 64-bit integers should * be used when available. If not defined, the native integers * will be employed (be they 32 or 64 bits). The minimal possible * 64-bitness is used, just enough to get 64-bit integers into Perl. * This may mean using for example "long longs", while your memory * may still be limited to 2 gigabytes. */ /* USE_64_BIT_ALL: * This symbol, if defined, indicates that 64-bit integers should * be used when available. If not defined, the native integers * will be used (be they 32 or 64 bits). The maximal possible * 64-bitness is employed: LP64 or ILP64, meaning that you will * be able to use more than 2 gigabytes of memory. This mode is * even more binary incompatible than USE_64_BIT_INT. You may not * be able to run the resulting executable in a 32-bit CPU at all or * you may need at least to reboot your OS to 64-bit mode. */ #ifndef USE_64_BIT_INT #define USE_64_BIT_INT /**/ #endif #ifndef USE_64_BIT_ALL /*#define USE_64_BIT_ALL / **/ #endif /* USE_DTRACE: * This symbol, if defined, indicates that Perl should * be built with support for DTrace. */ /*#define USE_DTRACE / **/ /* USE_FAST_STDIO: * This symbol, if defined, indicates that Perl should * be built to use 'fast stdio'. * Defaults to define in Perls 5.8 and earlier, to undef later. */ #ifndef USE_FAST_STDIO /*#define USE_FAST_STDIO / **/ #endif /* USE_LARGE_FILES: * This symbol, if defined, indicates that large file support * should be used when available. */ #ifndef USE_LARGE_FILES #define USE_LARGE_FILES /**/ #endif /* USE_LONG_DOUBLE: * This symbol, if defined, indicates that long doubles should * be used when available. */ #ifndef USE_LONG_DOUBLE /*#define USE_LONG_DOUBLE / **/ #endif /* USE_MORE_BITS: * This symbol, if defined, indicates that 64-bit interfaces and * long doubles should be used when available. */ #ifndef USE_MORE_BITS /*#define USE_MORE_BITS / **/ #endif /* MULTIPLICITY: * This symbol, if defined, indicates that Perl should * be built to use multiplicity. */ #ifndef MULTIPLICITY #define MULTIPLICITY /**/ #endif /* USE_PERLIO: * This symbol, if defined, indicates that the PerlIO abstraction should * be used throughout. If not defined, stdio should be * used in a fully backward compatible manner. */ #ifndef USE_PERLIO #define USE_PERLIO /**/ #endif /* USE_SOCKS: * This symbol, if defined, indicates that Perl should * be built to use socks. */ #ifndef USE_SOCKS /*#define USE_SOCKS / **/ #endif #endif perl-5.12.0-RC0/win32/config_H.gc0000644000175000017500000043441311325127002015122 0ustar jessejesse/* * This file was produced by running the config_h.SH script, which * gets its values from undef, which is generally produced by * running Configure. * * Feel free to modify any of this as the need arises. Note, however, * that running config_h.SH again will wipe out any changes you've made. * For a more permanent change edit undef and rerun config_h.SH. * * $Id: Config_h.U 1 2006-08-24 12:32:52Z rmanfredi $ */ /* * Package name : perl5 * Source directory : * Configuration time: Sun Jan 10 19:53:56 2010 * Configured by : Steve * Target system : */ #ifndef _config_h_ #define _config_h_ /* LOC_SED: * This symbol holds the complete pathname to the sed program. */ #define LOC_SED "" /**/ /* HAS_ALARM: * This symbol, if defined, indicates that the alarm routine is * available. */ #define HAS_ALARM /**/ /* HAS_BCMP: * This symbol is defined if the bcmp() routine is available to * compare blocks of memory. */ /*#define HAS_BCMP / **/ /* HAS_BCOPY: * This symbol is defined if the bcopy() routine is available to * copy blocks of memory. */ /*#define HAS_BCOPY / **/ /* HAS_BZERO: * This symbol is defined if the bzero() routine is available to * set a memory block to 0. */ /*#define HAS_BZERO / **/ /* HAS_CHOWN: * This symbol, if defined, indicates that the chown routine is * available. */ /*#define HAS_CHOWN / **/ /* HAS_CHROOT: * This symbol, if defined, indicates that the chroot routine is * available. */ /*#define HAS_CHROOT / **/ /* HAS_CHSIZE: * This symbol, if defined, indicates that the chsize routine is available * to truncate files. You might need a -lx to get this routine. */ #define HAS_CHSIZE /**/ /* HAS_CRYPT: * This symbol, if defined, indicates that the crypt routine is available * to encrypt passwords and the like. */ /*#define HAS_CRYPT / **/ /* HAS_CTERMID: * This symbol, if defined, indicates that the ctermid routine is * available to generate filename for terminal. */ /*#define HAS_CTERMID / **/ /* HAS_CUSERID: * This symbol, if defined, indicates that the cuserid routine is * available to get character login names. */ /*#define HAS_CUSERID / **/ /* HAS_DBL_DIG: * This symbol, if defined, indicates that this system's * or defines the symbol DBL_DIG, which is the number * of significant digits in a double precision number. If this * symbol is not defined, a guess of 15 is usually pretty good. */ #define HAS_DBL_DIG /**/ /* HAS_DIFFTIME: * This symbol, if defined, indicates that the difftime routine is * available. */ #define HAS_DIFFTIME /**/ /* HAS_DLERROR: * This symbol, if defined, indicates that the dlerror routine is * available to return a string describing the last error that * occurred from a call to dlopen(), dlclose() or dlsym(). */ #define HAS_DLERROR /**/ /* HAS_DUP2: * This symbol, if defined, indicates that the dup2 routine is * available to duplicate file descriptors. */ #define HAS_DUP2 /**/ /* HAS_FCHMOD: * This symbol, if defined, indicates that the fchmod routine is available * to change mode of opened files. If unavailable, use chmod(). */ /*#define HAS_FCHMOD / **/ /* HAS_FCHOWN: * This symbol, if defined, indicates that the fchown routine is available * to change ownership of opened files. If unavailable, use chown(). */ /*#define HAS_FCHOWN / **/ /* HAS_FCNTL: * This symbol, if defined, indicates to the C program that * the fcntl() function exists. */ /*#define HAS_FCNTL / **/ /* HAS_FGETPOS: * This symbol, if defined, indicates that the fgetpos routine is * available to get the file position indicator, similar to ftell(). */ #define HAS_FGETPOS /**/ /* HAS_FLOCK: * This symbol, if defined, indicates that the flock routine is * available to do file locking. */ #define HAS_FLOCK /**/ /* HAS_FORK: * This symbol, if defined, indicates that the fork routine is * available. */ /*#define HAS_FORK / **/ /* HAS_FSETPOS: * This symbol, if defined, indicates that the fsetpos routine is * available to set the file position indicator, similar to fseek(). */ #define HAS_FSETPOS /**/ /* HAS_GETTIMEOFDAY: * This symbol, if defined, indicates that the gettimeofday() system * call is available for a sub-second accuracy clock. Usually, the file * needs to be included (see I_SYS_RESOURCE). * The type "Timeval" should be used to refer to "struct timeval". */ #define HAS_GETTIMEOFDAY /**/ #ifdef HAS_GETTIMEOFDAY #define Timeval struct timeval /* Structure used by gettimeofday() */ #endif /* HAS_GETGROUPS: * This symbol, if defined, indicates that the getgroups() routine is * available to get the list of process groups. If unavailable, multiple * groups are probably not supported. */ /*#define HAS_GETGROUPS / **/ /* HAS_GETLOGIN: * This symbol, if defined, indicates that the getlogin routine is * available to get the login name. */ #define HAS_GETLOGIN /**/ /* HAS_GETPGID: * This symbol, if defined, indicates to the C program that * the getpgid(pid) function is available to get the * process group id. */ /*#define HAS_GETPGID / **/ /* HAS_GETPGRP2: * This symbol, if defined, indicates that the getpgrp2() (as in DG/UX) * routine is available to get the current process group. */ /*#define HAS_GETPGRP2 / **/ /* HAS_GETPPID: * This symbol, if defined, indicates that the getppid routine is * available to get the parent process ID. */ /*#define HAS_GETPPID / **/ /* HAS_GETPRIORITY: * This symbol, if defined, indicates that the getpriority routine is * available to get a process's priority. */ /*#define HAS_GETPRIORITY / **/ /* HAS_INET_ATON: * This symbol, if defined, indicates to the C program that the * inet_aton() function is available to parse IP address "dotted-quad" * strings. */ /*#define HAS_INET_ATON / **/ /* HAS_KILLPG: * This symbol, if defined, indicates that the killpg routine is available * to kill process groups. If unavailable, you probably should use kill * with a negative process number. */ #define HAS_KILLPG /**/ /* HAS_LINK: * This symbol, if defined, indicates that the link routine is * available to create hard links. */ #define HAS_LINK /**/ /* HAS_LOCALECONV: * This symbol, if defined, indicates that the localeconv routine is * available for numeric and monetary formatting conventions. */ #define HAS_LOCALECONV /**/ /* HAS_LOCKF: * This symbol, if defined, indicates that the lockf routine is * available to do file locking. */ /*#define HAS_LOCKF / **/ /* HAS_LSTAT: * This symbol, if defined, indicates that the lstat routine is * available to do file stats on symbolic links. */ /*#define HAS_LSTAT / **/ /* HAS_MBLEN: * This symbol, if defined, indicates that the mblen routine is available * to find the number of bytes in a multibye character. */ #define HAS_MBLEN /**/ /* HAS_MBSTOWCS: * This symbol, if defined, indicates that the mbstowcs routine is * available to covert a multibyte string into a wide character string. */ #define HAS_MBSTOWCS /**/ /* HAS_MBTOWC: * This symbol, if defined, indicates that the mbtowc routine is available * to covert a multibyte to a wide character. */ #define HAS_MBTOWC /**/ /* HAS_MEMCMP: * This symbol, if defined, indicates that the memcmp routine is available * to compare blocks of memory. */ #define HAS_MEMCMP /**/ /* HAS_MEMCPY: * This symbol, if defined, indicates that the memcpy routine is available * to copy blocks of memory. */ #define HAS_MEMCPY /**/ /* HAS_MEMMOVE: * This symbol, if defined, indicates that the memmove routine is available * to copy potentially overlapping blocks of memory. This should be used * only when HAS_SAFE_BCOPY is not defined. If neither is there, roll your * own version. */ #define HAS_MEMMOVE /**/ /* HAS_MEMSET: * This symbol, if defined, indicates that the memset routine is available * to set blocks of memory. */ #define HAS_MEMSET /**/ /* HAS_MKDIR: * This symbol, if defined, indicates that the mkdir routine is available * to create directories. Otherwise you should fork off a new process to * exec /bin/mkdir. */ #define HAS_MKDIR /**/ /* HAS_MKFIFO: * This symbol, if defined, indicates that the mkfifo routine is * available to create FIFOs. Otherwise, mknod should be able to * do it for you. However, if mkfifo is there, mknod might require * super-user privileges which mkfifo will not. */ /*#define HAS_MKFIFO / **/ /* HAS_MKTIME: * This symbol, if defined, indicates that the mktime routine is * available. */ #define HAS_MKTIME /**/ /* HAS_MSYNC: * This symbol, if defined, indicates that the msync system call is * available to synchronize a mapped file. */ /*#define HAS_MSYNC / **/ /* HAS_MUNMAP: * This symbol, if defined, indicates that the munmap system call is * available to unmap a region, usually mapped by mmap(). */ /*#define HAS_MUNMAP / **/ /* HAS_NICE: * This symbol, if defined, indicates that the nice routine is * available. */ /*#define HAS_NICE / **/ /* HAS_PATHCONF: * This symbol, if defined, indicates that pathconf() is available * to determine file-system related limits and options associated * with a given filename. */ /* HAS_FPATHCONF: * This symbol, if defined, indicates that pathconf() is available * to determine file-system related limits and options associated * with a given open file descriptor. */ /*#define HAS_PATHCONF / **/ /*#define HAS_FPATHCONF / **/ /* HAS_PAUSE: * This symbol, if defined, indicates that the pause routine is * available to suspend a process until a signal is received. */ #define HAS_PAUSE /**/ /* HAS_PIPE: * This symbol, if defined, indicates that the pipe routine is * available to create an inter-process channel. */ #define HAS_PIPE /**/ /* HAS_POLL: * This symbol, if defined, indicates that the poll routine is * available to poll active file descriptors. Please check I_POLL and * I_SYS_POLL to know which header should be included as well. */ /*#define HAS_POLL / **/ /* HAS_READDIR: * This symbol, if defined, indicates that the readdir routine is * available to read directory entries. You may have to include * . See I_DIRENT. */ #define HAS_READDIR /**/ /* HAS_SEEKDIR: * This symbol, if defined, indicates that the seekdir routine is * available. You may have to include . See I_DIRENT. */ #define HAS_SEEKDIR /**/ /* HAS_TELLDIR: * This symbol, if defined, indicates that the telldir routine is * available. You may have to include . See I_DIRENT. */ #define HAS_TELLDIR /**/ /* HAS_REWINDDIR: * This symbol, if defined, indicates that the rewinddir routine is * available. You may have to include . See I_DIRENT. */ #define HAS_REWINDDIR /**/ /* HAS_READLINK: * This symbol, if defined, indicates that the readlink routine is * available to read the value of a symbolic link. */ /*#define HAS_READLINK / **/ /* HAS_RENAME: * This symbol, if defined, indicates that the rename routine is available * to rename files. Otherwise you should do the unlink(), link(), unlink() * trick. */ #define HAS_RENAME /**/ /* HAS_RMDIR: * This symbol, if defined, indicates that the rmdir routine is * available to remove directories. Otherwise you should fork off a * new process to exec /bin/rmdir. */ #define HAS_RMDIR /**/ /* HAS_SELECT: * This symbol, if defined, indicates that the select routine is * available to select active file descriptors. If the timeout field * is used, may need to be included. */ #define HAS_SELECT /**/ /* HAS_SETEGID: * This symbol, if defined, indicates that the setegid routine is available * to change the effective gid of the current program. */ /*#define HAS_SETEGID / **/ /* HAS_SETEUID: * This symbol, if defined, indicates that the seteuid routine is available * to change the effective uid of the current program. */ /*#define HAS_SETEUID / **/ /* HAS_SETGROUPS: * This symbol, if defined, indicates that the setgroups() routine is * available to set the list of process groups. If unavailable, multiple * groups are probably not supported. */ /*#define HAS_SETGROUPS / **/ /* HAS_SETLINEBUF: * This symbol, if defined, indicates that the setlinebuf routine is * available to change stderr or stdout from block-buffered or unbuffered * to a line-buffered mode. */ /*#define HAS_SETLINEBUF / **/ /* HAS_SETLOCALE: * This symbol, if defined, indicates that the setlocale routine is * available to handle locale-specific ctype implementations. */ #define HAS_SETLOCALE /**/ /* HAS_SETPGID: * This symbol, if defined, indicates that the setpgid(pid, gpid) * routine is available to set process group ID. */ /*#define HAS_SETPGID / **/ /* HAS_SETPGRP2: * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX) * routine is available to set the current process group. */ /*#define HAS_SETPGRP2 / **/ /* HAS_SETPRIORITY: * This symbol, if defined, indicates that the setpriority routine is * available to set a process's priority. */ /*#define HAS_SETPRIORITY / **/ /* HAS_SETREGID: * This symbol, if defined, indicates that the setregid routine is * available to change the real and effective gid of the current * process. */ /* HAS_SETRESGID: * This symbol, if defined, indicates that the setresgid routine is * available to change the real, effective and saved gid of the current * process. */ /*#define HAS_SETREGID / **/ /*#define HAS_SETRESGID / **/ /* HAS_SETREUID: * This symbol, if defined, indicates that the setreuid routine is * available to change the real and effective uid of the current * process. */ /* HAS_SETRESUID: * This symbol, if defined, indicates that the setresuid routine is * available to change the real, effective and saved uid of the current * process. */ /*#define HAS_SETREUID / **/ /*#define HAS_SETRESUID / **/ /* HAS_SETRGID: * This symbol, if defined, indicates that the setrgid routine is available * to change the real gid of the current program. */ /*#define HAS_SETRGID / **/ /* HAS_SETRUID: * This symbol, if defined, indicates that the setruid routine is available * to change the real uid of the current program. */ /*#define HAS_SETRUID / **/ /* HAS_SETSID: * This symbol, if defined, indicates that the setsid routine is * available to set the process group ID. */ /*#define HAS_SETSID / **/ /* HAS_STRCHR: * This symbol is defined to indicate that the strchr()/strrchr() * functions are available for string searching. If not, try the * index()/rindex() pair. */ /* HAS_INDEX: * This symbol is defined to indicate that the index()/rindex() * functions are available for string searching. */ #define HAS_STRCHR /**/ /*#define HAS_INDEX / **/ /* HAS_STRCOLL: * This symbol, if defined, indicates that the strcoll routine is * available to compare strings using collating information. */ #define HAS_STRCOLL /**/ /* HAS_STRTOD: * This symbol, if defined, indicates that the strtod routine is * available to provide better numeric string conversion than atof(). */ #define HAS_STRTOD /**/ /* HAS_STRTOL: * This symbol, if defined, indicates that the strtol routine is available * to provide better numeric string conversion than atoi() and friends. */ #define HAS_STRTOL /**/ /* HAS_STRXFRM: * This symbol, if defined, indicates that the strxfrm() routine is * available to transform strings. */ #define HAS_STRXFRM /**/ /* HAS_SYMLINK: * This symbol, if defined, indicates that the symlink routine is available * to create symbolic links. */ /*#define HAS_SYMLINK / **/ /* HAS_SYSCALL: * This symbol, if defined, indicates that the syscall routine is * available to call arbitrary system calls. If undefined, that's tough. */ /*#define HAS_SYSCALL / **/ /* HAS_SYSCONF: * This symbol, if defined, indicates that sysconf() is available * to determine system related limits and options. */ /*#define HAS_SYSCONF / **/ /* HAS_SYSTEM: * This symbol, if defined, indicates that the system routine is * available to issue a shell command. */ #define HAS_SYSTEM /**/ /* HAS_TCGETPGRP: * This symbol, if defined, indicates that the tcgetpgrp routine is * available to get foreground process group ID. */ /*#define HAS_TCGETPGRP / **/ /* HAS_TCSETPGRP: * This symbol, if defined, indicates that the tcsetpgrp routine is * available to set foreground process group ID. */ /*#define HAS_TCSETPGRP / **/ /* HAS_TRUNCATE: * This symbol, if defined, indicates that the truncate routine is * available to truncate files. */ /*#define HAS_TRUNCATE / **/ /* HAS_TZNAME: * This symbol, if defined, indicates that the tzname[] array is * available to access timezone names. */ #define HAS_TZNAME /**/ /* HAS_UMASK: * This symbol, if defined, indicates that the umask routine is * available to set and get the value of the file creation mask. */ #define HAS_UMASK /**/ /* HAS_USLEEP: * This symbol, if defined, indicates that the usleep routine is * available to let the process sleep on a sub-second accuracy. */ /*#define HAS_USLEEP / **/ /* HAS_WAIT4: * This symbol, if defined, indicates that wait4() exists. */ /*#define HAS_WAIT4 / **/ /* HAS_WAITPID: * This symbol, if defined, indicates that the waitpid routine is * available to wait for child process. */ #define HAS_WAITPID /**/ /* HAS_WCSTOMBS: * This symbol, if defined, indicates that the wcstombs routine is * available to convert wide character strings to multibyte strings. */ #define HAS_WCSTOMBS /**/ /* HAS_WCTOMB: * This symbol, if defined, indicates that the wctomb routine is available * to covert a wide character to a multibyte. */ #define HAS_WCTOMB /**/ /* Groups_t: * This symbol holds the type used for the second argument to * getgroups() and setgroups(). Usually, this is the same as * gidtype (gid_t) , but sometimes it isn't. * It can be int, ushort, gid_t, etc... * It may be necessary to include to get any * typedef'ed information. This is only required if you have * getgroups() or setgroups().. */ #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS) #define Groups_t gid_t /* Type for 2nd arg to [sg]etgroups() */ #endif /* I_ARPA_INET: * This symbol, if defined, indicates to the C program that it should * include to get inet_addr and friends declarations. */ #define I_ARPA_INET /**/ /* I_DBM: * This symbol, if defined, indicates that exists and should * be included. */ /* I_RPCSVC_DBM: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_DBM / **/ #define I_RPCSVC_DBM /**/ /* I_DLFCN: * This symbol, if defined, indicates that exists and should * be included. */ #define I_DLFCN /**/ /* I_FCNTL: * This manifest constant tells the C program to include . */ #define I_FCNTL /**/ /* I_FLOAT: * This symbol, if defined, indicates to the C program that it should * include to get definition of symbols like DBL_MAX or * DBL_MIN, i.e. machine dependent floating point values. */ #define I_FLOAT /**/ /* I_GDBM: * This symbol, if defined, indicates that exists and should * be included. */ /*#define I_GDBM / **/ /* I_LIMITS: * This symbol, if defined, indicates to the C program that it should * include to get definition of symbols like WORD_BIT or * LONG_MAX, i.e. machine dependant limitations. */ #define I_LIMITS /**/ /* I_LOCALE: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_LOCALE /**/ /* I_MATH: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_MATH /**/ /* I_MEMORY: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_MEMORY / **/ /* I_NETINET_IN: * This symbol, if defined, indicates to the C program that it should * include . Otherwise, you may try . */ /*#define I_NETINET_IN / **/ /* I_SFIO: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SFIO / **/ /* I_STDDEF: * This symbol, if defined, indicates that exists and should * be included. */ #define I_STDDEF /**/ /* I_STDLIB: * This symbol, if defined, indicates that exists and should * be included. */ #define I_STDLIB /**/ /* I_STRING: * This symbol, if defined, indicates to the C program that it should * include (USG systems) instead of (BSD systems). */ #define I_STRING /**/ /* I_SYS_DIR: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_DIR / **/ /* I_SYS_FILE: * This symbol, if defined, indicates to the C program that it should * include to get definition of R_OK and friends. */ /*#define I_SYS_FILE / **/ /* I_SYS_IOCTL: * This symbol, if defined, indicates that exists and should * be included. Otherwise, include or . */ /* I_SYS_SOCKIO: * This symbol, if defined, indicates the should be included * to get socket ioctl options, like SIOCATMARK. */ /*#define I_SYS_IOCTL / **/ /*#define I_SYS_SOCKIO / **/ /* I_SYS_NDIR: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_NDIR / **/ /* I_SYS_PARAM: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_PARAM / **/ /* I_SYS_POLL: * This symbol, if defined, indicates that the program may include * . When I_POLL is also defined, it's probably safest * to only include . */ /*#define I_SYS_POLL / **/ /* I_SYS_RESOURCE: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_RESOURCE / **/ /* I_SYS_SELECT: * This symbol, if defined, indicates to the C program that it should * include in order to get definition of struct timeval. */ /*#define I_SYS_SELECT / **/ /* I_SYS_STAT: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_STAT /**/ /* I_SYS_TIMES: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_TIMES / **/ /* I_SYS_TYPES: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_TYPES /**/ /* I_SYS_UN: * This symbol, if defined, indicates to the C program that it should * include to get UNIX domain socket definitions. */ /*#define I_SYS_UN / **/ /* I_SYS_WAIT: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_WAIT / **/ /* I_TERMIO: * This symbol, if defined, indicates that the program should include * rather than . There are also differences in * the ioctl() calls that depend on the value of this symbol. */ /* I_TERMIOS: * This symbol, if defined, indicates that the program should include * the POSIX termios.h rather than sgtty.h or termio.h. * There are also differences in the ioctl() calls that depend on the * value of this symbol. */ /* I_SGTTY: * This symbol, if defined, indicates that the program should include * rather than . There are also differences in * the ioctl() calls that depend on the value of this symbol. */ /*#define I_TERMIO / **/ /*#define I_TERMIOS / **/ /*#define I_SGTTY / **/ /* I_UNISTD: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_UNISTD / **/ /* I_UTIME: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_UTIME /**/ /* I_VALUES: * This symbol, if defined, indicates to the C program that it should * include to get definition of symbols like MINFLOAT or * MAXLONG, i.e. machine dependant limitations. Probably, you * should use instead, if it is available. */ /*#define I_VALUES / **/ /* I_VFORK: * This symbol, if defined, indicates to the C program that it should * include vfork.h. */ /*#define I_VFORK / **/ /* CAN_VAPROTO: * This variable is defined on systems supporting prototype declaration * of functions with a variable number of arguments. */ /* _V: * This macro is used to declare function parameters in prototypes for * functions with a variable number of parameters. Use double parentheses. * For example: * * int printf _V((char *fmt, ...)); * * Remember to use the plain simple _() macro when declaring a function * with no variable number of arguments, since it might be possible to * have a non-effect _V() macro and still get prototypes via _(). */ /*#define CAN_VAPROTO / **/ #ifdef CAN_VAPROTO #define _V(args) args #else #define _V(args) () #endif /* INTSIZE: * This symbol contains the value of sizeof(int) so that the C * preprocessor can make decisions based on it. */ /* LONGSIZE: * This symbol contains the value of sizeof(long) so that the C * preprocessor can make decisions based on it. */ /* SHORTSIZE: * This symbol contains the value of sizeof(short) so that the C * preprocessor can make decisions based on it. */ #define INTSIZE 4 /**/ #define LONGSIZE 4 /**/ #define SHORTSIZE 2 /**/ /* MULTIARCH: * This symbol, if defined, signifies that the build * process will produce some binary files that are going to be * used in a cross-platform environment. This is the case for * example with the NeXT "fat" binaries that contain executables * for several CPUs. */ /*#define MULTIARCH / **/ /* HAS_QUAD: * This symbol, if defined, tells that there's a 64-bit integer type, * Quad_t, and its unsigned counterpar, Uquad_t. QUADKIND will be one * of QUAD_IS_INT, QUAD_IS_LONG, QUAD_IS_LONG_LONG, QUAD_IS_INT64_T, * or QUAD_IS___INT64. */ #define HAS_QUAD /**/ #ifdef HAS_QUAD # ifndef _MSC_VER # define Quad_t long long /**/ # define Uquad_t unsigned long long /**/ # define QUADKIND 3 /**/ # else # define Quad_t __int64 /**/ # define Uquad_t unsigned __int64 /**/ # define QUADKIND 5 /**/ # endif # define QUAD_IS_INT 1 # define QUAD_IS_LONG 2 # define QUAD_IS_LONG_LONG 3 # define QUAD_IS_INT64_T 4 # define QUAD_IS___INT64 5 #endif /* OSNAME: * This symbol contains the name of the operating system, as determined * by Configure. You shouldn't rely on it too much; the specific * feature tests from Configure are generally more reliable. */ /* OSVERS: * This symbol contains the version of the operating system, as determined * by Configure. You shouldn't rely on it too much; the specific * feature tests from Configure are generally more reliable. */ #define OSNAME "MSWin32" /**/ #define OSVERS "5.1" /**/ /* ARCHLIB: * This variable, if defined, holds the name of the directory in * which the user wants to put architecture-dependent public * library files for perl5. It is most often a local directory * such as /usr/local/lib. Programs using this variable must be * prepared to deal with filename expansion. If ARCHLIB is the * same as PRIVLIB, it is not defined, since presumably the * program already searches PRIVLIB. */ /* ARCHLIB_EXP: * This symbol contains the ~name expanded version of ARCHLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ #define ARCHLIB "c:\\perl\\lib" /**/ /*#define ARCHLIB_EXP "" / **/ /* ARCHNAME: * This symbol holds a string representing the architecture name. * It may be used to construct an architecture-dependant pathname * where library files may be held under a private library, for * instance. */ #define ARCHNAME "MSWin32-x86" /**/ /* BIN: * This symbol holds the path of the bin directory where the package will * be installed. Program must be prepared to deal with ~name substitution. */ /* BIN_EXP: * This symbol is the filename expanded version of the BIN symbol, for * programs that do not want to deal with that at run-time. */ /* PERL_RELOCATABLE_INC: * This symbol, if defined, indicates that we'd like to relocate entries * in @INC at run time based on the location of the perl binary. */ #define BIN "c:\\perl\\bin" /**/ #define BIN_EXP "c:\\perl\\bin" /**/ #define PERL_RELOCATABLE_INC "undef" /**/ /* CAT2: * This macro concatenates 2 tokens together. */ /* STRINGIFY: * This macro surrounds its token with double quotes. */ #if 42 == 1 #define CAT2(a,b) a/**/b #undef STRINGIFY #define STRINGIFY(a) "a" #endif #if 42 == 42 #define PeRl_CaTiFy(a, b) a ## b #define PeRl_StGiFy(a) #a #define CAT2(a,b) PeRl_CaTiFy(a,b) #define StGiFy(a) PeRl_StGiFy(a) #undef STRINGIFY #define STRINGIFY(a) PeRl_StGiFy(a) #endif #if 42 != 1 && 42 != 42 #include "Bletch: How does this C preprocessor concatenate tokens?" #endif /* CPPSTDIN: * This symbol contains the first part of the string which will invoke * the C preprocessor on the standard input and produce to standard * output. Typical value of "cc -E" or "/lib/cpp", but it can also * call a wrapper. See CPPRUN. */ /* CPPMINUS: * This symbol contains the second part of the string which will invoke * the C preprocessor on the standard input and produce to standard * output. This symbol will have the value "-" if CPPSTDIN needs a minus * to specify standard input, otherwise the value is "". */ /* CPPRUN: * This symbol contains the string which will invoke a C preprocessor on * the standard input and produce to standard output. It needs to end * with CPPLAST, after all other preprocessor flags have been specified. * The main difference with CPPSTDIN is that this program will never be a * pointer to a shell wrapper, i.e. it will be empty if no preprocessor is * available directly to the user. Note that it may well be different from * the preprocessor used to compile the C program. */ /* CPPLAST: * This symbol is intended to be used along with CPPRUN in the same manner * symbol CPPMINUS is used with CPPSTDIN. It contains either "-" or "". */ #ifndef _MSC_VER # define CPPSTDIN "gcc -E" # define CPPMINUS "-" # define CPPRUN "gcc -E" #else # define CPPSTDIN "cppstdin" # define CPPMINUS "" # define CPPRUN "cl -nologo -E" #endif #define CPPLAST "" /* HAS_ACCESS: * This manifest constant lets the C program know that the access() * system call is available to check for accessibility using real UID/GID. * (always present on UNIX.) */ #define HAS_ACCESS /**/ /* HAS_ACCESSX: * This symbol, if defined, indicates that the accessx routine is * available to do extended access checks. */ /*#define HAS_ACCESSX / **/ /* HAS_ASCTIME_R: * This symbol, if defined, indicates that the asctime_r routine * is available to asctime re-entrantly. */ /* ASCTIME_R_PROTO: * This symbol encodes the prototype of asctime_r. * It is zero if d_asctime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_asctime_r * is defined. */ /*#define HAS_ASCTIME_R / **/ #define ASCTIME_R_PROTO 0 /**/ /* The HASATTRIBUTE_* defines are left undefined here because they vary from * one version of GCC to another. Instead, they are defined on the basis of * the compiler version in . */ /* HASATTRIBUTE_FORMAT: * Can we handle GCC attribute for checking printf-style formats */ /* PRINTF_FORMAT_NULL_OK: * Allows __printf__ format to be null when checking printf-style */ /* HASATTRIBUTE_MALLOC: * Can we handle GCC attribute for malloc-style functions. */ /* HASATTRIBUTE_NONNULL: * Can we handle GCC attribute for nonnull function parms. */ /* HASATTRIBUTE_NORETURN: * Can we handle GCC attribute for functions that do not return */ /* HASATTRIBUTE_PURE: * Can we handle GCC attribute for pure functions */ /* HASATTRIBUTE_UNUSED: * Can we handle GCC attribute for unused variables and arguments */ /* HASATTRIBUTE_DEPRECATED: * Can we handle GCC attribute for marking deprecated APIs */ /* HASATTRIBUTE_WARN_UNUSED_RESULT: * Can we handle GCC attribute for warning on unused results */ /*#define HASATTRIBUTE_DEPRECATED / **/ /*#define HASATTRIBUTE_FORMAT / **/ /*#define PRINTF_FORMAT_NULL_OK / **/ /*#define HASATTRIBUTE_NORETURN / **/ /*#define HASATTRIBUTE_MALLOC / **/ /*#define HASATTRIBUTE_NONNULL / **/ /*#define HASATTRIBUTE_PURE / **/ /*#define HASATTRIBUTE_UNUSED / **/ /*#define HASATTRIBUTE_WARN_UNUSED_RESULT / **/ /* HASCONST: * This symbol, if defined, indicates that this C compiler knows about * the const type. There is no need to actually test for that symbol * within your programs. The mere use of the "const" keyword will * trigger the necessary tests. */ #define HASCONST /**/ #ifndef HASCONST #define const #endif /* HAS_CRYPT_R: * This symbol, if defined, indicates that the crypt_r routine * is available to crypt re-entrantly. */ /* CRYPT_R_PROTO: * This symbol encodes the prototype of crypt_r. * It is zero if d_crypt_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_crypt_r * is defined. */ /*#define HAS_CRYPT_R / **/ #define CRYPT_R_PROTO 0 /**/ /* HAS_CSH: * This symbol, if defined, indicates that the C-shell exists. */ /* CSH: * This symbol, if defined, contains the full pathname of csh. */ /*#define HAS_CSH / **/ #ifdef HAS_CSH #define CSH "" /**/ #endif /* HAS_CTERMID_R: * This symbol, if defined, indicates that the ctermid_r routine * is available to ctermid re-entrantly. */ /* CTERMID_R_PROTO: * This symbol encodes the prototype of ctermid_r. * It is zero if d_ctermid_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ctermid_r * is defined. */ /*#define HAS_CTERMID_R / **/ #define CTERMID_R_PROTO 0 /**/ /* HAS_CTIME_R: * This symbol, if defined, indicates that the ctime_r routine * is available to ctime re-entrantly. */ /* CTIME_R_PROTO: * This symbol encodes the prototype of ctime_r. * It is zero if d_ctime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ctime_r * is defined. */ /*#define HAS_CTIME_R / **/ #define CTIME_R_PROTO 0 /**/ /* HAS_DRAND48_R: * This symbol, if defined, indicates that the drand48_r routine * is available to drand48 re-entrantly. */ /* DRAND48_R_PROTO: * This symbol encodes the prototype of drand48_r. * It is zero if d_drand48_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_drand48_r * is defined. */ /*#define HAS_DRAND48_R / **/ #define DRAND48_R_PROTO 0 /**/ /* HAS_DRAND48_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the drand48() function. Otherwise, it is up * to the program to supply one. A good guess is * extern double drand48(void); */ /*#define HAS_DRAND48_PROTO / **/ /* HAS_EACCESS: * This symbol, if defined, indicates that the eaccess routine is * available to do extended access checks. */ /*#define HAS_EACCESS / **/ /* HAS_ENDGRENT: * This symbol, if defined, indicates that the getgrent routine is * available for finalizing sequential access of the group database. */ /*#define HAS_ENDGRENT / **/ /* HAS_ENDGRENT_R: * This symbol, if defined, indicates that the endgrent_r routine * is available to endgrent re-entrantly. */ /* ENDGRENT_R_PROTO: * This symbol encodes the prototype of endgrent_r. * It is zero if d_endgrent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endgrent_r * is defined. */ /*#define HAS_ENDGRENT_R / **/ #define ENDGRENT_R_PROTO 0 /**/ /* HAS_ENDHOSTENT: * This symbol, if defined, indicates that the endhostent() routine is * available to close whatever was being used for host queries. */ /*#define HAS_ENDHOSTENT / **/ /* HAS_ENDHOSTENT_R: * This symbol, if defined, indicates that the endhostent_r routine * is available to endhostent re-entrantly. */ /* ENDHOSTENT_R_PROTO: * This symbol encodes the prototype of endhostent_r. * It is zero if d_endhostent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endhostent_r * is defined. */ /*#define HAS_ENDHOSTENT_R / **/ #define ENDHOSTENT_R_PROTO 0 /**/ /* HAS_ENDNETENT: * This symbol, if defined, indicates that the endnetent() routine is * available to close whatever was being used for network queries. */ /*#define HAS_ENDNETENT / **/ /* HAS_ENDNETENT_R: * This symbol, if defined, indicates that the endnetent_r routine * is available to endnetent re-entrantly. */ /* ENDNETENT_R_PROTO: * This symbol encodes the prototype of endnetent_r. * It is zero if d_endnetent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endnetent_r * is defined. */ /*#define HAS_ENDNETENT_R / **/ #define ENDNETENT_R_PROTO 0 /**/ /* HAS_ENDPROTOENT: * This symbol, if defined, indicates that the endprotoent() routine is * available to close whatever was being used for protocol queries. */ /*#define HAS_ENDPROTOENT / **/ /* HAS_ENDPROTOENT_R: * This symbol, if defined, indicates that the endprotoent_r routine * is available to endprotoent re-entrantly. */ /* ENDPROTOENT_R_PROTO: * This symbol encodes the prototype of endprotoent_r. * It is zero if d_endprotoent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endprotoent_r * is defined. */ /*#define HAS_ENDPROTOENT_R / **/ #define ENDPROTOENT_R_PROTO 0 /**/ /* HAS_ENDPWENT: * This symbol, if defined, indicates that the getgrent routine is * available for finalizing sequential access of the passwd database. */ /*#define HAS_ENDPWENT / **/ /* HAS_ENDPWENT_R: * This symbol, if defined, indicates that the endpwent_r routine * is available to endpwent re-entrantly. */ /* ENDPWENT_R_PROTO: * This symbol encodes the prototype of endpwent_r. * It is zero if d_endpwent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endpwent_r * is defined. */ /*#define HAS_ENDPWENT_R / **/ #define ENDPWENT_R_PROTO 0 /**/ /* HAS_ENDSERVENT: * This symbol, if defined, indicates that the endservent() routine is * available to close whatever was being used for service queries. */ /*#define HAS_ENDSERVENT / **/ /* HAS_ENDSERVENT_R: * This symbol, if defined, indicates that the endservent_r routine * is available to endservent re-entrantly. */ /* ENDSERVENT_R_PROTO: * This symbol encodes the prototype of endservent_r. * It is zero if d_endservent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endservent_r * is defined. */ /*#define HAS_ENDSERVENT_R / **/ #define ENDSERVENT_R_PROTO 0 /**/ /* FLEXFILENAMES: * This symbol, if defined, indicates that the system supports filenames * longer than 14 characters. */ #define FLEXFILENAMES /**/ /* HAS_GETGRENT: * This symbol, if defined, indicates that the getgrent routine is * available for sequential access of the group database. */ /*#define HAS_GETGRENT / **/ /* HAS_GETGRENT_R: * This symbol, if defined, indicates that the getgrent_r routine * is available to getgrent re-entrantly. */ /* GETGRENT_R_PROTO: * This symbol encodes the prototype of getgrent_r. * It is zero if d_getgrent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrent_r * is defined. */ /*#define HAS_GETGRENT_R / **/ #define GETGRENT_R_PROTO 0 /**/ /* HAS_GETGRGID_R: * This symbol, if defined, indicates that the getgrgid_r routine * is available to getgrgid re-entrantly. */ /* GETGRGID_R_PROTO: * This symbol encodes the prototype of getgrgid_r. * It is zero if d_getgrgid_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrgid_r * is defined. */ /*#define HAS_GETGRGID_R / **/ #define GETGRGID_R_PROTO 0 /**/ /* HAS_GETGRNAM_R: * This symbol, if defined, indicates that the getgrnam_r routine * is available to getgrnam re-entrantly. */ /* GETGRNAM_R_PROTO: * This symbol encodes the prototype of getgrnam_r. * It is zero if d_getgrnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrnam_r * is defined. */ /*#define HAS_GETGRNAM_R / **/ #define GETGRNAM_R_PROTO 0 /**/ /* HAS_GETHOSTBYADDR: * This symbol, if defined, indicates that the gethostbyaddr() routine is * available to look up hosts by their IP addresses. */ #define HAS_GETHOSTBYADDR /**/ /* HAS_GETHOSTBYNAME: * This symbol, if defined, indicates that the gethostbyname() routine is * available to look up host names in some data base or other. */ #define HAS_GETHOSTBYNAME /**/ /* HAS_GETHOSTENT: * This symbol, if defined, indicates that the gethostent() routine is * available to look up host names in some data base or another. */ /*#define HAS_GETHOSTENT / **/ /* HAS_GETHOSTNAME: * This symbol, if defined, indicates that the C program may use the * gethostname() routine to derive the host name. See also HAS_UNAME * and PHOSTNAME. */ /* HAS_UNAME: * This symbol, if defined, indicates that the C program may use the * uname() routine to derive the host name. See also HAS_GETHOSTNAME * and PHOSTNAME. */ /* PHOSTNAME: * This symbol, if defined, indicates the command to feed to the * popen() routine to derive the host name. See also HAS_GETHOSTNAME * and HAS_UNAME. Note that the command uses a fully qualified path, * so that it is safe even if used by a process with super-user * privileges. */ /* HAS_PHOSTNAME: * This symbol, if defined, indicates that the C program may use the * contents of PHOSTNAME as a command to feed to the popen() routine * to derive the host name. */ #define HAS_GETHOSTNAME /**/ #define HAS_UNAME /**/ /*#define HAS_PHOSTNAME / **/ #ifdef HAS_PHOSTNAME #define PHOSTNAME "" /* How to get the host name */ #endif /* HAS_GETHOSTBYADDR_R: * This symbol, if defined, indicates that the gethostbyaddr_r routine * is available to gethostbyaddr re-entrantly. */ /* GETHOSTBYADDR_R_PROTO: * This symbol encodes the prototype of gethostbyaddr_r. * It is zero if d_gethostbyaddr_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostbyaddr_r * is defined. */ /*#define HAS_GETHOSTBYADDR_R / **/ #define GETHOSTBYADDR_R_PROTO 0 /**/ /* HAS_GETHOSTBYNAME_R: * This symbol, if defined, indicates that the gethostbyname_r routine * is available to gethostbyname re-entrantly. */ /* GETHOSTBYNAME_R_PROTO: * This symbol encodes the prototype of gethostbyname_r. * It is zero if d_gethostbyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostbyname_r * is defined. */ /*#define HAS_GETHOSTBYNAME_R / **/ #define GETHOSTBYNAME_R_PROTO 0 /**/ /* HAS_GETHOSTENT_R: * This symbol, if defined, indicates that the gethostent_r routine * is available to gethostent re-entrantly. */ /* GETHOSTENT_R_PROTO: * This symbol encodes the prototype of gethostent_r. * It is zero if d_gethostent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostent_r * is defined. */ /*#define HAS_GETHOSTENT_R / **/ #define GETHOSTENT_R_PROTO 0 /**/ /* HAS_GETHOST_PROTOS: * This symbol, if defined, indicates that includes * prototypes for gethostent(), gethostbyname(), and * gethostbyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ #define HAS_GETHOST_PROTOS /**/ /* HAS_GETLOGIN_R: * This symbol, if defined, indicates that the getlogin_r routine * is available to getlogin re-entrantly. */ /* GETLOGIN_R_PROTO: * This symbol encodes the prototype of getlogin_r. * It is zero if d_getlogin_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getlogin_r * is defined. */ /*#define HAS_GETLOGIN_R / **/ #define GETLOGIN_R_PROTO 0 /**/ /* HAS_GETNETBYADDR: * This symbol, if defined, indicates that the getnetbyaddr() routine is * available to look up networks by their IP addresses. */ /*#define HAS_GETNETBYADDR / **/ /* HAS_GETNETBYNAME: * This symbol, if defined, indicates that the getnetbyname() routine is * available to look up networks by their names. */ /*#define HAS_GETNETBYNAME / **/ /* HAS_GETNETENT: * This symbol, if defined, indicates that the getnetent() routine is * available to look up network names in some data base or another. */ /*#define HAS_GETNETENT / **/ /* HAS_GETNETBYADDR_R: * This symbol, if defined, indicates that the getnetbyaddr_r routine * is available to getnetbyaddr re-entrantly. */ /* GETNETBYADDR_R_PROTO: * This symbol encodes the prototype of getnetbyaddr_r. * It is zero if d_getnetbyaddr_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetbyaddr_r * is defined. */ /*#define HAS_GETNETBYADDR_R / **/ #define GETNETBYADDR_R_PROTO 0 /**/ /* HAS_GETNETBYNAME_R: * This symbol, if defined, indicates that the getnetbyname_r routine * is available to getnetbyname re-entrantly. */ /* GETNETBYNAME_R_PROTO: * This symbol encodes the prototype of getnetbyname_r. * It is zero if d_getnetbyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetbyname_r * is defined. */ /*#define HAS_GETNETBYNAME_R / **/ #define GETNETBYNAME_R_PROTO 0 /**/ /* HAS_GETNETENT_R: * This symbol, if defined, indicates that the getnetent_r routine * is available to getnetent re-entrantly. */ /* GETNETENT_R_PROTO: * This symbol encodes the prototype of getnetent_r. * It is zero if d_getnetent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetent_r * is defined. */ /*#define HAS_GETNETENT_R / **/ #define GETNETENT_R_PROTO 0 /**/ /* HAS_GETNET_PROTOS: * This symbol, if defined, indicates that includes * prototypes for getnetent(), getnetbyname(), and * getnetbyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ /*#define HAS_GETNET_PROTOS / **/ /* HAS_GETPROTOENT: * This symbol, if defined, indicates that the getprotoent() routine is * available to look up protocols in some data base or another. */ /*#define HAS_GETPROTOENT / **/ /* HAS_GETPGRP: * This symbol, if defined, indicates that the getpgrp routine is * available to get the current process group. */ /* USE_BSD_GETPGRP: * This symbol, if defined, indicates that getpgrp needs one * arguments whereas USG one needs none. */ /*#define HAS_GETPGRP / **/ /*#define USE_BSD_GETPGRP / **/ /* HAS_GETPROTOBYNAME: * This symbol, if defined, indicates that the getprotobyname() * routine is available to look up protocols by their name. */ /* HAS_GETPROTOBYNUMBER: * This symbol, if defined, indicates that the getprotobynumber() * routine is available to look up protocols by their number. */ #define HAS_GETPROTOBYNAME /**/ #define HAS_GETPROTOBYNUMBER /**/ /* HAS_GETPROTOBYNAME_R: * This symbol, if defined, indicates that the getprotobyname_r routine * is available to getprotobyname re-entrantly. */ /* GETPROTOBYNAME_R_PROTO: * This symbol encodes the prototype of getprotobyname_r. * It is zero if d_getprotobyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotobyname_r * is defined. */ /*#define HAS_GETPROTOBYNAME_R / **/ #define GETPROTOBYNAME_R_PROTO 0 /**/ /* HAS_GETPROTOBYNUMBER_R: * This symbol, if defined, indicates that the getprotobynumber_r routine * is available to getprotobynumber re-entrantly. */ /* GETPROTOBYNUMBER_R_PROTO: * This symbol encodes the prototype of getprotobynumber_r. * It is zero if d_getprotobynumber_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotobynumber_r * is defined. */ /*#define HAS_GETPROTOBYNUMBER_R / **/ #define GETPROTOBYNUMBER_R_PROTO 0 /**/ /* HAS_GETPROTOENT_R: * This symbol, if defined, indicates that the getprotoent_r routine * is available to getprotoent re-entrantly. */ /* GETPROTOENT_R_PROTO: * This symbol encodes the prototype of getprotoent_r. * It is zero if d_getprotoent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotoent_r * is defined. */ /*#define HAS_GETPROTOENT_R / **/ #define GETPROTOENT_R_PROTO 0 /**/ /* HAS_GETPROTO_PROTOS: * This symbol, if defined, indicates that includes * prototypes for getprotoent(), getprotobyname(), and * getprotobyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ #define HAS_GETPROTO_PROTOS /**/ /* HAS_GETPWENT: * This symbol, if defined, indicates that the getpwent routine is * available for sequential access of the passwd database. * If this is not available, the older getpw() function may be available. */ /*#define HAS_GETPWENT / **/ /* HAS_GETPWENT_R: * This symbol, if defined, indicates that the getpwent_r routine * is available to getpwent re-entrantly. */ /* GETPWENT_R_PROTO: * This symbol encodes the prototype of getpwent_r. * It is zero if d_getpwent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwent_r * is defined. */ /*#define HAS_GETPWENT_R / **/ #define GETPWENT_R_PROTO 0 /**/ /* HAS_GETPWNAM_R: * This symbol, if defined, indicates that the getpwnam_r routine * is available to getpwnam re-entrantly. */ /* GETPWNAM_R_PROTO: * This symbol encodes the prototype of getpwnam_r. * It is zero if d_getpwnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwnam_r * is defined. */ /*#define HAS_GETPWNAM_R / **/ #define GETPWNAM_R_PROTO 0 /**/ /* HAS_GETPWUID_R: * This symbol, if defined, indicates that the getpwuid_r routine * is available to getpwuid re-entrantly. */ /* GETPWUID_R_PROTO: * This symbol encodes the prototype of getpwuid_r. * It is zero if d_getpwuid_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwuid_r * is defined. */ /*#define HAS_GETPWUID_R / **/ #define GETPWUID_R_PROTO 0 /**/ /* HAS_GETSERVENT: * This symbol, if defined, indicates that the getservent() routine is * available to look up network services in some data base or another. */ /*#define HAS_GETSERVENT / **/ /* HAS_GETSERVBYNAME_R: * This symbol, if defined, indicates that the getservbyname_r routine * is available to getservbyname re-entrantly. */ /* GETSERVBYNAME_R_PROTO: * This symbol encodes the prototype of getservbyname_r. * It is zero if d_getservbyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservbyname_r * is defined. */ /*#define HAS_GETSERVBYNAME_R / **/ #define GETSERVBYNAME_R_PROTO 0 /**/ /* HAS_GETSERVBYPORT_R: * This symbol, if defined, indicates that the getservbyport_r routine * is available to getservbyport re-entrantly. */ /* GETSERVBYPORT_R_PROTO: * This symbol encodes the prototype of getservbyport_r. * It is zero if d_getservbyport_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservbyport_r * is defined. */ /*#define HAS_GETSERVBYPORT_R / **/ #define GETSERVBYPORT_R_PROTO 0 /**/ /* HAS_GETSERVENT_R: * This symbol, if defined, indicates that the getservent_r routine * is available to getservent re-entrantly. */ /* GETSERVENT_R_PROTO: * This symbol encodes the prototype of getservent_r. * It is zero if d_getservent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservent_r * is defined. */ /*#define HAS_GETSERVENT_R / **/ #define GETSERVENT_R_PROTO 0 /**/ /* HAS_GETSERV_PROTOS: * This symbol, if defined, indicates that includes * prototypes for getservent(), getservbyname(), and * getservbyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ #define HAS_GETSERV_PROTOS /**/ /* HAS_GETSPNAM_R: * This symbol, if defined, indicates that the getspnam_r routine * is available to getspnam re-entrantly. */ /* GETSPNAM_R_PROTO: * This symbol encodes the prototype of getspnam_r. * It is zero if d_getspnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getspnam_r * is defined. */ /*#define HAS_GETSPNAM_R / **/ #define GETSPNAM_R_PROTO 0 /**/ /* HAS_GETSERVBYNAME: * This symbol, if defined, indicates that the getservbyname() * routine is available to look up services by their name. */ /* HAS_GETSERVBYPORT: * This symbol, if defined, indicates that the getservbyport() * routine is available to look up services by their port. */ #define HAS_GETSERVBYNAME /**/ #define HAS_GETSERVBYPORT /**/ /* HAS_GMTIME_R: * This symbol, if defined, indicates that the gmtime_r routine * is available to gmtime re-entrantly. */ /* GMTIME_R_PROTO: * This symbol encodes the prototype of gmtime_r. * It is zero if d_gmtime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gmtime_r * is defined. */ /*#define HAS_GMTIME_R / **/ #define GMTIME_R_PROTO 0 /**/ /* HAS_HTONL: * This symbol, if defined, indicates that the htonl() routine (and * friends htons() ntohl() ntohs()) are available to do network * order byte swapping. */ /* HAS_HTONS: * This symbol, if defined, indicates that the htons() routine (and * friends htonl() ntohl() ntohs()) are available to do network * order byte swapping. */ /* HAS_NTOHL: * This symbol, if defined, indicates that the ntohl() routine (and * friends htonl() htons() ntohs()) are available to do network * order byte swapping. */ /* HAS_NTOHS: * This symbol, if defined, indicates that the ntohs() routine (and * friends htonl() htons() ntohl()) are available to do network * order byte swapping. */ #define HAS_HTONL /**/ #define HAS_HTONS /**/ #define HAS_NTOHL /**/ #define HAS_NTOHS /**/ /* HAS_LOCALTIME_R: * This symbol, if defined, indicates that the localtime_r routine * is available to localtime re-entrantly. */ /* LOCALTIME_R_NEEDS_TZSET: * Many libc's localtime_r implementations do not call tzset, * making them differ from localtime(), and making timezone * changes using \undef{TZ} without explicitly calling tzset * impossible. This symbol makes us call tzset before localtime_r */ /*#define LOCALTIME_R_NEEDS_TZSET / **/ #ifdef LOCALTIME_R_NEEDS_TZSET #define L_R_TZSET tzset(), #else #define L_R_TZSET #endif /* LOCALTIME_R_PROTO: * This symbol encodes the prototype of localtime_r. * It is zero if d_localtime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_localtime_r * is defined. */ /*#define HAS_LOCALTIME_R / **/ #define LOCALTIME_R_PROTO 0 /**/ /* HAS_LONG_DOUBLE: * This symbol will be defined if the C compiler supports long * doubles. */ /* LONG_DOUBLESIZE: * This symbol contains the size of a long double, so that the * C preprocessor can make decisions based on it. It is only * defined if the system supports long doubles. */ #define HAS_LONG_DOUBLE /**/ #ifdef HAS_LONG_DOUBLE # ifndef _MSC_VER # define LONG_DOUBLESIZE 12 /**/ # else # define LONG_DOUBLESIZE 8 /**/ # endif #endif /* HAS_LONG_LONG: * This symbol will be defined if the C compiler supports long long. */ /* LONGLONGSIZE: * This symbol contains the size of a long long, so that the * C preprocessor can make decisions based on it. It is only * defined if the system supports long long. */ /*#define HAS_LONG_LONG / **/ #ifdef HAS_LONG_LONG #define LONGLONGSIZE 8 /**/ #endif /* HAS_LSEEK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the lseek() function. Otherwise, it is up * to the program to supply one. A good guess is * extern off_t lseek(int, off_t, int); */ #define HAS_LSEEK_PROTO /**/ /* HAS_MEMCHR: * This symbol, if defined, indicates that the memchr routine is available * to locate characters within a C string. */ #define HAS_MEMCHR /**/ /* HAS_MKSTEMP: * This symbol, if defined, indicates that the mkstemp routine is * available to exclusively create and open a uniquely named * temporary file. */ /*#define HAS_MKSTEMP / **/ /* HAS_MMAP: * This symbol, if defined, indicates that the mmap system call is * available to map a file into memory. */ /* Mmap_t: * This symbol holds the return type of the mmap() system call * (and simultaneously the type of the first argument). * Usually set to 'void *' or 'caddr_t'. */ /*#define HAS_MMAP / **/ #define Mmap_t void * /**/ /* HAS_MSG: * This symbol, if defined, indicates that the entire msg*(2) library is * supported (IPC mechanism based on message queues). */ /*#define HAS_MSG / **/ /* OLD_PTHREAD_CREATE_JOINABLE: * This symbol, if defined, indicates how to create pthread * in joinable (aka undetached) state. NOTE: not defined * if pthread.h already has defined PTHREAD_CREATE_JOINABLE * (the new version of the constant). * If defined, known values are PTHREAD_CREATE_UNDETACHED * and __UNDETACHED. */ /*#define OLD_PTHREAD_CREATE_JOINABLE / **/ /* HAS_PTHREAD_ATFORK: * This symbol, if defined, indicates that the pthread_atfork routine * is available to setup fork handlers. */ /*#define HAS_PTHREAD_ATFORK / **/ /* HAS_PTHREAD_YIELD: * This symbol, if defined, indicates that the pthread_yield * routine is available to yield the execution of the current * thread. sched_yield is preferable to pthread_yield. */ /* SCHED_YIELD: * This symbol defines the way to yield the execution of * the current thread. Known ways are sched_yield, * pthread_yield, and pthread_yield with NULL. */ /* HAS_SCHED_YIELD: * This symbol, if defined, indicates that the sched_yield * routine is available to yield the execution of the current * thread. sched_yield is preferable to pthread_yield. */ /*#define HAS_PTHREAD_YIELD / **/ #define SCHED_YIELD /**/ /*#define HAS_SCHED_YIELD / **/ /* HAS_RANDOM_R: * This symbol, if defined, indicates that the random_r routine * is available to random re-entrantly. */ /* RANDOM_R_PROTO: * This symbol encodes the prototype of random_r. * It is zero if d_random_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_random_r * is defined. */ /*#define HAS_RANDOM_R / **/ #define RANDOM_R_PROTO 0 /**/ /* HAS_READDIR64_R: * This symbol, if defined, indicates that the readdir64_r routine * is available to readdir64 re-entrantly. */ /* READDIR64_R_PROTO: * This symbol encodes the prototype of readdir64_r. * It is zero if d_readdir64_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_readdir64_r * is defined. */ /*#define HAS_READDIR64_R / **/ #define READDIR64_R_PROTO 0 /**/ /* HAS_READDIR_R: * This symbol, if defined, indicates that the readdir_r routine * is available to readdir re-entrantly. */ /* READDIR_R_PROTO: * This symbol encodes the prototype of readdir_r. * It is zero if d_readdir_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_readdir_r * is defined. */ /*#define HAS_READDIR_R / **/ #define READDIR_R_PROTO 0 /**/ /* HAS_SEM: * This symbol, if defined, indicates that the entire sem*(2) library is * supported. */ /*#define HAS_SEM / **/ /* HAS_SETGRENT: * This symbol, if defined, indicates that the setgrent routine is * available for initializing sequential access of the group database. */ /*#define HAS_SETGRENT / **/ /* HAS_SETGRENT_R: * This symbol, if defined, indicates that the setgrent_r routine * is available to setgrent re-entrantly. */ /* SETGRENT_R_PROTO: * This symbol encodes the prototype of setgrent_r. * It is zero if d_setgrent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setgrent_r * is defined. */ /*#define HAS_SETGRENT_R / **/ #define SETGRENT_R_PROTO 0 /**/ /* HAS_SETHOSTENT: * This symbol, if defined, indicates that the sethostent() routine is * available. */ /*#define HAS_SETHOSTENT / **/ /* HAS_SETHOSTENT_R: * This symbol, if defined, indicates that the sethostent_r routine * is available to sethostent re-entrantly. */ /* SETHOSTENT_R_PROTO: * This symbol encodes the prototype of sethostent_r. * It is zero if d_sethostent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_sethostent_r * is defined. */ /*#define HAS_SETHOSTENT_R / **/ #define SETHOSTENT_R_PROTO 0 /**/ /* HAS_SETLOCALE_R: * This symbol, if defined, indicates that the setlocale_r routine * is available to setlocale re-entrantly. */ /* SETLOCALE_R_PROTO: * This symbol encodes the prototype of setlocale_r. * It is zero if d_setlocale_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setlocale_r * is defined. */ /*#define HAS_SETLOCALE_R / **/ #define SETLOCALE_R_PROTO 0 /**/ /* HAS_SETNETENT: * This symbol, if defined, indicates that the setnetent() routine is * available. */ /*#define HAS_SETNETENT / **/ /* HAS_SETNETENT_R: * This symbol, if defined, indicates that the setnetent_r routine * is available to setnetent re-entrantly. */ /* SETNETENT_R_PROTO: * This symbol encodes the prototype of setnetent_r. * It is zero if d_setnetent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setnetent_r * is defined. */ /*#define HAS_SETNETENT_R / **/ #define SETNETENT_R_PROTO 0 /**/ /* HAS_SETPROTOENT: * This symbol, if defined, indicates that the setprotoent() routine is * available. */ /*#define HAS_SETPROTOENT / **/ /* HAS_SETPGRP: * This symbol, if defined, indicates that the setpgrp routine is * available to set the current process group. */ /* USE_BSD_SETPGRP: * This symbol, if defined, indicates that setpgrp needs two * arguments whereas USG one needs none. See also HAS_SETPGID * for a POSIX interface. */ /*#define HAS_SETPGRP / **/ /*#define USE_BSD_SETPGRP / **/ /* HAS_SETPROTOENT_R: * This symbol, if defined, indicates that the setprotoent_r routine * is available to setprotoent re-entrantly. */ /* SETPROTOENT_R_PROTO: * This symbol encodes the prototype of setprotoent_r. * It is zero if d_setprotoent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setprotoent_r * is defined. */ /*#define HAS_SETPROTOENT_R / **/ #define SETPROTOENT_R_PROTO 0 /**/ /* HAS_SETPWENT: * This symbol, if defined, indicates that the setpwent routine is * available for initializing sequential access of the passwd database. */ /*#define HAS_SETPWENT / **/ /* HAS_SETPWENT_R: * This symbol, if defined, indicates that the setpwent_r routine * is available to setpwent re-entrantly. */ /* SETPWENT_R_PROTO: * This symbol encodes the prototype of setpwent_r. * It is zero if d_setpwent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setpwent_r * is defined. */ /*#define HAS_SETPWENT_R / **/ #define SETPWENT_R_PROTO 0 /**/ /* HAS_SETSERVENT: * This symbol, if defined, indicates that the setservent() routine is * available. */ /*#define HAS_SETSERVENT / **/ /* HAS_SETSERVENT_R: * This symbol, if defined, indicates that the setservent_r routine * is available to setservent re-entrantly. */ /* SETSERVENT_R_PROTO: * This symbol encodes the prototype of setservent_r. * It is zero if d_setservent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setservent_r * is defined. */ /*#define HAS_SETSERVENT_R / **/ #define SETSERVENT_R_PROTO 0 /**/ /* HAS_SETVBUF: * This symbol, if defined, indicates that the setvbuf routine is * available to change buffering on an open stdio stream. * to a line-buffered mode. */ #define HAS_SETVBUF /**/ /* HAS_SHM: * This symbol, if defined, indicates that the entire shm*(2) library is * supported. */ /*#define HAS_SHM / **/ /* Shmat_t: * This symbol holds the return type of the shmat() system call. * Usually set to 'void *' or 'char *'. */ /* HAS_SHMAT_PROTOTYPE: * This symbol, if defined, indicates that the sys/shm.h includes * a prototype for shmat(). Otherwise, it is up to the program to * guess one. Shmat_t shmat(int, Shmat_t, int) is a good guess, * but not always right so it should be emitted by the program only * when HAS_SHMAT_PROTOTYPE is not defined to avoid conflicting defs. */ #define Shmat_t void * /**/ /*#define HAS_SHMAT_PROTOTYPE / **/ /* HAS_SOCKET: * This symbol, if defined, indicates that the BSD socket interface is * supported. */ /* HAS_SOCKETPAIR: * This symbol, if defined, indicates that the BSD socketpair() call is * supported. */ /* HAS_MSG_CTRUNC: * This symbol, if defined, indicates that the MSG_CTRUNC is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_DONTROUTE: * This symbol, if defined, indicates that the MSG_DONTROUTE is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_OOB: * This symbol, if defined, indicates that the MSG_OOB is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_PEEK: * This symbol, if defined, indicates that the MSG_PEEK is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_PROXY: * This symbol, if defined, indicates that the MSG_PROXY is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_SCM_RIGHTS: * This symbol, if defined, indicates that the SCM_RIGHTS is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ #define HAS_SOCKET /**/ /*#define HAS_SOCKETPAIR / **/ /*#define HAS_MSG_CTRUNC / **/ /*#define HAS_MSG_DONTROUTE / **/ /*#define HAS_MSG_OOB / **/ /*#define HAS_MSG_PEEK / **/ /*#define HAS_MSG_PROXY / **/ /*#define HAS_SCM_RIGHTS / **/ /* HAS_SRAND48_R: * This symbol, if defined, indicates that the srand48_r routine * is available to srand48 re-entrantly. */ /* SRAND48_R_PROTO: * This symbol encodes the prototype of srand48_r. * It is zero if d_srand48_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_srand48_r * is defined. */ /*#define HAS_SRAND48_R / **/ #define SRAND48_R_PROTO 0 /**/ /* HAS_SRANDOM_R: * This symbol, if defined, indicates that the srandom_r routine * is available to srandom re-entrantly. */ /* SRANDOM_R_PROTO: * This symbol encodes the prototype of srandom_r. * It is zero if d_srandom_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_srandom_r * is defined. */ /*#define HAS_SRANDOM_R / **/ #define SRANDOM_R_PROTO 0 /**/ /* USE_STAT_BLOCKS: * This symbol is defined if this system has a stat structure declaring * st_blksize and st_blocks. */ #ifndef USE_STAT_BLOCKS /*#define USE_STAT_BLOCKS / **/ #endif /* USE_STRUCT_COPY: * This symbol, if defined, indicates that this C compiler knows how * to copy structures. If undefined, you'll need to use a block copy * routine of some sort instead. */ #define USE_STRUCT_COPY /**/ /* HAS_STRERROR: * This symbol, if defined, indicates that the strerror routine is * available to translate error numbers to strings. See the writeup * of Strerror() in this file before you try to define your own. */ /* HAS_SYS_ERRLIST: * This symbol, if defined, indicates that the sys_errlist array is * available to translate error numbers to strings. The extern int * sys_nerr gives the size of that table. */ /* Strerror: * This preprocessor symbol is defined as a macro if strerror() is * not available to translate error numbers to strings but sys_errlist[] * array is there. */ #define HAS_STRERROR /**/ #define HAS_SYS_ERRLIST /**/ #define Strerror(e) strerror(e) /* HAS_STRERROR_R: * This symbol, if defined, indicates that the strerror_r routine * is available to strerror re-entrantly. */ /* STRERROR_R_PROTO: * This symbol encodes the prototype of strerror_r. * It is zero if d_strerror_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_strerror_r * is defined. */ /*#define HAS_STRERROR_R / **/ #define STRERROR_R_PROTO 0 /**/ /* HAS_STRTOUL: * This symbol, if defined, indicates that the strtoul routine is * available to provide conversion of strings to unsigned long. */ #define HAS_STRTOUL /**/ /* HAS_TIME: * This symbol, if defined, indicates that the time() routine exists. */ /* Time_t: * This symbol holds the type returned by time(). It can be long, * or time_t on BSD sites (in which case should be * included). */ #define HAS_TIME /**/ #define Time_t time_t /* Time type */ /* HAS_TIMES: * This symbol, if defined, indicates that the times() routine exists. * Note that this became obsolete on some systems (SUNOS), which now * use getrusage(). It may be necessary to include . */ #define HAS_TIMES /**/ /* HAS_TMPNAM_R: * This symbol, if defined, indicates that the tmpnam_r routine * is available to tmpnam re-entrantly. */ /* TMPNAM_R_PROTO: * This symbol encodes the prototype of tmpnam_r. * It is zero if d_tmpnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_tmpnam_r * is defined. */ /*#define HAS_TMPNAM_R / **/ #define TMPNAM_R_PROTO 0 /**/ /* HAS_TTYNAME_R: * This symbol, if defined, indicates that the ttyname_r routine * is available to ttyname re-entrantly. */ /* TTYNAME_R_PROTO: * This symbol encodes the prototype of ttyname_r. * It is zero if d_ttyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ttyname_r * is defined. */ /*#define HAS_TTYNAME_R / **/ #define TTYNAME_R_PROTO 0 /**/ /* HAS_UNION_SEMUN: * This symbol, if defined, indicates that the union semun is * defined by including . If not, the user code * probably needs to define it as: * union semun { * int val; * struct semid_ds *buf; * unsigned short *array; * } */ /* USE_SEMCTL_SEMUN: * This symbol, if defined, indicates that union semun is * used for semctl IPC_STAT. */ /* USE_SEMCTL_SEMID_DS: * This symbol, if defined, indicates that struct semid_ds * is * used for semctl IPC_STAT. */ #define HAS_UNION_SEMUN /**/ /*#define USE_SEMCTL_SEMUN / **/ /*#define USE_SEMCTL_SEMID_DS / **/ /* HAS_VFORK: * This symbol, if defined, indicates that vfork() exists. */ /*#define HAS_VFORK / **/ /* HAS_PSEUDOFORK: * This symbol, if defined, indicates that an emulation of the * fork routine is available. */ /*#define HAS_PSEUDOFORK / **/ /* Signal_t: * This symbol's value is either "void" or "int", corresponding to the * appropriate return type of a signal handler. Thus, you can declare * a signal handler using "Signal_t (*handler)()", and define the * handler using "Signal_t handler(sig)". */ #define Signal_t void /* Signal handler's return type */ /* HASVOLATILE: * This symbol, if defined, indicates that this C compiler knows about * the volatile declaration. */ #define HASVOLATILE /**/ #ifndef HASVOLATILE #define volatile #endif /* Fpos_t: * This symbol holds the type used to declare file positions in libc. * It can be fpos_t, long, uint, etc... It may be necessary to include * to get any typedef'ed information. */ #define Fpos_t fpos_t /* File position type */ /* Gid_t_f: * This symbol defines the format string used for printing a Gid_t. */ #define Gid_t_f "ld" /**/ /* Gid_t_sign: * This symbol holds the signedess of a Gid_t. * 1 for unsigned, -1 for signed. */ #define Gid_t_sign -1 /* GID sign */ /* Gid_t_size: * This symbol holds the size of a Gid_t in bytes. */ #define Gid_t_size 4 /* GID size */ /* Gid_t: * This symbol holds the return type of getgid() and the type of * argument to setrgid() and related functions. Typically, * it is the type of group ids in the kernel. It can be int, ushort, * gid_t, etc... It may be necessary to include to get * any typedef'ed information. */ #define Gid_t gid_t /* Type for getgid(), etc... */ /* I_DIRENT: * This symbol, if defined, indicates to the C program that it should * include . Using this symbol also triggers the definition * of the Direntry_t define which ends up being 'struct dirent' or * 'struct direct' depending on the availability of . */ /* DIRNAMLEN: * This symbol, if defined, indicates to the C program that the length * of directory entry names is provided by a d_namlen field. Otherwise * you need to do strlen() on the d_name field. */ /* Direntry_t: * This symbol is set to 'struct direct' or 'struct dirent' depending on * whether dirent is available or not. You should use this pseudo type to * portably declare your directory entries. */ #define I_DIRENT /**/ #define DIRNAMLEN /**/ #define Direntry_t struct direct /* I_GRP: * This symbol, if defined, indicates to the C program that it should * include . */ /* GRPASSWD: * This symbol, if defined, indicates to the C program that struct group * in contains gr_passwd. */ /*#define I_GRP / **/ /*#define GRPASSWD / **/ /* I_MACH_CTHREADS: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_MACH_CTHREADS / **/ /* I_NDBM: * This symbol, if defined, indicates that exists and should * be included. */ /* I_GDBMNDBM: * This symbol, if defined, indicates that exists and should * be included. This was the location of the ndbm.h compatibility file * in RedHat 7.1. */ /* I_GDBM_NDBM: * This symbol, if defined, indicates that exists and should * be included. This is the location of the ndbm.h compatibility file * in Debian 4.0. */ /* NDBM_H_USES_PROTOTYPES: * This symbol, if defined, indicates that uses real ANSI C * prototypes instead of K&R style function declarations without any * parameter information. While ANSI C prototypes are supported in C++, * K&R style function declarations will yield errors. */ /* GDBMNDBM_H_USES_PROTOTYPES: * This symbol, if defined, indicates that uses real ANSI C * prototypes instead of K&R style function declarations without any * parameter information. While ANSI C prototypes are supported in C++, * K&R style function declarations will yield errors. */ /* GDBM_NDBM_H_USES_PROTOTYPES: * This symbol, if defined, indicates that uses real ANSI C * prototypes instead of K&R style function declarations without any * parameter information. While ANSI C prototypes are supported in C++, * K&R style function declarations will yield errors. */ /*#define I_NDBM / **/ /*#define I_GDBMNDBM / **/ /*#define I_GDBM_NDBM / **/ /*#define NDBM_H_USES_PROTOTYPES / **/ /*#define GDBMNDBM_H_USES_PROTOTYPES / **/ /*#define GDBM_NDBM_H_USES_PROTOTYPES / **/ /* I_NETDB: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_NETDB / **/ /* I_NET_ERRNO: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_NET_ERRNO / **/ /* I_PTHREAD: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_PTHREAD / **/ /* I_PWD: * This symbol, if defined, indicates to the C program that it should * include . */ /* PWQUOTA: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_quota. */ /* PWAGE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_age. */ /* PWCHANGE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_change. */ /* PWCLASS: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_class. */ /* PWEXPIRE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_expire. */ /* PWCOMMENT: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_comment. */ /* PWGECOS: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_gecos. */ /* PWPASSWD: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_passwd. */ /*#define I_PWD / **/ /*#define PWQUOTA / **/ /*#define PWAGE / **/ /*#define PWCHANGE / **/ /*#define PWCLASS / **/ /*#define PWEXPIRE / **/ /*#define PWCOMMENT / **/ /*#define PWGECOS / **/ /*#define PWPASSWD / **/ /* I_SYS_ACCESS: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_ACCESS / **/ /* I_SYS_SECURITY: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_SECURITY / **/ /* I_SYSUIO: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSUIO / **/ /* I_STDARG: * This symbol, if defined, indicates that exists and should * be included. */ /* I_VARARGS: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_STDARG /**/ /*#define I_VARARGS / **/ /* PERL_INC_VERSION_LIST: * This variable specifies the list of subdirectories in over * which perl.c:incpush() and lib/lib.pm will automatically * search when adding directories to @INC, in a format suitable * for a C initialization string. See the inc_version_list entry * in Porting/Glossary for more details. */ /*#define PERL_INC_VERSION_LIST 0 / **/ /* INSTALL_USR_BIN_PERL: * This symbol, if defined, indicates that Perl is to be installed * also as /usr/bin/perl. */ /*#define INSTALL_USR_BIN_PERL / **/ /* Off_t: * This symbol holds the type used to declare offsets in the kernel. * It can be int, long, off_t, etc... It may be necessary to include * to get any typedef'ed information. */ /* LSEEKSIZE: * This symbol holds the number of bytes used by the Off_t. */ /* Off_t_size: * This symbol holds the number of bytes used by the Off_t. */ #define Off_t long /* type */ #define LSEEKSIZE 4 /* size */ #define Off_t_size 4 /* size */ /* Free_t: * This variable contains the return type of free(). It is usually * void, but occasionally int. */ /* Malloc_t: * This symbol is the type of pointer returned by malloc and realloc. */ #define Malloc_t void * /**/ #define Free_t void /**/ /* PERL_MALLOC_WRAP: * This symbol, if defined, indicates that we'd like malloc wrap checks. */ #define PERL_MALLOC_WRAP /**/ /* MYMALLOC: * This symbol, if defined, indicates that we're using our own malloc. */ /*#define MYMALLOC / **/ /* Mode_t: * This symbol holds the type used to declare file modes * for systems calls. It is usually mode_t, but may be * int or unsigned short. It may be necessary to include * to get any typedef'ed information. */ #define Mode_t mode_t /* file mode parameter for system calls */ /* Netdb_host_t: * This symbol holds the type used for the 1st argument * to gethostbyaddr(). */ /* Netdb_hlen_t: * This symbol holds the type used for the 2nd argument * to gethostbyaddr(). */ /* Netdb_name_t: * This symbol holds the type used for the argument to * gethostbyname(). */ /* Netdb_net_t: * This symbol holds the type used for the 1st argument to * getnetbyaddr(). */ #define Netdb_host_t char * /**/ #define Netdb_hlen_t int /**/ #define Netdb_name_t char * /**/ #define Netdb_net_t long /**/ /* PERL_OTHERLIBDIRS: * This variable contains a colon-separated set of paths for the perl * binary to search for additional library files or modules. * These directories will be tacked to the end of @INC. * Perl will automatically search below each path for version- * and architecture-specific directories. See PERL_INC_VERSION_LIST * for more details. */ /*#define PERL_OTHERLIBDIRS "" / **/ /* Pid_t: * This symbol holds the type used to declare process ids in the kernel. * It can be int, uint, pid_t, etc... It may be necessary to include * to get any typedef'ed information. */ #define Pid_t int /* PID type */ /* PRIVLIB: * This symbol contains the name of the private library for this package. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. The program * should be prepared to do ~ expansion. */ /* PRIVLIB_EXP: * This symbol contains the ~name expanded version of PRIVLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ #define PRIVLIB "c:\\perl\\lib" /**/ #define PRIVLIB_EXP (win32_get_privlib(PERL_VERSION_STRING, NULL)) /**/ /* CAN_PROTOTYPE: * If defined, this macro indicates that the C compiler can handle * function prototypes. */ /* _: * This macro is used to declare function parameters for folks who want * to make declarations with prototypes using a different style than * the above macros. Use double parentheses. For example: * * int main _((int argc, char *argv[])); */ #define CAN_PROTOTYPE /**/ #ifdef CAN_PROTOTYPE #define _(args) args #else #define _(args) () #endif /* Select_fd_set_t: * This symbol holds the type used for the 2nd, 3rd, and 4th * arguments to select. Usually, this is 'fd_set *', if HAS_FD_SET * is defined, and 'int *' otherwise. This is only useful if you * have select(), of course. */ #define Select_fd_set_t Perl_fd_set * /**/ /* SH_PATH: * This symbol contains the full pathname to the shell used on this * on this system to execute Bourne shell scripts. Usually, this will be * /bin/sh, though it's possible that some systems will have /bin/ksh, * /bin/pdksh, /bin/ash, /bin/bash, or even something such as * D:/bin/sh.exe. */ #define SH_PATH "cmd /x /c" /**/ /* SIG_NAME: * This symbol contains a list of signal names in order of * signal number. This is intended * to be used as a static array initialization, like this: * char *sig_name[] = { SIG_NAME }; * The signals in the list are separated with commas, and each signal * is surrounded by double quotes. There is no leading SIG in the signal * name, i.e. SIGQUIT is known as "QUIT". * Gaps in the signal numbers (up to NSIG) are filled in with NUMnn, * etc., where nn is the actual signal number (e.g. NUM37). * The signal number for sig_name[i] is stored in sig_num[i]. * The last element is 0 to terminate the list with a NULL. This * corresponds to the 0 at the end of the sig_name_init list. * Note that this variable is initialized from the sig_name_init, * not from sig_name (which is unused). */ /* SIG_NUM: * This symbol contains a list of signal numbers, in the same order as the * SIG_NAME list. It is suitable for static array initialization, as in: * int sig_num[] = { SIG_NUM }; * The signals in the list are separated with commas, and the indices * within that list and the SIG_NAME list match, so it's easy to compute * the signal name from a number or vice versa at the price of a small * dynamic linear lookup. * Duplicates are allowed, but are moved to the end of the list. * The signal number corresponding to sig_name[i] is sig_number[i]. * if (i < NSIG) then sig_number[i] == i. * The last element is 0, corresponding to the 0 at the end of * the sig_name_init list. * Note that this variable is initialized from the sig_num_init, * not from sig_num (which is unused). */ /* SIG_SIZE: * This variable contains the number of elements of the SIG_NAME * and SIG_NUM arrays, excluding the final NULL entry. */ #define SIG_NAME "ZERO", "HUP", "INT", "QUIT", "ILL", "NUM05", "NUM06", "NUM07", "FPE", "KILL", "NUM10", "SEGV", "NUM12", "PIPE", "ALRM", "TERM", "NUM16", "NUM17", "NUM18", "NUM19", "CHLD", "BREAK", "ABRT", "STOP", "NUM24", "CONT", "CLD", 0 /**/ #define SIG_NUM 0, 1, 2, 21, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 20, 0 /**/ #define SIG_SIZE 27 /**/ /* SITEARCH: * This symbol contains the name of the private library for this package. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. The program * should be prepared to do ~ expansion. * The standard distribution will put nothing in this directory. * After perl has been installed, users may install their own local * architecture-dependent modules in this directory with * MakeMaker Makefile.PL * or equivalent. See INSTALL for details. */ /* SITEARCH_EXP: * This symbol contains the ~name expanded version of SITEARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ #define SITEARCH "c:\\perl\\site\\lib" /**/ /*#define SITEARCH_EXP "" / **/ /* SITELIB: * This symbol contains the name of the private library for this package. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. The program * should be prepared to do ~ expansion. * The standard distribution will put nothing in this directory. * After perl has been installed, users may install their own local * architecture-independent modules in this directory with * MakeMaker Makefile.PL * or equivalent. See INSTALL for details. */ /* SITELIB_EXP: * This symbol contains the ~name expanded version of SITELIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ /* SITELIB_STEM: * This define is SITELIB_EXP with any trailing version-specific component * removed. The elements in inc_version_list (inc_version_list.U) can * be tacked onto this variable to generate a list of directories to search. */ #define SITELIB "c:\\perl\\site\\lib" /**/ #define SITELIB_EXP (win32_get_sitelib(PERL_VERSION_STRING, NULL)) /**/ #define SITELIB_STEM "" /**/ /* Size_t_size: * This symbol holds the size of a Size_t in bytes. */ #define Size_t_size 4 /**/ /* Size_t: * This symbol holds the type used to declare length parameters * for string functions. It is usually size_t, but may be * unsigned long, int, etc. It may be necessary to include * to get any typedef'ed information. */ #define Size_t size_t /* length paramater for string functions */ /* Sock_size_t: * This symbol holds the type used for the size argument of * various socket calls (just the base type, not the pointer-to). */ #define Sock_size_t int /**/ /* STDCHAR: * This symbol is defined to be the type of char used in stdio.h. * It has the values "unsigned char" or "char". */ #define STDCHAR char /**/ /* Uid_t_f: * This symbol defines the format string used for printing a Uid_t. */ #define Uid_t_f "ld" /**/ /* Uid_t_sign: * This symbol holds the signedess of a Uid_t. * 1 for unsigned, -1 for signed. */ #define Uid_t_sign -1 /* UID sign */ /* Uid_t_size: * This symbol holds the size of a Uid_t in bytes. */ #define Uid_t_size 4 /* UID size */ /* Uid_t: * This symbol holds the type used to declare user ids in the kernel. * It can be int, ushort, uid_t, etc... It may be necessary to include * to get any typedef'ed information. */ #define Uid_t uid_t /* UID type */ /* USE_ITHREADS: * This symbol, if defined, indicates that Perl should be built to * use the interpreter-based threading implementation. */ /* USE_5005THREADS: * This symbol, if defined, indicates that Perl should be built to * use the 5.005-based threading implementation. * Only valid up to 5.8.x. */ /* OLD_PTHREADS_API: * This symbol, if defined, indicates that Perl should * be built to use the old draft POSIX threads API. */ /* USE_REENTRANT_API: * This symbol, if defined, indicates that Perl should * try to use the various _r versions of library functions. * This is extremely experimental. */ /*#define USE_5005THREADS / **/ /*#define USE_ITHREADS / **/ #if defined(USE_5005THREADS) && !defined(USE_ITHREADS) #define USE_THREADS /* until src is revised*/ #endif /*#define OLD_PTHREADS_API / **/ /*#define USE_REENTRANT_API / **/ /* PERL_VENDORARCH: * If defined, this symbol contains the name of a private library. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. * It may have a ~ on the front. * The standard distribution will put nothing in this directory. * Vendors who distribute perl may wish to place their own * architecture-dependent modules and extensions in this directory with * MakeMaker Makefile.PL INSTALLDIRS=vendor * or equivalent. See INSTALL for details. */ /* PERL_VENDORARCH_EXP: * This symbol contains the ~name expanded version of PERL_VENDORARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ /*#define PERL_VENDORARCH "" / **/ /*#define PERL_VENDORARCH_EXP "" / **/ /* PERL_VENDORLIB_EXP: * This symbol contains the ~name expanded version of VENDORLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ /* PERL_VENDORLIB_STEM: * This define is PERL_VENDORLIB_EXP with any trailing version-specific component * removed. The elements in inc_version_list (inc_version_list.U) can * be tacked onto this variable to generate a list of directories to search. */ /*#define PERL_VENDORLIB_EXP "" / **/ /*#define PERL_VENDORLIB_STEM "" / **/ /* VOIDFLAGS: * This symbol indicates how much support of the void type is given by this * compiler. What various bits mean: * * 1 = supports declaration of void * 2 = supports arrays of pointers to functions returning void * 4 = supports comparisons between pointers to void functions and * addresses of void functions * 8 = suports declaration of generic void pointers * * The package designer should define VOIDUSED to indicate the requirements * of the package. This can be done either by #defining VOIDUSED before * including config.h, or by defining defvoidused in Myinit.U. If the * latter approach is taken, only those flags will be tested. If the * level of void support necessary is not present, defines void to int. */ #ifndef VOIDUSED #define VOIDUSED 15 #endif #define VOIDFLAGS 15 #if (VOIDFLAGS & VOIDUSED) != VOIDUSED #define void int /* is void to be avoided? */ #define M_VOID /* Xenix strikes again */ #endif /* USE_CROSS_COMPILE: * This symbol, if defined, indicates that Perl is being cross-compiled. */ /* PERL_TARGETARCH: * This symbol, if defined, indicates the target architecture * Perl has been cross-compiled to. Undefined if not a cross-compile. */ #ifndef USE_CROSS_COMPILE /*#define USE_CROSS_COMPILE / **/ #define PERL_TARGETARCH "" /**/ #endif /* MEM_ALIGNBYTES: * This symbol contains the number of bytes required to align a * double, or a long double when applicable. Usual values are 2, * 4 and 8. The default is eight, for safety. */ #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH) # define MEM_ALIGNBYTES 8 #else #define MEM_ALIGNBYTES 8 #endif /* BYTEORDER: * This symbol holds the hexadecimal constant defined in byteorder, * in a UV, i.e. 0x1234 or 0x4321 or 0x12345678, etc... * If the compiler supports cross-compiling or multiple-architecture * binaries (eg. on NeXT systems), use compiler-defined macros to * determine the byte order. * On NeXT 3.2 (and greater), you can build "Fat" Multiple Architecture * Binaries (MAB) on either big endian or little endian machines. * The endian-ness is available at compile-time. This only matters * for perl, where the config.h can be generated and installed on * one system, and used by a different architecture to build an * extension. Older versions of NeXT that might not have * defined either *_ENDIAN__ were all on Motorola 680x0 series, * so the default case (for NeXT) is big endian to catch them. * This might matter for NeXT 3.0. */ #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH) # ifdef __LITTLE_ENDIAN__ # if LONGSIZE == 4 # define BYTEORDER 0x1234 # else # if LONGSIZE == 8 # define BYTEORDER 0x12345678 # endif # endif # else # ifdef __BIG_ENDIAN__ # if LONGSIZE == 4 # define BYTEORDER 0x4321 # else # if LONGSIZE == 8 # define BYTEORDER 0x87654321 # endif # endif # endif # endif # if !defined(BYTEORDER) && (defined(NeXT) || defined(__NeXT__)) # define BYTEORDER 0x4321 # endif #else #define BYTEORDER 0x1234 /* large digits for MSB */ #endif /* NeXT */ /* CHARBITS: * This symbol contains the size of a char, so that the C preprocessor * can make decisions based on it. */ #define CHARBITS 8 /**/ /* CASTI32: * This symbol is defined if the C compiler can cast negative * or large floating point numbers to 32-bit ints. */ #ifndef _MSC_VER # define CASTI32 /**/ #endif /* CASTNEGFLOAT: * This symbol is defined if the C compiler can cast negative * numbers to unsigned longs, ints and shorts. */ /* CASTFLAGS: * This symbol contains flags that say what difficulties the compiler * has casting odd floating values to unsigned long: * 0 = ok * 1 = couldn't cast < 0 * 2 = couldn't cast >= 0x80000000 * 4 = couldn't cast in argument expression list */ #define CASTNEGFLOAT /**/ #define CASTFLAGS 0 /**/ /* VOID_CLOSEDIR: * This symbol, if defined, indicates that the closedir() routine * does not return a value. */ /*#define VOID_CLOSEDIR / **/ /* HAS_FD_SET: * This symbol, when defined, indicates presence of the fd_set typedef * in */ #define HAS_FD_SET /**/ /* Gconvert: * This preprocessor macro is defined to convert a floating point * number to a string without a trailing decimal point. This * emulates the behavior of sprintf("%g"), but is sometimes much more * efficient. If gconvert() is not available, but gcvt() drops the * trailing decimal point, then gcvt() is used. If all else fails, * a macro using sprintf("%g") is used. Arguments for the Gconvert * macro are: value, number of digits, whether trailing zeros should * be retained, and the output buffer. * The usual values are: * d_Gconvert='gconvert((x),(n),(t),(b))' * d_Gconvert='gcvt((x),(n),(b))' * d_Gconvert='sprintf((b),"%.*g",(n),(x))' * The last two assume trailing zeros should not be kept. */ #define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(x)) /* HAS_GETPAGESIZE: * This symbol, if defined, indicates that the getpagesize system call * is available to get system page size, which is the granularity of * many memory management calls. */ /*#define HAS_GETPAGESIZE / **/ /* HAS_GNULIBC: * This symbol, if defined, indicates to the C program that * the GNU C library is being used. A better check is to use * the __GLIBC__ and __GLIBC_MINOR__ symbols supplied with glibc. */ /*#define HAS_GNULIBC / **/ #if defined(HAS_GNULIBC) && !defined(_GNU_SOURCE) # define _GNU_SOURCE #endif /* HAS_ISASCII: * This manifest constant lets the C program know that isascii * is available. */ #define HAS_ISASCII /**/ /* HAS_LCHOWN: * This symbol, if defined, indicates that the lchown routine is * available to operate on a symbolic link (instead of following the * link). */ /*#define HAS_LCHOWN / **/ /* HAS_OPEN3: * This manifest constant lets the C program know that the three * argument form of open(2) is available. */ /*#define HAS_OPEN3 / **/ /* HAS_SAFE_BCOPY: * This symbol, if defined, indicates that the bcopy routine is available * to copy potentially overlapping memory blocks. Normally, you should * probably use memmove() or memcpy(). If neither is defined, roll your * own version. */ /*#define HAS_SAFE_BCOPY / **/ /* HAS_SAFE_MEMCPY: * This symbol, if defined, indicates that the memcpy routine is available * to copy potentially overlapping memory blocks. If you need to * copy overlapping memory blocks, you should check HAS_MEMMOVE and * use memmove() instead, if available. */ /*#define HAS_SAFE_MEMCPY / **/ /* HAS_SANE_MEMCMP: * This symbol, if defined, indicates that the memcmp routine is available * and can be used to compare relative magnitudes of chars with their high * bits set. If it is not defined, roll your own version. */ #define HAS_SANE_MEMCMP /**/ /* HAS_SIGACTION: * This symbol, if defined, indicates that Vr4's sigaction() routine * is available. */ /*#define HAS_SIGACTION / **/ /* HAS_SIGSETJMP: * This variable indicates to the C program that the sigsetjmp() * routine is available to save the calling process's registers * and stack environment for later use by siglongjmp(), and * to optionally save the process's signal mask. See * Sigjmp_buf, Sigsetjmp, and Siglongjmp. */ /* Sigjmp_buf: * This is the buffer type to be used with Sigsetjmp and Siglongjmp. */ /* Sigsetjmp: * This macro is used in the same way as sigsetjmp(), but will invoke * traditional setjmp() if sigsetjmp isn't available. * See HAS_SIGSETJMP. */ /* Siglongjmp: * This macro is used in the same way as siglongjmp(), but will invoke * traditional longjmp() if siglongjmp isn't available. * See HAS_SIGSETJMP. */ /*#define HAS_SIGSETJMP / **/ #ifdef HAS_SIGSETJMP #define Sigjmp_buf sigjmp_buf #define Sigsetjmp(buf,save_mask) sigsetjmp((buf),(save_mask)) #define Siglongjmp(buf,retval) siglongjmp((buf),(retval)) #else #define Sigjmp_buf jmp_buf #define Sigsetjmp(buf,save_mask) setjmp((buf)) #define Siglongjmp(buf,retval) longjmp((buf),(retval)) #endif /* USE_STDIO_PTR: * This symbol is defined if the _ptr and _cnt fields (or similar) * of the stdio FILE structure can be used to access the stdio buffer * for a file handle. If this is defined, then the FILE_ptr(fp) * and FILE_cnt(fp) macros will also be defined and should be used * to access these fields. */ /* FILE_ptr: * This macro is used to access the _ptr field (or equivalent) of the * FILE structure pointed to by its argument. This macro will always be * defined if USE_STDIO_PTR is defined. */ /* STDIO_PTR_LVALUE: * This symbol is defined if the FILE_ptr macro can be used as an * lvalue. */ /* FILE_cnt: * This macro is used to access the _cnt field (or equivalent) of the * FILE structure pointed to by its argument. This macro will always be * defined if USE_STDIO_PTR is defined. */ /* STDIO_CNT_LVALUE: * This symbol is defined if the FILE_cnt macro can be used as an * lvalue. */ /* STDIO_PTR_LVAL_SETS_CNT: * This symbol is defined if using the FILE_ptr macro as an lvalue * to increase the pointer by n has the side effect of decreasing the * value of File_cnt(fp) by n. */ /* STDIO_PTR_LVAL_NOCHANGE_CNT: * This symbol is defined if using the FILE_ptr macro as an lvalue * to increase the pointer by n leaves File_cnt(fp) unchanged. */ #define USE_STDIO_PTR /**/ #ifdef USE_STDIO_PTR #define FILE_ptr(fp) ((fp)->_ptr) #define STDIO_PTR_LVALUE /**/ #define FILE_cnt(fp) ((fp)->_cnt) #define STDIO_CNT_LVALUE /**/ /*#define STDIO_PTR_LVAL_SETS_CNT / **/ #define STDIO_PTR_LVAL_NOCHANGE_CNT /**/ #endif /* USE_STDIO_BASE: * This symbol is defined if the _base field (or similar) of the * stdio FILE structure can be used to access the stdio buffer for * a file handle. If this is defined, then the FILE_base(fp) macro * will also be defined and should be used to access this field. * Also, the FILE_bufsiz(fp) macro will be defined and should be used * to determine the number of bytes in the buffer. USE_STDIO_BASE * will never be defined unless USE_STDIO_PTR is. */ /* FILE_base: * This macro is used to access the _base field (or equivalent) of the * FILE structure pointed to by its argument. This macro will always be * defined if USE_STDIO_BASE is defined. */ /* FILE_bufsiz: * This macro is used to determine the number of bytes in the I/O * buffer pointed to by _base field (or equivalent) of the FILE * structure pointed to its argument. This macro will always be defined * if USE_STDIO_BASE is defined. */ #define USE_STDIO_BASE /**/ #ifdef USE_STDIO_BASE #define FILE_base(fp) ((fp)->_base) #define FILE_bufsiz(fp) ((fp)->_cnt + (fp)->_ptr - (fp)->_base) #endif /* HAS_VPRINTF: * This symbol, if defined, indicates that the vprintf routine is available * to printf with a pointer to an argument list. If unavailable, you * may need to write your own, probably in terms of _doprnt(). */ /* USE_CHAR_VSPRINTF: * This symbol is defined if this system has vsprintf() returning type * (char*). The trend seems to be to declare it as "int vsprintf()". It * is up to the package author to declare vsprintf correctly based on the * symbol. */ #define HAS_VPRINTF /**/ /*#define USE_CHAR_VSPRINTF / **/ /* DOUBLESIZE: * This symbol contains the size of a double, so that the C preprocessor * can make decisions based on it. */ #define DOUBLESIZE 8 /**/ /* I_TIME: * This symbol, if defined, indicates to the C program that it should * include . */ /* I_SYS_TIME: * This symbol, if defined, indicates to the C program that it should * include . */ /* I_SYS_TIME_KERNEL: * This symbol, if defined, indicates to the C program that it should * include with KERNEL defined. */ /* HAS_TM_TM_ZONE: * This symbol, if defined, indicates to the C program that * the struct tm has a tm_zone field. */ /* HAS_TM_TM_GMTOFF: * This symbol, if defined, indicates to the C program that * the struct tm has a tm_gmtoff field. */ #define I_TIME /**/ /*#define I_SYS_TIME / **/ /*#define I_SYS_TIME_KERNEL / **/ /*#define HAS_TM_TM_ZONE / **/ /*#define HAS_TM_TM_GMTOFF / **/ /* VAL_O_NONBLOCK: * This symbol is to be used during open() or fcntl(F_SETFL) to turn on * non-blocking I/O for the file descriptor. Note that there is no way * back, i.e. you cannot turn it blocking again this way. If you wish to * alternatively switch between blocking and non-blocking, use the * ioctl(FIOSNBIO) call instead, but that is not supported by all devices. */ /* VAL_EAGAIN: * This symbol holds the errno error code set by read() when no data was * present on the non-blocking file descriptor. */ /* RD_NODATA: * This symbol holds the return code from read() when no data is present * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is * not defined, then you can't distinguish between no data and EOF by * issuing a read(). You'll have to find another way to tell for sure! */ /* EOF_NONBLOCK: * This symbol, if defined, indicates to the C program that a read() on * a non-blocking file descriptor will return 0 on EOF, and not the value * held in RD_NODATA (-1 usually, in that case!). */ #define VAL_O_NONBLOCK O_NONBLOCK #define VAL_EAGAIN EAGAIN #define RD_NODATA -1 #define EOF_NONBLOCK /* PTRSIZE: * This symbol contains the size of a pointer, so that the C preprocessor * can make decisions based on it. It will be sizeof(void *) if * the compiler supports (void *); otherwise it will be * sizeof(char *). */ #define PTRSIZE 4 /**/ /* Drand01: * This macro is to be used to generate uniformly distributed * random numbers over the range [0., 1.[. You may have to supply * an 'extern double drand48();' in your program since SunOS 4.1.3 * doesn't provide you with anything relevant in its headers. * See HAS_DRAND48_PROTO. */ /* Rand_seed_t: * This symbol defines the type of the argument of the * random seed function. */ /* seedDrand01: * This symbol defines the macro to be used in seeding the * random number generator (see Drand01). */ /* RANDBITS: * This symbol indicates how many bits are produced by the * function used to generate normalized random numbers. * Values include 15, 16, 31, and 48. */ #define Drand01() (rand()/(double)((unsigned)1< or * to get any typedef'ed information. * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t). */ #define SSize_t int /* signed count of bytes */ /* EBCDIC: * This symbol, if defined, indicates that this system uses * EBCDIC encoding. */ /*#define EBCDIC / **/ /* SETUID_SCRIPTS_ARE_SECURE_NOW: * This symbol, if defined, indicates that the bug that prevents * setuid scripts from being secure is not present in this kernel. */ /* DOSUID: * This symbol, if defined, indicates that the C program should * check the script that it is executing for setuid/setgid bits, and * attempt to emulate setuid/setgid on systems that have disabled * setuid #! scripts because the kernel can't do it securely. * It is up to the package designer to make sure that this emulation * is done securely. Among other things, it should do an fstat on * the script it just opened to make sure it really is a setuid/setgid * script, it should make sure the arguments passed correspond exactly * to the argument on the #! line, and it should not trust any * subprocesses to which it must pass the filename rather than the * file descriptor of the script to be executed. */ /*#define SETUID_SCRIPTS_ARE_SECURE_NOW / **/ /*#define DOSUID / **/ /* PERL_USE_DEVEL: * This symbol, if defined, indicates that Perl was configured with * -Dusedevel, to enable development features. This should not be * done for production builds. */ /*#define PERL_USE_DEVEL / **/ /* HAS_ATOLF: * This symbol, if defined, indicates that the atolf routine is * available to convert strings into long doubles. */ /*#define HAS_ATOLF / **/ /* HAS_ATOLL: * This symbol, if defined, indicates that the atoll routine is * available to convert strings into long longs. */ /*#define HAS_ATOLL / **/ /* HAS__FWALK: * This symbol, if defined, indicates that the _fwalk system call is * available to apply a function to all the file handles. */ /*#define HAS__FWALK / **/ /* HAS_AINTL: * This symbol, if defined, indicates that the aintl routine is * available. If copysignl is also present we can emulate modfl. */ /*#define HAS_AINTL / **/ /* HAS_BUILTIN_CHOOSE_EXPR: * Can we handle GCC builtin for compile-time ternary-like expressions */ /* HAS_BUILTIN_EXPECT: * Can we handle GCC builtin for telling that certain values are more * likely */ /*#define HAS_BUILTIN_EXPECT / **/ /*#define HAS_BUILTIN_CHOOSE_EXPR / **/ /* HAS_C99_VARIADIC_MACROS: * If defined, the compiler supports C99 variadic macros. */ /*#define HAS_C99_VARIADIC_MACROS / **/ /* HAS_CLASS: * This symbol, if defined, indicates that the class routine is * available to classify doubles. Available for example in AIX. * The returned values are defined in and are: * * FP_PLUS_NORM Positive normalized, nonzero * FP_MINUS_NORM Negative normalized, nonzero * FP_PLUS_DENORM Positive denormalized, nonzero * FP_MINUS_DENORM Negative denormalized, nonzero * FP_PLUS_ZERO +0.0 * FP_MINUS_ZERO -0.0 * FP_PLUS_INF +INF * FP_MINUS_INF -INF * FP_NANS Signaling Not a Number (NaNS) * FP_NANQ Quiet Not a Number (NaNQ) */ /*#define HAS_CLASS / **/ /* HAS_CLEARENV: * This symbol, if defined, indicates that the clearenv () routine is * available for use. */ /*#define HAS_CLEARENV / **/ /* HAS_STRUCT_CMSGHDR: * This symbol, if defined, indicates that the struct cmsghdr * is supported. */ /*#define HAS_STRUCT_CMSGHDR / **/ /* HAS_COPYSIGNL: * This symbol, if defined, indicates that the copysignl routine is * available. If aintl is also present we can emulate modfl. */ /*#define HAS_COPYSIGNL / **/ /* USE_CPLUSPLUS: * This symbol, if defined, indicates that a C++ compiler was * used to compiled Perl and will be used to compile extensions. */ /*#define USE_CPLUSPLUS / **/ /* HAS_DBMINIT_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the dbminit() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int dbminit(char *); */ /*#define HAS_DBMINIT_PROTO / **/ /* HAS_DIR_DD_FD: * This symbol, if defined, indicates that the the DIR* dirstream * structure contains a member variable named dd_fd. */ /*#define HAS_DIR_DD_FD / **/ /* HAS_DIRFD: * This manifest constant lets the C program know that dirfd * is available. */ /*#define HAS_DIRFD / **/ /* DLSYM_NEEDS_UNDERSCORE: * This symbol, if defined, indicates that we need to prepend an * underscore to the symbol name before calling dlsym(). This only * makes sense if you *have* dlsym, which we will presume is the * case if you're using dl_dlopen.xs. */ /*#define DLSYM_NEEDS_UNDERSCORE / **/ /* HAS_FAST_STDIO: * This symbol, if defined, indicates that the "fast stdio" * is available to manipulate the stdio buffers directly. */ #define HAS_FAST_STDIO /**/ /* HAS_FCHDIR: * This symbol, if defined, indicates that the fchdir routine is * available to change directory using a file descriptor. */ /*#define HAS_FCHDIR / **/ /* FCNTL_CAN_LOCK: * This symbol, if defined, indicates that fcntl() can be used * for file locking. Normally on Unix systems this is defined. * It may be undefined on VMS. */ /*#define FCNTL_CAN_LOCK / **/ /* HAS_FINITE: * This symbol, if defined, indicates that the finite routine is * available to check whether a double is finite (non-infinity non-NaN). */ /*#define HAS_FINITE / **/ /* HAS_FINITEL: * This symbol, if defined, indicates that the finitel routine is * available to check whether a long double is finite * (non-infinity non-NaN). */ /*#define HAS_FINITEL / **/ /* HAS_FLOCK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the flock() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int flock(int, int); */ #define HAS_FLOCK_PROTO /**/ /* HAS_FP_CLASS: * This symbol, if defined, indicates that the fp_class routine is * available to classify doubles. Available for example in Digital UNIX. * The returned values are defined in and are: * * FP_SNAN Signaling NaN (Not-a-Number) * FP_QNAN Quiet NaN (Not-a-Number) * FP_POS_INF +infinity * FP_NEG_INF -infinity * FP_POS_NORM Positive normalized * FP_NEG_NORM Negative normalized * FP_POS_DENORM Positive denormalized * FP_NEG_DENORM Negative denormalized * FP_POS_ZERO +0.0 (positive zero) * FP_NEG_ZERO -0.0 (negative zero) */ /*#define HAS_FP_CLASS / **/ /* HAS_FPCLASS: * This symbol, if defined, indicates that the fpclass routine is * available to classify doubles. Available for example in Solaris/SVR4. * The returned values are defined in and are: * * FP_SNAN signaling NaN * FP_QNAN quiet NaN * FP_NINF negative infinity * FP_PINF positive infinity * FP_NDENORM negative denormalized non-zero * FP_PDENORM positive denormalized non-zero * FP_NZERO negative zero * FP_PZERO positive zero * FP_NNORM negative normalized non-zero * FP_PNORM positive normalized non-zero */ /*#define HAS_FPCLASS / **/ /* HAS_FPCLASSIFY: * This symbol, if defined, indicates that the fpclassify routine is * available to classify doubles. Available for example in HP-UX. * The returned values are defined in and are * * FP_NORMAL Normalized * FP_ZERO Zero * FP_INFINITE Infinity * FP_SUBNORMAL Denormalized * FP_NAN NaN * */ /*#define HAS_FPCLASSIFY / **/ /* HAS_FPCLASSL: * This symbol, if defined, indicates that the fpclassl routine is * available to classify long doubles. Available for example in IRIX. * The returned values are defined in and are: * * FP_SNAN signaling NaN * FP_QNAN quiet NaN * FP_NINF negative infinity * FP_PINF positive infinity * FP_NDENORM negative denormalized non-zero * FP_PDENORM positive denormalized non-zero * FP_NZERO negative zero * FP_PZERO positive zero * FP_NNORM negative normalized non-zero * FP_PNORM positive normalized non-zero */ /*#define HAS_FPCLASSL / **/ /* HAS_FPOS64_T: * This symbol will be defined if the C compiler supports fpos64_t. */ /*#define HAS_FPOS64_T / **/ /* HAS_FREXPL: * This symbol, if defined, indicates that the frexpl routine is * available to break a long double floating-point number into * a normalized fraction and an integral power of 2. */ /*#define HAS_FREXPL / **/ /* HAS_STRUCT_FS_DATA: * This symbol, if defined, indicates that the struct fs_data * to do statfs() is supported. */ /*#define HAS_STRUCT_FS_DATA / **/ /* HAS_FSEEKO: * This symbol, if defined, indicates that the fseeko routine is * available to fseek beyond 32 bits (useful for ILP32 hosts). */ /*#define HAS_FSEEKO / **/ /* HAS_FSTATFS: * This symbol, if defined, indicates that the fstatfs routine is * available to stat filesystems by file descriptors. */ /*#define HAS_FSTATFS / **/ /* HAS_FSYNC: * This symbol, if defined, indicates that the fsync routine is * available to write a file's modified data and attributes to * permanent storage. */ /*#define HAS_FSYNC / **/ /* HAS_FTELLO: * This symbol, if defined, indicates that the ftello routine is * available to ftell beyond 32 bits (useful for ILP32 hosts). */ /*#define HAS_FTELLO / **/ /* HAS_FUTIMES: * This symbol, if defined, indicates that the futimes routine is * available to change file descriptor time stamps with struct timevals. */ /*#define HAS_FUTIMES / **/ /* HAS_GETADDRINFO: * This symbol, if defined, indicates that the getaddrinfo() function * is available for use. */ /*#define HAS_GETADDRINFO / **/ /* HAS_GETCWD: * This symbol, if defined, indicates that the getcwd routine is * available to get the current working directory. */ #define HAS_GETCWD /**/ /* HAS_GETESPWNAM: * This symbol, if defined, indicates that the getespwnam system call is * available to retrieve enchanced (shadow) password entries by name. */ /*#define HAS_GETESPWNAM / **/ /* HAS_GETFSSTAT: * This symbol, if defined, indicates that the getfsstat routine is * available to stat filesystems in bulk. */ /*#define HAS_GETFSSTAT / **/ /* HAS_GETITIMER: * This symbol, if defined, indicates that the getitimer routine is * available to return interval timers. */ /*#define HAS_GETITIMER / **/ /* HAS_GETMNT: * This symbol, if defined, indicates that the getmnt routine is * available to get filesystem mount info by filename. */ /*#define HAS_GETMNT / **/ /* HAS_GETMNTENT: * This symbol, if defined, indicates that the getmntent routine is * available to iterate through mounted file systems to get their info. */ /*#define HAS_GETMNTENT / **/ /* HAS_GETNAMEINFO: * This symbol, if defined, indicates that the getnameinfo() function * is available for use. */ /*#define HAS_GETNAMEINFO / **/ /* HAS_GETPRPWNAM: * This symbol, if defined, indicates that the getprpwnam system call is * available to retrieve protected (shadow) password entries by name. */ /*#define HAS_GETPRPWNAM / **/ /* HAS_GETSPNAM: * This symbol, if defined, indicates that the getspnam system call is * available to retrieve SysV shadow password entries by name. */ /*#define HAS_GETSPNAM / **/ /* HAS_HASMNTOPT: * This symbol, if defined, indicates that the hasmntopt routine is * available to query the mount options of file systems. */ /*#define HAS_HASMNTOPT / **/ /* HAS_ILOGBL: * This symbol, if defined, indicates that the ilogbl routine is * available. If scalbnl is also present we can emulate frexpl. */ /*#define HAS_ILOGBL / **/ /* HAS_INETNTOP: * This symbol, if defined, indicates that the inet_ntop() function * is available to parse IPv4 and IPv6 strings. */ /*#define HAS_INETNTOP / **/ /* HAS_INETPTON: * This symbol, if defined, indicates that the inet_pton() function * is available to parse IPv4 and IPv6 strings. */ /*#define HAS_INETPTON / **/ /* HAS_INT64_T: * This symbol will defined if the C compiler supports int64_t. * Usually the needs to be included, but sometimes * is enough. */ /*#define HAS_INT64_T / **/ /* HAS_ISFINITE: * This symbol, if defined, indicates that the isfinite routine is * available to check whether a double is finite (non-infinity non-NaN). */ /*#define HAS_ISFINITE / **/ /* HAS_ISINF: * This symbol, if defined, indicates that the isinf routine is * available to check whether a double is an infinity. */ /*#define HAS_ISINF / **/ /* HAS_ISNAN: * This symbol, if defined, indicates that the isnan routine is * available to check whether a double is a NaN. */ #define HAS_ISNAN /**/ /* HAS_ISNANL: * This symbol, if defined, indicates that the isnanl routine is * available to check whether a long double is a NaN. */ /*#define HAS_ISNANL / **/ /* HAS_LDBL_DIG: * This symbol, if defined, indicates that this system's * or defines the symbol LDBL_DIG, which is the number * of significant digits in a long double precision number. Unlike * for DBL_DIG, there's no good guess for LDBL_DIG if it is undefined. */ #define HAS_LDBL_DIG /**/ /* LIBM_LIB_VERSION: * This symbol, if defined, indicates that libm exports _LIB_VERSION * and that math.h defines the enum to manipulate it. */ /*#define LIBM_LIB_VERSION / **/ /* HAS_MADVISE: * This symbol, if defined, indicates that the madvise system call is * available to map a file into memory. */ /*#define HAS_MADVISE / **/ /* HAS_MALLOC_SIZE: * This symbol, if defined, indicates that the malloc_size * routine is available for use. */ /*#define HAS_MALLOC_SIZE / **/ /* HAS_MALLOC_GOOD_SIZE: * This symbol, if defined, indicates that the malloc_good_size * routine is available for use. */ /*#define HAS_MALLOC_GOOD_SIZE / **/ /* HAS_MKDTEMP: * This symbol, if defined, indicates that the mkdtemp routine is * available to exclusively create a uniquely named temporary directory. */ /*#define HAS_MKDTEMP / **/ /* HAS_MKSTEMPS: * This symbol, if defined, indicates that the mkstemps routine is * available to excluslvely create and open a uniquely named * (with a suffix) temporary file. */ /*#define HAS_MKSTEMPS / **/ /* HAS_MODFL: * This symbol, if defined, indicates that the modfl routine is * available to split a long double x into a fractional part f and * an integer part i such that |f| < 1.0 and (f + i) = x. */ /* HAS_MODFL_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the modfl() function. Otherwise, it is up * to the program to supply one. */ /* HAS_MODFL_POW32_BUG: * This symbol, if defined, indicates that the modfl routine is * broken for long doubles >= pow(2, 32). * For example from 4294967303.150000 one would get 4294967302.000000 * and 1.150000. The bug has been seen in certain versions of glibc, * release 2.2.2 is known to be okay. */ /*#define HAS_MODFL / **/ /*#define HAS_MODFL_PROTO / **/ /*#define HAS_MODFL_POW32_BUG / **/ /* HAS_MPROTECT: * This symbol, if defined, indicates that the mprotect system call is * available to modify the access protection of a memory mapped file. */ /*#define HAS_MPROTECT / **/ /* HAS_STRUCT_MSGHDR: * This symbol, if defined, indicates that the struct msghdr * is supported. */ /*#define HAS_STRUCT_MSGHDR / **/ /* HAS_NL_LANGINFO: * This symbol, if defined, indicates that the nl_langinfo routine is * available to return local data. You will also need * and therefore I_LANGINFO. */ /*#define HAS_NL_LANGINFO / **/ /* HAS_OFF64_T: * This symbol will be defined if the C compiler supports off64_t. */ /*#define HAS_OFF64_T / **/ /* HAS_PROCSELFEXE: * This symbol is defined if PROCSELFEXE_PATH is a symlink * to the absolute pathname of the executing program. */ /* PROCSELFEXE_PATH: * If HAS_PROCSELFEXE is defined this symbol is the filename * of the symbolic link pointing to the absolute pathname of * the executing program. */ /*#define HAS_PROCSELFEXE / **/ #if defined(HAS_PROCSELFEXE) && !defined(PROCSELFEXE_PATH) #define PROCSELFEXE_PATH /**/ #endif /* HAS_PTHREAD_ATTR_SETSCOPE: * This symbol, if defined, indicates that the pthread_attr_setscope * system call is available to set the contention scope attribute of * a thread attribute object. */ /*#define HAS_PTHREAD_ATTR_SETSCOPE / **/ /* HAS_READV: * This symbol, if defined, indicates that the readv routine is * available to do gather reads. You will also need * and there I_SYSUIO. */ /*#define HAS_READV / **/ /* HAS_RECVMSG: * This symbol, if defined, indicates that the recvmsg routine is * available to send structured socket messages. */ /*#define HAS_RECVMSG / **/ /* HAS_SBRK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the sbrk() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern void* sbrk(int); * extern void* sbrk(size_t); */ /*#define HAS_SBRK_PROTO / **/ /* HAS_SCALBNL: * This symbol, if defined, indicates that the scalbnl routine is * available. If ilogbl is also present we can emulate frexpl. */ /*#define HAS_SCALBNL / **/ /* HAS_SENDMSG: * This symbol, if defined, indicates that the sendmsg routine is * available to send structured socket messages. */ /*#define HAS_SENDMSG / **/ /* HAS_SETITIMER: * This symbol, if defined, indicates that the setitimer routine is * available to set interval timers. */ /*#define HAS_SETITIMER / **/ /* HAS_SETPROCTITLE: * This symbol, if defined, indicates that the setproctitle routine is * available to set process title. */ /*#define HAS_SETPROCTITLE / **/ /* USE_SFIO: * This symbol, if defined, indicates that sfio should * be used. */ /*#define USE_SFIO / **/ /* HAS_SIGNBIT: * This symbol, if defined, indicates that the signbit routine is * available to check if the given number has the sign bit set. * This should include correct testing of -0.0. This will only be set * if the signbit() routine is safe to use with the NV type used internally * in perl. Users should call Perl_signbit(), which will be #defined to * the system's signbit() function or macro if this symbol is defined. */ /*#define HAS_SIGNBIT / **/ /* HAS_SIGPROCMASK: * This symbol, if defined, indicates that the sigprocmask * system call is available to examine or change the signal mask * of the calling process. */ /*#define HAS_SIGPROCMASK / **/ /* USE_SITECUSTOMIZE: * This symbol, if defined, indicates that sitecustomize should * be used. */ #ifndef USE_SITECUSTOMIZE /*#define USE_SITECUSTOMIZE / **/ #endif /* HAS_SNPRINTF: * This symbol, if defined, indicates that the snprintf () library * function is available for use. */ /* HAS_VSNPRINTF: * This symbol, if defined, indicates that the vsnprintf () library * function is available for use. */ #define HAS_SNPRINTF /**/ #define HAS_VSNPRINTF /**/ /* HAS_SOCKATMARK: * This symbol, if defined, indicates that the sockatmark routine is * available to test whether a socket is at the out-of-band mark. */ /*#define HAS_SOCKATMARK / **/ /* HAS_SOCKATMARK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the sockatmark() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int sockatmark(int); */ /*#define HAS_SOCKATMARK_PROTO / **/ /* HAS_SOCKS5_INIT: * This symbol, if defined, indicates that the socks5_init routine is * available to initialize SOCKS 5. */ /*#define HAS_SOCKS5_INIT / **/ /* SPRINTF_RETURNS_STRLEN: * This variable defines whether sprintf returns the length of the string * (as per the ANSI spec). Some C libraries retain compatibility with * pre-ANSI C and return a pointer to the passed in buffer; for these * this variable will be undef. */ #define SPRINTF_RETURNS_STRLEN /**/ /* HAS_SQRTL: * This symbol, if defined, indicates that the sqrtl routine is * available to do long double square roots. */ /*#define HAS_SQRTL / **/ /* HAS_SETRESGID_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the setresgid() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern int setresgid(uid_t ruid, uid_t euid, uid_t suid); */ /*#define HAS_SETRESGID_PROTO / **/ /* HAS_SETRESUID_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the setresuid() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern int setresuid(uid_t ruid, uid_t euid, uid_t suid); */ /*#define HAS_SETRESUID_PROTO / **/ /* HAS_STRUCT_STATFS_F_FLAGS: * This symbol, if defined, indicates that the struct statfs * does have the f_flags member containing the mount flags of * the filesystem containing the file. * This kind of struct statfs is coming from (BSD 4.3), * not from (SYSV). Older BSDs (like Ultrix) do not * have statfs() and struct statfs, they have ustat() and getmnt() * with struct ustat and struct fs_data. */ /*#define HAS_STRUCT_STATFS_F_FLAGS / **/ /* HAS_STRUCT_STATFS: * This symbol, if defined, indicates that the struct statfs * to do statfs() is supported. */ /*#define HAS_STRUCT_STATFS / **/ /* HAS_FSTATVFS: * This symbol, if defined, indicates that the fstatvfs routine is * available to stat filesystems by file descriptors. */ /*#define HAS_FSTATVFS / **/ /* HAS_STRFTIME: * This symbol, if defined, indicates that the strftime routine is * available to do time formatting. */ #define HAS_STRFTIME /**/ /* HAS_STRLCAT: * This symbol, if defined, indicates that the strlcat () routine is * available to do string concatenation. */ /*#define HAS_STRLCAT / **/ /* HAS_STRLCPY: * This symbol, if defined, indicates that the strlcpy () routine is * available to do string copying. */ /*#define HAS_STRLCPY / **/ /* HAS_STRTOLD: * This symbol, if defined, indicates that the strtold routine is * available to convert strings to long doubles. */ /*#define HAS_STRTOLD / **/ /* HAS_STRTOLL: * This symbol, if defined, indicates that the strtoll routine is * available to convert strings to long longs. */ /*#define HAS_STRTOLL / **/ /* HAS_STRTOQ: * This symbol, if defined, indicates that the strtoq routine is * available to convert strings to long longs (quads). */ /*#define HAS_STRTOQ / **/ /* HAS_STRTOULL: * This symbol, if defined, indicates that the strtoull routine is * available to convert strings to unsigned long longs. */ /*#define HAS_STRTOULL / **/ /* HAS_STRTOUQ: * This symbol, if defined, indicates that the strtouq routine is * available to convert strings to unsigned long longs (quads). */ /*#define HAS_STRTOUQ / **/ /* HAS_SYSCALL_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the syscall() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern int syscall(int, ...); * extern int syscall(long, ...); */ /*#define HAS_SYSCALL_PROTO / **/ /* HAS_TELLDIR_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the telldir() function. Otherwise, it is up * to the program to supply one. A good guess is * extern long telldir(DIR*); */ #define HAS_TELLDIR_PROTO /**/ /* HAS_CTIME64: * This symbol, if defined, indicates that the ctime64 () routine is * available to do the 64bit variant of ctime () */ /* HAS_LOCALTIME64: * This symbol, if defined, indicates that the localtime64 () routine is * available to do the 64bit variant of localtime () */ /* HAS_GMTIME64: * This symbol, if defined, indicates that the gmtime64 () routine is * available to do the 64bit variant of gmtime () */ /* HAS_MKTIME64: * This symbol, if defined, indicates that the mktime64 () routine is * available to do the 64bit variant of mktime () */ /* HAS_DIFFTIME64: * This symbol, if defined, indicates that the difftime64 () routine is * available to do the 64bit variant of difftime () */ /* HAS_ASCTIME64: * This symbol, if defined, indicates that the asctime64 () routine is * available to do the 64bit variant of asctime () */ /*#define HAS_CTIME64 / **/ /*#define HAS_LOCALTIME64 / **/ /*#define HAS_GMTIME64 / **/ /*#define HAS_MKTIME64 / **/ /*#define HAS_DIFFTIME64 / **/ /*#define HAS_ASCTIME64 / **/ /* HAS_TIMEGM: * This symbol, if defined, indicates that the timegm routine is * available to do the opposite of gmtime () */ /*#define HAS_TIMEGM / **/ /* U32_ALIGNMENT_REQUIRED: * This symbol, if defined, indicates that you must access * character data through U32-aligned pointers. */ #ifndef U32_ALIGNMENT_REQUIRED #define U32_ALIGNMENT_REQUIRED /**/ #endif /* HAS_UALARM: * This symbol, if defined, indicates that the ualarm routine is * available to do alarms with microsecond granularity. */ /*#define HAS_UALARM / **/ /* HAS_UNORDERED: * This symbol, if defined, indicates that the unordered routine is * available to check whether two doubles are unordered * (effectively: whether either of them is NaN) */ /*#define HAS_UNORDERED / **/ /* HAS_UNSETENV: * This symbol, if defined, indicates that the unsetenv () routine is * available for use. */ /*#define HAS_UNSETENV / **/ /* HAS_USLEEP_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the usleep() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int usleep(useconds_t); */ /*#define HAS_USLEEP_PROTO / **/ /* HAS_USTAT: * This symbol, if defined, indicates that the ustat system call is * available to query file system statistics by dev_t. */ /*#define HAS_USTAT / **/ /* HAS_WRITEV: * This symbol, if defined, indicates that the writev routine is * available to do scatter writes. */ /*#define HAS_WRITEV / **/ /* USE_DYNAMIC_LOADING: * This symbol, if defined, indicates that dynamic loading of * some sort is available. */ #define USE_DYNAMIC_LOADING /**/ /* FFLUSH_NULL: * This symbol, if defined, tells that fflush(NULL) does flush * all pending stdio output. */ /* FFLUSH_ALL: * This symbol, if defined, tells that to flush * all pending stdio output one must loop through all * the stdio file handles stored in an array and fflush them. * Note that if fflushNULL is defined, fflushall will not * even be probed for and will be left undefined. */ #define FFLUSH_NULL /**/ /*#define FFLUSH_ALL / **/ /* I_ASSERT: * This symbol, if defined, indicates that exists and * could be included by the C program to get the assert() macro. */ #define I_ASSERT /**/ /* I_CRYPT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_CRYPT / **/ /* DB_Prefix_t: * This symbol contains the type of the prefix structure element * in the header file. In older versions of DB, it was * int, while in newer ones it is u_int32_t. */ /* DB_Hash_t: * This symbol contains the type of the prefix structure element * in the header file. In older versions of DB, it was * int, while in newer ones it is size_t. */ /* DB_VERSION_MAJOR_CFG: * This symbol, if defined, defines the major version number of * Berkeley DB found in the header when Perl was configured. */ /* DB_VERSION_MINOR_CFG: * This symbol, if defined, defines the minor version number of * Berkeley DB found in the header when Perl was configured. * For DB version 1 this is always 0. */ /* DB_VERSION_PATCH_CFG: * This symbol, if defined, defines the patch version number of * Berkeley DB found in the header when Perl was configured. * For DB version 1 this is always 0. */ #define DB_Hash_t int /**/ #define DB_Prefix_t int /**/ #define DB_VERSION_MAJOR_CFG 0 /**/ #define DB_VERSION_MINOR_CFG 0 /**/ #define DB_VERSION_PATCH_CFG 0 /**/ /* I_FP: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_FP / **/ /* I_FP_CLASS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_FP_CLASS / **/ /* I_IEEEFP: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_IEEEFP / **/ /* I_INTTYPES: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_INTTYPES / **/ /* I_LANGINFO: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_LANGINFO / **/ /* I_LIBUTIL: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_LIBUTIL / **/ /* I_MALLOCMALLOC: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_MALLOCMALLOC / **/ /* I_MNTENT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_MNTENT / **/ /* I_NETINET_TCP: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_NETINET_TCP / **/ /* I_POLL: * This symbol, if defined, indicates that exists and * should be included. (see also HAS_POLL) */ /*#define I_POLL / **/ /* I_PROT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_PROT / **/ /* I_SHADOW: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SHADOW / **/ /* I_SOCKS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SOCKS / **/ /* I_SUNMATH: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SUNMATH / **/ /* I_SYSLOG: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSLOG / **/ /* I_SYSMODE: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSMODE / **/ /* I_SYS_MOUNT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYS_MOUNT / **/ /* I_SYS_STATFS: * This symbol, if defined, indicates that exists. */ /*#define I_SYS_STATFS / **/ /* I_SYS_STATVFS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYS_STATVFS / **/ /* I_SYSUTSNAME: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSUTSNAME / **/ /* I_SYS_VFS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYS_VFS / **/ /* I_USTAT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_USTAT / **/ /* PERL_PRIfldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'f') for output. */ /* PERL_PRIgldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'g') for output. */ /* PERL_PRIeldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'e') for output. */ /* PERL_SCNfldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'f') for input. */ /*#define PERL_PRIfldbl "f" / **/ /*#define PERL_PRIgldbl "g" / **/ /*#define PERL_PRIeldbl "e" / **/ /*#define PERL_SCNfldbl "f" / **/ /* PERL_MAD: * This symbol, if defined, indicates that the Misc Attribution * Declaration code should be conditionally compiled. */ /*#define PERL_MAD / **/ /* NEED_VA_COPY: * This symbol, if defined, indicates that the system stores * the variable argument list datatype, va_list, in a format * that cannot be copied by simple assignment, so that some * other means must be used when copying is required. * As such systems vary in their provision (or non-provision) * of copying mechanisms, handy.h defines a platform- * independent macro, Perl_va_copy(src, dst), to do the job. */ /*#define NEED_VA_COPY / **/ /* IVTYPE: * This symbol defines the C type used for Perl's IV. */ /* UVTYPE: * This symbol defines the C type used for Perl's UV. */ /* I8TYPE: * This symbol defines the C type used for Perl's I8. */ /* U8TYPE: * This symbol defines the C type used for Perl's U8. */ /* I16TYPE: * This symbol defines the C type used for Perl's I16. */ /* U16TYPE: * This symbol defines the C type used for Perl's U16. */ /* I32TYPE: * This symbol defines the C type used for Perl's I32. */ /* U32TYPE: * This symbol defines the C type used for Perl's U32. */ /* I64TYPE: * This symbol defines the C type used for Perl's I64. */ /* U64TYPE: * This symbol defines the C type used for Perl's U64. */ /* NVTYPE: * This symbol defines the C type used for Perl's NV. */ /* IVSIZE: * This symbol contains the sizeof(IV). */ /* UVSIZE: * This symbol contains the sizeof(UV). */ /* I8SIZE: * This symbol contains the sizeof(I8). */ /* U8SIZE: * This symbol contains the sizeof(U8). */ /* I16SIZE: * This symbol contains the sizeof(I16). */ /* U16SIZE: * This symbol contains the sizeof(U16). */ /* I32SIZE: * This symbol contains the sizeof(I32). */ /* U32SIZE: * This symbol contains the sizeof(U32). */ /* I64SIZE: * This symbol contains the sizeof(I64). */ /* U64SIZE: * This symbol contains the sizeof(U64). */ /* NVSIZE: * This symbol contains the sizeof(NV). */ /* NV_PRESERVES_UV: * This symbol, if defined, indicates that a variable of type NVTYPE * can preserve all the bits of a variable of type UVTYPE. */ /* NV_PRESERVES_UV_BITS: * This symbol contains the number of bits a variable of type NVTYPE * can preserve of a variable of type UVTYPE. */ /* NV_OVERFLOWS_INTEGERS_AT: * This symbol gives the largest integer value that NVs can hold. This * value + 1.0 cannot be stored accurately. It is expressed as constant * floating point expression to reduce the chance of decimale/binary * conversion issues. If it can not be determined, the value 0 is given. */ /* NV_ZERO_IS_ALLBITS_ZERO: * This symbol, if defined, indicates that a variable of type NVTYPE * stores 0.0 in memory as all bits zero. */ #define IVTYPE long /**/ #define UVTYPE unsigned long /**/ #define I8TYPE char /**/ #define U8TYPE unsigned char /**/ #define I16TYPE short /**/ #define U16TYPE unsigned short /**/ #define I32TYPE long /**/ #define U32TYPE unsigned long /**/ #ifdef HAS_QUAD # ifndef _MSC_VER # define I64TYPE long long /**/ # define U64TYPE unsigned long long /**/ # else # define I64TYPE __int64 /**/ # define U64TYPE unsigned __int64 /**/ # endif #endif #define NVTYPE double /**/ #define IVSIZE 4 /**/ #define UVSIZE 4 /**/ #define I8SIZE 1 /**/ #define U8SIZE 1 /**/ #define I16SIZE 2 /**/ #define U16SIZE 2 /**/ #define I32SIZE 4 /**/ #define U32SIZE 4 /**/ #ifdef HAS_QUAD #define I64SIZE 8 /**/ #define U64SIZE 8 /**/ #endif #define NVSIZE 8 /**/ #define NV_PRESERVES_UV #define NV_PRESERVES_UV_BITS 32 #define NV_OVERFLOWS_INTEGERS_AT 256.0*256.0*256.0*256.0*256.0*256.0*2.0*2.0*2.0*2.0*2.0 #define NV_ZERO_IS_ALLBITS_ZERO #if UVSIZE == 8 # ifdef BYTEORDER # if BYTEORDER == 0x1234 # undef BYTEORDER # define BYTEORDER 0x12345678 # else # if BYTEORDER == 0x4321 # undef BYTEORDER # define BYTEORDER 0x87654321 # endif # endif # endif #endif /* IVdf: * This symbol defines the format string used for printing a Perl IV * as a signed decimal integer. */ /* UVuf: * This symbol defines the format string used for printing a Perl UV * as an unsigned decimal integer. */ /* UVof: * This symbol defines the format string used for printing a Perl UV * as an unsigned octal integer. */ /* UVxf: * This symbol defines the format string used for printing a Perl UV * as an unsigned hexadecimal integer in lowercase abcdef. */ /* UVXf: * This symbol defines the format string used for printing a Perl UV * as an unsigned hexadecimal integer in uppercase ABCDEF. */ /* NVef: * This symbol defines the format string used for printing a Perl NV * using %e-ish floating point format. */ /* NVff: * This symbol defines the format string used for printing a Perl NV * using %f-ish floating point format. */ /* NVgf: * This symbol defines the format string used for printing a Perl NV * using %g-ish floating point format. */ #define IVdf "ld" /**/ #define UVuf "lu" /**/ #define UVof "lo" /**/ #define UVxf "lx" /**/ #define UVXf "lX" /**/ #define NVef "e" /**/ #define NVff "f" /**/ #define NVgf "g" /**/ /* SELECT_MIN_BITS: * This symbol holds the minimum number of bits operated by select. * That is, if you do select(n, ...), how many bits at least will be * cleared in the masks if some activity is detected. Usually this * is either n or 32*ceil(n/32), especially many little-endians do * the latter. This is only useful if you have select(), naturally. */ #define SELECT_MIN_BITS 32 /**/ /* STARTPERL: * This variable contains the string to put in front of a perl * script to make sure (one hopes) that it runs with perl and not * some shell. */ #define STARTPERL "#!perl" /**/ /* HAS_STDIO_STREAM_ARRAY: * This symbol, if defined, tells that there is an array * holding the stdio streams. */ /* STDIO_STREAM_ARRAY: * This symbol tells the name of the array holding the stdio streams. * Usual values include _iob, __iob, and __sF. */ /*#define HAS_STDIO_STREAM_ARRAY / **/ #ifdef HAS_STDIO_STREAM_ARRAY #define STDIO_STREAM_ARRAY #endif /* GMTIME_MAX: * This symbol contains the maximum value for the time_t offset that * the system function gmtime () accepts, and defaults to 0 */ /* GMTIME_MIN: * This symbol contains the minimum value for the time_t offset that * the system function gmtime () accepts, and defaults to 0 */ /* LOCALTIME_MAX: * This symbol contains the maximum value for the time_t offset that * the system function localtime () accepts, and defaults to 0 */ /* LOCALTIME_MIN: * This symbol contains the minimum value for the time_t offset that * the system function localtime () accepts, and defaults to 0 */ #define GMTIME_MAX 2147483647 /**/ #define GMTIME_MIN 0 /**/ #define LOCALTIME_MAX 2147483647 /**/ #define LOCALTIME_MIN 0 /**/ /* USE_64_BIT_INT: * This symbol, if defined, indicates that 64-bit integers should * be used when available. If not defined, the native integers * will be employed (be they 32 or 64 bits). The minimal possible * 64-bitness is used, just enough to get 64-bit integers into Perl. * This may mean using for example "long longs", while your memory * may still be limited to 2 gigabytes. */ /* USE_64_BIT_ALL: * This symbol, if defined, indicates that 64-bit integers should * be used when available. If not defined, the native integers * will be used (be they 32 or 64 bits). The maximal possible * 64-bitness is employed: LP64 or ILP64, meaning that you will * be able to use more than 2 gigabytes of memory. This mode is * even more binary incompatible than USE_64_BIT_INT. You may not * be able to run the resulting executable in a 32-bit CPU at all or * you may need at least to reboot your OS to 64-bit mode. */ #ifndef USE_64_BIT_INT /*#define USE_64_BIT_INT / **/ #endif #ifndef USE_64_BIT_ALL /*#define USE_64_BIT_ALL / **/ #endif /* USE_DTRACE: * This symbol, if defined, indicates that Perl should * be built with support for DTrace. */ /*#define USE_DTRACE / **/ /* USE_FAST_STDIO: * This symbol, if defined, indicates that Perl should * be built to use 'fast stdio'. * Defaults to define in Perls 5.8 and earlier, to undef later. */ #ifndef USE_FAST_STDIO /*#define USE_FAST_STDIO / **/ #endif /* USE_LARGE_FILES: * This symbol, if defined, indicates that large file support * should be used when available. */ #ifndef USE_LARGE_FILES /*#define USE_LARGE_FILES / **/ #endif /* USE_LONG_DOUBLE: * This symbol, if defined, indicates that long doubles should * be used when available. */ #ifndef USE_LONG_DOUBLE /*#define USE_LONG_DOUBLE / **/ #endif /* USE_MORE_BITS: * This symbol, if defined, indicates that 64-bit interfaces and * long doubles should be used when available. */ #ifndef USE_MORE_BITS /*#define USE_MORE_BITS / **/ #endif /* MULTIPLICITY: * This symbol, if defined, indicates that Perl should * be built to use multiplicity. */ #ifndef MULTIPLICITY /*#define MULTIPLICITY / **/ #endif /* USE_PERLIO: * This symbol, if defined, indicates that the PerlIO abstraction should * be used throughout. If not defined, stdio should be * used in a fully backward compatible manner. */ #ifndef USE_PERLIO /*#define USE_PERLIO / **/ #endif /* USE_SOCKS: * This symbol, if defined, indicates that Perl should * be built to use socks. */ #ifndef USE_SOCKS /*#define USE_SOCKS / **/ #endif #endif perl-5.12.0-RC0/overload.h0000644000175000017500000000302011325127001014076 0ustar jessejesse/* -*- buffer-read-only: t -*- * * overload.h * * Copyright (C) 1997, 1998, 2000, 2001, 2005, 2006, 2007 by Larry Wall * and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * * !!!!!!! DO NOT EDIT THIS FILE !!!!!!! * This file is built by overload.pl */ enum { fallback_amg, to_sv_amg, to_av_amg, to_hv_amg, to_gv_amg, to_cv_amg, inc_amg, dec_amg, bool__amg, numer_amg, string_amg, not_amg, copy_amg, abs_amg, neg_amg, iter_amg, int_amg, lt_amg, le_amg, gt_amg, ge_amg, eq_amg, ne_amg, slt_amg, sle_amg, sgt_amg, sge_amg, seq_amg, sne_amg, nomethod_amg, add_amg, add_ass_amg, subtr_amg, subtr_ass_amg, mult_amg, mult_ass_amg, div_amg, div_ass_amg, modulo_amg, modulo_ass_amg, pow_amg, pow_ass_amg, lshift_amg, lshift_ass_amg, rshift_amg, rshift_ass_amg, band_amg, band_ass_amg, bor_amg, bor_ass_amg, bxor_amg, bxor_ass_amg, ncmp_amg, scmp_amg, compl_amg, atan2_amg, cos_amg, sin_amg, exp_amg, log_amg, sqrt_amg, repeat_amg, repeat_ass_amg, concat_amg, concat_ass_amg, smart_amg, ftest_amg, regexp_amg, DESTROY_amg, max_amg_code /* Do not leave a trailing comma here. C9X allows it, C89 doesn't. */ }; #define NofAMmeth max_amg_code perl-5.12.0-RC0/README.vms0000444000175000017500000006677411347250766013650 0ustar jessejesseIf you read this file _as_is_, just ignore the equal signs on the left. This file is written in the POD format (see [.POD]PERLPOD.POD;1) which is specially designed to be readable as is. =head1 NAME README.vms - Configuring, building, testing, and installing perl on VMS =head1 SYNOPSIS To configure, build, test, and install perl on VMS: @ Configure mms mms test mms install mmk may be used in place of mms in the last three steps. =head1 DESCRIPTION =head2 Important safety tip For best results, make sure you read the "Configuring the Perl Build", "Building Perl", and "Installing Perl" sections of this document before you build or install. Also please note other changes in the current release by having a look at L. Also note that, as of Perl version 5.005 and later, an ANSI C compliant compiler is required to build Perl. VAX C is I ANSI compliant, as it died a natural death some time before the standard was set. Therefore VAX C will not compile Perl 5.005 or later. We are sorry about that. There have been no recent reports of builds using Gnu C, but latent (and most likely outdated) support for it is still present in various parts of the sources. Currently the HP (formerly Compaq, and even more formerly DEC) C compiler is the only viable alternative for building Perl. There is minimal support for HP C++ but this support is not complete; if you get it working please write to the vmsperl list (for info see L). =head2 Introduction to Perl on VMS The VMS port of Perl is as functionally complete as any other Perl port (and as complete as the ports on some Unix systems). The Perl binaries provide all the Perl system calls that are either available under VMS or reasonably emulated. There are some incompatibilities in process handling (e.g. the fork/exec model for creating subprocesses doesn't do what you might expect under Unix), mainly because VMS and Unix handle processes and sub-processes very differently. There are still some unimplemented system functions, and of course we could use modules implementing useful VMS system services, so if you'd like to lend a hand we'd love to have you. Join the Perl Porting Team Now! =head2 Other required software for Compiling Perl on VMS In addition to VMS and DCL you will need two things: =over 4 =item 1 A C compiler. HP (formerly Compaq, more formerly DEC) C for VMS (VAX, Alpha, or Itanium). Various ancient versions of DEC C had some caveats, so if you're using a version older than 7.x on Alpha or Itanium or 6.x on VAX, you may need to upgrade to get a successful build. =item 2 A make tool. HP's MMS may work, but MadGoat's free MMS analog MMK (available from http://www.kednos.com/kednos/Resources/MMK) has consistently worked better. Gnu Make might work, but it's been so long since anyone's tested it that we're not sure. MMK is free though, so go ahead and use that. =back =head2 Additional software that is optional for Perl on VMS You may also want to have on hand: =over 4 =item 1 GUNZIP/GZIP for VMS A de-compressor for *.gz and *.tgz files available from a number of web/ftp sites and is distributed on the OpenVMS Freeware CD-ROM from HP. http://www.hp.com/go/openvms/freeware/ =item 2 VMS TAR For reading and writing unix tape archives (*.tar files). Vmstar is also available from a number of web/ftp sites and is distributed on the OpenVMS Freeware CD-ROM from HP. http://www.hp.com/go/openvms/freeware/ Recent versions of VMS tar on ODS-5 volumes may extract tape archive files with ^. escaped periods in them. See below for further workarounds. A port of GNU tar is also available as part of the GNV package: http://h71000.www7.hp.com/opensource/gnv.html =item 3 UNZIP for VMS A combination decompressor and archive reader/writer for *.zip files. Unzip is available from a number of web/ftp sites. http://www.info-zip.org/UnZip.html http://www.hp.com/go/openvms/freeware/ ftp://ftp.process.com/vms-freeware/fileserv/ =item 5 GNU PATCH and DIFFUTILS for VMS Patches to Perl are usually distributed as GNU unified or contextual diffs. Such patches are created by the GNU diff program (part of the diffutils distribution) and applied with GNU patch. VMS ports of these utilities are available here: http://www.antinode.info/dec/sw/diffutils.html http://www.hp.com/go/openvms/freeware/ =back Please note that UNZIP and GUNZIP are not the same thing (they work with different formats). Many of the useful files from CPAN (the Comprehensive Perl Archive Network) are in *.tar.gz or *.tgz format (this includes copies of the source code for perl as well as modules and scripts that you may wish to add later) hence you probably want to have GUNZIP.EXE and VMSTAR.EXE on your VMS machine. If you want to include socket support, you'll need a TCP/IP stack and either DEC C, or socket libraries. See the "Socket Support (optional)" topic for more details. =head1 Unpacking the Perl source code You may need to set up a foreign symbol for the unpacking utility of choice. As of version 5.10.0, Perl will still build and run on ODS-2 volumes, including on VAX, but there are a number of modules whose temporary files and tests are much happier residing on ODS-5 volumes. For example, CPANPLUS will fail most of its tests on an ODS-2 volume because it includes files with multiple dots that will have been converted to underscores and the tests will have difficulty finding them. So your best bet is to unpack the Perl source kit on an ODS-5 volume using recent versions of vmstar (e.g. V3.4 or later). Contrary to advice provided with previous versions of Perl, do I use the ODS-2 compatability qualifier. Instead, use a command like the following: vmstar -xvf perl-5^.12^.0.tar Then rename the top-level source directory like so: set security/protection=(o:rwed) perl-5^.12^.0.dir rename perl-5^.12^.0.dir perl-5_12_0.dir The reason for this last step is that while filenames with multiple dots are generally supported by Perl on VMS, I names with multiple dots are a special case with special problems because the dot is the traditional directory delimiter on VMS. Rudimentary support for multi-dot directory names is available, but some of the oldest and most essential parts of Perl (such as searching for and loading library modules) do not yet fully support the ODS-5 caret-escape syntax. =head1 Configuring the Perl build To configure perl (a necessary first step), issue the command @ Configure from the top of an unpacked perl source directory. You will be asked a series of questions, and the answers to them (along with the capabilities of your C compiler and network stack) will determine how perl is custom built for your machine. If you have any symbols or logical names in your environment that may interfere with the build or regression testing of perl then configure.com will try to warn you about them. If a logical name is causing you trouble but is in an LNM table that you do not have write access to then try defining your own to a harmless equivalence string in a table such that it is resolved before the other (e.g. if TMP is defined in the SYSTEM table then try DEFINE TMP "NL:" or somesuch in your process table) otherwise simply deassign the dangerous logical names. The potentially troublesome logicals and symbols are: COMP "LOGICAL" EXT "LOGICAL" FOO "LOGICAL" LIB "LOGICAL" LIST "LOGICAL" MIME "LOGICAL" POSIX "LOGICAL" SYS "LOGICAL" T "LOGICAL" THREAD "LOGICAL" THREADS "LOGICAL" TIME "LOGICAL" TMP "LOGICAL" UNICODE "LOGICAL" UTIL "LOGICAL" TEST "SYMBOL" As a handy shortcut, the command: @ Configure "-des" (note the quotation marks and case) will choose reasonable defaults automatically (it takes DEC C over Gnu C, DEC C sockets over SOCKETSHR sockets, and either over no sockets). Some options can be given explicitly on the command line; the following example specifies a non-default location for where Perl will be installed: @ Configure "-d" "-Dprefix=dka100:[utils.perl5.]" Note that the installation location would be by default where you unpacked the source with a "_ROOT." appended. For example if you unpacked the perl source into: DKA200:[PERL-5_10_2...] Then the PERL_SETUP.COM that gets written out by CONFIGURE.COM will try to DEFINE your installation PERL_ROOT to be: DKA200:[PERL-5_10_2_ROOT.] More help with configure.com is available from: @ Configure "-h" See the "Changing compile-time options (optional)" section below to learn even more details about how to influence the outcome of the important configuration step. If you find yourself reconfiguring and rebuilding then be sure to also follow the advice in the "Cleaning up and starting fresh (optional)" and the checklist of items in the "CAVEATS" sections below. =head2 Changing compile-time options (optional) for Perl on VMS Most of the user definable features of Perl are enabled or disabled in configure.com, which processes the hints file config_h.SH. There is code in there to Do The Right Thing, but that may end up being the wrong thing for you. Make sure you understand what you are doing since inappropriate changes to configure.com or config_h.SH can render perl unbuildable; odds are that there's nothing in there you'll need to change. =head2 Socket Support (optional) for Perl on VMS Perl includes a number of functions for IP sockets, which are available if you choose to compile Perl with socket support. Since IP networking is an optional addition to VMS, there are several different IP stacks available. How well integrated they are into the system depends on the stack, your version of VMS, and the version of your C compiler. The default solution available is to use the socket routines built into DEC C. Which routines are available depend on the version of VMS you're running, and require proper UCX emulation by your TCP/IP vendor. Relatively current versions of Multinet, TCPWare, Pathway, and UCX all provide the required libraries--check your manuals or release notes to see if your version is new enough. The other solution uses the SOCKETSHR library. Before VAX/VMS 5.5-2 it was the most portable solution. The SOCKETSHR library has not been maintained since VAX/VMS 5.5-2, and it is not known if will even compile with the ANSI C that Perl currently requires. It remains an option for historical reasons, just in case someone might find it useful. In combination with either UCX or NetLib, this supported all the major TCP stacks (Multinet, Pathways, TCPWare, UCX, and CMU) on all versions of VMS Perl ran on up to VAX/VMS 6.2 and Alpha VMS 1.5 with all the compilers on both VAX and Alpha. The portion of the socket interface was also consistent across versions of VMS and C compilers. It has a problem with UDP sockets when used with Multinet, though, so you should be aware of that. As of VAX/VMS 5.5-2 and later, CMU is the only TCP/IP program that requires socketshr, and the sources have been lost to the most recent CMU bug fixes, so CMU is limited to OpenVMS/VAX 6.2 or earlier, which is the last release that binaries for the last released patches are known to exist. There is currently no official web site for downloading either CMU or SOCKETSHR; however, copies may be found in the DECUS archives. =head1 Building Perl The configuration script will print out, at the very end, the MMS or MMK command you need to compile perl. Issue it (exactly as printed) to start the build. Once you issue your MMS or MMK command, sit back and wait. Perl should compile and link without a problem. If a problem does occur check the "CAVEATS" section of this document. If that does not help send some mail to the VMSPERL mailing list. Instructions are in the "Mailing Lists" section of this document. =head1 Testing Perl Once Perl has built cleanly you need to test it to make sure things work. This step is very important since there are always things that can go wrong somehow and yield a dysfunctional Perl for you. Testing is very easy, though, as there's a full test suite in the perl distribution. To run the tests, enter the I MMS line you used to compile Perl and add the word "test" to the end, like this: If the compile command was: MMS then the test command ought to be: MMS test MMS (or MMK) will run all the tests. This may take some time, as there are a lot of tests. If any tests fail, there will be a note made on-screen. At the end of all the tests, a summary of the tests, the number passed and failed, and the time taken will be displayed. The test driver invoked via MMS TEST has a DCL wrapper ([.VMS]TEST.COM) that downgrades privileges to NETMBX, TMPMBX for the duration of the test run, and then restores them to their prior state upon completion of testing. This is done to ensure that the tests run in a private sandbox and can do no harm to your system even in the unlikely event something goes badly wrong in one of the test scripts while running the tests from a privileged account. A side effect of this safety precaution is that the account used to run the test suite must be the owner of the directory tree in which Perl has been built; otherwise the manipulations of temporary files and directories attempted by some of the tests will fail. If any tests fail, it means something is wrong with Perl, or at least with the particular module or feature that reported failure. If the test suite hangs (some tests can take upwards of two or three minutes, or more if you're on an especially slow machine, depending on your machine speed, so don't be hasty), then the test I the last one displayed failed. Don't install Perl unless you're confident that you're OK. Regardless of how confident you are, make a bug report to the VMSPerl mailing list. If one or more tests fail, you can get more information on the failure by issuing this command sequence: @ [.VMS]TEST .typ "" "-v" [.subdir]test.T where ".typ" is the file type of the Perl images you just built (if you didn't do anything special, use .EXE), and "[.subdir]test.T" is the test that failed. For example, with a normal Perl build, if the test indicated that t/op/time failed, then you'd do this: @ [.VMS]TEST .EXE "" "-v" [.OP]TIME.T Note that test names are reported in UNIX syntax and relative to the top-level build directory. When supplying them individually to the test driver, you can use either UNIX or VMS syntax, but you must give the path relative to the [.T] directory and you must also add the .T extension to the filename. So, for example if the test lib/Math/Trig fails, you would run: @ [.VMS]TEST .EXE "" -"v" [-.lib.math]trig.t When you send in a bug report for failed tests, please include the output from this command, which is run from the main source directory: MCR []MINIPERL "-V" Note that -"V" really is a capital V in double quotes. This will dump out a couple of screens worth of configuration information, and can help us diagnose the problem. If (and only if) that did not work then try enclosing the output of: MMS printconfig If (and only if) that did not work then try enclosing the output of: @ [.vms]myconfig You may also be asked to provide your C compiler version ("CC/VERSION NL:" with DEC C, "gcc --version" with GNU CC). To obtain the version of MMS or MMK you are running try "MMS/ident" or "MMK /ident". The GNU make version can be identified with "make --version". =head2 Cleaning up and starting fresh (optional) installing Perl on VMS If you need to recompile from scratch, you have to make sure you clean up first. There is a procedure to do it--enter the I MMS line you used to compile and add "realclean" at the end, like this: if the compile command was: MMS then the cleanup command ought to be: MMS realclean If you do not do this things may behave erratically during the subsequent rebuild attempt. They might not, too, so it is best to be sure and do it. =head1 Installing Perl There are several steps you need to take to get Perl installed and running. =over 4 =item 1 Check your default file protections with SHOW PROTECTION /DEFAULT and adjust if necessary with SET PROTECTION=(code)/DEFAULT. =item 2 Decide where you want Perl to be installed (unless you have already done so by using the "prefix" configuration parameter -- see the example in the "Configuring the Perl build" section). The DCL script PERL_SETUP.COM that is written by CONFIGURE.COM will help you with the definition of the PERL_ROOT and PERLSHR logical names and the PERL foreign command symbol. Take a look at PERL_SETUP.COM and modify it if you want to. The installation process will execute PERL_SETUP.COM and copy files to the directory tree pointed to by the PERL_ROOT logical name defined there, so make sure that you have write access to the parent directory of what will become the root of your Perl installation. =item 3 Run the install script via: MMS install or MMK install If for some reason it complains about target INSTALL being up to date, throw a /FORCE switch on the MMS or MMK command. =back Copy PERL_SETUP.COM to a place accessible to your perl users. For example: COPY PERL_SETUP.COM SYS$LIBRARY: If you want to have everyone on the system have access to perl then add a line that reads $ @sys$library:perl_setup to SYS$MANAGER:SYLOGIN.COM. Two alternatives to the foreign symbol would be to install PERL into DCLTABLES.EXE (Check out the section "Installing Perl into DCLTABLES (optional)" for more information), or put the image in a directory that's in your DCL$PATH (if you're using VMS V6.2 or higher). An alternative to having PERL_SETUP.COM define the PERLSHR logical name is to simply copy it into the system shareable library directory with: copy perl_root:[000000]perlshr.exe sys$share: See also the "INSTALLing images (optional)" section. =head2 Installing Perl into DCLTABLES (optional) on VMS Execute the following command file to define PERL as a DCL command. You'll need CMKRNL privilege to install the new dcltables.exe. $ create perl.cld ! ! modify to reflect location of your perl.exe ! define verb perl image perl_root:[000000]perl.exe cliflags (foreign) $! $ set command perl /table=sys$common:[syslib]dcltables.exe - /output=sys$common:[syslib]dcltables.exe $ install replace sys$common:[syslib]dcltables.exe $ exit =head2 INSTALLing Perl images (optional) on VMS On systems that are using perl quite a bit, and particularly those with minimal RAM, you can boost the performance of perl by INSTALLing it as a known image. PERLSHR.EXE is typically larger than 3000 blocks and that is a reasonably large amount of IO to load each time perl is invoked. INSTALL ADD PERLSHR/SHARE INSTALL ADD PERL/HEADER should be enough for PERLSHR.EXE (/share implies /header and /open), while /HEADER should do for PERL.EXE (perl.exe is not a shared image). If your code 'use's modules, check to see if there is a shareable image for them, too. In the base perl build, POSIX, IO, Fcntl, Opcode, SDBM_File, DCLsym, and Stdio, and other extensions all have shared images that can be installed /SHARE. How much of a win depends on your memory situation, but if you are firing off perl with any regularity (like more than once every 20 seconds or so) it is probably beneficial to INSTALL at least portions of perl. While there is code in perl to remove privileges as it runs you are advised to NOT INSTALL PERL.EXE with PRIVs! =head2 Running h2ph to create perl header files (optional) on VMS If using HP C, ensure that you have extracted loose versions of your compiler's header or *.H files. Be sure to check the contents of: SYS$LIBRARY:DECC$RTLDEF.TLB SYS$LIBRARY:SYS$LIB_C.TLB SYS$LIBRARY:SYS$STARLET_C.TLB etcetera. If using GNU cc then also check your GNU_CC:[000000...] tree for the locations of the GNU cc headers. =head1 Reporting Bugs If you come across what you think might be a bug in Perl, please report it. There's a script in PERL_ROOT:[UTILS], perlbug, that walks you through the process of creating a bug report. This script includes details of your installation, and is very handy. Completed bug reports should go to perlbug@perl.com. =head1 CAVEATS Probably the single biggest gotcha in compiling Perl is giving the wrong switches to MMS/MMK when you build. Use I what the configure.com script prints! The next big gotcha is directory depth. Perl can create directories four, five, or even six levels deep during the build, so you don't have to be too deep to start to hit the RMS 8 level limit (for ODS 2 volumes which were common on versions of VMS prior to V7.2 and even with V7.3 on the VAX). It is best to do: DEFINE/TRANS=(CONC,TERM) PERLSRC "disk:[dir.dir.dir.perldir.]" SET DEFAULT PERLSRC:[000000] before building in cases where you have to unpack the distribution so deep (note the trailing period in the definition of PERLSRC). Perl modules from CPAN can be just as bad (or worse), so watch out for them, too. Perl's configuration script will warn if it thinks you are too deep (at least on a VAX or on Alpha versions of VMS prior to 7.2). But MakeMaker will not warn you if you start out building a module too deep in a directory. As noted above ODS-5 escape sequences such as ^. can break the perl build. Solutions include renaming files and directories as needed when unpacking perl or CPAN modules on ODS-5 volumes. Be sure that the process that you use to build perl has a PGFLQ greater than 100000. Be sure to have a correct local time zone to UTC offset defined (in seconds) in the logical name SYS$TIMEZONE_DIFFERENTIAL before running the regression test suite. The SYS$MANAGER:UTC$CONFIGURE_TDF.COM procedure will help you set that logical for your system but may require system privileges. For example, a location 5 hours west of UTC (such as the US East coast while not on daylight savings time) would have: DEFINE SYS$TIMEZONE_DIFFERENTIAL "-18000" A final thing that causes trouble is leftover pieces from a failed build. If things go wrong make sure you do a "(MMK|MMS|make) realclean" before you rebuild. =head2 GNU issues with Perl on VMS It has been a while since the GNU utilities such as GCC or GNU make were used to build perl on VMS. Hence they may require a great deal of source code modification to work again. http://www.progis.de/ =head2 Floating Point Considerations Prior to 5.8.0, Perl simply accepted the default floating point options of the C compiler, namely representing doubles with D_FLOAT on VAX and G_FLOAT on Alpha. Single precision floating point values are represented in F_FLOAT format when either D_FLOAT or G_FLOAT is in use for doubles. Beginning with 5.8.0, Alpha builds now use IEEE floating point formats by default, which in VMS parlance are S_FLOAT for singles and T_FLOAT for doubles. IEEE is not available on VAX, so F_FLOAT and D_FLOAT remain the defaults for singles and doubles respectively. Itanium builds have always used IEEE by default. The available non-default options are G_FLOAT on VAX and D_FLOAT or G_FLOAT on Alpha or Itanium. The use of IEEE on Alpha or Itanium introduces NaN, infinity, and denormalization capabilities not available with D_FLOAT and G_FLOAT. When using one of those non-IEEE formats, silent underflow and overflow are emulated in the conversion of strings to numbers, but it is preferable to get the real thing by using IEEE where possible. Regardless of what floating point format you consider preferable, be aware that the choice may have an impact on compatibility with external libraries, such as database interfaces, and with existing data, such as data created with the C function and written to disk, or data stored via the Storable extension. For example, a C will create a D_FLOAT, G_FLOAT, or T_FLOAT depending on what your Perl was configured with. When written to disk, the value can only be retrieved later by a Perl configured with the same floating point option that was in effect when it was created. To obtain a non-IEEE build on Alpha, simply answer no to the "Use IEEE math?" question during the configuration. To obtain an option different from the C compiler default on either VAX or Alpha, put in the option that you want in answer to the "Any additional cc flags?" question. For example, to obtain a G_FLOAT build on VAX, put in C. =head1 Mailing Lists There are several mailing lists available to the Perl porter. For VMS specific issues (including both Perl questions and installation problems) there is the VMSPERL mailing list. It is usually a low-volume (10-12 messages a week) mailing list. To subscribe, send a mail message to VMSPERL-SUBSCRIBE@PERL.ORG. The VMSPERL mailing list address is VMSPERL@PERL.ORG. Any mail sent there gets echoed to all subscribers of the list. There is a searchable archive of the list on the web at: http://www.xray.mpe.mpg.de/mailing-lists/vmsperl/ To unsubscribe from VMSPERL send a message to VMSPERL-UNSUBSCRIBE@PERL.ORG. Be sure to do so from the subscribed account that you are canceling. =head2 Web sites for Perl on VMS Vmsperl pages on the web include: http://www.sidhe.org/vmsperl/index.html http://www.cpan.org/modules/by-module/VMS/ http://www.xray.mpe.mpg.de/mailing-lists/vmsperl/ http://www-ang.kfunigraz.ac.at/~binder/perl.html http://archive.develooper.com/vmsperl@perl.org/ http://h71000.www7.hp.com/openvms/products/ips/apache/csws_modperl.html =head1 SEE ALSO Perl information for users and programmers about the port of perl to VMS is available from the [.POD]PERLVMS.POD file that gets installed as L. For administrators the perlvms document also includes a detailed discussion of extending vmsperl with CPAN modules after Perl has been installed. =head1 AUTHORS Originally by Charles Bailey bailey@newman.upenn.edu. See the git repository for history. =head1 ACKNOWLEDGEMENTS A real big thanks needs to go to Charles Bailey bailey@newman.upenn.edu, who is ultimately responsible for Perl 5.004 running on VMS. Without him, nothing the rest of us have done would be at all important. There are, of course, far too many people involved in the porting and testing of Perl to mention everyone who deserves it, so please forgive us if we've missed someone. That said, special thanks are due to the following: Tim Adye T.J.Adye@rl.ac.uk for the VMS emulations of getpw*() David Denholm denholm@conmat.phys.soton.ac.uk for extensive testing and provision of pipe and SocketShr code, Mark Pizzolato mark@infocomm.com for the getredirection() code Rich Salz rsalz@bbn.com for readdir() and related routines Peter Prymmer pvhp@best.com for extensive testing, as well as development work on configuration and documentation for VMS Perl, Dan Sugalski dan@sidhe.org for extensive contributions to recent version support, development of VMS-specific extensions, and dissemination of information about VMS Perl, the Stanford Synchrotron Radiation Laboratory and the Laboratory of Nuclear Studies at Cornell University for the opportunity to test and develop for the AXP, John Hasstedt John.Hasstedt@sunysb.edu for VAX VMS V7.2 support John Malmberg wb8tyw@qsl.net for ODS-5 filename handling and other modernizations and to the entire VMSperl group for useful advice and suggestions. In addition the perl5-porters deserve credit for their creativity and willingness to work with the VMS newcomers. Finally, the greatest debt of gratitude is due to Larry Wall larry@wall.org, for having the ideas which have made our sleepless nights possible. Thanks, The VMSperl group =cut perl-5.12.0-RC0/make_ext.pl0000444000175000017500000003376311325127001014263 0ustar jessejesse#!./miniperl use strict; use warnings; use Config; BEGIN { if ($^O eq 'MSWin32') { unshift @INC, ('../cpan/Cwd', '../cpan/Cwd/lib'); require File::Spec::Functions; require FindExt; } else { unshift @INC, 'cpan/Cwd'; } } use Cwd; my $is_Win32 = $^O eq 'MSWin32'; my $is_VMS = $^O eq 'VMS'; my $is_Unix = !$is_Win32 && !$is_VMS; # To clarify, this isn't the entire suite of modules considered "toolchain" # It's not even all modules needed to build ext/ # It's just the source paths of the (minimum complete set of) modules in ext/ # needed to build the nonxs modules # After which, all nonxs modules are in lib, which was always sufficient to # allow miniperl to build everything else. # This list cannot get any longer without overflowing the length limit for # environment variables on VMS my @toolchain = qw(cpan/AutoLoader/lib cpan/Cwd cpan/Cwd/lib cpan/ExtUtils-Command/lib dist/ExtUtils-Install/lib cpan/ExtUtils-MakeMaker/lib cpan/ExtUtils-Manifest/lib cpan/File-Path/lib ); # Used only in ExtUtils::Liblist::Kid::_win32_ext() push @toolchain, 'cpan/Text-ParseWords/lib' if $is_Win32; my @ext_dirs = qw(cpan dist ext); my $ext_dirs_re = '(?:' . join('|', @ext_dirs) . ')'; # This script acts as a simple interface for building extensions. # It's actually a cut and shut of the Unix version ext/utils/makeext and the # Windows version win32/build_ext.pl hence the two invocation styles. # On Unix, it primarily used by the perl Makefile one extention at a time: # # d_dummy $(dynamic_ext): miniperl preplibrary FORCE # @$(RUN) ./miniperl make_ext.pl --target=dynamic $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) # # On Windows or VMS, # If '--static' is specified, static extensions will be built. # If '--dynamic' is specified, dynamic extensions will be built. # If '--nonxs' is specified, nonxs extensions will be built. # If '--dynaloader' is specificied, DynaLoader will be built. # If '--all' is specified, all extensions will be built. # # make_ext.pl "MAKE=make [-make_opts]" --dir=directory [--target=target] [--static|--dynamic|--all] +ext2 !ext1 # # E.g. # # make_ext.pl "MAKE=nmake -nologo" --dir=..\ext # # make_ext.pl "MAKE=nmake -nologo" --dir=..\ext --target=clean # # make_ext.pl MAKE=dmake --dir=..\ext # # make_ext.pl MAKE=dmake --dir=..\ext --target=clean # # Will skip building extensions which are marked with an '!' char. # Mostly because they still not ported to specified platform. # # If any extensions are listed with a '+' char then only those # extensions will be built, but only if they arent countermanded # by an '!ext' and are appropriate to the type of building being done. # It may be deleted in a later release of perl so try to # avoid using it for other purposes. my (%excl, %incl, %opts, @extspec, @pass_through); foreach (@ARGV) { if (/^!(.*)$/) { $excl{$1} = 1; } elsif (/^\+(.*)$/) { $incl{$1} = 1; } elsif (/^--([\w\-]+)$/) { $opts{$1} = 1; } elsif (/^--([\w\-]+)=(.*)$/) { push @{$opts{$1}}, $2; } elsif (/=/) { push @pass_through, $_; } elsif (length) { push @extspec, $_; } } my $static = $opts{static} || $opts{all}; my $dynamic = $opts{dynamic} || $opts{all}; my $nonxs = $opts{nonxs} || $opts{all}; my $dynaloader = $opts{dynaloader} || $opts{all}; # The Perl Makefile.SH will expand all extensions to # lib/auto/X/X.a (or lib/auto/X/Y/Y.a if nested) # A user wishing to run make_ext might use # X (or X/Y or X::Y if nested) # canonise into X/Y form (pname) foreach (@extspec) { if (s{^lib/auto/}{}) { # Remove lib/auto prefix and /*.* suffix s{/[^/]+\.[^/]+$}{}; } elsif (s{^$ext_dirs_re/}{}) { # Remove ext/ prefix and /pm_to_blib suffix s{/pm_to_blib$}{}; # Targets are given as files on disk, but the extension spec is still # written using /s for each :: tr!-!/!; } elsif (s{::}{\/}g) { # Convert :: to / } else { s/\..*o//; } } my $makecmd = shift @pass_through; # Should be something like MAKE=make unshift @pass_through, 'PERL_CORE=1'; my @dirs = @{$opts{dir} || \@ext_dirs}; my $target = $opts{target}[0]; $target = 'all' unless defined $target; # Previously, $make was taken from config.sh. However, the user might # instead be running a possibly incompatible make. This might happen if # the user types "gmake" instead of a plain "make", for example. The # correct current value of MAKE will come through from the main perl # makefile as MAKE=/whatever/make in $makecmd. We'll be cautious in # case third party users of this script (are there any?) don't have the # MAKE=$(MAKE) argument, which was added after 5.004_03. unless(defined $makecmd and $makecmd =~ /^MAKE=(.*)$/) { die "$0: WARNING: Please include MAKE=\$(MAKE) in \@ARGV\n"; } # This isn't going to cope with anything fancy, such as spaces inside command # names, but neither did what it replaced. Once there is a use case that needs # it, please supply patches. Until then, I'm sticking to KISS my @make = split ' ', $1 || $Config{make} || $ENV{MAKE}; # Using an array of 0 or 1 elements makes the subsequent code simpler. my @run = $Config{run}; @run = () if not defined $run[0] or $run[0] eq ''; if ($target eq '') { die "make_ext: no make target specified (eg all or clean)\n"; } elsif ($target !~ /(?:^all|clean)$/) { # for the time being we are strict about what make_ext is used for die "$0: unknown make target '$target'\n"; } if (!@extspec and !$static and !$dynamic and !$nonxs and !$dynaloader) { die "$0: no extension specified\n"; } my $perl; my %extra_passthrough; if ($is_Win32) { (my $here = getcwd()) =~ s{/}{\\}g; $perl = $^X; if ($perl =~ m#^\.\.#) { $perl = "$here\\$perl"; } (my $topdir = $perl) =~ s/\\[^\\]+$//; # miniperl needs to find perlglob and pl2bat $ENV{PATH} = "$topdir;$topdir\\win32\\bin;$ENV{PATH}"; my $pl2bat = "$topdir\\win32\\bin\\pl2bat"; unless (-f "$pl2bat.bat") { my @args = ($perl, "-I$topdir\\lib", ("$pl2bat.pl") x 2); print "@args\n"; system(@args) unless defined $::Cross::platform; } my $build = getcwd(); print "In $build"; foreach my $dir (@dirs) { chdir($dir) or die "Cannot cd to $dir: $!\n"; (my $ext = getcwd()) =~ s{/}{\\}g; FindExt::scan_ext($ext); FindExt::set_static_extensions(split ' ', $Config{static_ext}); chdir $build or die "Couldn't chdir to '$build': $!"; # restore our start directory } my @ext; push @ext, FindExt::static_ext() if $static; push @ext, FindExt::dynamic_ext() if $dynamic; push @ext, FindExt::nonxs_ext() if $nonxs; push @ext, 'DynaLoader' if $dynaloader; foreach (sort @ext) { if (%incl and !exists $incl{$_}) { #warn "Skipping extension $_, not in inclusion list\n"; next; } if (exists $excl{$_}) { warn "Skipping extension $_, not ported to current platform"; next; } push @extspec, $_; if($_ eq 'DynaLoader' and $target !~ /clean$/) { # No, we don't know why nmake can't work out the dependency chain push @{$extra_passthrough{$_}}, 'DynaLoader.c'; } elsif(FindExt::is_static($_)) { push @{$extra_passthrough{$_}}, 'LINKTYPE=static'; } } chdir '..' or die "Couldn't chdir to build directory: $!"; # now in the Perl build } elsif ($is_VMS) { $perl = $^X; push @extspec, (split ' ', $Config{static_ext}) if $static; push @extspec, (split ' ', $Config{dynamic_ext}) if $dynamic; push @extspec, (split ' ', $Config{nonxs_ext}) if $nonxs; push @extspec, 'DynaLoader' if $dynaloader; } { # Cwd needs to be built before Encode recurses into subdirectories. # This seems to be the simplest way to ensure this ordering: my (@first, @other); foreach (@extspec) { if ($_ eq 'Cwd') { push @first, $_; } else { push @other, $_; } } @extspec = (@first, @other); } if ($Config{osname} eq 'catamount' and @extspec) { # Snowball's chance of building extensions. die "This is $Config{osname}, not building $extspec[0], sorry.\n"; } foreach my $spec (@extspec) { my $mname = $spec; $mname =~ s!/!::!g; my $ext_pathname; # Try new style ext/Data-Dumper/ first my $copy = $spec; $copy =~ tr!/!-!; foreach my $dir (@ext_dirs) { if (-d "$dir/$copy") { $ext_pathname = "$dir/$copy"; last; } } if (!defined $ext_pathname) { if (-d "ext/$spec") { # Old style ext/Data/Dumper/ $ext_pathname = "ext/$spec"; } else { warn "Can't find extension $spec in any of @ext_dirs"; next; } } print "\tMaking $mname ($target)\n"; build_extension($ext_pathname, $perl, $mname, [@pass_through, @{$extra_passthrough{$spec} || []}]); } sub build_extension { my ($ext_dir, $perl, $mname, $pass_through) = @_; unless (chdir "$ext_dir") { warn "Cannot cd to $ext_dir: $!"; return; } my $up = $ext_dir; $up =~ s![^/]+!..!g; $perl ||= "$up/miniperl"; my $return_dir = $up; my $lib_dir = "$up/lib"; # $lib_dir must be last, as we're copying files into it, and in a parallel # make there's a race condition if one process tries to open a module that # another process has half-written. my @new_inc = ((map {"$up/$_"} @toolchain), $lib_dir); if ($is_Win32) { @new_inc = map {File::Spec::Functions::rel2abs($_)} @new_inc; } $ENV{PERL5LIB} = join $Config{path_sep}, @new_inc; $ENV{PERL_CORE} = 1; # warn $ENV{PERL5LIB}; my $makefile; if ($is_VMS) { $makefile = 'descrip.mms'; if ($target =~ /clean$/ && !-f $makefile && -f "${makefile}_old") { $makefile = "${makefile}_old"; } } else { $makefile = 'Makefile'; } if (!-f $makefile) { if (!-f 'Makefile.PL') { print "\nCreating Makefile.PL in $ext_dir for $mname\n"; # We need to cope well with various possible layouts my @dirs = split /::/, $mname; my $leaf = pop @dirs; my $leafname = "$leaf.pm"; my $pathname = join '/', @dirs, $leafname; my @locations = ($leafname, $pathname, "lib/$pathname"); my $fromname; foreach (@locations) { if (-f $_) { $fromname = $_; last; } } unless ($fromname) { die "For $mname tried @locations in in $ext_dir but can't find source"; } my $pod_name; ($pod_name = $fromname) =~ s/\.pm\z/.pod/; $pod_name = $fromname unless -e $pod_name; open my $fh, '>', 'Makefile.PL' or die "Can't open Makefile.PL for writing: $!"; print $fh <<"EOM"; #-*- buffer-read-only: t -*- # This Makefile.PL was written by $0. # It will be deleted automatically by make realclean use strict; use ExtUtils::MakeMaker; WriteMakefile( NAME => '$mname', VERSION_FROM => '$fromname', ABSTRACT_FROM => '$pod_name', realclean => {FILES => 'Makefile.PL'}, ); # ex: set ro: EOM close $fh or die "Can't close Makefile.PL: $!"; } print "\nRunning Makefile.PL in $ext_dir\n"; # Presumably this can be simplified my @cross; if (defined $::Cross::platform) { # Inherited from win32/buildext.pl @cross = "-MCross=$::Cross::platform"; } elsif ($opts{cross}) { # Inherited from make_ext.pl @cross = '-MCross'; } my @args = (@cross, 'Makefile.PL'); if ($is_VMS) { my $libd = VMS::Filespec::vmspath($lib_dir); push @args, "INST_LIB=$libd", "INST_ARCHLIB=$libd"; } else { push @args, 'INSTALLDIRS=perl', 'INSTALLMAN1DIR=none', 'INSTALLMAN3DIR=none'; } push @args, @$pass_through; _quote_args(\@args) if $is_VMS; print join(' ', @run, $perl, @args), "\n"; my $code = system @run, $perl, @args; warn "$code from $ext_dir\'s Makefile.PL" if $code; # Right. The reason for this little hack is that we're sitting inside # a program run by ./miniperl, but there are tasks we need to perform # when the 'realclean', 'distclean' or 'veryclean' targets are run. # Unfortunately, they can be run *after* 'clean', which deletes # ./miniperl # So we do our best to leave a set of instructions identical to what # we would do if we are run directly as 'realclean' etc # Whilst we're perfect, unfortunately the targets we call are not, as # some of them rely on a $(PERL) for their own distclean targets. # But this always used to be a problem with the old /bin/sh version of # this. if ($is_Unix) { my $suffix = '.sh'; foreach my $clean_target ('realclean', 'veryclean') { my $file = "$return_dir/$clean_target$suffix"; open my $fh, '>>', $file or die "open $file: $!"; # Quite possible that we're being run in parallel here. # Can't use Fcntl this early to get the LOCK_EX flock $fh, 2 or warn "flock $file: $!"; print $fh <<"EOS"; cd $ext_dir if test ! -f Makefile -a -f Makefile.old; then echo "Note: Using Makefile.old" make -f Makefile.old $clean_target MAKE='@make' @pass_through else if test ! -f Makefile ; then echo "Warning: No Makefile!" fi make $clean_target MAKE='@make' @pass_through fi cd $return_dir EOS close $fh or die "close $file: $!"; } } } if (not -f $makefile) { print "Warning: No Makefile!\n"; } if ($is_VMS) { _macroify_passthrough($pass_through); unshift @$pass_through, "/DESCRIPTION=$makefile"; } if (!$target or $target !~ /clean$/) { # Give makefile an opportunity to rewrite itself. # reassure users that life goes on... my @args = ('config', @$pass_through); _quote_args(\@args) if $is_VMS; system(@run, @make, @args) and print "@run @make @args failed, continuing anyway...\n"; } my @targ = ($target, @$pass_through); _quote_args(\@targ) if $is_VMS; print "Making $target in $ext_dir\n@run @make @targ\n"; my $code = system(@run, @make, @targ); die "Unsuccessful make($ext_dir): code=$code" if $code != 0; chdir $return_dir || die "Cannot cd to $return_dir: $!"; } sub _quote_args { my $args = shift; # must be array reference # Do not quote qualifiers that begin with '/'. map { if (!/^\//) { $_ =~ s/\"/""/g; # escape C<"> by doubling $_ = q(").$_.q("); } } @{$args} ; } sub _macroify_passthrough { my $passthrough = shift; _quote_args($passthrough); my $macro = '/MACRO=(' . join(',',@$passthrough) . ')'; @$passthrough = (); @$passthrough[0] = $macro; } perl-5.12.0-RC0/README0000444000175000017500000001270411347251146013015 0ustar jessejessePerl is Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 by Larry Wall and others. All rights reserved. ABOUT PERL ========== Perl is a general-purpose programming language originally developed for text manipulation and now used for a wide range of tasks including system administration, web development, network programming, GUI development, and more. The language is intended to be practical (easy to use, efficient, complete) rather than beautiful (tiny, elegant, minimal). Its major features are that it's easy to use, supports both procedural and object-oriented (OO) programming, has powerful built-in support for text processing, and has one of the world's most impressive collections of third-party modules. For an introduction to the language's features, see pod/perlintro.pod. For a discussion of the important changes in this release, see pod/perl5120delta.pod. (This will also be installed as perldelta.pod). There are also many Perl books available, covering a wide variety of topics, from various publishers. See pod/perlbook.pod for more information. INSTALLATION ============ If you're using a relatively modern operating system and want to install this version of Perl locally, run the following commands: ./Configure -des -Dprefix=$HOME/localperl make test make install This will configure and compile perl for your platform, run the regression tests, and install perl in a subdirectory "localperl" of your home directory. If you run into any trouble whatsoever or you need to install a customized version of Perl, you should read the detailed instructions in the "INSTALL" file that came with this distribution. Additionally, there are a number of "README" files with hints and tips about building and using Perl on a wide variety of platforms, some more common than others. Once you have Perl installed, a wealth of documentation is available to you through the 'perldoc' tool. To get started, run this command: perldoc perl IF YOU RUN INTO TROUBLE ======================= Perl is a large and complex system that's used for everything from knitting to rocket science. If you run into trouble, it's quite likely that someone else has already solved the problem you're facing. Once you've exhausted the documentation, please report bugs to us using the 'perlbug' tool. For more information about perlbug, either type 'perldoc perlbug' or just 'perlbug' on a line by itself. While it was current when we made it available, Perl is constantly evolving and there may be a more recent version that fixes bugs you've run into or adds new features that you might find useful. You can always find the latest version of perl on a CPAN (Comprehensive Perl Archive Network) site near you at http://www.cpan.org/src/ Just a personal note: I want you to know that I create nice things like this because it pleases the Author of my story. If this bothers you, then your notion of Authorship needs some revision. But you can use perl anyway. :-) The author. LICENSING ========= This program is free software; you can redistribute it and/or modify it under the terms of either: a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" which comes with this Kit. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either the GNU General Public License or the Artistic License for more details. You should have received a copy of the Artistic License with this Kit, in the file named "Artistic". If not, I'll be glad to provide one. You should also have received a copy of the GNU General Public License along with this program in the file named "Copying". If not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA or visit their web page on the internet at http://www.gnu.org/copyleft/gpl.html. For those of you that choose to use the GNU General Public License, my interpretation of the GNU General Public License is that no Perl script falls under the terms of the GPL unless you explicitly put said script under the terms of the GPL yourself. Furthermore, any object code linked with perl does not automatically fall under the terms of the GPL, provided such object code only adds definitions of subroutines and variables, and does not otherwise impair the resulting interpreter from executing any standard Perl script. I consider linking in C subroutines in this manner to be the moral equivalent of defining subroutines in the Perl language itself. You may sell such an object file as proprietary provided that you provide or offer to provide the Perl source, as specified by the GNU General Public License. (This is merely an alternate way of specifying input to the program.) You may also sell a binary produced by the dumping of a running Perl script that belongs to you, provided that you provide or offer to provide the Perl source as specified by the GPL. (The fact that a Perl interpreter and your code are in the same binary file is, in this case, a form of mere aggregation.) This is my interpretation of the GPL. If you still have concerns or difficulties understanding my intent, feel free to contact me. Of course, the Artistic License spells all this out for your protection, so you may prefer to use that. perl-5.12.0-RC0/beos/0000755000175000017500000000000011351321566013062 5ustar jessejesseperl-5.12.0-RC0/beos/nm.c0000444000175000017500000000270311143650473013641 0ustar jessejesse/* nm.c - a feeble shared-lib library parser * Copyright 1997, 1998 Tom Spindler * This software is covered under perl's Artistic license. */ /* $Id: nm.c,v 1.1 1998/02/16 03:51:26 dogcow Exp $ */ #include #include #include #include #include #include main(int argc, char **argv) { char *path, *symname; image_id img; int32 n = 0; volatile int32 symnamelen, symtype; void *symloc; if (argc != 2) { printf("more args, bozo\n"); exit(1); } path = (void *) malloc((size_t) 2048); symname = (void *) malloc((size_t) 2048); if (!getcwd(path, 2048)) { printf("aiee!\n"); exit(1); } if (!strcat(path, "/")) {printf("naah.\n"); exit (1); } /*printf("%s\n",path);*/ if ('/' != argv[1][0]) { if (!strcat(path, argv[1])) { printf("feh1\n"); exit(1); } } else { if (!strcpy(path, argv[1])) { printf("gah!\n"); exit(1); } } /*printf("%s\n",path);*/ img = load_add_on(path); if (B_ERROR == img) {printf("Couldn't load_add_on() %s.\n", path); exit(2); } symnamelen=2047; while (B_BAD_INDEX != get_nth_image_symbol(img, n++, symname, &symnamelen, &symtype, &symloc)) { printf("%s |%s |GLOB %Lx | \n", symname, ((B_SYMBOL_TYPE_ANY == symtype) || (B_SYMBOL_TYPE_TEXT == symtype)) ? "FUNC" : "VAR ", symloc); symnamelen=2047; } printf("number of symbols: %d\n", n); if (B_ERROR == unload_add_on(img)) {printf("err while closing.\n"); exit(3); } free(path); return(0); } perl-5.12.0-RC0/beos/beosish.h0000444000175000017500000000134011143650473014664 0ustar jessejesse#ifndef PERL_BEOS_BEOSISH_H #define PERL_BEOS_BEOSISH_H #include "../unixish.h" #undef waitpid #define waitpid beos_waitpid pid_t beos_waitpid(pid_t process_id, int *status_location, int options); /* This seems to be protoless. */ char *gcvt(double value, int num_digits, char *buffer); /* flock support, if available */ #ifdef HAS_FLOCK #include #undef close #define close flock_close #undef dup2 #define dup2 flock_dup2 #endif /* HAS_FLOCK */ #undef kill #define kill beos_kill int beos_kill(pid_t pid, int sig); #undef sigaction #define sigaction(sig, act, oact) beos_sigaction((sig), (act), (oact)) int beos_sigaction(int sig, const struct sigaction *act, struct sigaction *oact); #endif perl-5.12.0-RC0/beos/beos.c0000444000175000017500000000355711143650473014167 0ustar jessejesse#include "beos/beosish.h" #undef waitpid #undef kill #undef sigaction #include #include #include #include #include #include #include /* In BeOS 5.0 the waitpid() seems to misbehave in that the status * has the upper and lower bytes swapped compared with the usual * POSIX/UNIX implementations. To undo the surpise effect to the * rest of Perl we need this wrapper. (The rest of BeOS might be * surprised because of this, though.) */ pid_t beos_waitpid(pid_t process_id, int *status_location, int options) { pid_t got = waitpid(process_id, status_location, options); if (status_location) *status_location = (*status_location & 0x00FF) << 8 | (*status_location & 0xFF00) >> 8; return got; } /* BeOS kill() doesn't like the combination of the pseudo-signal 0 and * specifying a process group (i.e. pid < -1 || pid == 0). We work around * by changing pid to the respective process group leader. That should work * well enough in most cases. */ int beos_kill(pid_t pid, int sig) { if (sig == 0) { if (pid == 0) { /* it's our process group */ pid = getpgrp(); } else if (pid < -1) { /* just address the process group leader */ pid = -pid; } } return kill(pid, sig); } /* sigaction() should fail, if trying to ignore or install a signal handler * for a signal that cannot be caught or ignored. The BeOS R5 sigaction() * doesn't return an error, though. */ int beos_sigaction(int sig, const struct sigaction *act, struct sigaction *oact) { int result = sigaction(sig, act, oact); if (result == 0 && act && act->sa_handler != SIG_DFL && act->sa_handler != SIG_ERR && (sig == SIGKILL || sig == SIGSTOP)) { result = -1; errno = EINVAL; } return result; } perl-5.12.0-RC0/globals.c0000444000175000017500000000243211325125741013716 0ustar jessejesse/* globals.c * * Copyright (C) 1995, 1999, 2000, 2001, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * 'For the rest, they shall represent the other Free Peoples of the World: * Elves, Dwarves, and Men.' --Elrond * * [p.275 of _The Lord of the Rings_, II/iii: "The Ring Goes South"] */ /* This file exists to #include "perl.h" _ONCE_ with * PERL_IN_GLOBALS_C defined. That causes various global varaiables * in perl.h and other files it includes to be _defined_ (and initialized) * rather than just declared. * * There is a #include "perlapi.h" which makes use of the fact * that the object file created from this file will be included by linker * (to resolve global variables). perlapi.h mention various other "API" * functions not used by perl itself, but the functions get * pulled into the perl executable via the refrerence here. * */ #include "INTERN.h" #define PERL_IN_GLOBALS_C #include "perl.h" #include "perlapi.h" /* bring in PL_force_link_funcs */ /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */ perl-5.12.0-RC0/pad.c0000444000175000017500000013700011346121271013034 0ustar jessejesse/* pad.c * * Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 * by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. */ /* * 'Anyway: there was this Mr. Frodo left an orphan and stranded, as you * might say, among those queer Bucklanders, being brought up anyhow in * Brandy Hall. A regular warren, by all accounts. Old Master Gorbadoc * never had fewer than a couple of hundred relations in the place. * Mr. Bilbo never did a kinder deed than when he brought the lad back * to live among decent folk.' --the Gaffer * * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"] */ /* XXX DAPM * As of Sept 2002, this file is new and may be in a state of flux for * a while. I've marked things I intent to come back and look at further * with an 'XXX DAPM' comment. */ /* =head1 Pad Data Structures This file contains the functions that create and manipulate scratchpads, which are array-of-array data structures attached to a CV (ie a sub) and which store lexical variables and opcode temporary and per-thread values. =for apidoc m|AV *|CvPADLIST|CV *cv CV's can have CvPADLIST(cv) set to point to an AV. For these purposes "forms" are a kind-of CV, eval""s are too (except they're not callable at will and are always thrown away after the eval"" is done executing). Require'd files are simply evals without any outer lexical scope. XSUBs don't have CvPADLIST set - dXSTARG fetches values from PL_curpad, but that is really the callers pad (a slot of which is allocated by every entersub). The CvPADLIST AV has does not have AvREAL set, so REFCNT of component items is managed "manual" (mostly in pad.c) rather than normal av.c rules. The items in the AV are not SVs as for a normal AV, but other AVs: 0'th Entry of the CvPADLIST is an AV which represents the "names" or rather the "static type information" for lexicals. The CvDEPTH'th entry of CvPADLIST AV is an AV which is the stack frame at that depth of recursion into the CV. The 0'th slot of a frame AV is an AV which is @_. other entries are storage for variables and op targets. During compilation: C is set to the names AV. C is set to the frame AV for the frame CvDEPTH == 1. C is set to the body of the frame AV (i.e. AvARRAY(PL_comppad)). During execution, C and C refer to the live frame of the currently executing sub. Iterating over the names AV iterates over all possible pad items. Pad slots that are SVs_PADTMP (targets/GVs/constants) end up having &PL_sv_undef "names" (see pad_alloc()). Only my/our variable (SVs_PADMY/SVs_PADOUR) slots get valid names. The rest are op targets/GVs/constants which are statically allocated or resolved at compile time. These don't have names by which they can be looked up from Perl code at run time through eval"" like my/our variables can be. Since they can't be looked up by "name" but only by their index allocated at compile time (which is usually in PL_op->op_targ), wasting a name SV for them doesn't make sense. The SVs in the names AV have their PV being the name of the variable. xlow+1..xhigh inclusive in the NV union is a range of cop_seq numbers for which the name is valid. For typed lexicals name SV is SVt_PVMG and SvSTASH points at the type. For C lexicals, the type is also SVt_PVMG, with the SvOURSTASH slot pointing at the stash of the associated global (so that duplicate C declarations in the same package can be detected). SvUVX is sometimes hijacked to store the generation number during compilation. If SvFAKE is set on the name SV, then that slot in the frame AV is a REFCNT'ed reference to a lexical from "outside". In this case, the name SV does not use xlow and xhigh to store a cop_seq range, since it is in scope throughout. Instead xhigh stores some flags containing info about the real lexical (is it declared in an anon, and is it capable of being instantiated multiple times?), and for fake ANONs, xlow contains the index within the parent's pad where the lexical's value is stored, to make cloning quicker. If the 'name' is '&' the corresponding entry in frame AV is a CV representing a possible closure. (SvFAKE and name of '&' is not a meaningful combination currently but could become so if C is implemented.) Note that formats are treated as anon subs, and are cloned each time write is called (if necessary). The flag SVs_PADSTALE is cleared on lexicals each time the my() is executed, and set on scope exit. This allows the 'Variable $x is not available' warning to be generated in evals, such as { my $x = 1; sub f { eval '$x'} } f(); For state vars, SVs_PADSTALE is overloaded to mean 'not yet initialised' =cut */ #include "EXTERN.h" #define PERL_IN_PAD_C #include "perl.h" #include "keywords.h" #define COP_SEQ_RANGE_LOW_set(sv,val) \ STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END #define COP_SEQ_RANGE_HIGH_set(sv,val) \ STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END #define PARENT_PAD_INDEX_set(sv,val) \ STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END #define PARENT_FAKELEX_FLAGS_set(sv,val) \ STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END #define PAD_MAX I32_MAX #ifdef PERL_MAD void pad_peg(const char* s) { static int pegcnt; PERL_ARGS_ASSERT_PAD_PEG; pegcnt++; } #endif /* =for apidoc pad_new Create a new compiling padlist, saving and updating the various global vars at the same time as creating the pad itself. The following flags can be OR'ed together: padnew_CLONE this pad is for a cloned CV padnew_SAVE save old globals padnew_SAVESUB also save extra stuff for start of sub =cut */ PADLIST * Perl_pad_new(pTHX_ int flags) { dVAR; AV *padlist, *padname, *pad; ASSERT_CURPAD_LEGAL("pad_new"); /* XXX DAPM really need a new SAVEt_PAD which restores all or most * vars (based on flags) rather than storing vals + addresses for * each individually. Also see pad_block_start. * XXX DAPM Try to see whether all these conditionals are required */ /* save existing state, ... */ if (flags & padnew_SAVE) { SAVECOMPPAD(); SAVESPTR(PL_comppad_name); if (! (flags & padnew_CLONE)) { SAVEI32(PL_padix); SAVEI32(PL_comppad_name_fill); SAVEI32(PL_min_intro_pending); SAVEI32(PL_max_intro_pending); SAVEBOOL(PL_cv_has_eval); if (flags & padnew_SAVESUB) { SAVEBOOL(PL_pad_reset_pending); } } } /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be * saved - check at some pt that this is okay */ /* ... create new pad ... */ padlist = newAV(); padname = newAV(); pad = newAV(); if (flags & padnew_CLONE) { /* XXX DAPM I dont know why cv_clone needs it * doing differently yet - perhaps this separate branch can be * dispensed with eventually ??? */ AV * const a0 = newAV(); /* will be @_ */ av_extend(a0, 0); av_store(pad, 0, MUTABLE_SV(a0)); AvREIFY_only(a0); } else { av_store(pad, 0, NULL); } AvREAL_off(padlist); av_store(padlist, 0, MUTABLE_SV(padname)); av_store(padlist, 1, MUTABLE_SV(pad)); /* ... then update state variables */ PL_comppad_name = MUTABLE_AV((*av_fetch(padlist, 0, FALSE))); PL_comppad = MUTABLE_AV((*av_fetch(padlist, 1, FALSE))); PL_curpad = AvARRAY(PL_comppad); if (! (flags & padnew_CLONE)) { PL_comppad_name_fill = 0; PL_min_intro_pending = 0; PL_padix = 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 ) ); return (PADLIST*)padlist; } /* =for apidoc pad_undef 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. (This function should really be called pad_free, but the name was already taken) =cut */ void Perl_pad_undef(pTHX_ CV* cv) { dVAR; I32 ix; const PADLIST * const padlist = CvPADLIST(cv); PERL_ARGS_ASSERT_PAD_UNDEF; pad_peg("pad_undef"); if (!padlist) return; if (SvIS_FREED(padlist)) /* may be during global destruction */ return; 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. */ /* XXX DAPM for efficiency, we should only do this if we know we have * children, or integrate this loop with general cleanup */ if (!PL_dirty) { /* don't bother during global destruction */ CV * const outercv = CvOUTSIDE(cv); const U32 seq = CvOUTSIDE_SEQ(cv); AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]); SV ** const namepad = AvARRAY(comppad_name); AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]); SV ** const curpad = AvARRAY(comppad); for (ix = AvFILLp(comppad_name); ix > 0; ix--) { SV * const namesv = namepad[ix]; if (namesv && namesv != &PL_sv_undef && *SvPVX_const(namesv) == '&') { CV * const innercv = MUTABLE_CV(curpad[ix]); U32 inner_rc = SvREFCNT(innercv); assert(inner_rc); namepad[ix] = NULL; SvREFCNT_dec(namesv); if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */ curpad[ix] = NULL; SvREFCNT_dec(innercv); inner_rc--; } /* in use, not just a prototype */ if (inner_rc && (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 = AvFILLp(padlist); while (ix >= 0) { SV* const sv = AvARRAY(padlist)[ix--]; if (sv) { if (sv == (const SV *)PL_comppad_name) PL_comppad_name = NULL; else if (sv == (const SV *)PL_comppad) { PL_comppad = NULL; PL_curpad = NULL; } } SvREFCNT_dec(sv); } SvREFCNT_dec(MUTABLE_SV(CvPADLIST(cv))); CvPADLIST(cv) = NULL; } static PADOFFSET S_pad_add_name_sv(pTHX_ SV *namesv, const U32 flags, HV *typestash, HV *ourstash) { dVAR; const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY); PERL_ARGS_ASSERT_PAD_ADD_NAME_SV; ASSERT_CURPAD_ACTIVE("pad_add_name"); if (typestash) { assert(SvTYPE(namesv) == SVt_PVMG); SvPAD_TYPED_on(namesv); SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash)))); } if (ourstash) { SvPAD_OUR_on(namesv); SvOURSTASH_set(namesv, ourstash); SvREFCNT_inc_simple_void_NN(ourstash); } else if (flags & padadd_STATE) { SvPAD_STATE_on(namesv); } av_store(PL_comppad_name, offset, namesv); return offset; } /* =for apidoc pad_add_name Create a new name and associated PADMY SV in the current pad; return the offset. If C is valid, the name is for a typed lexical; set the name's stash to that value. If C is valid, it's an our lexical, set the name's SvOURSTASH to that value If fake, it means we're cloning an existing entry =cut */ PADOFFSET Perl_pad_add_name(pTHX_ const char *name, const STRLEN len, const U32 flags, HV *typestash, HV *ourstash) { dVAR; PADOFFSET offset; SV *namesv; PERL_ARGS_ASSERT_PAD_ADD_NAME; if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK)) Perl_croak(aTHX_ "panic: pad_add_name illegal flag bits 0x%" UVxf, (UV)flags); namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV); /* Until we're using the length for real, cross check that we're being told the truth. */ PERL_UNUSED_ARG(len); assert(strlen(name) == len); sv_setpv(namesv, name); if ((flags & padadd_NO_DUP_CHECK) == 0) { /* check for duplicate declaration */ pad_check_dup(namesv, flags & padadd_OUR, ourstash); } offset = pad_add_name_sv(namesv, flags, typestash, ourstash); /* not yet introduced */ COP_SEQ_RANGE_LOW_set(namesv, PAD_MAX); /* min */ COP_SEQ_RANGE_HIGH_set(namesv, 0); /* max */ if (!PL_min_intro_pending) PL_min_intro_pending = offset; PL_max_intro_pending = offset; /* if it's not a simple scalar, replace with an AV or HV */ /* XXX DAPM since slot has been allocated, replace * av_store with PL_curpad[offset] ? */ if (*name == '@') av_store(PL_comppad, offset, MUTABLE_SV(newAV())); else if (*name == '%') av_store(PL_comppad, offset, MUTABLE_SV(newHV())); SvPADMY_on(PL_curpad[offset]); DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n", (long)offset, name, PTR2UV(PL_curpad[offset]))); return offset; } /* =for apidoc pad_alloc Allocate a new my or tmp pad entry. For a my, simply push a null SV onto the end of PL_comppad, but for a tmp, scan the pad from PL_padix upwards for a slot which has no name and no active value. =cut */ /* XXX DAPM integrate alloc(), add_name() and add_anon(), * or at least rationalise ??? */ /* And flag whether the incoming name is UTF8 or 8 bit? Could do this either with the +ve/-ve hack of the HV code, or expanding the flag bits. Either way, this makes proper Unicode safe pad support. NWC */ PADOFFSET Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype) { dVAR; SV *sv; I32 retval; PERL_UNUSED_ARG(optype); ASSERT_CURPAD_ACTIVE("pad_alloc"); if (AvARRAY(PL_comppad) != PL_curpad) Perl_croak(aTHX_ "panic: pad_alloc"); if (PL_pad_reset_pending) pad_reset(); if (tmptype & SVs_PADMY) { sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE); retval = AvFILLp(PL_comppad); } else { SV * const * const names = AvARRAY(PL_comppad_name); const SSize_t names_fill = AvFILLp(PL_comppad_name); for (;;) { /* * "foreach" index vars temporarily become aliases to non-"my" * values. Thus we must skip, not just pad values that are * marked as current pad values, but also those with names. */ /* HVDS why copy to sv here? we don't seem to use it */ if (++PL_padix <= names_fill && (sv = names[PL_padix]) && sv != &PL_sv_undef) continue; sv = *av_fetch(PL_comppad, PL_padix, TRUE); if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) && !IS_PADGV(sv) && !IS_PADCONST(sv)) break; } retval = PL_padix; } 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])); #ifdef DEBUG_LEAKING_SCALARS sv->sv_debug_optype = optype; sv->sv_debug_inpad = 1; #endif return (PADOFFSET)retval; } /* =for apidoc pad_add_anon Add an anon code entry to the current compiling pad =cut */ PADOFFSET Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type) { dVAR; PADOFFSET ix; SV* const name = newSV_type(SVt_PVNV); PERL_ARGS_ASSERT_PAD_ADD_ANON; pad_peg("add_anon"); sv_setpvs(name, "&"); /* Are these two actually ever read? */ COP_SEQ_RANGE_HIGH_set(name, ~0); COP_SEQ_RANGE_LOW_set(name, 1); ix = pad_alloc(op_type, SVs_PADMY); av_store(PL_comppad_name, ix, name); /* XXX DAPM use PL_curpad[] ? */ av_store(PL_comppad, ix, sv); SvPADMY_on(sv); /* to avoid ref loops, we never have parent + child referencing each * other simultaneously */ if (CvOUTSIDE((const CV *)sv)) { assert(!CvWEAKOUTSIDE((const CV *)sv)); CvWEAKOUTSIDE_on(MUTABLE_CV(sv)); SvREFCNT_dec(CvOUTSIDE(MUTABLE_CV(sv))); } return ix; } /* =for apidoc pad_check_dup Check for duplicate declarations: report any of: * a my in the current scope with the same name; * an our (anywhere in the pad) with the same name and the same stash as C C indicates that the name to check is an 'our' declaration =cut */ STATIC void S_pad_check_dup(pTHX_ SV *name, const U32 flags, const HV *ourstash) { dVAR; SV **svp; PADOFFSET top, off; const U32 is_our = flags & padadd_OUR; PERL_ARGS_ASSERT_PAD_CHECK_DUP; ASSERT_CURPAD_ACTIVE("pad_check_dup"); assert((flags & ~padadd_OUR) == 0); if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC)) return; /* nothing to check */ svp = AvARRAY(PL_comppad_name); top = AvFILLp(PL_comppad_name); /* check the current scope */ /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same * type ? */ for (off = top; (I32)off > PL_comppad_name_floor; off--) { SV * const sv = svp[off]; if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX || COP_SEQ_RANGE_HIGH(sv) == 0) && sv_eq(name, sv)) { if (is_our && (SvPAD_OUR(sv))) break; /* "our" masking "our" */ Perl_warner(aTHX_ packWARN(WARN_MISC), "\"%s\" variable %"SVf" masks earlier declaration in same %s", (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"), sv, (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX ? "scope" : "statement")); --off; break; } } /* check the rest of the pad */ if (is_our) { do { SV * const sv = svp[off]; if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX || COP_SEQ_RANGE_HIGH(sv) == 0) && SvOURSTASH(sv) == ourstash && sv_eq(name, sv)) { Perl_warner(aTHX_ packWARN(WARN_MISC), "\"our\" variable %"SVf" redeclared", sv); if ((I32)off <= PL_comppad_name_floor) Perl_warner(aTHX_ packWARN(WARN_MISC), "\t(Did you mean \"local\" instead of \"our\"?)\n"); break; } } while ( off-- > 0 ); } } /* =for apidoc pad_findmy Given a lexical name, try to find its offset, first in the current pad, or failing that, in the pads of any lexically enclosing subs (including the complications introduced by eval). If the name is found in an outer pad, then a fake entry is added to the current pad. Returns the offset in the current pad, or NOT_IN_PAD on failure. =cut */ PADOFFSET Perl_pad_findmy(pTHX_ const char *name, STRLEN len, U32 flags) { dVAR; SV *out_sv; int out_flags; I32 offset; const AV *nameav; SV **name_svp; PERL_ARGS_ASSERT_PAD_FINDMY; pad_peg("pad_findmy"); if (flags) Perl_croak(aTHX_ "panic: pad_findmy illegal flag bits 0x%" UVxf, (UV)flags); /* Yes, it is a bug (read work in progress) that we're not really using this length parameter, and instead relying on strlen() later on. But I'm not comfortable about changing the pad API piecemeal to use and rely on lengths. This only exists to avoid an "unused parameter" warning. */ if (len < 2) return NOT_IN_PAD; /* But until we're using the length for real, cross check that we're being told the truth. */ assert(strlen(name) == len); offset = pad_findlex(name, PL_compcv, PL_cop_seqmax, 1, NULL, &out_sv, &out_flags); if ((PADOFFSET)offset != NOT_IN_PAD) return offset; /* look for an our that's being introduced; this allows * our $foo = 0 unless defined $foo; * to not give a warning. (Yes, this is a hack) */ nameav = MUTABLE_AV(AvARRAY(CvPADLIST(PL_compcv))[0]); name_svp = AvARRAY(nameav); for (offset = AvFILLp(nameav); offset > 0; offset--) { const SV * const namesv = name_svp[offset]; if (namesv && namesv != &PL_sv_undef && !SvFAKE(namesv) && (SvPAD_OUR(namesv)) && strEQ(SvPVX_const(namesv), name) && COP_SEQ_RANGE_LOW(namesv) == PAD_MAX /* min */ ) return offset; } return NOT_IN_PAD; } /* * Returns the offset of a lexical $_, if there is one, at run time. * Used by the UNDERBAR XS macro. */ PADOFFSET Perl_find_rundefsvoffset(pTHX) { dVAR; SV *out_sv; int out_flags; return pad_findlex("$_", find_runcv(NULL), PL_curcop->cop_seq, 1, NULL, &out_sv, &out_flags); } /* =for apidoc pad_findlex Find a named lexical anywhere in a chain of nested pads. Add fake entries in the inner pads if it's found in an outer one. Returns the offset in the bottom pad of the lex or the fake lex. cv is the CV in which to start the search, and seq is the current cop_seq to match against. If warn is true, print appropriate warnings. The out_* vars return values, and so are pointers to where the returned values should be stored. out_capture, if non-null, requests that the innermost instance of the lexical is captured; out_name_sv is set to the innermost matched namesv or fake namesv; out_flags returns the flags normally associated with the IVX field of a fake namesv. Note that pad_findlex() is recursive; it recurses up the chain of CVs, then comes back down, adding fake entries as it goes. It has to be this way because fake namesvs in anon protoypes have to store in xlow the index into the parent pad. =cut */ /* the CV has finished being compiled. This is not a sufficient test for * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */ #define CvCOMPILED(cv) CvROOT(cv) /* the CV does late binding of its lexicals */ #define CvLATE(cv) (CvANON(cv) || SvTYPE(cv) == SVt_PVFM) STATIC PADOFFSET S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn, SV** out_capture, SV** out_name_sv, int *out_flags) { dVAR; I32 offset, new_offset; SV *new_capture; SV **new_capturep; const AV * const padlist = CvPADLIST(cv); PERL_ARGS_ASSERT_PAD_FINDLEX; *out_flags = 0; DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad findlex cv=0x%"UVxf" searching \"%s\" seq=%d%s\n", PTR2UV(cv), name, (int)seq, out_capture ? " capturing" : "" )); /* first, search this pad */ if (padlist) { /* not an undef CV */ I32 fake_offset = 0; const AV * const nameav = MUTABLE_AV(AvARRAY(padlist)[0]); SV * const * const name_svp = AvARRAY(nameav); for (offset = AvFILLp(nameav); offset > 0; offset--) { const SV * const namesv = name_svp[offset]; if (namesv && namesv != &PL_sv_undef && strEQ(SvPVX_const(namesv), name)) { if (SvFAKE(namesv)) fake_offset = offset; /* in case we don't find a real one */ else if ( seq > COP_SEQ_RANGE_LOW(namesv) /* min */ && seq <= COP_SEQ_RANGE_HIGH(namesv)) /* max */ break; } } if (offset > 0 || fake_offset > 0 ) { /* a match! */ if (offset > 0) { /* not fake */ fake_offset = 0; *out_name_sv = name_svp[offset]; /* return the namesv */ /* 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 alreadly-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_sv), (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv))); } else { /* fake match */ offset = fake_offset; *out_name_sv = name_svp[offset]; /* return the namesv */ *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv); 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_sv) )); } /* return the lex? */ if (out_capture) { /* our ? */ if (SvPAD_OUR(*out_name_sv)) { *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) Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE), "Variable \"%s\" is not available", name); *out_capture = NULL; } /* real value */ else { int newwarn = warn; if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI) && !SvPAD_STATE(name_svp[offset]) && warn && ckWARN(WARN_CLOSURE)) { newwarn = 0; Perl_warner(aTHX_ packWARN(WARN_CLOSURE), "Variable \"%s\" will not stay shared", name); } if (fake_offset && CvANON(cv) && CvCLONE(cv) &&!CvCLONED(cv)) { SV *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_sv; (void) pad_findlex(name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), newwarn, out_capture, out_name_sv, out_flags); *out_name_sv = n; return offset; } *out_capture = AvARRAY(MUTABLE_AV(AvARRAY(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) && !SvPAD_STATE(name_svp[offset])) { Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE), "Variable \"%s\" is not available", name); *out_capture = NULL; } } if (!*out_capture) { if (*name == '@') *out_capture = sv_2mortal(MUTABLE_SV(newAV())); else if (*name == '%') *out_capture = sv_2mortal(MUTABLE_SV(newHV())); else *out_capture = sv_newmortal(); } } return offset; } } /* it's not in this pad - try above */ if (!CvOUTSIDE(cv)) 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; offset = pad_findlex(name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1, new_capturep, out_name_sv, out_flags); if ((PADOFFSET)offset == 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 */ { /* This relies on sv_setsv_flags() upgrading the destination to the same type as the source, independant of the flags set, and on it being "good" and only copying flag bits and pointers that it understands. */ SV *new_namesv = newSVsv(*out_name_sv); AV * const ocomppad_name = PL_comppad_name; PAD * const ocomppad = PL_comppad; PL_comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]); PL_comppad = MUTABLE_AV(AvARRAY(padlist)[1]); PL_curpad = AvARRAY(PL_comppad); new_offset = pad_add_name_sv(new_namesv, (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0), SvPAD_TYPED(*out_name_sv) ? SvSTASH(*out_name_sv) : NULL, SvOURSTASH(*out_name_sv) ); SvFAKE_on(new_namesv); DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad addname: %ld \"%.*s\" FAKE\n", (long)new_offset, (int) SvCUR(new_namesv), SvPVX(new_namesv))); PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags); PARENT_PAD_INDEX_set(new_namesv, 0); if (SvPAD_OUR(new_namesv)) { NOOP; /* do nothing */ } else if (CvLATE(cv)) { /* delayed creation - just note the offset within parent pad */ PARENT_PAD_INDEX_set(new_namesv, offset); CvCLONE_on(cv); } else { /* immediate creation - capture outer value right now */ av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep)); 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_sv = new_namesv; *out_flags = PARENT_FAKELEX_FLAGS(new_namesv); PL_comppad_name = ocomppad_name; PL_comppad = ocomppad; PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL; } return new_offset; } #ifdef DEBUGGING /* =for apidoc pad_sv Get the value at offset po in the current pad. Use macro PAD_SV instead of calling this function directly. =cut */ SV * Perl_pad_sv(pTHX_ PADOFFSET po) { dVAR; ASSERT_CURPAD_ACTIVE("pad_sv"); if (!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])) ); return PL_curpad[po]; } /* =for apidoc pad_setsv Set the entry at offset po in the current pad to sv. Use the macro PAD_SETSV() rather than calling this function directly. =cut */ void Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv) { dVAR; PERL_ARGS_ASSERT_PAD_SETSV; 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)) ); PL_curpad[po] = sv; } #endif /* =for apidoc pad_block_start Update the pad compilation state variables on entry to a new block =cut */ /* XXX DAPM perhaps: * - integrate this in general state-saving routine ??? * - combine with the state-saving going on in pad_new ??? * - introduce a new SAVE type that does all this in one go ? */ void Perl_pad_block_start(pTHX_ int full) { dVAR; ASSERT_CURPAD_ACTIVE("pad_block_start"); SAVEI32(PL_comppad_name_floor); PL_comppad_name_floor = AvFILLp(PL_comppad_name); if (full) PL_comppad_name_fill = PL_comppad_name_floor; if (PL_comppad_name_floor < 0) PL_comppad_name_floor = 0; SAVEI32(PL_min_intro_pending); SAVEI32(PL_max_intro_pending); PL_min_intro_pending = 0; SAVEI32(PL_comppad_name_fill); SAVEI32(PL_padix_floor); PL_padix_floor = PL_padix; PL_pad_reset_pending = FALSE; } /* =for apidoc intro_my "Introduce" my variables to visible status. =cut */ U32 Perl_intro_my(pTHX) { dVAR; SV **svp; I32 i; ASSERT_CURPAD_ACTIVE("intro_my"); if (! PL_min_intro_pending) return PL_cop_seqmax; svp = AvARRAY(PL_comppad_name); for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) { SV * const sv = svp[i]; if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && !COP_SEQ_RANGE_HIGH(sv)) { COP_SEQ_RANGE_HIGH_set(sv, PAD_MAX); /* 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, SvPVX_const(sv), (unsigned long)COP_SEQ_RANGE_LOW(sv), (unsigned long)COP_SEQ_RANGE_HIGH(sv)) ); } } 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+1))); return PL_cop_seqmax++; } /* =for apidoc pad_leavemy Cleanup at end of scope during compilation: set the max seq number for lexicals in this scope and warn of any lexicals that never got introduced. =cut */ void Perl_pad_leavemy(pTHX) { dVAR; I32 off; SV * const * const svp = AvARRAY(PL_comppad_name); PL_pad_reset_pending = FALSE; 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 SV * const sv = svp[off]; if (sv && sv != &PL_sv_undef && !SvFAKE(sv)) Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "%"SVf" never introduced", SVfARG(sv)); } } /* "Deintroduce" my variables that are leaving with this scope. */ for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) { const SV * const sv = svp[off]; if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && COP_SEQ_RANGE_HIGH(sv) == PAD_MAX) { 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, SvPVX_const(sv), (unsigned long)COP_SEQ_RANGE_LOW(sv), (unsigned long)COP_SEQ_RANGE_HIGH(sv)) ); } } PL_cop_seqmax++; DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax)); } /* =for apidoc pad_swipe Abandon the tmp in the current pad at offset po and replace with a new one. =cut */ void Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust) { dVAR; ASSERT_CURPAD_LEGAL("pad_swipe"); if (!PL_curpad) return; if (AvARRAY(PL_comppad) != PL_curpad) Perl_croak(aTHX_ "panic: pad_swipe curpad"); if (!po) Perl_croak(aTHX_ "panic: pad_swipe po"); DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n", PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)); if (PL_curpad[po]) SvPADTMP_off(PL_curpad[po]); if (refadjust) SvREFCNT_dec(PL_curpad[po]); /* if pad tmps aren't shared between ops, then there's no need to * create a new tmp when an existing op is freed */ #ifdef USE_BROKEN_PAD_RESET PL_curpad[po] = newSV(0); SvPADTMP_on(PL_curpad[po]); #else PL_curpad[po] = &PL_sv_undef; #endif if ((I32)po < PL_padix) PL_padix = po - 1; } /* =for apidoc pad_reset Mark all the current temporaries for reuse =cut */ /* XXX pad_reset() is currently disabled because it results in serious bugs. * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed * on the stack by OPs that use them, there are several ways to get an alias * to a shared TARG. Such an alias will change randomly and unpredictably. * We avoid doing this until we can think of a Better Way. * GSAR 97-10-29 */ static void S_pad_reset(pTHX) { dVAR; #ifdef USE_BROKEN_PAD_RESET if (AvARRAY(PL_comppad) != PL_curpad) Perl_croak(aTHX_ "panic: pad_reset 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 ) ); if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */ register I32 po; for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) { if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po])) SvPADTMP_off(PL_curpad[po]); } PL_padix = PL_padix_floor; } #endif PL_pad_reset_pending = FALSE; } /* =for apidoc pad_tidy Tidy up a pad after we've finished compiling it: * remove most stuff from the pads of anonsub prototypes; * give it a @_; * mark tmps as such. =cut */ /* XXX DAPM surely most of this stuff should be done properly * at the right time beforehand, rather than going around afterwards * cleaning up our mistakes ??? */ void Perl_pad_tidy(pTHX_ padtidy_type type) { dVAR; ASSERT_CURPAD_ACTIVE("pad_tidy"); /* If this CV has had any 'eval-capable' ops planted in it * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any * anon prototypes in the chain of CVs should be marked as cloneable, * so that for example the eval's CV in C<< sub { eval '$x' } >> gets * the right CvOUTSIDE. * If running with -d, *any* sub may potentially have an eval * excuted within it. */ 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); } } } /* extend curpad to match namepad */ if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad)) av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL); if (type == padtidy_SUBCLONE) { SV * const * const namep = AvARRAY(PL_comppad_name); PADOFFSET ix; for (ix = AvFILLp(PL_comppad); ix > 0; ix--) { SV *namesv; if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix])) continue; /* * The only things that a clonable function needs in its * pad are anonymous subs. * The rest are created anew during cloning. */ if (!((namesv = namep[ix]) != NULL && namesv != &PL_sv_undef && *SvPVX_const(namesv) == '&')) { SvREFCNT_dec(PL_curpad[ix]); PL_curpad[ix] = NULL; } } } else if (type == padtidy_SUB) { /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */ AV * const av = newAV(); /* Will be @_ */ av_extend(av, 0); av_store(PL_comppad, 0, MUTABLE_SV(av)); AvREIFY_only(av); } /* XXX DAPM rationalise these two similar branches */ if (type == padtidy_SUB) { PADOFFSET ix; for (ix = AvFILLp(PL_comppad); ix > 0; ix--) { if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix])) continue; if (!SvPADMY(PL_curpad[ix])) SvPADTMP_on(PL_curpad[ix]); } } else if (type == padtidy_FORMAT) { PADOFFSET ix; for (ix = AvFILLp(PL_comppad); ix > 0; ix--) { if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix])) SvPADTMP_on(PL_curpad[ix]); } } PL_curpad = AvARRAY(PL_comppad); } /* =for apidoc pad_free Free the SV at offset po in the current pad. =cut */ /* XXX DAPM integrate with pad_swipe ???? */ void Perl_pad_free(pTHX_ PADOFFSET po) { dVAR; ASSERT_CURPAD_LEGAL("pad_free"); if (!PL_curpad) return; if (AvARRAY(PL_comppad) != PL_curpad) Perl_croak(aTHX_ "panic: pad_free curpad"); if (!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) ); if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) { SvPADTMP_off(PL_curpad[po]); #ifdef USE_ITHREADS /* SV could be a shared hash key (eg bugid #19022) */ if (!SvIsCOW(PL_curpad[po])) SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */ #endif } if ((I32)po < PL_padix) PL_padix = po - 1; } /* =for apidoc do_dump_pad Dump the contents of a padlist =cut */ void Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full) { dVAR; const AV *pad_name; const AV *pad; SV **pname; SV **ppad; I32 ix; PERL_ARGS_ASSERT_DO_DUMP_PAD; if (!padlist) { return; } pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE)); pad = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 1, FALSE)); pname = AvARRAY(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) ); for (ix = 1; ix <= AvFILLp(pad_name); ix++) { const SV *namesv = pname[ix]; if (namesv && namesv == &PL_sv_undef) { namesv = NULL; } if (namesv) { if (SvFAKE(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), SvPVX_const(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), SvPVX_const(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) ); } } } /* =for apidoc cv_dump dump the contents of a CV =cut */ #ifdef DEBUGGING STATIC void S_cv_dump(pTHX_ const CV *cv, const char *title) { dVAR; const CV * const outside = CvOUTSIDE(cv); AV* const padlist = CvPADLIST(cv); 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")); PerlIO_printf(Perl_debug_log, " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist)); do_dump_pad(1, Perl_debug_log, padlist, 1); } #endif /* DEBUGGING */ /* =for apidoc cv_clone Clone a CV: make a new CV which points to the same code etc, but which has a newly-created pad built by copying the prototype pad and capturing any outer lexicals. =cut */ CV * Perl_cv_clone(pTHX_ CV *proto) { dVAR; I32 ix; AV* const protopadlist = CvPADLIST(proto); const AV *const protopad_name = (const AV *)*av_fetch(protopadlist, 0, FALSE); const AV *const protopad = (const AV *)*av_fetch(protopadlist, 1, FALSE); SV** const pname = AvARRAY(protopad_name); SV** const ppad = AvARRAY(protopad); const I32 fname = AvFILLp(protopad_name); const I32 fpad = AvFILLp(protopad); CV* cv; SV** outpad; CV* outside; long depth; PERL_ARGS_ASSERT_CV_CLONE; assert(!CvUNIQUE(proto)); /* Since cloneable anon subs can be nested, CvOUTSIDE may point * to a prototype; we instead want the cloned parent who called us. * Note that in general for formats, CvOUTSIDE != find_runcv */ outside = CvOUTSIDE(proto); if (outside && CvCLONE(outside) && ! CvCLONED(outside)) outside = find_runcv(NULL); depth = CvDEPTH(outside); assert(depth || SvTYPE(proto) == SVt_PVFM); if (!depth) depth = 1; assert(CvPADLIST(outside)); ENTER; SAVESPTR(PL_compcv); cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto))); CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE); CvCLONED_on(cv); #ifdef USE_ITHREADS CvFILE(cv) = CvISXSUB(proto) ? CvFILE(proto) : savepv(CvFILE(proto)); #else CvFILE(cv) = CvFILE(proto); #endif CvGV(cv) = CvGV(proto); CvSTASH(cv) = CvSTASH(proto); OP_REFCNT_LOCK; CvROOT(cv) = OpREFCNT_inc(CvROOT(proto)); OP_REFCNT_UNLOCK; CvSTART(cv) = CvSTART(proto); CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside)); CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto); if (SvPOK(proto)) sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto)); CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE); av_fill(PL_comppad, fpad); for (ix = fname; ix >= 0; ix--) av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix])); PL_curpad = AvARRAY(PL_comppad); outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]); for (ix = fpad; ix > 0; ix--) { SV* const namesv = (ix <= fname) ? pname[ix] : NULL; SV *sv = NULL; if (namesv && namesv != &PL_sv_undef) { /* lexical */ if (SvFAKE(namesv)) { /* lexical from outside? */ sv = outpad[PARENT_PAD_INDEX(namesv)]; assert(sv); /* formats may have an inactive parent, while my $x if $false can leave an active var marked as stale. And state vars are always available */ if (SvPADSTALE(sv) && !SvPAD_STATE(namesv)) { Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE), "Variable \"%s\" is not available", SvPVX_const(namesv)); sv = NULL; } else SvREFCNT_inc_simple_void_NN(sv); } if (!sv) { const char sigil = SvPVX_const(namesv)[0]; if (sigil == '&') sv = SvREFCNT_inc(ppad[ix]); else if (sigil == '@') sv = MUTABLE_SV(newAV()); else if (sigil == '%') sv = MUTABLE_SV(newHV()); else sv = newSV(0); SvPADMY_on(sv); /* reset the 'assign only once' flag on each state var */ if (SvPAD_STATE(namesv)) SvPADSTALE_on(sv); } } else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) { sv = SvREFCNT_inc_NN(ppad[ix]); } else { sv = newSV(0); SvPADTMP_on(sv); } PL_curpad[ix] = sv; } DEBUG_Xv( PerlIO_printf(Perl_debug_log, "\nPad CV clone\n"); cv_dump(outside, "Outside"); cv_dump(proto, "Proto"); cv_dump(cv, "To"); ); LEAVE; if (CvCONST(cv)) { /* Constant sub () { $x } closing over $x - see lib/constant.pm: * 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 const_sv = op_const_sv(CvSTART(cv), cv); if (const_sv) { SvREFCNT_dec(cv); cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv); } else { CvCONST_off(cv); } } return cv; } /* =for apidoc pad_fixup_inner_anons For any anon CVs in the pad, change CvOUTSIDE of that CV from old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be moved to a pre-existing CV struct. =cut */ void Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv) { dVAR; I32 ix; AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]); AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]); SV ** const namepad = AvARRAY(comppad_name); SV ** const curpad = AvARRAY(comppad); PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS; PERL_UNUSED_ARG(old_cv); for (ix = AvFILLp(comppad_name); ix > 0; ix--) { const SV * const namesv = namepad[ix]; if (namesv && namesv != &PL_sv_undef && *SvPVX_const(namesv) == '&') { CV * const innercv = MUTABLE_CV(curpad[ix]); assert(CvWEAKOUTSIDE(innercv)); assert(CvOUTSIDE(innercv) == old_cv); CvOUTSIDE(innercv) = new_cv; } } } /* =for apidoc pad_push Push a new pad frame onto the padlist, unless there's already a pad at this depth, in which case don't bother creating a new one. Then give the new pad an @_ in slot zero. =cut */ void Perl_pad_push(pTHX_ PADLIST *padlist, int depth) { dVAR; PERL_ARGS_ASSERT_PAD_PUSH; if (depth > AvFILLp(padlist)) { SV** const svp = AvARRAY(padlist); AV* const newpad = newAV(); SV** const oldpad = AvARRAY(svp[depth-1]); I32 ix = AvFILLp((const AV *)svp[1]); const I32 names_fill = AvFILLp((const AV *)svp[0]); SV** const names = AvARRAY(svp[0]); AV *av; for ( ;ix > 0; ix--) { if (names_fill >= ix && names[ix] != &PL_sv_undef) { const char sigil = SvPVX_const(names[ix])[0]; if ((SvFLAGS(names[ix]) & SVf_FAKE) || (SvFLAGS(names[ix]) & SVpad_STATE) || 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); SvPADMY_on(sv); } } else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[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_extend(av, 0); av_store(newpad, 0, MUTABLE_SV(av)); AvREIFY_only(av); av_store(padlist, depth, MUTABLE_SV(newpad)); AvFILLp(padlist) = depth; } } HV * Perl_pad_compname_type(pTHX_ const PADOFFSET po) { dVAR; SV* const * const av = av_fetch(PL_comppad_name, po, FALSE); if ( SvPAD_TYPED(*av) ) { return SvSTASH(*av); } return NULL; } /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */ perl-5.12.0-RC0/Porting/0000755000175000017500000000000011351321566013554 5ustar jessejesseperl-5.12.0-RC0/Porting/README.y20380000444000175000017500000000672711325125741015230 0ustar jessejesseThe y2038 implementation for perl =========================================================================== This is an implementation of POSIX time.h which solves the year 2038 bug on systems where time_t is only 32 bits. It is implemented in bog-standard ANSI C. The latest version can be found at http://y2038.googlecode.com/ It makes use of the system's native 32 bit functions to perform time zone and daylight savings time calculations and thus does *not* need to ship its own time zone table. time64.h currently implements three public functions, localtime64_r(), gmtime64_r() and timegm64(). They are implementations of localtime_r(), gmtime_r() and timegm64(). To install, simply copy time64.c and time64.h into your project and make use of the functions. To test, run "make test". You must have Perl, prove (which comes with a recent version of the Test::Harness Perl module) and bzdiff installed to run the full test suite. It will do a number of unit tests, plus test against a large table of known good values in different time zones. Limitations, Issues, etc... --------------------------- localtime64_r() gets its time zone and daylight savings time information by mappping the future year back to a similar one between 2010 and 2037, safe for localtime_r(). The calculations are accurate according to current time zone and daylight savings information, but may become inaccurate if a change is made that takes place after 2010. Future versions will probe for a 64 bit safe system localtime_r() and gmtime_r() and use that. The maximum date is still limited by your tm struct. Most 32 bit systems use a signed integer tm_year which means the practical upper limit is the year 2147483647 which is somewhere around 2**54. You can use a 64 bit clean tm struct by setting USE_TM64 in time64.h Portability ----------- I would like to add some configuration detection stuff in the future, but for now all I can do is document the assumptions... This code assumes that long longs are 64 bit integers which is technically in violation of the C standard. This can be changed in time64.h by changing the Time64_T and Int64 typedefs. There are a number of configuration options in time64.h. Configure variables ------------------- Configure probes for the maximum and minimum values that gmtime () and localtime () accept on the local system. Configure however is only used on unix-like systems. For windows and VMS these values are hard-coded. You can use timecheck.c in the Porting directory to check those values yourself, using the same technique that is used in Configure based on bit-shifting: $ cd perl/Porting $ cc -O -o timecheck timecheck.c $ ./timecheck ====================== Sizeof time_t = 8 gmtime () boundaries: 8: 0x00f0c2ab7c54a97f: 2147485547-12-31 23:59:59 8: -0x0000000e79747c00: 0-01-01 00:00:00 localtime () boundaries: 8: 0x00f0c2ab7c549b6f: 2147485547-12-31 23:59:59 8: -0x0000000e79748094: 0-01-01 00:00:00 Configure variables: sGMTIME_max='67768036191676799' sGMTIME_min='-62167219200' sLOCALTIME_max='67768036191673199' sLOCALTIME_min='-62167220372' In the rare case that your system uses a double for time_t, you can use the alternate approach to test for these values: $ cd perl/Porting $ cc -O -o timecheck2{,.c} $ ./timecheck2 gmtime max 67768036191676800 localtime max 67768036191673200 gmtime min -67768040609740800 localtime min -67768040609741968 perl-5.12.0-RC0/Porting/checkVERSION.pl0000555000175000017500000000171711143650473016244 0ustar jessejesse#!/usr/bin/perl -w # # Check the tree against missing VERSIONs. # # Originally by Larry Shatzer # use strict; use File::Find; find( sub { return unless -f; if (/\.pm$/ && $File::Find::name !~ m:/t/:) { # pm but not in a test unless (parse_file($_)) { print "$File::Find::name\n"; } } }, @ARGV ? shift : "."); sub parse_file { my $parsefile = shift; my $result; open(FH,$parsefile) or warn "Could not open '$parsefile': $!"; my $inpod = 0; while () { $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod; next if $inpod || /^\s*\#/; chomp; next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/; my $eval = qq{ package ExtUtils::MakeMaker::_version; no strict; local $1$2; \$$2=undef; do { $_ }; \$$2 }; no warnings; $result = eval($eval); warn "Could not eval '$eval' in $parsefile: $@" if $@; $result = "undef" unless defined $result; last; } close FH; return $result; } perl-5.12.0-RC0/Porting/thirdclean0000444000175000017500000000656611325125741015625 0ustar jessejesse#!./perl # DAPM: this description is from the original commit message: # this appears to be a HP leak detection thing: # # Add a script for cleaning out the "known noise" # from Third Degree reports: either noise caused # by libc itself, or Perl_yyparse leaks. local $/; $_ = ; my @accv = /(^-+ \w+ -- \d+ --(?:.(?!^-))+)/msg; my @leak = /(\d+ bytes? in \d+ leaks? .+? created at:(?:.(?!^[\d-]))+)/msg; $leak[ 0] =~ s/.* were found:\n\n//m; # Snip off totals. # Weed out the known access violations. @accv = grep { ! /-- ru[hs] --.+setlocale.+Perl_init_i18nl10n/s } @accv; @accv = grep { ! /-- [rw][ui]s --.+_doprnt_dis/s } @accv; @accv = grep { ! /-- (?:fon|ris) --.+__strxfrm/s } @accv; @accv = grep { ! /-- rus --.+__catgets/s } @accv; @accv = grep { ! /-- rus --.+__execvp/s } @accv; @accv = grep { ! /-- rus --.+tmpnam.+tmpfile/s } @accv; @accv = grep { ! /-- rus --.+__gethostbyname/s } @accv; @accv = grep { ! /-- ris --.+__actual_atof/s } @accv; @accv = grep { ! /-- ris --.+__strftime/s } @accv; # Weed out untraceable access violations. @accv = grep { ! / ----- /s } @accv; @accv = grep { ! /-- r[ui][hs] --.+proc_at_/s } @accv; @accv = grep { ! /-- r[ui][hs] --.+pc = 0x/s } @accv; # The following look like being caused by the intrinsic inlined # string handling functions reading one or few bytes beyond the # actual length. @accv = grep { ! /-- rih --.+(?:memmove|strcpy).+moreswitches/s } @accv; @accv = grep { ! /-- (?:rih|rus) --.+strcpy.+gv_fetchfile/s } @accv; @accv = grep { ! /-- rih --.+strcmp.+doopen_pm/s } @accv; @accv = grep { ! /-- rih --.+strcmp.+gv_fetchpv/s } @accv; @accv = grep { ! /-- r[ui]h --.+strcmp.+gv_fetchmeth/s } @accv; @accv = grep { ! /-- rih --.+memmove.+my_setenv/s } @accv; @accv = grep { ! /-- rih --.+memmove.+catpvn_flags/s } @accv; # yyparse. @accv = grep { ! /Perl_yyparse/s } @accv; # Weed out the known memory leaks. @leak = grep { ! /setlocale.+Perl_init_i18nl10n/s } @leak; @leak = grep { ! /setlocale.+set_numeric_standard/s } @leak; @leak = grep { ! /_findiop.+fopen/s } @leak; @leak = grep { ! /_findiop.+__fdopen/s } @leak; @leak = grep { ! /__localtime/s } @leak; @leak = grep { ! /__get_libc_context/s } @leak; @leak = grep { ! /__sia_init/s } @leak; # Weed out untraceable memory leaks. @leak = grep { ! / ----- /s } @leak; @leak = grep { ! /pc = 0x/s } @leak; @leak = grep { ! /_pc_range_table/s } @leak; @leak = grep { ! /_add_gp_range/s } @leak; # yyparse. @leak = grep { ! /Perl_yyparse/s } @leak; # Output the cleaned up report. # Access violations. for (my $i = 0; $i < @accv; $i++) { $_ = $accv[$i]; s/\d+/$i/; print; } # Memory leaks. my ($leakb, $leakn, $leaks); for (my $i = 0; $i < @leak; $i++) { $_ = $leak[$i]; print $_, "\n"; /^(\d+) bytes? in (\d+) leak/; $leakb += $1; $leakn += $2; $leaks += $1 if /including (\d+) super/; } print "Bytes $leakb Leaks $leakn Super $leaks\n" if $leakb; perl-5.12.0-RC0/Porting/make_snapshot.pl0000555000175000017500000000452211325127001016736 0ustar jessejesse#!/usr/bin/perl use strict; use warnings; use File::Path; use Cwd; # This is a quick and dirty snapshot generator for the perl5.git.perl.org web page # to use to generate the snapshot files. Yes it is ugly and contains hard coded crap # and could use some love. But for this todo I am out of time now. -- Yves $ENV{PATH}="/usr/local/bin:/bin/"; use POSIX qw(strftime); sub isotime { strftime "%Y-%m-%d.%H:%M:%S",gmtime(shift||time) } my ($abbr,$sha1,$tstamp); $sha1= shift || "HEAD"; my $zip_root= $ENV{PERL_SNAPSHOT_ZIP_ROOT} || "/gitcommon/snapshot/tgz"; my $gitdir= shift || `git rev-parse --git-dir` or die "Not a git repo!\n"; chomp( $gitdir,$sha1); my $workdir= $gitdir; my $is_bare; if ( $workdir =~ s!/\.git\z!! ) { chdir $workdir or die "Failed to chdir to $workdir\n"; } else { $is_bare= 1; chdir $workdir or die "Failed to chdir to bare repo $workdir\n"; } #'die $workdir; ($sha1, $abbr,$tstamp)= split /\s+/, `git log --pretty='format:%H %h %ct' -1 $sha1` or die "Failed to parse '$sha1'\n"; chomp($sha1,$abbr,$tstamp); #die "'$sha1','$abbr'\n"; my $path= join "/", $zip_root, substr($sha1,0,2), substr($sha1,0,4); my $tar_file= "$sha1.tar.$$"; my $gz_file= "$sha1.tar.gz"; my $prefix= "perl-$abbr/"; if (!-e "$path/$gz_file") { mkpath $path if !-d $path; system("git archive --format=tar --prefix=$prefix $sha1 > $path/$tar_file"); my @branches=map { $is_bare ? $_ : "origin/$_" } ( 'blead', 'maint-5.10', 'maint-5.8', 'maint-5.8-dor', 'maint-5.6', 'maint-5.005', 'maint-5.004', ); my $branch; foreach my $b (@branches) { $branch= $b and last if `git log --pretty='format:%H' $b | grep $sha1`; } $branch ||= "unknown-branch"; chomp(my $describe= `git describe`); chdir $path; { open my $fh,">","$path/$$.patch" or die "Failed to open $$.patch for writing\n"; print $fh join(" ", $branch, isotime($tstamp), $sha1, $describe) . "\n"; close $fh; } system("tar -f $tar_file --transform='s,^$$,$prefix,g' --owner=root --group=root --mode=664 --append $$.patch"); unlink "$$.patch"; system("gzip -S .gz -9 $tar_file"); rename "$tar_file.gz", "$gz_file"; } print "ok\tperl-$abbr.tar.gz\t$path/$gz_file", -t STDOUT ? "\n" :""; perl-5.12.0-RC0/Porting/config.sh0000444000175000017500000007235711347250766015401 0ustar jessejesse#!/bin/sh # # This file was produced by running the Configure script. It holds all the # definitions figured out by Configure. Should you modify one of these values, # do not forget to propagate your changes by running "Configure -der". You may # instead choose to run each of the .SH files by yourself, or "Configure -S". # # Package name : perl5 # Source directory : . # Configuration time: Wed Dec 3 15:15:56 CET 2008 # Configured by : merijn # Target system : linux nb09 2.6.22.19-0.1-default #1 smp 2008-10-14 22:17:43 +0200 i686 i686 i386 gnulinux : Configure command line arguments. config_arg0='./Configure' config_args='-Dprefix=/opt/perl -Dcf_by=merijn -Dcf_email=yourname@yourhost.yourplace.com -Dperladmin=yourname@yourhost.yourplace.com -Dmydomain=.yourplace.com -Dmyhostname=yourhost -Duse64bitint -Dusedevel -dE' config_argc=9 config_arg1='-Dprefix=/opt/perl' config_arg2='-Dcf_by=merijn' config_arg3='-Dcf_email=yourname@yourhost.yourplace.com' config_arg4='-Dperladmin=yourname@yourhost.yourplace.com' config_arg5='-Dmydomain=.yourplace.com' config_arg6='-Dmyhostname=yourhost' config_arg7='-Duse64bitint' config_arg8='-Dusedevel' config_arg9='-dE' Author='' Date='$Date' Header='' Id='$Id' Locker='' Log='$Log' RCSfile='$RCSfile' Revision='$Revision' Source='' State='' _a='.a' _exe='' _o='.o' afs='false' afsroot='/afs' alignbytes='4' ansi2knr='' aphostname='' api_revision='5' api_subversion='0' api_version='12' api_versionstring='5.12.0' ar='ar' archlib='/opt/perl/lib/5.12.0/i686-linux-64int' archlibexp='/opt/perl/lib/5.12.0/i686-linux-64int' archname64='64int' archname='i686-linux-64int' archobjs='' asctime_r_proto='0' awk='awk' baserev='5.0' bash='' bin='/opt/perl/bin' binexp='/opt/perl/bin' bison='bison' byacc='byacc' byteorder='12345678' c='' castflags='0' cat='cat' cc='cc' cccdlflags='-fPIC' ccdlflags='-Wl,-E' ccflags='-fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64' ccflags_uselargefiles='-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64' ccname='gcc' ccsymbols='' ccversion='' cf_by='merijn' cf_email='yourname@yourhost.yourplace.com' cf_time='Wed Jan 23 09:43:56 CET 2008' charbits='8' chgrp='' chmod='chmod' chown='' clocktype='clock_t' comm='comm' compress='' contains='grep' cp='cp' cpio='' cpp='cpp' cpp_stuff='42' cppccsymbols='' cppflags='-fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include' cpplast='-' cppminus='-' cpprun='cc -E' cppstdin='cc -E' cppsymbols='__CHAR_BIT__=8 __DBL_DENORM_MIN__=4.9406564584124654e-324 __DBL_DIG__=15 __DBL_EPSILON__=2.2204460492503131e-16 __DBL_HAS_DENORM__=1 __DBL_HAS_INFINITY__=1 __DBL_HAS_QUIET_NAN__=1 __DBL_MANT_DIG__=53 __DBL_MAX_10_EXP__=308 __DBL_MAX__=1.7976931348623157e+308 __DBL_MAX_EXP__=1024 __DBL_MIN_10_EXP__=(-307) __DBL_MIN__=2.2250738585072014e-308 __DBL_MIN_EXP__=(-1021) __DEC128_DEN__=0.000000000000000000000000000000001E-6143DL __DEC128_EPSILON__=1E-33DL __DEC128_MANT_DIG__=34 __DEC128_MAX__=9.999999999999999999999999999999999E6144DL __DEC128_MAX_EXP__=6144 __DEC128_MIN__=1E-6143DL __DEC128_MIN_EXP__=(-6143) __DEC32_DEN__=0.000001E-95DF __DEC32_EPSILON__=1E-6DF __DEC32_MANT_DIG__=7 __DEC32_MAX__=9.999999E96DF __DEC32_MAX_EXP__=96 __DEC32_MIN__=1E-95DF __DEC32_MIN_EXP__=(-95) __DEC64_DEN__=0.000000000000001E-383DD __DEC64_EPSILON__=1E-15DD __DEC64_MANT_DIG__=16 __DEC64_MAX__=9.999999999999999E384DD __DEC64_MAX_EXP__=384 __DEC64_MIN__=1E-383DD __DEC64_MIN_EXP__=(-383) __DEC_EVAL_METHOD__=2 __DECIMAL_DIG__=21 __ELF__=1 _FILE_OFFSET_BITS=64 __FINITE_MATH_ONLY__=0 __FLT_DENORM_MIN__=1.40129846e-45F __FLT_DIG__=6 __FLT_EPSILON__=1.19209290e-7F __FLT_EVAL_METHOD__=2 __FLT_HAS_DENORM__=1 __FLT_HAS_INFINITY__=1 __FLT_HAS_QUIET_NAN__=1 __FLT_MANT_DIG__=24 __FLT_MAX_10_EXP__=38 __FLT_MAX__=3.40282347e+38F __FLT_MAX_EXP__=128 __FLT_MIN_10_EXP__=(-37) __FLT_MIN__=1.17549435e-38F __FLT_MIN_EXP__=(-125) __FLT_RADIX__=2 __GLIBC__=2 __GLIBC_MINOR__=7 __GNUC__=4 __GNUC_GNU_INLINE__=1 __GNUC_MINOR__=2 __GNUC_PATCHLEVEL__=1 __GNU_LIBRARY__=6 __gnu_linux__=1 __GXX_ABI_VERSION=1002 __i386=1 __i386__=1 i386=1 __INT_MAX__=2147483647 __INTMAX_MAX__=9223372036854775807LL __INTMAX_TYPE__=long\ long\ int _LARGEFILE_SOURCE=1 __LDBL_DENORM_MIN__=3.64519953188247460253e-4951L __LDBL_DIG__=18 __LDBL_EPSILON__=1.08420217248550443401e-19L __LDBL_HAS_DENORM__=1 __LDBL_HAS_INFINITY__=1 __LDBL_HAS_QUIET_NAN__=1 __LDBL_MANT_DIG__=64 __LDBL_MAX_10_EXP__=4932 __LDBL_MAX__=1.18973149535723176502e+4932L __LDBL_MAX_EXP__=16384 __LDBL_MIN_10_EXP__=(-4931) __LDBL_MIN__=3.36210314311209350626e-4932L __LDBL_MIN_EXP__=(-16381) __linux=1 __linux__=1 linux=1 __LONG_LONG_MAX__=9223372036854775807LL __LONG_MAX__=2147483647L _POSIX_C_SOURCE=200112L _POSIX_SOURCE=1 __PTRDIFF_TYPE__=int __REGISTER_PREFIX__= __SCHAR_MAX__=127 __SHRT_MAX__=32767 __SIZE_TYPE__=unsigned\ int __STDC__=1 __STDC_HOSTED__=1 __UINTMAX_TYPE__=long\ long\ unsigned\ int __unix=1 __unix__=1 unix=1 __USE_BSD=1 __USE_FILE_OFFSET64=1 __USE_LARGEFILE=1 __USE_MISC=1 __USE_POSIX=1 __USE_POSIX199309=1 __USE_POSIX199506=1 __USE_POSIX2=1 __USER_LABEL_PREFIX__= __USE_SVID=1 __VERSION__="4.2.1\ (SUSE\ Linux)" __WCHAR_MAX__=2147483647 __WCHAR_TYPE__=long\ int __WINT_TYPE__=unsigned\ int' crypt_r_proto='0' cryptlib='' csh='csh' ctermid_r_proto='0' ctime_r_proto='0' d_Gconvert='gcvt((x),(n),(b))' d_PRIEUldbl='define' d_PRIFUldbl='define' d_PRIGUldbl='define' d_PRIXU64='define' d_PRId64='define' d_PRIeldbl='define' d_PRIfldbl='define' d_PRIgldbl='define' d_PRIi64='define' d_PRIo64='define' d_PRIu64='define' d_PRIx64='define' d_SCNfldbl='define' d__fwalk='undef' d_access='define' d_accessx='undef' d_aintl='undef' d_alarm='define' d_archlib='define' d_asctime64='undef' d_asctime_r='undef' d_atolf='undef' d_atoll='define' d_attribute_deprecated='define' d_attribute_format='define' d_attribute_malloc='define' d_attribute_nonnull='define' d_attribute_noreturn='define' d_attribute_pure='define' d_attribute_unused='define' d_attribute_warn_unused_result='define' d_bcmp='define' d_bcopy='define' d_bsd='undef' d_bsdgetpgrp='undef' d_bsdsetpgrp='undef' d_builtin_choose_expr='define' d_builtin_expect='define' d_bzero='define' d_c99_variadic_macros='define' d_casti32='undef' d_castneg='define' d_charvspr='undef' d_chown='define' d_chroot='define' d_chsize='undef' d_class='undef' d_clearenv='define' d_closedir='define' d_cmsghdr_s='define' d_const='define' d_copysignl='define' d_cplusplus='undef' d_crypt='define' d_crypt_r='undef' d_csh='define' d_ctermid='define' d_ctermid_r='undef' d_ctime64='undef' d_ctime_r='undef' d_cuserid='define' d_dbl_dig='define' d_dbminitproto='define' d_difftime64='undef' d_difftime='define' d_dir_dd_fd='undef' d_dirfd='define' d_dirnamlen='undef' d_dlerror='define' d_dlopen='define' d_dlsymun='undef' d_dosuid='undef' d_drand48_r='undef' d_drand48proto='define' d_dup2='define' d_eaccess='define' d_endgrent='define' d_endgrent_r='undef' d_endhent='define' d_endhostent_r='undef' d_endnent='define' d_endnetent_r='undef' d_endpent='define' d_endprotoent_r='undef' d_endpwent='define' d_endpwent_r='undef' d_endsent='define' d_endservent_r='undef' d_eofnblk='define' d_eunice='undef' d_faststdio='undef' d_fchdir='define' d_fchmod='define' d_fchown='define' d_fcntl='define' d_fcntl_can_lock='define' d_fd_macros='define' d_fd_set='define' d_fds_bits='undef' d_fgetpos='define' d_finite='define' d_finitel='define' d_flexfnam='define' d_flock='define' d_flockproto='define' d_fork='define' d_fp_class='undef' d_fpathconf='define' d_fpclass='undef' d_fpclassify='undef' d_fpclassl='undef' d_fpos64_t='undef' d_frexpl='define' d_fs_data_s='undef' d_fseeko='define' d_fsetpos='define' d_fstatfs='define' d_fstatvfs='define' d_fsync='define' d_ftello='define' d_ftime='undef' d_futimes='define' d_gdbm_ndbm_h_uses_prototypes='undef' d_gdbmndbm_h_uses_prototypes='undef' d_getaddrinfo='define' d_getcwd='define' d_getespwnam='undef' d_getfsstat='undef' d_getgrent='define' d_getgrent_r='undef' d_getgrgid_r='undef' d_getgrnam_r='undef' d_getgrps='define' d_gethbyaddr='define' d_gethbyname='define' d_gethent='define' d_gethname='define' d_gethostbyaddr_r='undef' d_gethostbyname_r='undef' d_gethostent_r='undef' d_gethostprotos='define' d_getitimer='define' d_getlogin='define' d_getlogin_r='undef' d_getmnt='undef' d_getmntent='define' d_getnameinfo='define' d_getnbyaddr='define' d_getnbyname='define' d_getnent='define' d_getnetbyaddr_r='undef' d_getnetbyname_r='undef' d_getnetent_r='undef' d_getnetprotos='define' d_getpagsz='define' d_getpbyname='define' d_getpbynumber='define' d_getpent='define' d_getpgid='define' d_getpgrp2='undef' d_getpgrp='define' d_getppid='define' d_getprior='define' d_getprotobyname_r='undef' d_getprotobynumber_r='undef' d_getprotoent_r='undef' d_getprotoprotos='define' d_getprpwnam='undef' d_getpwent='define' d_getpwent_r='undef' d_getpwnam_r='undef' d_getpwuid_r='undef' d_getsbyname='define' d_getsbyport='define' d_getsent='define' d_getservbyname_r='undef' d_getservbyport_r='undef' d_getservent_r='undef' d_getservprotos='define' d_getspnam='define' d_getspnam_r='undef' d_gettimeod='define' d_gmtime64='undef' d_gmtime_r='undef' d_gnulibc='define' d_grpasswd='define' d_hasmntopt='define' d_htonl='define' d_ilogbl='define' d_inc_version_list='undef' d_index='undef' d_inetaton='define' d_inetntop='define' d_inetpton='define' d_int64_t='define' d_isascii='define' d_isfinite='undef' d_isinf='define' d_isnan='define' d_isnanl='define' d_killpg='define' d_lchown='define' d_ldbl_dig='define' d_libm_lib_version='define' d_link='define' d_localtime64='undef' d_localtime_r='undef' d_localtime_r_needs_tzset='undef' d_locconv='define' d_lockf='define' d_longdbl='define' d_longlong='define' d_lseekproto='define' d_lstat='define' d_madvise='define' d_malloc_good_size='undef' d_malloc_size='undef' d_mblen='define' d_mbstowcs='define' d_mbtowc='define' d_memchr='define' d_memcmp='define' d_memcpy='define' d_memmove='define' d_memset='define' d_mkdir='define' d_mkdtemp='define' d_mkfifo='define' d_mkstemp='define' d_mkstemps='undef' d_mktime64='undef' d_mktime='define' d_mmap='define' d_modfl='define' d_modfl_pow32_bug='undef' d_modflproto='define' d_mprotect='define' d_msg='define' d_msg_ctrunc='define' d_msg_dontroute='define' d_msg_oob='define' d_msg_peek='define' d_msg_proxy='define' d_msgctl='define' d_msgget='define' d_msghdr_s='define' d_msgrcv='define' d_msgsnd='define' d_msync='define' d_munmap='define' d_mymalloc='undef' d_ndbm='define' d_ndbm_h_uses_prototypes='undef' d_nice='define' d_nl_langinfo='define' d_nv_preserves_uv='undef' d_nv_zero_is_allbits_zero='define' d_off64_t='undef' d_old_pthread_create_joinable='undef' d_oldpthreads='undef' d_oldsock='undef' d_open3='define' d_pathconf='define' d_pause='define' d_perl_otherlibdirs='undef' d_phostname='undef' d_pipe='define' d_poll='define' d_portable='define' d_printf_format_null='define' d_procselfexe='define' d_pseudofork='undef' d_pthread_atfork='undef' d_pthread_attr_setscope='define' d_pthread_yield='define' d_pwage='undef' d_pwchange='undef' d_pwclass='undef' d_pwcomment='undef' d_pwexpire='undef' d_pwgecos='define' d_pwpasswd='define' d_pwquota='undef' d_qgcvt='define' d_quad='define' d_random_r='undef' d_readdir64_r='undef' d_readdir='define' d_readdir_r='undef' d_readlink='define' d_readv='define' d_recvmsg='define' d_rename='define' d_rewinddir='define' d_rmdir='define' d_safebcpy='undef' d_safemcpy='undef' d_sanemcmp='define' d_sbrkproto='define' d_scalbnl='define' d_sched_yield='define' d_scm_rights='define' d_seekdir='define' d_select='define' d_sem='define' d_semctl='define' d_semctl_semid_ds='define' d_semctl_semun='define' d_semget='define' d_semop='define' d_sendmsg='define' d_setegid='define' d_seteuid='define' d_setgrent='define' d_setgrent_r='undef' d_setgrps='define' d_sethent='define' d_sethostent_r='undef' d_setitimer='define' d_setlinebuf='define' d_setlocale='define' d_setlocale_r='undef' d_setnent='define' d_setnetent_r='undef' d_setpent='define' d_setpgid='define' d_setpgrp2='undef' d_setpgrp='define' d_setprior='define' d_setproctitle='undef' d_setprotoent_r='undef' d_setpwent='define' d_setpwent_r='undef' d_setregid='define' d_setresgid='define' d_setresuid='define' d_setreuid='define' d_setrgid='undef' d_setruid='undef' d_setsent='define' d_setservent_r='undef' d_setsid='define' d_setvbuf='define' d_sfio='undef' d_shm='define' d_shmat='define' d_shmatprototype='define' d_shmctl='define' d_shmdt='define' d_shmget='define' d_sigaction='define' d_signbit='define' d_sigprocmask='define' d_sigsetjmp='define' d_sitearch='define' d_snprintf='define' d_sockatmark='define' d_sockatmarkproto='define' d_socket='define' d_socklen_t='define' d_sockpair='define' d_socks5_init='undef' d_sprintf_returns_strlen='define' d_sqrtl='define' d_srand48_r='undef' d_srandom_r='undef' d_sresgproto='undef' d_sresuproto='undef' d_statblks='define' d_statfs_f_flags='undef' d_statfs_s='define' d_statvfs='define' d_stdio_cnt_lval='undef' d_stdio_ptr_lval='undef' d_stdio_ptr_lval_nochange_cnt='undef' d_stdio_ptr_lval_sets_cnt='undef' d_stdio_stream_array='undef' d_stdiobase='undef' d_stdstdio='undef' d_strchr='define' d_strcoll='define' d_strctcpy='define' d_strerrm='strerror(e)' d_strerror='define' d_strerror_r='undef' d_strftime='define' d_strlcat='undef' d_strlcpy='undef' d_strtod='define' d_strtol='define' d_strtold='define' d_strtoll='define' d_strtoq='define' d_strtoul='define' d_strtoull='define' d_strtouq='define' d_strxfrm='define' d_suidsafe='undef' d_symlink='define' d_syscall='define' d_syscallproto='define' d_sysconf='define' d_sysernlst='' d_syserrlst='define' d_system='define' d_tcgetpgrp='define' d_tcsetpgrp='define' d_telldir='define' d_telldirproto='define' d_time='define' d_timegm='define' d_times='define' d_tm_tm_gmtoff='define' d_tm_tm_zone='define' d_tmpnam_r='undef' d_truncate='define' d_ttyname_r='undef' d_tzname='define' d_u32align='define' d_ualarm='define' d_umask='define' d_uname='define' d_union_semun='undef' d_unordered='undef' d_unsetenv='define' d_usleep='define' d_usleepproto='define' d_ustat='define' d_vendorarch='undef' d_vendorbin='undef' d_vendorlib='undef' d_vendorscript='undef' d_vfork='undef' d_void_closedir='undef' d_voidsig='define' d_voidtty='' d_volatile='define' d_vprintf='define' d_vsnprintf='define' d_wait4='define' d_waitpid='define' d_wcstombs='define' d_wctomb='define' d_writev='define' d_xenix='undef' date='date' db_hashtype='u_int32_t' db_prefixtype='size_t' db_version_major='4' db_version_minor='5' db_version_patch='20' defvoidused='15' direntrytype='struct dirent' dlext='so' dlsrc='dl_dlopen.xs' doublesize='8' drand01='drand48()' drand48_r_proto='0' dtrace='' dynamic_ext='attributes B Compress/Raw/Zlib Cwd Data/Dumper DB_File Devel/DProf Devel/Peek Devel/PPPort Digest/MD5 Digest/SHA Encode Fcntl File/Glob Filter/Util/Call GDBM_File Hash/Util I18N/Langinfo IO IPC/SysV List/Util Math/BigInt/FastCalc MIME/Base64 NDBM_File ODBM_File Opcode PerlIO/encoding PerlIO/scalar PerlIO/via POSIX re SDBM_File Socket Storable Sys/Hostname Sys/Syslog Text/Soundex threads Time/HiRes Time/Piece Unicode/Normalize XS/APItest XS/APItest/KeywordRPN XS/Typemap threads/shared Hash/Util/FieldHash' eagain='EAGAIN' ebcdic='undef' echo='echo' egrep='egrep' emacs='' endgrent_r_proto='0' endhostent_r_proto='0' endnetent_r_proto='0' endprotoent_r_proto='0' endpwent_r_proto='0' endservent_r_proto='0' eunicefix=':' exe_ext='' expr='expr' extensions='attributes B Compress/Raw/Zlib Cwd Data/Dumper DB_File Devel/DProf Devel/Peek Devel/PPPort Digest/MD5 Digest/SHA Encode Fcntl File/Glob Filter/Util/Call GDBM_File Hash/Util I18N/Langinfo IO IPC/SysV List/Util Math/BigInt/FastCalc MIME/Base64 NDBM_File ODBM_File Opcode PerlIO/encoding PerlIO/scalar PerlIO/via POSIX re SDBM_File Socket Storable Sys/Hostname Sys/Syslog Text/Soundex threads Time/HiRes Time/Piece Unicode/Normalize XS/APItest XS/APItest/KeywordRPN XS/Typemap threads/shared Hash/Util/FieldHash Compress/Zlib Errno IO_Compress_Base IO_Compress_Zlib Module/Pluggable Test/Harness' extern_C='extern' extras='' fflushNULL='define' fflushall='undef' find='' firstmakefile='makefile' flex='' fpossize='16' fpostype='fpos_t' freetype='void' from=':' full_ar='/usr/bin/ar' full_csh='/usr/bin/csh' full_sed='/usr/bin/sed' gccansipedantic='' gccosandvers='' gccversion='4.2.1 (SUSE Linux)' getgrent_r_proto='0' getgrgid_r_proto='0' getgrnam_r_proto='0' gethostbyaddr_r_proto='0' gethostbyname_r_proto='0' gethostent_r_proto='0' getlogin_r_proto='0' getnetbyaddr_r_proto='0' getnetbyname_r_proto='0' getnetent_r_proto='0' getprotobyname_r_proto='0' getprotobynumber_r_proto='0' getprotoent_r_proto='0' getpwent_r_proto='0' getpwnam_r_proto='0' getpwuid_r_proto='0' getservbyname_r_proto='0' getservbyport_r_proto='0' getservent_r_proto='0' getspnam_r_proto='0' gidformat='"lu"' gidsign='1' gidsize='4' gidtype='gid_t' glibpth='/usr/shlib /lib /usr/lib /usr/lib/386 /lib/386 /usr/ccs/lib /usr/ucblib /usr/local/lib ' gmake='gmake' gmtime_r_proto='0' gnulibc_version='2.7' grep='grep' groupcat='cat /etc/group' groupstype='gid_t' gzip='gzip' h_fcntl='false' h_sysfile='true' hint='recommended' hostcat='cat /etc/hosts' html1dir=' ' html1direxp='' html3dir=' ' html3direxp='' i16size='2' i16type='short' i32size='4' i32type='long' i64size='8' i64type='long long' i8size='1' i8type='signed char' i_arpainet='define' i_assert='define' i_bsdioctl='' i_crypt='define' i_db='define' i_dbm='define' i_dirent='define' i_dld='undef' i_dlfcn='define' i_fcntl='undef' i_float='define' i_fp='undef' i_fp_class='undef' i_gdbm='define' i_gdbm_ndbm='undef' i_gdbmndbm='undef' i_grp='define' i_ieeefp='undef' i_inttypes='define' i_langinfo='define' i_libutil='undef' i_limits='define' i_locale='define' i_machcthr='undef' i_malloc='define' i_mallocmalloc='undef' i_math='define' i_memory='undef' i_mntent='define' i_ndbm='define' i_netdb='define' i_neterrno='undef' i_netinettcp='define' i_niin='define' i_poll='define' i_prot='undef' i_pthread='define' i_pwd='define' i_rpcsvcdbm='undef' i_sfio='undef' i_sgtty='undef' i_shadow='define' i_socks='undef' i_stdarg='define' i_stddef='define' i_stdlib='define' i_string='define' i_sunmath='undef' i_sysaccess='undef' i_sysdir='define' i_sysfile='define' i_sysfilio='undef' i_sysin='undef' i_sysioctl='define' i_syslog='define' i_sysmman='define' i_sysmode='undef' i_sysmount='define' i_sysndir='undef' i_sysparam='define' i_syspoll='define' i_sysresrc='define' i_syssecrt='undef' i_sysselct='define' i_syssockio='undef' i_sysstat='define' i_sysstatfs='define' i_sysstatvfs='define' i_systime='define' i_systimek='undef' i_systimes='define' i_systypes='define' i_sysuio='define' i_sysun='define' i_sysutsname='define' i_sysvfs='define' i_syswait='define' i_termio='undef' i_termios='define' i_time='define' i_unistd='define' i_ustat='define' i_utime='define' i_values='define' i_varargs='undef' i_varhdr='stdarg.h' i_vfork='undef' ignore_versioned_solibs='y' inc_version_list='' inc_version_list_init='0' incpath='' inews='' initialinstalllocation='/opt/perl/bin' installarchlib='/opt/perl/lib/5.12.0/i686-linux-64int' installbin='/opt/perl/bin' installhtml1dir='' installhtml3dir='' installman1dir='/opt/perl/man/man1' installman3dir='/opt/perl/man/man3' installprefix='/opt/perl' installprefixexp='/opt/perl' installprivlib='/opt/perl/lib/5.12.0' installscript='/opt/perl/bin' installsitearch='/opt/perl/lib/site_perl/5.12.0/i686-linux-64int' installsitebin='/opt/perl/bin' installsitehtml1dir='' installsitehtml3dir='' installsitelib='/opt/perl/lib/site_perl/5.12.0' installsiteman1dir='/opt/perl/man/man1' installsiteman3dir='/opt/perl/man/man3' installsitescript='/opt/perl/bin' installstyle='lib' installusrbinperl='undef' installvendorarch='' installvendorbin='' installvendorhtml1dir='' installvendorhtml3dir='' installvendorlib='' installvendorman1dir='' installvendorman3dir='' installvendorscript='' intsize='4' issymlink='test -h' ivdformat='"Ld"' ivsize='8' ivtype='long long' known_extensions='attributes B Compress/Raw/Zlib Cwd Data/Dumper DB_File Devel/DProf Devel/Peek Devel/PPPort Digest/MD5 Digest/SHA Encode Fcntl File/Glob Filter/Util/Call GDBM_File Hash/Util I18N/Langinfo IO IPC/SysV List/Util Math/BigInt/FastCalc MIME/Base64 NDBM_File ODBM_File Opcode PerlIO/encoding PerlIO/scalar PerlIO/via POSIX re SDBM_File Socket Storable Sys/Hostname Sys/Syslog Text/Soundex threads Time/HiRes Time/Piece Unicode/Normalize Win32 Win32API/File Win32CORE XS/APItest XS/APItest/KeywordRPN XS/Typemap threads/shared Hash/Util/FieldHash' ksh='' ld='cc' lddlflags='-shared -O2 -L/usr/local/lib -fstack-protector' ldflags='-L/usr/local/lib -fstack-protector' ldflags_uselargefiles='' ldlibpthname='LD_LIBRARY_PATH' less='less' lib_ext='.a' libc='/lib/libc-2.7.so' libperl='libperl.a' libpth='/usr/local/lib /lib /usr/lib' libs='-lnsl -lgdbm -ldb -ldl -lm -lcrypt -lutil -lc -lgdbm_compat' libsdirs=' /usr/lib' libsfiles=' libnsl.so libgdbm.so libdb.so libdl.so libm.so libcrypt.so libutil.so libc.so libgdbm_compat.so' libsfound=' /usr/lib/libnsl.so /usr/lib/libgdbm.so /usr/lib/libdb.so /usr/lib/libdl.so /usr/lib/libm.so /usr/lib/libcrypt.so /usr/lib/libutil.so /usr/lib/libc.so /usr/lib/libgdbm_compat.so' libspath=' /usr/local/lib /lib /usr/lib' libswanted='sfio socket inet nsl nm gdbm dbm db malloc dl dld ld sun m crypt sec util c cposix posix ucb BSD gdbm_compat' libswanted_uselargefiles='' line='' lint='' lkflags='' ln='ln' lns='/bin/ln -s' localtime_r_proto='0' locincpth='/usr/local/include /opt/local/include /usr/gnu/include /opt/gnu/include /usr/GNU/include /opt/GNU/include' loclibpth='/usr/local/lib /opt/local/lib /usr/gnu/lib /opt/gnu/lib /usr/GNU/lib /opt/GNU/lib' longdblsize='12' longlongsize='8' longsize='4' lp='' lpr='' ls='ls' lseeksize='8' lseektype='off_t' mad='undef' madlyh='' madlyobj='' madlysrc='' mail='' mailx='' make='make' make_set_make='#' mallocobj='' mallocsrc='' malloctype='void *' man1dir='/opt/perl/man/man1' man1direxp='/opt/perl/man/man1' man1ext='1' man3dir='/opt/perl/man/man3' man3direxp='/opt/perl/man/man3' man3ext='3' mips_type='' mistrustnm='' mkdir='mkdir' mmaptype='void *' modetype='mode_t' more='more' multiarch='undef' mv='' myarchname='i686-linux' mydomain='.yourplace.com' myhostname='yourhost' myuname='linux nb09 2.6.22.19-0.1-default #1 smp 2008-10-14 22:17:43 +0200 i686 i686 i386 gnulinux ' n='-n' need_va_copy='undef' netdb_hlen_type='size_t' netdb_host_type='const void *' netdb_name_type='const char *' netdb_net_type='in_addr_t' nm='nm' nm_opt='' nm_so_opt='--dynamic' nonxs_ext='Compress/Zlib Errno IO_Compress_Base IO_Compress_Zlib Module/Pluggable Test/Harness' nroff='nroff' nvEUformat='"E"' nvFUformat='"F"' nvGUformat='"G"' nv_overflows_integers_at='256.0*256.0*256.0*256.0*256.0*256.0*2.0*2.0*2.0*2.0*2.0' nv_preserves_uv_bits='53' nveformat='"e"' nvfformat='"f"' nvgformat='"g"' nvsize='8' nvtype='double' o_nonblock='O_NONBLOCK' obj_ext='.o' old_pthread_create_joinable='' optimize='-O2' orderlib='false' osname='linux' osvers='2.6.22.19-0.1-default' otherlibdirs=' ' package='perl5' pager='/usr/bin/less' passcat='cat /etc/passwd' patchlevel='11' path_sep=':' perl5='/opt/perl/bin/perl' perl='' perl_patchlevel='34948' perladmin='yourname@yourhost.yourplace.com' perllibs='-lnsl -ldl -lm -lcrypt -lutil -lc' perlpath='/opt/perl/bin/perl5.12.0' pg='pg' phostname='' pidtype='pid_t' plibpth='' pmake='' pr='' prefix='/opt/perl' prefixexp='/opt/perl' privlib='/opt/perl/lib/5.12.0' privlibexp='/opt/perl/lib/5.12.0' procselfexe='"/proc/self/exe"' prototype='define' ptrsize='4' quadkind='3' quadtype='long long' randbits='48' randfunc='drand48' random_r_proto='0' randseedtype='long' ranlib=':' rd_nodata='-1' readdir64_r_proto='0' readdir_r_proto='0' revision='5' rm='rm' rm_try='/bin/rm -f try try a.out .out try.[cho] try..o core core.try* try.core*' rmail='' run='' runnm='false' sGMTIME_max='2147483647' sGMTIME_min='-2147483648' sLOCALTIME_max='2147483647' sLOCALTIME_min='-2147483648' sPRIEUldbl='"LE"' sPRIFUldbl='"LF"' sPRIGUldbl='"LG"' sPRIXU64='"LX"' sPRId64='"Ld"' sPRIeldbl='"Le"' sPRIfldbl='"Lf"' sPRIgldbl='"Lg"' sPRIi64='"Li"' sPRIo64='"Lo"' sPRIu64='"Lu"' sPRIx64='"Lx"' sSCNfldbl='"Lf"' sched_yield='sched_yield()' scriptdir='/opt/perl/bin' scriptdirexp='/opt/perl/bin' sed='sed' seedfunc='srand48' selectminbits='32' selecttype='fd_set *' sendmail='' setgrent_r_proto='0' sethostent_r_proto='0' setlocale_r_proto='0' setnetent_r_proto='0' setprotoent_r_proto='0' setpwent_r_proto='0' setservent_r_proto='0' sh='/bin/sh' shar='' sharpbang='#!' shmattype='void *' shortsize='2' shrpenv='' shsharp='true' sig_count='65' sig_name='ZERO HUP INT QUIT ILL TRAP ABRT BUS FPE KILL USR1 SEGV USR2 PIPE ALRM TERM STKFLT CHLD CONT STOP TSTP TTIN TTOU URG XCPU XFSZ VTALRM PROF WINCH IO PWR SYS NUM32 NUM33 RTMIN NUM35 NUM36 NUM37 NUM38 NUM39 NUM40 NUM41 NUM42 NUM43 NUM44 NUM45 NUM46 NUM47 NUM48 NUM49 NUM50 NUM51 NUM52 NUM53 NUM54 NUM55 NUM56 NUM57 NUM58 NUM59 NUM60 NUM61 NUM62 NUM63 RTMAX IOT CLD POLL UNUSED ' sig_name_init='"ZERO", "HUP", "INT", "QUIT", "ILL", "TRAP", "ABRT", "BUS", "FPE", "KILL", "USR1", "SEGV", "USR2", "PIPE", "ALRM", "TERM", "STKFLT", "CHLD", "CONT", "STOP", "TSTP", "TTIN", "TTOU", "URG", "XCPU", "XFSZ", "VTALRM", "PROF", "WINCH", "IO", "PWR", "SYS", "NUM32", "NUM33", "RTMIN", "NUM35", "NUM36", "NUM37", "NUM38", "NUM39", "NUM40", "NUM41", "NUM42", "NUM43", "NUM44", "NUM45", "NUM46", "NUM47", "NUM48", "NUM49", "NUM50", "NUM51", "NUM52", "NUM53", "NUM54", "NUM55", "NUM56", "NUM57", "NUM58", "NUM59", "NUM60", "NUM61", "NUM62", "NUM63", "RTMAX", "IOT", "CLD", "POLL", "UNUSED", 0' sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 6 17 29 31 ' sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 6, 17, 29, 31, 0' sig_size='69' signal_t='void' sitearch='/opt/perl/lib/site_perl/5.12.0/i686-linux-64int' sitearchexp='/opt/perl/lib/site_perl/5.12.0/i686-linux-64int' sitebin='/opt/perl/bin' sitebinexp='/opt/perl/bin' sitehtml1dir='' sitehtml1direxp='' sitehtml3dir='' sitehtml3direxp='' sitelib='/opt/perl/lib/site_perl/5.12.0' sitelib_stem='/opt/perl/lib/site_perl' sitelibexp='/opt/perl/lib/site_perl/5.12.0' siteman1dir='/opt/perl/man/man1' siteman1direxp='/opt/perl/man/man1' siteman3dir='/opt/perl/man/man3' siteman3direxp='/opt/perl/man/man3' siteprefix='/opt/perl' siteprefixexp='/opt/perl' sitescript='/opt/perl/bin' sitescriptexp='/opt/perl/bin' sizesize='4' sizetype='size_t' sleep='' smail='' so='so' sockethdr='' socketlib='' socksizetype='socklen_t' sort='sort' spackage='Perl5' spitshell='cat' srand48_r_proto='0' srandom_r_proto='0' src='.' ssizetype='ssize_t' startperl='#!/opt/perl/bin/perl5.12.0' startsh='#!/bin/sh' static_ext=' ' stdchar='char' stdio_base='((fp)->_IO_read_base)' stdio_bufsiz='((fp)->_IO_read_end - (fp)->_IO_read_base)' stdio_cnt='((fp)->_IO_read_end - (fp)->_IO_read_ptr)' stdio_filbuf='' stdio_ptr='((fp)->_IO_read_ptr)' stdio_stream_array='' strerror_r_proto='0' strings='/usr/include/string.h' submit='' subversion='0' sysman='/usr/share/man/man1' tail='' tar='' targetarch='' tbl='' tee='' test='test' timeincl='/usr/include/sys/time.h /usr/include/time.h ' timetype='time_t' tmpnam_r_proto='0' to=':' touch='touch' tr='tr' trnl='\n' troff='' ttyname_r_proto='0' u16size='2' u16type='unsigned short' u32size='4' u32type='unsigned long' u64size='8' u64type='unsigned long long' u8size='1' u8type='unsigned char' uidformat='"lu"' uidsign='1' uidsize='4' uidtype='uid_t' uname='uname' uniq='uniq' uquadtype='unsigned long long' use5005threads='undef' use64bitall='undef' use64bitint='define' usecrosscompile='undef' usedevel='define' usedl='define' usedtrace='undef' usefaststdio='undef' useithreads='undef' uselargefiles='define' uselongdouble='undef' usemallocwrap='define' usemorebits='undef' usemultiplicity='undef' usemymalloc='n' usenm='false' useopcode='true' useperlio='define' useposix='true' usereentrant='undef' userelocatableinc='undef' usesfio='false' useshrplib='false' usesitecustomize='undef' usesocks='undef' usethreads='undef' usevendorprefix='undef' usevfork='false' usrinc='/usr/include' uuname='' uvXUformat='"LX"' uvoformat='"Lo"' uvsize='8' uvtype='unsigned long long' uvuformat='"Lu"' uvxformat='"Lx"' vaproto='undef' vendorarch='' vendorarchexp='' vendorbin='' vendorbinexp='' vendorhtml1dir=' ' vendorhtml1direxp='' vendorhtml3dir=' ' vendorhtml3direxp='' vendorlib='' vendorlib_stem='' vendorlibexp='' vendorman1dir=' ' vendorman1direxp='' vendorman3dir=' ' vendorman3direxp='' vendorprefix='' vendorprefixexp='' vendorscript='' vendorscriptexp='' version='5.12.0' version_patchlevel_string='version 12 subversion 0' versiononly='define' vi='' voidflags='15' xlibpth='/usr/lib/386 /lib/386' yacc='/pro/3gl/CPAN/bin/byacc' yaccflags='' zcat='' zip='zip' : Configure command line arguments. config_arg0='./Configure' config_args='-Dprefix=/opt/perl -Dcf_by=merijn -Dcf_email=yourname@yourhost.yourplace.com -Dperladmin=yourname@yourhost.yourplace.com -Dmydomain=.yourplace.com -Dmyhostname=yourhost -Duse64bitint -Dusedevel -dE' config_argc=9 config_arg1='-Dprefix=/opt/perl' config_arg2='-Dcf_by=merijn' config_arg3='-Dcf_email=yourname@yourhost.yourplace.com' config_arg4='-Dperladmin=yourname@yourhost.yourplace.com' config_arg5='-Dmydomain=.yourplace.com' config_arg6='-Dmyhostname=yourhost' config_arg7='-Duse64bitint' config_arg8='-Dusedevel' config_arg9='-dE' PERL_REVISION=5 PERL_VERSION=12 PERL_SUBVERSION=0 PERL_API_REVISION=5 PERL_API_VERSION=12 PERL_API_SUBVERSION=0 PERL_PATCHLEVEL=34948 PERL_CONFIG_SH=true : Variables propagated from previous config.sh file. libdb_needs_pthread='N' perl-5.12.0-RC0/Porting/regcharclass.pl0000555000175000017500000005332411325125741016560 0ustar jessejessepackage CharClass::Matcher; use strict; use warnings; use warnings FATAL => 'all'; use Text::Wrap qw(wrap); use Encode; use Data::Dumper; $Data::Dumper::Useqq= 1; our $hex_fmt= "0x%02X"; =head1 NAME CharClass::Matcher -- Generate C macros that match character classes efficiently =head1 SYNOPSIS perl Porting/regcharclass.pl =head1 DESCRIPTION Dynamically generates macros for detecting special charclasses in latin-1, utf8, and codepoint forms. Macros can be set to return the length (in bytes) of the matched codepoint, or the codepoint itself. To regenerate regcharclass.h, run this script from perl-root. No arguments are necessary. Using WHATEVER as an example the following macros will be produced: =over 4 =item is_WHATEVER(s,is_utf8) =item is_WHATEVER_safe(s,e,is_utf8) Do a lookup as appropriate based on the is_utf8 flag. When possible comparisons involving octect<128 are done before checking the is_utf8 flag, hopefully saving time. =item is_WHATEVER_utf8(s) =item is_WHATEVER_utf8_safe(s,e) Do a lookup assuming the string is encoded in (normalized) UTF8. =item is_WHATEVER_latin1(s) =item is_WHATEVER_latin1_safe(s,e) Do a lookup assuming the string is encoded in latin-1 (aka plan octets). =item is_WHATEVER_cp(cp) Check to see if the string matches a given codepoint (hypotethically a U32). The condition is constructed as as to "break out" as early as possible if the codepoint is out of range of the condition. IOW: (cp==X || (cp>X && (cp==Y || (cp>Y && ...)))) Thus if the character is X+1 only two comparisons will be done. Making matching lookups slower, but non-matching faster. =back Additionally it is possible to generate C variants that return the codepoint read instead of the number of octets read, this can be done by suffixing '-cp' to the type description. =head2 CODE FORMAT perltidy -st -bt=1 -bbt=0 -pt=0 -sbt=1 -ce -nwls== "%f" =head1 AUTHOR Author: Yves Orton (demerphq) 2007 =head1 BUGS No tests directly here (although the regex engine will fail tests if this code is broken). Insufficient documentation and no Getopts handler for using the module as a script. =head1 LICENSE You may distribute under the terms of either the GNU General Public License or the Artistic License, as specified in the README file. =cut # Sub naming convention: # __func : private subroutine, can not be called as a method # _func : private method, not meant for external use # func : public method. # private subs #------------------------------------------------------------------------------- # # ($cp,$n,$l,$u)=__uni_latin($str); # # Return a list of arrays, each of which when interepreted correctly # represent the string in some given encoding with specific conditions. # # $cp - list of codepoints that make up the string. # $n - list of octets that make up the string if all codepoints < 128 # $l - list of octets that make up the string in latin1 encoding if all # codepoints < 256, and at least one codepoint is >127. # $u - list of octets that make up the string in utf8 if any codepoint >127 # # High CP | Defined #-----------+---------- # 0 - 127 : $n # 128 - 255 : $l, $u # 256 - ... : $u # sub __uni_latin1 { my $str= shift; my $max= 0; my @cp; for my $ch ( split //, $str ) { my $cp= ord $ch; push @cp, $cp; $max= $cp if $max < $cp; } my ( $n, $l, $u ); if ( $max < 128 ) { $n= [@cp]; } else { $l= [@cp] if $max && $max < 256; my $copy= $str; # must copy string, FB_CROAK makes encode destructive $u= eval { Encode::encode( "utf8", $copy, Encode::FB_CROAK ) }; # $u is utf8 but with the utf8 flag OFF # therefore "C*" gets us the values of the bytes involved. $u= [ unpack "C*", $u ] if defined $u; } return ( \@cp, $n, $l, $u ); } # # $clean= __clean($expr); # # Cleanup a ternary expression, removing unnecessary parens and apply some # simplifications using regexes. # sub __clean { my ( $expr )= @_; our $parens; $parens= qr/ (?> \( (?> (?: (?> [^()]+ ) | (??{ $parens }) )* ) \) ) /x; #print "$parens\n$expr\n"; 1 while $expr =~ s/ \( \s* ( $parens ) \s* \) /$1/gx; 1 while $expr =~ s/ \( \s* ($parens) \s* \? \s* \( \s* ($parens) \s* \? \s* ($parens|[^:]+?) \s* : \s* ($parens|[^)]+?) \s* \) \s* : \s* \4 \s* \)/( ( $1 && $2 ) ? $3 : 0 )/gx; return $expr; } # # $text= __macro(@args); # Join args together by newlines, and then neatly add backslashes to the end # of every line as expected by the C pre-processor for #define's. # sub __macro { my $str= join "\n", @_; $str =~ s/\s*$//; my @lines= map { s/\s+$//; s/\t/ /g; $_ } split /\n/, $str; my $last= pop @lines; $str= join "\n", ( map { sprintf "%-76s\\", $_ } @lines ), $last; 1 while $str =~ s/^(\t*) {8}/$1\t/gm; return $str . "\n"; } # # my $op=__incrdepth($op); # # take an 'op' hashref and add one to it and all its childrens depths. # sub __incrdepth { my $op= shift; return unless ref $op; $op->{depth} += 1; __incrdepth( $op->{yes} ); __incrdepth( $op->{no} ); return $op; } # join two branches of an opcode together with a condition, incrementing # the depth on the yes branch when we do so. # returns the new root opcode of the tree. sub __cond_join { my ( $cond, $yes, $no )= @_; return { test => $cond, yes => __incrdepth( $yes ), no => $no, depth => 0, }; } # Methods # constructor # # my $obj=CLASS->new(op=>'SOMENAME',title=>'blah',txt=>[..]); # # Create a new CharClass::Matcher object by parsing the text in # the txt array. Currently applies the following rules: # # Element starts with C<0x>, line is evaled the result treated as # a number which is passed to chr(). # # Element starts with C<">, line is evaled and the result treated # as a string. # # Each string is then stored in the 'strs' subhash as a hash record # made up of the results of __uni_latin1, using the keynames # 'low','latin1','utf8', as well as the synthesized 'LATIN1' and # 'UTF8' which hold a merge of 'low' and their lowercase equivelents. # # Size data is tracked per type in the 'size' subhash. # # Return an object # sub new { my $class= shift; my %opt= @_; for ( qw(op txt) ) { die "in " . __PACKAGE__ . " constructor '$_;' is a mandatory field" if !exists $opt{$_}; } my $self= bless { op => $opt{op}, title => $opt{title} || '', }, $class; foreach my $txt ( @{ $opt{txt} } ) { my $str= $txt; if ( $str =~ /^[""]/ ) { $str= eval $str; } elsif ( $str =~ /^0x/ ) { $str= chr eval $str; } elsif ( /\S/ ) { die "Unparseable line: $txt\n"; } else { next; } my ( $cp, $low, $latin1, $utf8 )= __uni_latin1( $str ); my $UTF8= $low || $utf8; my $LATIN1= $low || $latin1; #die Dumper($txt,$cp,$low,$latin1,$utf8) # if $txt=~/NEL/ or $utf8 and @$utf8>3; @{ $self->{strs}{$str} }{qw( str txt low utf8 latin1 cp UTF8 LATIN1 )}= ( $str, $txt, $low, $utf8, $latin1, $cp, $UTF8, $LATIN1 ); my $rec= $self->{strs}{$str}; foreach my $key ( qw(low utf8 latin1 cp UTF8 LATIN1) ) { $self->{size}{$key}{ 0 + @{ $self->{strs}{$str}{$key} } }++ if $self->{strs}{$str}{$key}; } $self->{has_multi} ||= @$cp > 1; $self->{has_ascii} ||= $latin1 && @$latin1; $self->{has_low} ||= $low && @$low; $self->{has_high} ||= !$low && !$latin1; } $self->{val_fmt}= $hex_fmt; $self->{count}= 0 + keys %{ $self->{strs} }; return $self; } # my $trie = make_trie($type,$maxlen); # # using the data stored in the object build a trie of a specifc type, # and with specific maximum depth. The trie is made up the elements of # the given types array for each string in the object (assuming it is # not too long.) # # returns the trie, or undef if there was no relevent data in the object. # sub make_trie { my ( $self, $type, $maxlen )= @_; my $strs= $self->{strs}; my %trie; foreach my $rec ( values %$strs ) { die "panic: unknown type '$type'" if !exists $rec->{$type}; my $dat= $rec->{$type}; next unless $dat; next if $maxlen && @$dat > $maxlen; my $node= \%trie; foreach my $elem ( @$dat ) { $node->{$elem} ||= {}; $node= $node->{$elem}; } $node->{''}= $rec->{str}; } return 0 + keys( %trie ) ? \%trie : undef; } # my $optree= _optree() # # recursively convert a trie to an optree where every node represents # an if else branch. # # sub _optree { my ( $self, $trie, $test_type, $ret_type, $else, $depth )= @_; return unless defined $trie; if ( $self->{has_multi} and $ret_type =~ /cp|both/ ) { die "Can't do 'cp' optree from multi-codepoint strings"; } $ret_type ||= 'len'; $else= 0 unless defined $else; $depth= 0 unless defined $depth; my @conds= sort { $a <=> $b } grep { length $_ } keys %$trie; if ( $trie->{''} ) { if ( $ret_type eq 'cp' ) { $else= $self->{strs}{ $trie->{''} }{cp}[0]; $else= sprintf "$self->{val_fmt}", $else if $else > 9; } elsif ( $ret_type eq 'len' ) { $else= $depth; } elsif ( $ret_type eq 'both') { $else= $self->{strs}{ $trie->{''} }{cp}[0]; $else= sprintf "$self->{val_fmt}", $else if $else > 9; $else= "len=$depth, $else"; } } return $else if !@conds; my $node= {}; my $root= $node; my ( $yes_res, $as_code, @cond ); my $test= $test_type eq 'cp' ? "cp" : "((U8*)s)[$depth]"; my $Update= sub { $node->{vals}= [@cond]; $node->{test}= $test; $node->{yes}= $yes_res; $node->{depth}= $depth; $node->{no}= shift; }; while ( @conds ) { my $cond= shift @conds; my $res= $self->_optree( $trie->{$cond}, $test_type, $ret_type, $else, $depth + 1 ); my $res_code= Dumper( $res ); if ( !$yes_res || $res_code ne $as_code ) { if ( $yes_res ) { $Update->( {} ); $node= $node->{no}; } ( $yes_res, $as_code )= ( $res, $res_code ); @cond= ( $cond ); } else { push @cond, $cond; } } $Update->( $else ); return $root; } # my $optree= optree(%opts); # # Convert a trie to an optree, wrapper for _optree sub optree { my $self= shift; my %opt= @_; my $trie= $self->make_trie( $opt{type}, $opt{max_depth} ); $opt{ret_type} ||= 'len'; my $test_type= $opt{type} eq 'cp' ? 'cp' : 'depth'; return $self->_optree( $trie, $test_type, $opt{ret_type}, $opt{else}, 0 ); } # my $optree= generic_optree(%opts); # # build a "generic" optree out of the three 'low', 'latin1', 'utf8' # sets of strings, including a branch for handling the string type check. # sub generic_optree { my $self= shift; my %opt= @_; $opt{ret_type} ||= 'len'; my $test_type= 'depth'; my $else= $opt{else} || 0; my $latin1= $self->make_trie( 'latin1', $opt{max_depth} ); my $utf8= $self->make_trie( 'utf8', $opt{max_depth} ); $_= $self->_optree( $_, $test_type, $opt{ret_type}, $else, 0 ) for $latin1, $utf8; if ( $utf8 ) { $else= __cond_join( "( is_utf8 )", $utf8, $latin1 || $else ); } elsif ( $latin1 ) { $else= __cond_join( "!( is_utf8 )", $latin1, $else ); } my $low= $self->make_trie( 'low', $opt{max_depth} ); if ( $low ) { $else= $self->_optree( $low, $test_type, $opt{ret_type}, $else, 0 ); } return $else; } # length_optree() # # create a string length guarded optree. # sub length_optree { my $self= shift; my %opt= @_; my $type= $opt{type}; die "Can't do a length_optree on type 'cp', makes no sense." if $type eq 'cp'; my ( @size, $method ); if ( $type eq 'generic' ) { $method= 'generic_optree'; my %sizes= ( %{ $self->{size}{low} || {} }, %{ $self->{size}{latin1} || {} }, %{ $self->{size}{utf8} || {} } ); @size= sort { $a <=> $b } keys %sizes; } else { $method= 'optree'; @size= sort { $a <=> $b } keys %{ $self->{size}{$type} }; } my $else= ( $opt{else} ||= 0 ); for my $size ( @size ) { my $optree= $self->$method( %opt, type => $type, max_depth => $size ); my $cond= "((e)-(s) > " . ( $size - 1 ).")"; $else= __cond_join( $cond, $optree, $else ); } return $else; } # _cond_as_str # turn a list of conditions into a text expression # - merges ranges of conditions, and joins the result with || sub _cond_as_str { my ( $self, $op, $combine )= @_; my $cond= $op->{vals}; my $test= $op->{test}; return "( $test )" if !defined $cond; # rangify the list my @ranges; my $Update= sub { if ( @ranges ) { if ( $ranges[-1][0] == $ranges[-1][1] ) { $ranges[-1]= $ranges[-1][0]; } elsif ( $ranges[-1][0] + 1 == $ranges[-1][1] ) { $ranges[-1]= $ranges[-1][0]; push @ranges, $ranges[-1] + 1; } } }; for my $cond ( @$cond ) { if ( !@ranges || $cond != $ranges[-1][1] + 1 ) { $Update->(); push @ranges, [ $cond, $cond ]; } else { $ranges[-1][1]++; } } $Update->(); return $self->_combine( $test, @ranges ) if $combine; @ranges= map { ref $_ ? sprintf( "( $self->{val_fmt} <= $test && $test <= $self->{val_fmt} )", @$_ ) : sprintf( "$self->{val_fmt} == $test", $_ ); } @ranges; return "( " . join( " || ", @ranges ) . " )"; } # _combine # recursively turn a list of conditions into a fast break-out condition # used by _cond_as_str() for 'cp' type macros. sub _combine { my ( $self, $test, @cond )= @_; return if !@cond; my $item= shift @cond; my ( $cstr, $gtv ); if ( ref $item ) { $cstr= sprintf( "( $self->{val_fmt} <= $test && $test <= $self->{val_fmt} )", @$item ); $gtv= sprintf "$self->{val_fmt}", $item->[1]; } else { $cstr= sprintf( "$self->{val_fmt} == $test", $item ); $gtv= sprintf "$self->{val_fmt}", $item; } if ( @cond ) { return "( $cstr || ( $gtv < $test &&\n" . $self->_combine( $test, @cond ) . " ) )"; } else { return $cstr; } } # _render() # recursively convert an optree to text with reasonably neat formatting sub _render { my ( $self, $op, $combine, $brace )= @_; if ( !ref $op ) { return $op; } my $cond= $self->_cond_as_str( $op, $combine ); my $yes= $self->_render( $op->{yes}, $combine, 1 ); my $no= $self->_render( $op->{no}, $combine, 0 ); return "( $cond )" if $yes eq '1' and $no eq '0'; my ( $lb, $rb )= $brace ? ( "( ", " )" ) : ( "", "" ); return "$lb$cond ? $yes : $no$rb" if !ref( $op->{yes} ) && !ref( $op->{no} ); my $ind1= " " x 4; my $ind= "\n" . ( $ind1 x $op->{depth} ); if ( ref $op->{yes} ) { $yes= $ind . $ind1 . $yes; } else { $yes= " " . $yes; } return "$lb$cond ?$yes$ind: $no$rb"; } # $expr=render($op,$combine) # # convert an optree to text with reasonably neat formatting. If $combine # is true then the condition is created using "fast breakouts" which # produce uglier expressions that are more efficient for common case, # longer lists such as that resulting from type 'cp' output. # Currently only used for type 'cp' macros. sub render { my ( $self, $op, $combine )= @_; my $str= "( " . $self->_render( $op, $combine ) . " )"; return __clean( $str ); } # make_macro # make a macro of a given type. # calls into make_trie and (generic_|length_)optree as needed # Opts are: # type : 'cp','generic','low','latin1','utf8','LATIN1','UTF8' # ret_type : 'cp' or 'len' # safe : add length guards to macro # # type defaults to 'generic', and ret_type to 'len' unless type is 'cp' # in which case it defaults to 'cp' as well. # # it is illegal to do a type 'cp' macro on a pattern with multi-codepoint # sequences in it, as the generated macro will accept only a single codepoint # as an argument. # # returns the macro. sub make_macro { my $self= shift; my %opts= @_; my $type= $opts{type} || 'generic'; die "Can't do a 'cp' on multi-codepoint character class '$self->{op}'" if $type eq 'cp' and $self->{has_multi}; my $ret_type= $opts{ret_type} || ( $opts{type} eq 'cp' ? 'cp' : 'len' ); my $method; if ( $opts{safe} ) { $method= 'length_optree'; } elsif ( $type eq 'generic' ) { $method= 'generic_optree'; } else { $method= 'optree'; } my $optree= $self->$method( %opts, type => $type, ret_type => $ret_type ); my $text= $self->render( $optree, $type eq 'cp' ); my @args= $type eq 'cp' ? 'cp' : 's'; push @args, "e" if $opts{safe}; push @args, "is_utf8" if $type eq 'generic'; push @args, "len" if $ret_type eq 'both'; my $pfx= $ret_type eq 'both' ? 'what_len_' : $ret_type eq 'cp' ? 'what_' : 'is_'; my $ext= $type eq 'generic' ? '' : '_' . lc( $type ); $ext .= "_safe" if $opts{safe}; my $argstr= join ",", @args; return "/*** GENERATED CODE ***/\n" . __macro( "#define $pfx$self->{op}$ext($argstr)\n$text" ); } # if we arent being used as a module (highly likely) then process # the __DATA__ below and produce macros in regcharclass.h # if an argument is provided to the script then it is assumed to # be the path of the file to output to, if the arg is '-' outputs # to STDOUT. if ( !caller ) { $|++; my $path= shift @ARGV; if ( !$path ) { $path= "regcharclass.h"; if ( !-e $path ) { $path= "../$path" } if ( !-e $path ) { die "Can't find '$path' to update!\n" } } my $out_fh; if ( $path eq '-' ) { $out_fh= \*STDOUT; } else { rename $path, "$path.bak"; open $out_fh, ">", $path or die "Can't write to '$path':$!"; binmode $out_fh; # want unix line endings even when run on win32. } my ( $zero )= $0 =~ /([^\\\/]+)$/; print $out_fh <<"HEADER"; /* -*- buffer-read-only: t -*- * * regcharclass.h * * Copyright (C) 2007, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * * !!!!!!! DO NOT EDIT THIS FILE !!!!!!! * This file is built by Porting/$zero. * * Any changes made here will be lost! * */ HEADER my ( $op, $title, @txt, @types, @mods ); my $doit= sub { return unless $op; print $out_fh "/*\n\t$op: $title\n\n"; print $out_fh join "\n", ( map { "\t$_" } @txt ), "*/", ""; my $obj= __PACKAGE__->new( op => $op, title => $title, txt => \@txt ); #die Dumper(\@types,\@mods); foreach my $type_spec ( @types ) { my ( $type, $ret )= split /-/, $type_spec; $ret ||= 'len'; foreach my $mod ( @mods ) { next if $mod eq 'safe' and $type eq 'cp'; my $macro= $obj->make_macro( type => $type, ret_type => $ret, safe => $mod eq 'safe' ); print $out_fh $macro, "\n"; } } }; while ( ) { s/^\s*#//; next unless /\S/; chomp; if ( /^([A-Z]+)/ ) { $doit->(); ( $op, $title )= split /\s*:\s*/, $_, 2; @txt= (); } elsif ( s/^=>// ) { my ( $type, $modifier )= split /:/, $_; @types= split ' ', $type; @mods= split ' ', $modifier; } else { push @txt, "$_"; } } $doit->(); print $out_fh "/* ex: set ro: */\n"; print "updated $path\n" if $path ne '-'; } # # Valid types: generic, LATIN1, UTF8, low, latin1, utf8 # default return value is octects read. # append -cp to make it codepoint matched. # modifiers come after the colon, valid possibilities # being 'fast' and 'safe'. # 1; # in the unlikely case we are being used as a module __DATA__ LNBREAK: Line Break: \R => generic UTF8 LATIN1 :fast safe "\x0D\x0A" # CRLF - Network (Windows) line ending 0x0A # LF | LINE FEED 0x0B # VT | VERTICAL TAB 0x0C # FF | FORM FEED 0x0D # CR | CARRIAGE RETURN 0x85 # NEL | NEXT LINE 0x2028 # LINE SEPARATOR 0x2029 # PARAGRAPH SEPARATOR HORIZWS: Horizontal Whitespace: \h \H => generic UTF8 LATIN1 cp :fast safe 0x09 # HT 0x20 # SPACE 0xa0 # NBSP 0x1680 # OGHAM SPACE MARK 0x180e # MONGOLIAN VOWEL SEPARATOR 0x2000 # EN QUAD 0x2001 # EM QUAD 0x2002 # EN SPACE 0x2003 # EM SPACE 0x2004 # THREE-PER-EM SPACE 0x2005 # FOUR-PER-EM SPACE 0x2006 # SIX-PER-EM SPACE 0x2007 # FIGURE SPACE 0x2008 # PUNCTUATION SPACE 0x2009 # THIN SPACE 0x200A # HAIR SPACE 0x202f # NARROW NO-BREAK SPACE 0x205f # MEDIUM MATHEMATICAL SPACE 0x3000 # IDEOGRAPHIC SPACE VERTWS: Vertical Whitespace: \v \V => generic UTF8 LATIN1 cp :fast safe 0x0A # LF 0x0B # VT 0x0C # FF 0x0D # CR 0x85 # NEL 0x2028 # LINE SEPARATOR 0x2029 # PARAGRAPH SEPARATOR TRICKYFOLD: Problematic fold case letters. => generic cp generic-cp generic-both :fast safe 0x00DF # LATIN1 SMALL LETTER SHARP S 0x0390 # GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS 0x03B0 # GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS perl-5.12.0-RC0/Porting/checkURL.pl0000555000175000017500000002770211325127001015547 0ustar jessejesse#!perl use strict; use warnings; use autodie; use feature qw(say); use File::Find::Rule; use File::Slurp; use File::Spec; use IO::Socket::SSL; use List::Util qw(sum); use LWP::UserAgent; use Net::FTP; use Parallel::Fork::BossWorkerAsync; use Term::ProgressBar::Simple; use URI::Find::Simple qw( list_uris ); $| = 1; my %ignore; while ( my $line = ) { chomp $line; next if $line =~ /^#/; next unless $line; $ignore{$line} = 1; } my $ua = LWP::UserAgent->new; $ua->timeout(58); $ua->env_proxy; my @filenames = @ARGV; @filenames = sort grep { $_ !~ /^\.git/ } File::Find::Rule->new->file->in('.') unless @filenames; my $total_bytes = sum map {-s} @filenames; my $extract_progress = Term::ProgressBar::Simple->new( { count => $total_bytes, name => 'Extracting URIs', } ); my %uris; foreach my $filename (@filenames) { next if $filename =~ /uris\.txt/; next if $filename =~ /check_uris/; next if $filename =~ /\.patch$/; my $contents = read_file($filename); my @uris = list_uris($contents); foreach my $uri (@uris) { next unless $uri =~ /^(http|ftp)/; next if $ignore{$uri}; # no need to hit rt.perl.org next if $uri =~ m{^http://rt.perl.org/rt3/Ticket/Display.html?id=\d+$}; # no need to hit rt.cpan.org next if $uri =~ m{^http://rt.cpan.org/Public/Bug/Display.html?id=\d+$}; push @{ $uris{$uri} }, $filename; } $extract_progress += -s $filename; } my $bw = Parallel::Fork::BossWorkerAsync->new( work_handler => \&work_alarmed, global_timeout => 120, worker_count => 20, ); foreach my $uri ( keys %uris ) { my @filenames = @{ $uris{$uri} }; $bw->add_work( { uri => $uri, filenames => \@filenames } ); } undef $extract_progress; my $fetch_progress = Term::ProgressBar::Simple->new( { count => scalar( keys %uris ), name => 'Fetching URIs', } ); my %filenames; while ( $bw->pending() ) { my $response = $bw->get_result(); my $uri = $response->{uri}; my @filenames = @{ $response->{filenames} }; my $is_success = $response->{is_success}; my $message = $response->{message}; unless ($is_success) { foreach my $filename (@filenames) { push @{ $filenames{$filename} }, { uri => $uri, message => $message }; } } $fetch_progress++; } $bw->shut_down(); my $fh = IO::File->new('> uris.txt'); foreach my $filename ( sort keys %filenames ) { $fh->say("* $filename"); my @bits = @{ $filenames{$filename} }; foreach my $bit (@bits) { my $uri = $bit->{uri}; my $message = $bit->{message}; $fh->say(" $uri"); $fh->say(" $message"); } } $fh->close; say 'Finished, see uris.txt'; sub work_alarmed { my $conf = shift; eval { local $SIG{ALRM} = sub { die "alarm\n" }; # NB: \n required alarm 60; $conf = work($conf); alarm 0; }; if ($@) { $conf->{is_success} = 0; $conf->{message} = 'Timed out'; } return $conf; } sub work { my $conf = shift; my $uri = $conf->{uri}; my @filenames = @{ $conf->{filenames} }; if ( $uri =~ /^http/ ) { my $uri_without_fragment = URI->new($uri); my $fragment = $uri_without_fragment->fragment(undef); my $response = $ua->head($uri_without_fragment); $conf->{is_success} = $response->is_success; $conf->{message} = $response->status_line; return $conf; } else { my $uri_object = URI->new($uri); my $host = $uri_object->host; my $path = $uri_object->path; my ( $volume, $directories, $filename ) = File::Spec->splitpath($path); my $ftp = Net::FTP->new( $host, Passive => 1, Timeout => 60 ); unless ($ftp) { $conf->{is_succcess} = 0; $conf->{message} = "Can not connect to $host: $@"; return $conf; } my $can_login = $ftp->login( "anonymous", '-anonymous@' ); unless ($can_login) { $conf->{is_success} = 0; $conf->{message} = "Can not login ", $ftp->message; return $conf; } my $can_binary = $ftp->binary(); unless ($can_binary) { $conf->{is_success} = 0; $conf->{message} = "Can not binary ", $ftp->message; return $conf; } my $can_cwd = $ftp->cwd($directories); unless ($can_cwd) { $conf->{is_success} = 0; $conf->{message} = "Can not cwd to $directories ", $ftp->message; return $conf; } if ($filename) { my $can_size = $ftp->size($filename); unless ($can_size) { $conf->{is_success} = 0; $conf->{message} = "Can not size $filename in $directories", $ftp->message; return $conf; } } else { my ($can_dir) = $ftp->dir; unless ($can_dir) { my ($can_ls) = $ftp->ls; unless ($can_ls) { $conf->{is_success} = 0; $conf->{message} = "Can not dir or ls in $directories ", $ftp->message; return $conf; } } } $conf->{is_success} = 1; return $conf; } } __DATA__ # these are fine but give errors ftp://ftp.stratus.com/pub/vos/posix/ga/ga.html ftp://ftp.stratus.com/pub/vos/utility/utility.html # this is missing, sigh ftp://ftp.sco.com/SLS/ptf7051e.Z http://perlmonks.thepen.com/42898.html # this are URI extraction bugs http://www.perl.org/E http://en.wikipedia.org/wiki/SREC_(file_format http://somewhere.else',-type=/ ftp:passive-mode ftp: http:[- http://search.cpan.org/src/KWILLIAMS/Module-Build-0.30/lib/Module/Build/Platform/Windows.pm:split_like_shell http://www.xray.mpe.mpg.de/mailing-lists/perl5- http://support.microsoft.com/support/kb/articles/Q280/3/41.ASP: # these are used as an example http://example.com/ http://something.here/ http://users.perl5.git.perl.org/~yourlogin/ http://github.com/USERNAME/perl/tree/orange http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar http://somewhere.else$/ http://somewhere.else$/ http://somewhere.else/bin/foo&bar',-Type= http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar http://www.perl.org/test.cgi http://cpan2.local/ http://search.cpan.org/perldoc? http://cpan1.local/ http://cpan.dev.local/CPAN http:/// ftp:// ftp://myurl/ ftp://ftp.software.ibm.com/aix/fixes/v4/other/vac.C.5.0.2.6.bff http://www14.software.ibm.com/webapp/download/downloadaz.jsp http://www.cpan.org/modules/by-module/Archive/Archive-Zip-*.tar.gz http://www.unicode.org/Public/MAPPINGS/ISO8859/8859-*.TXT http://localhost/tmp/index.txt http://example.com/foo/bar.html http://example.com/Text-Bastardize-1.06.tar.gz ftp://example.com/sources/packages.txt http://example.com/sources/packages.txt http://example.com/sources ftp://example.com/sources http://some.where.com/dir/file.txt http://some.where.com/dir/a.txt http://foo.com/X.tgz ftp://foo.com/X.tgz http://foo/ http://www.foo.com:8000/ http://mysite.com/cgi-bin/log.cgi/http://www.some.other.site/args http://decoded/mirror/path http://a/b/c/d/e/f/g/h/i/j http://foo/bar.gz ftp://ftp.perl.org http://purl.org/rss/1.0/modules/taxonomy/ ftp://ftp.sun.ac.za/CPAN/CPAN/ ftp://ftp.cpan.org/pub/mirror/index.txt ftp://cpan.org/pub/mirror/index.txt http://example.com/~eh/ http://plagger.org/.../rss http://umn.dl.sourceforge.net/mingw/gcc-g++-3.4.5-20060117-1.tar.gz http://umn.dl.sourceforge.net/mingw/binutils-2.16.91-20060119-1.tar.gz http://umn.dl.sourceforge.net/mingw/mingw-runtime-3.10.tar.gz http://umn.dl.sourceforge.net/mingw/gcc-core-3.4.5-20060117-1.tar.gz http://umn.dl.sourceforge.net/mingw/w32api-3.6.tar.gz http://search.cpan.org/CPAN/authors/id/S/SH/SHAY/dmake-4.5-20060619-SHAY.zip http://module-build.sourceforge.net/META-spec-new.html http://module-build.sourceforge.net/META-spec-v1.4.html http://www.cs.vu.nl/~tmgil/vi.html http://perlcomposer.sourceforge.net/vperl.html http://www.perl.com/CPAN/authors/Tom_Christiansen/scripts/rep http://w4.lns.cornell.edu/~pvhp/ptk/ptkTOC.html http://world.std.com/~aep/ptkdb/ http://www.castlelink.co.uk/object_system/ http://www.fh-wedel.de/elvis/ ftp://ftp.blarg.net/users/amol/zsh/ ftp://ftp.funet.fi/pub/languages/perl/CPAN http://search.cpan.org/CPAN/authors/id/S/SH/SHAY/dmake-4.5-20060619-SHAY.zip # these are used to generate or match URLs http://www.cpan.org/modules/by-authors/id/$1/$1$2/$dist http://www.cpantesters.org/show/%s.yaml ftp://(.*?)/(.*)/(.* ftp://(.*?)/(.*)/(.* ftp://(.*?)/(.*)/(.* ftp://ftp.foo.bar/ http://$host/ http://wwwe%3C46/ ftp:/ # weird redirects that LWP doesn't like http://www.theperlreview.com/community_calendar http://www.software.hp.com/portal/swdepot/displayProductInfo.do?productNumber=PERL http://groups.google.com/ http://groups.google.com/group/comp.lang.perl.misc/topics http://groups.google.co.uk/group/perl.perl5.porters/browse_thread/thread/b4e2b1d88280ddff/630b667a66e3509f?#630b667a66e3509f http://groups.google.com/group/comp.sys.sgi.admin/msg/3ad8353bc4ce3cb0 http://groups.google.com/group/perl.module.build/browse_thread/thread/c8065052b2e0d741 http://groups.google.com/group/perl.perl5.porters/browse_thread/thread/adaffaaf939b042e/20dafc298df737f0%2320dafc298df737f0?sa=X&oi=groupsr&start=0&num=3 # broken webserver that doesn't like HEAD requests http://docs.sun.com/app/docs/doc/816-5168/syslog-3c?a=view # these have been reported upstream to CPAN authors http://www.gnu.org/manual/tar/html_node/tar_139.html http://www.w3.org/pub/WWW/TR/Wd-css-1.html http://support.microsoft.com/support/kb/articles/Q280/3/41.ASP http://msdn.microsoft.com/workshop/author/dhtml/httponly_cookies.asp http://search.cpan.org/search?query=Module::Build::Convert http://www.refcnt.org/papers/module-build-convert http://csrc.nist.gov/cryptval/shs.html http://msdn.microsoft.com/workshop/author/dhtml/reference/charsets/charset4.asp http://www.debian.or.jp/~kubota/unicode-symbols.html.en http://www.mail-archive.com/perl5-porters@perl.org/msg69766.html http://www.debian.or.jp/~kubota/unicode-symbols.html.en http://rfc.net/rfc2781.html http://www.icu-project.org/charset/ http://ppewww.ph.gla.ac.uk/~flavell/charset/form-i18n.html http://www.rfc-editor.org/ http://www.rfc.net/ http://www.oreilly.com/people/authors/lunde/cjk_inf.html http://www.oreilly.com/catalog/cjkvinfo/ http://www.cpan.org/modules/by-author/Damian_Conway/Filter-Simple.tar.gz http://www.csse.monash.edu.au/~damian/CPAN/Filter-Simple.tar.gz http://www.egt.ie/standards/iso3166/iso3166-1-en.html http://www.bsi-global.com/iso4217currency http://www.plover.com/~mjd/perl/Memoize/ http://www.plover.com/~mjd/perl/MiniMemoize/ http://www.sysadminmag.com/tpj/issues/vol5_5/ ftp://ftp.tpc.int/tpc/server/UNIX/ http://www.nara.gov/genealogy/ http://home.utah-inter.net/kinsearch/Soundex.html http://www.nara.gov/genealogy/soundex/soundex.html http://rfc.net/rfc3461.html ftp://ftp.cs.pdx.edu/pub/elvis/ http://www.fh-wedel.de/elvis/ __END__ =head1 NAME checkURL.pl - Check that all the URLs in the Perl source are valid =head1 DESCRIPTION This program checks that all the URLs in the Perl source are valid. It checks HTTP and FTP links in parallel and contains a list of known bad example links in its source. It takes 4 minutes to run on my machine. The results are written to 'uris.txt' and list the filename, the URL and the error: * ext/Locale-Maketext/lib/Locale/Maketext.pod http://sunsite.dk/RFC/rfc/rfc2277.html 404 Not Found ... It should be run every so often and links fixed and upstream authors notified. Note that the web is unstable and some websites are temporarily down. perl-5.12.0-RC0/Porting/curliff.pl0000555000175000017500000000207511325125741015546 0ustar jessejesse#!/usr/bin/perl -ws # curliff.pl - convert certain files in the Perl distribution that # need to be in CR-LF format to CR-LF, or back to LF format (with the # -r option). The CR-LF format is NOT to be used for checking in # files to the Perforce repository, but it IS to be used when making # Perl snapshots or releases. use strict; use vars qw($r); # This list is also in makerel. my @FILES = qw( djgpp/configure.bat README.ce README.dos README.symbian README.win32 symbian/config.pl symbian/makesis.pl symbian/README symbian/xsbuild.pl win32/Makefile win32/makefile.mk win32/Makefile.ce win32/ce-helpers/compile-all.bat win32/ce-helpers/compile.bat win32/ce-helpers/registry.bat ); { local($^I, @ARGV) = ('.orig', @FILES); while (<>) { if ($r) { s/\015\012/\012/; # Curliffs to liffs. } else { s/\015?\012/\015\012/; # Curliffs and liffs to curliffs. } print; close ARGV if eof; # Reset $. } } perl-5.12.0-RC0/Porting/add-package.pl0000555000175000017500000004216611325127001016231 0ustar jessejesse#!/opt/bin/perl use strict; use warnings; use Cwd; use Getopt::Std; use File::Basename; use FindBin; my $Opts = {}; getopts( 'r:p:e:c:vudn', $Opts ); my $Cwd = cwd(); my $Verbose = 1; my $ExcludeRe = $Opts->{e} ? qr/$Opts->{e}/i : undef; my $Debug = $Opts->{v} || 0; my $RunDiff = $Opts->{d} || 0; my $PkgDir = $Opts->{p} || cwd(); my $Repo = $Opts->{r} or die "Need repository!\n". usage(); my $Changes = $Opts->{c} || 'Changes ChangeLog'; my $NoBranch = $Opts->{n} || 0; ### strip trailing slashes; $Repo =~ s|/$||; my $CPV = $Debug ? '-v' : ''; my $TestBin = 'ptardiff'; my $PkgDirRe = quotemeta( $PkgDir .'/' ); my $BranchName = basename( $PkgDir ) . '.' . $$; my $OrigRepo = $Repo; ### establish working directory, either branch or full copy if ( $NoBranch ) { ### create a copy of the repo directory my $RepoCopy = "$Repo-$BranchName"; print "Copying repository to $RepoCopy ..." if $Verbose; ### --archive == -dPpR, but --archive is not portable, and neither ### is -d, so settling for -PpR system( "cp -PpR -f $Repo $RepoCopy" ) and die "Copying master repo to $RepoCopy failed: $?"; ### Going forward, use the copy in place of the original repo $Repo = $RepoCopy; print "done\n" if $Verbose; } else { ### create a git branch for the new package print "Setting up a branch from blead called '$BranchName'..." if $Verbose; chdir $Repo or die "Could not chdir to $Repo: $!"; unless ( -d '.git' ) { die "\n$Repo is not a git repository\n"; } my $status = `git status`; unless ( $status =~ /nothing to commit/ims ) { die "\nWorking directory not clean. Stopping.\n"; } system( "git checkout -b $BranchName blead" ) and die "Could not create branch '$BranchName': $?"; print "done\n" if $Verbose; } ### chdir there chdir $PkgDir or die "Could not chdir to $PkgDir: $!"; ### copy over all files under lib/ my @LibFiles; { print "Copying libdir..." if $Verbose; die "Can't (yet) copy from a repository (found .git or .svn)" if -d '.git' || -d '.svn'; die "No lib/ directory found\n" unless -d 'lib'; system( "cp -fR $CPV lib $Repo" ) and die "Copy of lib/ failed: $?"; @LibFiles = map { chomp; $_ } ### should we get rid of this file? grep { $ExcludeRe && $_ =~ $ExcludeRe ? do { warn "Removing $Repo/$_\n"; system("rm $Repo/$_") and die "rm '$Repo/$_' failed: $?"; undef } : 1 } `find lib -type f` or die "Could not detect library files\n"; print "done\n" if $Verbose; } ### find the directory to put the t/ and bin/ files under my $RelTopDir; # topdir from the repo root my $TopDir; # full path to the top dir my $ModName; # name of the module my @ModFiles; # the .PMs in this package { print "Creating top level dir..." if $Verbose; ### make sure we get the shortest file, so we dont accidentally get ### a subdir @ModFiles = sort { length($a) <=> length($b) } map { chomp; $_ } grep { $ExcludeRe ? $_ !~ $ExcludeRe : 1 } grep /\.p(?:m|od)$/, `find $PkgDir/lib -type f` or die "No TopDir detected\n"; $RelTopDir = $ModFiles[0]; $RelTopDir =~ s/^$PkgDirRe//; $RelTopDir =~ s/\.p(m|od)$//; $TopDir = "$Repo/$RelTopDir"; ### create the dir if it's not there yet unless( -d $TopDir ) { system( "mkdir $TopDir" ) and die "Creating dir $TopDir failed: $?"; } ### the module name, like Foo::Bar ### slice syntax not elegant, but we need to remove the ### leading 'lib/' entry ### stupid temp vars! stupid perl! it doesn't do @{..}[0..-1] :( { my @list = @{[split '/', $RelTopDir]}; $ModName = join '::', @list[1 .. $#list]; } ### the .pm files in this package @ModFiles = map { s|^$PkgDirRe||; $_ } @ModFiles or die "Could not detect modfiles\n"; print "done\n" if $Verbose; } my $TopDirRe = quotemeta( $TopDir . '/' ); ### copy over t/ and bin/ directories to the $TopDir my @TestFiles; { print "Copying t/* files to $TopDir..." if $Verbose; -d 't' ? system( "cp -fR $CPV t $TopDir" ) && die "Copy of t/ failed: $?" : warn "No t/ directory found\n"; @TestFiles = map { chomp; s|^$TopDirRe||; s|//|/|g; $_ } ### should we get rid of this file? grep { $ExcludeRe && $_ =~ $ExcludeRe ? do { warn "Removing $_\n"; system("rm $TopDir/$_") and die "rm '$_' failed: $?"; undef } : 1 } `find t -type f` or die "Could not detect testfiles\n"; print "done\n" if $Verbose; } my $BinDir; my @BinFiles; my $TopBinDir; BIN: { $BinDir = -d 'bin' ? 'bin' : -d 'scripts' ? 'scripts' : undef ; unless ($BinDir) { print "No bin/ or scripts/ directory found\n" if $Verbose; last BIN; } my $TopBinDir = "$TopDir/$BinDir/"; print "Copying $BinDir/* files to $TopBinDir..." if $Verbose; my $CopyCmd = "cp -fR $CPV $BinDir $TopDir"; print "Running '$CopyCmd'..." if $Verbose; system($CopyCmd) && die "Copy of $BinDir failed: $?"; @BinFiles = map { chomp; s|^$TopDirRe||; s|//|/|g; $_ } ### should we get rid of this file? grep { $ExcludeRe && $_ =~ $ExcludeRe ? do { warn "Removing $_\n"; system("rm $TopDir/$_") and die "rm '$_' failed: $?"; undef } : 1 } `find $BinDir -type f` or die "Could not detect binfiles\n"; print "done\n" if $Verbose; } ### copy over change log my @Changes; foreach my $cl (split m/\s+/ => $Changes) { -f $cl or next; push @Changes, $cl; print "Copying $cl files to $TopDir..." if $Verbose; system( "cp -f $CPV $cl $TopDir" ) and die "Copy of $cl failed: $?"; } ### add files where they are required my @NewFiles; my @ChangedFiles; { for my $bin ( map { basename( $_ ) } @BinFiles ) { print "Registering $bin with system files...\n"; ### fix installperl, so these files get installed by other utils ### ./installperl: return if $name =~ ### /^(?:cpan|instmodsh|prove|corelist|ptar|ptardiff|config_data)\z/; { my $file = 'installperl'; ### not there already? unless( `grep $TestBin $Repo/$file| grep $bin` ) { print " Adding $bin to $file..." if $Verbose; ### double \\| required --> once for in this script, once ### for the cli system("$^X -pi -e 's/($TestBin\\|)/$bin|\$1/' $Repo/$file") and die "Could not add $bin to $file: $?"; print "done\n" if $Verbose; push @ChangedFiles, $file; } else { print " $bin already mentioned in $file\n" if $Verbose; } } ### fix utils.lst, so the new tools are mentioned { my $file = 'utils.lst'; ### not there already? unless( `grep $bin $Repo/$file` ) { print " Adding $bin to $file..." if $Verbose; ### double \\| required --> once for in this script, once ### for the cli system("$^X -pi -e 's!($TestBin)!\$1\nutils/$bin!' $Repo/$file") and die "Could not add $bin to $file: $?"; print "done\n" if $Verbose; push @ChangedFiles, $file; } else { print " $bin already mentioned in $file\n" if $Verbose; } } ### make a $bin.PL file and fix it up { my $src = "utils/${TestBin}.PL"; my $file = "utils/${bin}.PL"; ### not there already? unless( -e "$Repo/$file" ) { print " Creating $file..." if $Verbose; ### important part of the template looks like this ### (we'll need to change it): # my $script = File::Spec->catfile( # File::Spec->catdir( # File::Spec->updir, qw[lib Archive Tar bin] # ), "module-load.pl"); ### copy another template file system( "cp -f $Repo/$src $Repo/$file" ) and die "Could not create $file from $src: $?"; ### change the 'updir' path ### make sure to escape the \[ character classes my $updir = join ' ', (split('/', $RelTopDir), $BinDir); system( "$^X -pi -e'". 's/^(.*?File::Spec->updir, qw\[).+?(\].*)$/'. "\$1 $updir \$2/' $Repo/$file" ) and die "Could not fix updir for $bin in $file: $?"; ### change the name of the file from $TestBin to $bin system( "$^X -pi -e's/$TestBin/$bin/' $Repo/$file" ) and die "Could not update $file with '$bin' as name: $?"; print "done\n" if $Verbose; } else { print " $file already exists\n" if $Verbose; } ### we've may just have created a new file, it will have to ### go into the manifest push @NewFiles, $file; } ### add an entry to utils/Makefile.SH for $bin { my $file = "utils/Makefile.SH"; ### not there already? unless( `grep $bin $Repo/$file` ) { print " Adding $bin entries to $file..." if $Verbose; ### $bin appears on 4 lines in this file, so replace all 4 ### first, pl = system( "$^X -pi -e'/^pl\\s+=/ && s/(${TestBin}.PL)/". "\$1 ${bin}.PL/' $Repo/$file" ) and die "Could not add $bin to the pl = entry: $?"; ### next, plextract = system( "$^X -pi -e'/^plextract\\s+=/ " . "&& s/(${TestBin})/\$1 $bin/' $Repo/$file" ) and die "Could not add $bin to the plextract = entry: $?"; ### third, plextractexe = system( "$^X -pi -e'/^plextractexe\\s+=/ " . "&& s!(\./${TestBin})!\$1 ./$bin!' $Repo/$file" ) and die "Could not add $bin to the plextractexe = entry: $?"; ### last, the make directive $bin: system( "$^X -pi -e'/^(${TestBin}:.+)/; \$x=\$1 or next;" . "\$x =~ s/$TestBin/$bin/g;" . '$_.=$/.$x.$/;' . "' $Repo/$file" ) and die "Could not add $bin as a make directive: $?"; push @ChangedFiles, $file; print "done\n" if $Verbose; } else { print " $bin already added to $file\n" if $Verbose; } } ### add entries to win32/Makefile and win32/makefile.mk ### they contain the following lines: # ./win32/makefile.mk: ..\utils\ptardiff \ # ./win32/makefile.mk: xsubpp instmodsh prove ptar ptardiff for my $file ( qw[win32/Makefile win32/makefile.mk] ) { unless ( `grep $bin $Repo/$file` ) { print " Adding $bin entries to $file..." if $Verbose; system( "$^X -pi -e'/^(.+?utils.${TestBin}.+)/;". '$x=$1 or next;' . "\$x =~ s/$TestBin/$bin/g;" . '$_.=$x.$/;' . "' $Repo/$file" ) and die "Could not add $bin to UTILS section in $file: $?\n"; system( "$^X -pi -e's/( $TestBin)/\$1 $bin/' $Repo/$file" ) and die "Could not add $bin to $file: $?\n"; push @ChangedFiles, $file; print "done\n" if $Verbose; } else { print " $bin already added to $file\n" if $Verbose; } } ### we need some entries in a vms specific file as well.. ### except, i dont understand how it works or what it does, and it ### looks all a bit odd... so lets just print a warning... ### the entries look something like this: # ./vms/descrip_mms.template:utils4 = [.utils]enc2xs.com # [.utils]piconv.com [.utils]cpan.com [.utils]prove.com # [.utils]ptar.com [.utils]ptardiff.com [.utils]shasum.com # ./vms/descrip_mms.template:[.utils]ptardiff.com : [.utils]ptardiff.PL # $(ARCHDIR)Config.pm { my $file = 'vms/descrip_mms.template'; unless( `grep $bin $Repo/$file` ) { print $/.$/; print " WARNING! You should add entries like the following\n" . " to $file (Using $TestBin as an example)\n" . " Unfortunately I dont understand what these entries\n" . " do, so I wont change them automatically:\n\n"; print `grep -nC1 $TestBin $Repo/$file`; print $/.$/; } else { print " $bin already added to $file\n" if $Verbose; } } } } ### update the manifest { my $file = $Repo . '/MANIFEST'; my @manifest; { open my $fh, "<$file" or die "Could not open $file: $!"; @manifest = <$fh>; close $fh; } ### fill it with files from our package my %pkg_files; for ( @ModFiles ) { $pkg_files{$_} = "$_\t$ModName\n"; } for ( @TestFiles ) { $pkg_files{"$RelTopDir/$_"} = "$RelTopDir/$_\t$ModName tests\n" } for ( @BinFiles ) { $pkg_files{"$RelTopDir/$_"} = "$RelTopDir/$_\tthe ". basename($_) ." utility\n"; } for ( @Changes ) { $pkg_files{"$RelTopDir/$_"} = "$RelTopDir/$_\t$ModName change log\n"; } for ( @NewFiles ) { $pkg_files{$_} = "$_\tthe ". do { m/(.+?)\.PL$/; basename($1) } . " utility\n" } ### remove all the files that are already in the manifest; delete $pkg_files{ [split]->[0] } for @manifest; print "Adding the following entries to the MANIFEST:\n" if $Verbose; print "\t$_" for sort values %pkg_files; print $/.$/; push @manifest, values %pkg_files; { chmod 0644, $file; open my $fh, ">$file" or die "Could not open $file for writing: $!"; #print $fh sort { lc $a cmp lc $b } @manifest; ### XXX stolen from pod/buildtoc:sub do_manifest print $fh map { $_->[0] } sort { $a->[1] cmp $b->[1] || $a->[0] cmp $b->[0] } map { my $f = lc $_; $f =~ s/[^a-z0-9\s]//g; [ $_, $f ] } @manifest; close $fh; } push @ChangedFiles, 'MANIFEST'; } ### would you like us to show you a diff? if( $RunDiff ) { if ( $NoBranch ) { my $diff = $Repo; $diff =~ s/$$/patch/; ### weird RV ;( my $master = basename( $OrigRepo ); my $repo = basename( $Repo ); my $chdir = dirname( $OrigRepo ); ### the .patch file is added by an rsync from the APC ### but isn't actually in the p4 repo, so exclude it my $cmd = "cd $chdir; diff -ruN --exclude=.patch $master $repo > $diff"; print "Running: '$cmd'\n"; print "Generating diff..." if $Verbose; system( $cmd ); #and die "Could not write diff to '$diff': $?"; die "Could not write diff to '$diff'" unless -e $diff && -s _; print "done\n" if $Verbose; print "\nDiff can be applied with patch -p1 in $OrigRepo\n\n"; print " Diff written to: $diff\n\n" if $Verbose; } else { my $diff = "$Repo/$BranchName"; $diff =~ s/$$/patch/; my $cmd = "cd $Repo; git diff > $diff"; print "Running: '$cmd'\n"; print "Generating diff..." if $Verbose; system( $cmd ); #and die "Could not write diff to '$diff': $?"; die "Could not write diff to '$diff'" unless -e $diff && -s _; print "done\n" if $Verbose; print " Diff written to: $diff\n\n" if $Verbose; } } # add files to git index unless ( $NoBranch ) { chdir $Repo; system( "git add $CPV $_" ) for ( @LibFiles, @NewFiles, @ChangedFiles, map { "$RelTopDir/$_" } @TestFiles, @BinFiles, @Changes ); } # return to original directory chdir $Cwd; sub usage { my $me = basename($0); return qq[ Usage: $me -r PERL_REPO_DIR [-p PACKAGE_DIR] [-v] [-d] [-e REGEX] Options: -r Path to perl-core git repository -v Run verbosely -c File containing changelog (default 'Changes' or 'ChangeLog') -e Perl regex matching files that shouldn't be included -d Create a diff as patch file -p Path to the package to add. Defaults to cwd() -n No branching; repository is not a git repo \n]; } perl-5.12.0-RC0/Porting/podtidy0000444000175000017500000000046311325125741015152 0ustar jessejesse#!perl use strict; use warnings; use Pod::Tidy; # Reformat pod using Pod::Tidy # 72 is what fmt defaults to $Text::Wrap::columns = 72; my $filename = shift || die "Usage podtidy [filename]"; Pod::Tidy::tidy_files( files => [$filename], verbose => 1, inplace => 1, nobackup => 1, ); perl-5.12.0-RC0/Porting/config_H0000444000175000017500000042640511347250766015234 0ustar jessejesse/* This file (config_H) is a sample config.h file. If you are unable to successfully run Configure, copy this file to config.h and edit it to suit your system. */ /* * This file was produced by running the config_h.SH script, which * gets its values from config.sh, which is generally produced by * running Configure. * * Feel free to modify any of this as the need arises. Note, however, * that running config_h.SH again will wipe out any changes you've made. * For a more permanent change edit config.sh and rerun config_h.SH. * * $Id: Config_h.U 1 2006-08-24 12:32:52Z rmanfredi $ */ /* * Package name : perl5 * Source directory : . * Configuration time: Fri Oct 3 17:54:26 CEST 2008 * Configured by : merijn * Target system : linux nb09 2.6.22.18-0.2-default #1 smp 2008-06-09 13:53:20 +0200 i686 i686 i386 gnulinux */ #ifndef _config_h_ #define _config_h_ /* LOC_SED: * This symbol holds the complete pathname to the sed program. */ #define LOC_SED "/usr/bin/sed" /**/ /* HAS_ALARM: * This symbol, if defined, indicates that the alarm routine is * available. */ #define HAS_ALARM /**/ /* HAS_BCMP: * This symbol is defined if the bcmp() routine is available to * compare blocks of memory. */ #define HAS_BCMP /**/ /* HAS_BCOPY: * This symbol is defined if the bcopy() routine is available to * copy blocks of memory. */ #define HAS_BCOPY /**/ /* HAS_BZERO: * This symbol is defined if the bzero() routine is available to * set a memory block to 0. */ #define HAS_BZERO /**/ /* HAS_CHOWN: * This symbol, if defined, indicates that the chown routine is * available. */ #define HAS_CHOWN /**/ /* HAS_CHROOT: * This symbol, if defined, indicates that the chroot routine is * available. */ #define HAS_CHROOT /**/ /* HAS_CHSIZE: * This symbol, if defined, indicates that the chsize routine is available * to truncate files. You might need a -lx to get this routine. */ /*#define HAS_CHSIZE / **/ /* HAS_CRYPT: * This symbol, if defined, indicates that the crypt routine is available * to encrypt passwords and the like. */ #define HAS_CRYPT /**/ /* HAS_CTERMID: * This symbol, if defined, indicates that the ctermid routine is * available to generate filename for terminal. */ #define HAS_CTERMID /**/ /* HAS_CUSERID: * This symbol, if defined, indicates that the cuserid routine is * available to get character login names. */ #define HAS_CUSERID /**/ /* HAS_DBL_DIG: * This symbol, if defined, indicates that this system's * or defines the symbol DBL_DIG, which is the number * of significant digits in a double precision number. If this * symbol is not defined, a guess of 15 is usually pretty good. */ #define HAS_DBL_DIG /* */ /* HAS_DIFFTIME: * This symbol, if defined, indicates that the difftime routine is * available. */ #define HAS_DIFFTIME /**/ /* HAS_DLERROR: * This symbol, if defined, indicates that the dlerror routine is * available to return a string describing the last error that * occurred from a call to dlopen(), dlclose() or dlsym(). */ #define HAS_DLERROR /**/ /* SETUID_SCRIPTS_ARE_SECURE_NOW: * This symbol, if defined, indicates that the bug that prevents * setuid scripts from being secure is not present in this kernel. */ /* DOSUID: * This symbol, if defined, indicates that the C program should * check the script that it is executing for setuid/setgid bits, and * attempt to emulate setuid/setgid on systems that have disabled * setuid #! scripts because the kernel can't do it securely. * It is up to the package designer to make sure that this emulation * is done securely. Among other things, it should do an fstat on * the script it just opened to make sure it really is a setuid/setgid * script, it should make sure the arguments passed correspond exactly * to the argument on the #! line, and it should not trust any * subprocesses to which it must pass the filename rather than the * file descriptor of the script to be executed. */ /*#define SETUID_SCRIPTS_ARE_SECURE_NOW / **/ /*#define DOSUID / **/ /* HAS_DUP2: * This symbol, if defined, indicates that the dup2 routine is * available to duplicate file descriptors. */ #define HAS_DUP2 /**/ /* HAS_FCHMOD: * This symbol, if defined, indicates that the fchmod routine is available * to change mode of opened files. If unavailable, use chmod(). */ #define HAS_FCHMOD /**/ /* HAS_FCHOWN: * This symbol, if defined, indicates that the fchown routine is available * to change ownership of opened files. If unavailable, use chown(). */ #define HAS_FCHOWN /**/ /* HAS_FCNTL: * This symbol, if defined, indicates to the C program that * the fcntl() function exists. */ #define HAS_FCNTL /**/ /* HAS_FGETPOS: * This symbol, if defined, indicates that the fgetpos routine is * available to get the file position indicator, similar to ftell(). */ #define HAS_FGETPOS /**/ /* HAS_FLOCK: * This symbol, if defined, indicates that the flock routine is * available to do file locking. */ #define HAS_FLOCK /**/ /* HAS_FORK: * This symbol, if defined, indicates that the fork routine is * available. */ #define HAS_FORK /**/ /* HAS_FSETPOS: * This symbol, if defined, indicates that the fsetpos routine is * available to set the file position indicator, similar to fseek(). */ #define HAS_FSETPOS /**/ /* HAS_GETTIMEOFDAY: * This symbol, if defined, indicates that the gettimeofday() system * call is available for a sub-second accuracy clock. Usually, the file * needs to be included (see I_SYS_RESOURCE). * The type "Timeval" should be used to refer to "struct timeval". */ #define HAS_GETTIMEOFDAY /**/ #ifdef HAS_GETTIMEOFDAY #define Timeval struct timeval /* Structure used by gettimeofday() */ #endif /* HAS_GETGROUPS: * This symbol, if defined, indicates that the getgroups() routine is * available to get the list of process groups. If unavailable, multiple * groups are probably not supported. */ #define HAS_GETGROUPS /**/ /* HAS_GETLOGIN: * This symbol, if defined, indicates that the getlogin routine is * available to get the login name. */ #define HAS_GETLOGIN /**/ /* HAS_GETPGID: * This symbol, if defined, indicates to the C program that * the getpgid(pid) function is available to get the * process group id. */ #define HAS_GETPGID /**/ /* HAS_GETPGRP2: * This symbol, if defined, indicates that the getpgrp2() (as in DG/UX) * routine is available to get the current process group. */ /*#define HAS_GETPGRP2 / **/ /* HAS_GETPPID: * This symbol, if defined, indicates that the getppid routine is * available to get the parent process ID. */ #define HAS_GETPPID /**/ /* HAS_GETPRIORITY: * This symbol, if defined, indicates that the getpriority routine is * available to get a process's priority. */ #define HAS_GETPRIORITY /**/ /* HAS_INET_ATON: * This symbol, if defined, indicates to the C program that the * inet_aton() function is available to parse IP address "dotted-quad" * strings. */ #define HAS_INET_ATON /**/ /* HAS_KILLPG: * This symbol, if defined, indicates that the killpg routine is available * to kill process groups. If unavailable, you probably should use kill * with a negative process number. */ #define HAS_KILLPG /**/ /* HAS_LINK: * This symbol, if defined, indicates that the link routine is * available to create hard links. */ #define HAS_LINK /**/ /* HAS_LOCALECONV: * This symbol, if defined, indicates that the localeconv routine is * available for numeric and monetary formatting conventions. */ #define HAS_LOCALECONV /**/ /* HAS_LOCKF: * This symbol, if defined, indicates that the lockf routine is * available to do file locking. */ #define HAS_LOCKF /**/ /* HAS_LSTAT: * This symbol, if defined, indicates that the lstat routine is * available to do file stats on symbolic links. */ #define HAS_LSTAT /**/ /* HAS_MBLEN: * This symbol, if defined, indicates that the mblen routine is available * to find the number of bytes in a multibye character. */ #define HAS_MBLEN /**/ /* HAS_MBSTOWCS: * This symbol, if defined, indicates that the mbstowcs routine is * available to covert a multibyte string into a wide character string. */ #define HAS_MBSTOWCS /**/ /* HAS_MBTOWC: * This symbol, if defined, indicates that the mbtowc routine is available * to covert a multibyte to a wide character. */ #define HAS_MBTOWC /**/ /* HAS_MEMCMP: * This symbol, if defined, indicates that the memcmp routine is available * to compare blocks of memory. */ #define HAS_MEMCMP /**/ /* HAS_MEMCPY: * This symbol, if defined, indicates that the memcpy routine is available * to copy blocks of memory. */ #define HAS_MEMCPY /**/ /* HAS_MEMMOVE: * This symbol, if defined, indicates that the memmove routine is available * to copy potentially overlapping blocks of memory. This should be used * only when HAS_SAFE_BCOPY is not defined. If neither is there, roll your * own version. */ #define HAS_MEMMOVE /**/ /* HAS_MEMSET: * This symbol, if defined, indicates that the memset routine is available * to set blocks of memory. */ #define HAS_MEMSET /**/ /* HAS_MKDIR: * This symbol, if defined, indicates that the mkdir routine is available * to create directories. Otherwise you should fork off a new process to * exec /bin/mkdir. */ #define HAS_MKDIR /**/ /* HAS_MKFIFO: * This symbol, if defined, indicates that the mkfifo routine is * available to create FIFOs. Otherwise, mknod should be able to * do it for you. However, if mkfifo is there, mknod might require * super-user privileges which mkfifo will not. */ #define HAS_MKFIFO /**/ /* HAS_MKTIME: * This symbol, if defined, indicates that the mktime routine is * available. */ #define HAS_MKTIME /**/ /* HAS_MSYNC: * This symbol, if defined, indicates that the msync system call is * available to synchronize a mapped file. */ #define HAS_MSYNC /**/ /* HAS_MUNMAP: * This symbol, if defined, indicates that the munmap system call is * available to unmap a region, usually mapped by mmap(). */ #define HAS_MUNMAP /**/ /* HAS_NICE: * This symbol, if defined, indicates that the nice routine is * available. */ #define HAS_NICE /**/ /* HAS_PATHCONF: * This symbol, if defined, indicates that pathconf() is available * to determine file-system related limits and options associated * with a given filename. */ /* HAS_FPATHCONF: * This symbol, if defined, indicates that pathconf() is available * to determine file-system related limits and options associated * with a given open file descriptor. */ #define HAS_PATHCONF /**/ #define HAS_FPATHCONF /**/ /* HAS_PAUSE: * This symbol, if defined, indicates that the pause routine is * available to suspend a process until a signal is received. */ #define HAS_PAUSE /**/ /* HAS_PIPE: * This symbol, if defined, indicates that the pipe routine is * available to create an inter-process channel. */ #define HAS_PIPE /**/ /* HAS_POLL: * This symbol, if defined, indicates that the poll routine is * available to poll active file descriptors. Please check I_POLL and * I_SYS_POLL to know which header should be included as well. */ #define HAS_POLL /**/ /* HAS_READDIR: * This symbol, if defined, indicates that the readdir routine is * available to read directory entries. You may have to include * . See I_DIRENT. */ #define HAS_READDIR /**/ /* HAS_SEEKDIR: * This symbol, if defined, indicates that the seekdir routine is * available. You may have to include . See I_DIRENT. */ #define HAS_SEEKDIR /**/ /* HAS_TELLDIR: * This symbol, if defined, indicates that the telldir routine is * available. You may have to include . See I_DIRENT. */ #define HAS_TELLDIR /**/ /* HAS_REWINDDIR: * This symbol, if defined, indicates that the rewinddir routine is * available. You may have to include . See I_DIRENT. */ #define HAS_REWINDDIR /**/ /* HAS_READLINK: * This symbol, if defined, indicates that the readlink routine is * available to read the value of a symbolic link. */ #define HAS_READLINK /**/ /* HAS_RENAME: * This symbol, if defined, indicates that the rename routine is available * to rename files. Otherwise you should do the unlink(), link(), unlink() * trick. */ #define HAS_RENAME /**/ /* HAS_RMDIR: * This symbol, if defined, indicates that the rmdir routine is * available to remove directories. Otherwise you should fork off a * new process to exec /bin/rmdir. */ #define HAS_RMDIR /**/ /* HAS_SELECT: * This symbol, if defined, indicates that the select routine is * available to select active file descriptors. If the timeout field * is used, may need to be included. */ #define HAS_SELECT /**/ /* HAS_SETEGID: * This symbol, if defined, indicates that the setegid routine is available * to change the effective gid of the current program. */ #define HAS_SETEGID /**/ /* HAS_SETEUID: * This symbol, if defined, indicates that the seteuid routine is available * to change the effective uid of the current program. */ #define HAS_SETEUID /**/ /* HAS_SETGROUPS: * This symbol, if defined, indicates that the setgroups() routine is * available to set the list of process groups. If unavailable, multiple * groups are probably not supported. */ #define HAS_SETGROUPS /**/ /* HAS_SETLINEBUF: * This symbol, if defined, indicates that the setlinebuf routine is * available to change stderr or stdout from block-buffered or unbuffered * to a line-buffered mode. */ #define HAS_SETLINEBUF /**/ /* HAS_SETLOCALE: * This symbol, if defined, indicates that the setlocale routine is * available to handle locale-specific ctype implementations. */ #define HAS_SETLOCALE /**/ /* HAS_SETPGID: * This symbol, if defined, indicates that the setpgid(pid, gpid) * routine is available to set process group ID. */ #define HAS_SETPGID /**/ /* HAS_SETPGRP2: * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX) * routine is available to set the current process group. */ /*#define HAS_SETPGRP2 / **/ /* HAS_SETPRIORITY: * This symbol, if defined, indicates that the setpriority routine is * available to set a process's priority. */ #define HAS_SETPRIORITY /**/ /* HAS_SETREGID: * This symbol, if defined, indicates that the setregid routine is * available to change the real and effective gid of the current * process. */ /* HAS_SETRESGID: * This symbol, if defined, indicates that the setresgid routine is * available to change the real, effective and saved gid of the current * process. */ #define HAS_SETREGID /**/ #define HAS_SETRESGID /**/ /* HAS_SETREUID: * This symbol, if defined, indicates that the setreuid routine is * available to change the real and effective uid of the current * process. */ /* HAS_SETRESUID: * This symbol, if defined, indicates that the setresuid routine is * available to change the real, effective and saved uid of the current * process. */ #define HAS_SETREUID /**/ #define HAS_SETRESUID /**/ /* HAS_SETRGID: * This symbol, if defined, indicates that the setrgid routine is available * to change the real gid of the current program. */ /*#define HAS_SETRGID / **/ /* HAS_SETRUID: * This symbol, if defined, indicates that the setruid routine is available * to change the real uid of the current program. */ /*#define HAS_SETRUID / **/ /* HAS_SETSID: * This symbol, if defined, indicates that the setsid routine is * available to set the process group ID. */ #define HAS_SETSID /**/ /* HAS_STRCHR: * This symbol is defined to indicate that the strchr()/strrchr() * functions are available for string searching. If not, try the * index()/rindex() pair. */ /* HAS_INDEX: * This symbol is defined to indicate that the index()/rindex() * functions are available for string searching. */ #define HAS_STRCHR /**/ /*#define HAS_INDEX / **/ /* HAS_STRCOLL: * This symbol, if defined, indicates that the strcoll routine is * available to compare strings using collating information. */ #define HAS_STRCOLL /**/ /* HAS_STRTOD: * This symbol, if defined, indicates that the strtod routine is * available to provide better numeric string conversion than atof(). */ #define HAS_STRTOD /**/ /* HAS_STRTOL: * This symbol, if defined, indicates that the strtol routine is available * to provide better numeric string conversion than atoi() and friends. */ #define HAS_STRTOL /**/ /* HAS_STRXFRM: * This symbol, if defined, indicates that the strxfrm() routine is * available to transform strings. */ #define HAS_STRXFRM /**/ /* HAS_SYMLINK: * This symbol, if defined, indicates that the symlink routine is available * to create symbolic links. */ #define HAS_SYMLINK /**/ /* HAS_SYSCALL: * This symbol, if defined, indicates that the syscall routine is * available to call arbitrary system calls. If undefined, that's tough. */ #define HAS_SYSCALL /**/ /* HAS_SYSCONF: * This symbol, if defined, indicates that sysconf() is available * to determine system related limits and options. */ #define HAS_SYSCONF /**/ /* HAS_SYSTEM: * This symbol, if defined, indicates that the system routine is * available to issue a shell command. */ #define HAS_SYSTEM /**/ /* HAS_TCGETPGRP: * This symbol, if defined, indicates that the tcgetpgrp routine is * available to get foreground process group ID. */ #define HAS_TCGETPGRP /**/ /* HAS_TCSETPGRP: * This symbol, if defined, indicates that the tcsetpgrp routine is * available to set foreground process group ID. */ #define HAS_TCSETPGRP /**/ /* HAS_TRUNCATE: * This symbol, if defined, indicates that the truncate routine is * available to truncate files. */ #define HAS_TRUNCATE /**/ /* HAS_TZNAME: * This symbol, if defined, indicates that the tzname[] array is * available to access timezone names. */ #define HAS_TZNAME /**/ /* HAS_UMASK: * This symbol, if defined, indicates that the umask routine is * available to set and get the value of the file creation mask. */ #define HAS_UMASK /**/ /* HAS_USLEEP: * This symbol, if defined, indicates that the usleep routine is * available to let the process sleep on a sub-second accuracy. */ #define HAS_USLEEP /**/ /* HAS_WAIT4: * This symbol, if defined, indicates that wait4() exists. */ #define HAS_WAIT4 /**/ /* HAS_WAITPID: * This symbol, if defined, indicates that the waitpid routine is * available to wait for child process. */ #define HAS_WAITPID /**/ /* HAS_WCSTOMBS: * This symbol, if defined, indicates that the wcstombs routine is * available to convert wide character strings to multibyte strings. */ #define HAS_WCSTOMBS /**/ /* HAS_WCTOMB: * This symbol, if defined, indicates that the wctomb routine is available * to covert a wide character to a multibyte. */ #define HAS_WCTOMB /**/ /* Groups_t: * This symbol holds the type used for the second argument to * getgroups() and setgroups(). Usually, this is the same as * gidtype (gid_t) , but sometimes it isn't. * It can be int, ushort, gid_t, etc... * It may be necessary to include to get any * typedef'ed information. This is only required if you have * getgroups() or setgroups().. */ #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS) #define Groups_t gid_t /* Type for 2nd arg to [sg]etgroups() */ #endif /* I_ARPA_INET: * This symbol, if defined, indicates to the C program that it should * include to get inet_addr and friends declarations. */ #define I_ARPA_INET /**/ /* I_DBM: * This symbol, if defined, indicates that exists and should * be included. */ /* I_RPCSVC_DBM: * This symbol, if defined, indicates that exists and * should be included. */ #define I_DBM /**/ /*#define I_RPCSVC_DBM / **/ /* I_DLFCN: * This symbol, if defined, indicates that exists and should * be included. */ #define I_DLFCN /**/ /* I_FCNTL: * This manifest constant tells the C program to include . */ /*#define I_FCNTL / **/ /* I_FLOAT: * This symbol, if defined, indicates to the C program that it should * include to get definition of symbols like DBL_MAX or * DBL_MIN, i.e. machine dependent floating point values. */ #define I_FLOAT /**/ /* I_GDBM: * This symbol, if defined, indicates that exists and should * be included. */ #define I_GDBM /**/ /* I_LIMITS: * This symbol, if defined, indicates to the C program that it should * include to get definition of symbols like WORD_BIT or * LONG_MAX, i.e. machine dependant limitations. */ #define I_LIMITS /**/ /* I_LOCALE: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_LOCALE /**/ /* I_MATH: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_MATH /**/ /* I_MEMORY: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_MEMORY / **/ /* I_NETINET_IN: * This symbol, if defined, indicates to the C program that it should * include . Otherwise, you may try . */ #define I_NETINET_IN /**/ /* I_SFIO: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SFIO / **/ /* I_STDDEF: * This symbol, if defined, indicates that exists and should * be included. */ #define I_STDDEF /**/ /* I_STDLIB: * This symbol, if defined, indicates that exists and should * be included. */ #define I_STDLIB /**/ /* I_STRING: * This symbol, if defined, indicates to the C program that it should * include (USG systems) instead of (BSD systems). */ #define I_STRING /**/ /* I_SYS_DIR: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_DIR /**/ /* I_SYS_FILE: * This symbol, if defined, indicates to the C program that it should * include to get definition of R_OK and friends. */ #define I_SYS_FILE /**/ /* I_SYS_IOCTL: * This symbol, if defined, indicates that exists and should * be included. Otherwise, include or . */ /* I_SYS_SOCKIO: * This symbol, if defined, indicates the should be included * to get socket ioctl options, like SIOCATMARK. */ #define I_SYS_IOCTL /**/ /*#define I_SYS_SOCKIO / **/ /* I_SYS_NDIR: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_NDIR / **/ /* I_SYS_PARAM: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_PARAM /**/ /* I_SYS_POLL: * This symbol, if defined, indicates that the program may include * . When I_POLL is also defined, it's probably safest * to only include . */ #define I_SYS_POLL /**/ /* I_SYS_RESOURCE: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_RESOURCE /**/ /* I_SYS_SELECT: * This symbol, if defined, indicates to the C program that it should * include in order to get definition of struct timeval. */ #define I_SYS_SELECT /**/ /* I_SYS_STAT: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_STAT /**/ /* I_SYS_TIMES: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_TIMES /**/ /* I_SYS_TYPES: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_TYPES /**/ /* I_SYS_UN: * This symbol, if defined, indicates to the C program that it should * include to get UNIX domain socket definitions. */ #define I_SYS_UN /**/ /* I_SYS_WAIT: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_WAIT /**/ /* I_TERMIO: * This symbol, if defined, indicates that the program should include * rather than . There are also differences in * the ioctl() calls that depend on the value of this symbol. */ /* I_TERMIOS: * This symbol, if defined, indicates that the program should include * the POSIX termios.h rather than sgtty.h or termio.h. * There are also differences in the ioctl() calls that depend on the * value of this symbol. */ /* I_SGTTY: * This symbol, if defined, indicates that the program should include * rather than . There are also differences in * the ioctl() calls that depend on the value of this symbol. */ /*#define I_TERMIO / **/ #define I_TERMIOS /**/ /*#define I_SGTTY / **/ /* I_UNISTD: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_UNISTD /**/ /* I_UTIME: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_UTIME /**/ /* I_VALUES: * This symbol, if defined, indicates to the C program that it should * include to get definition of symbols like MINFLOAT or * MAXLONG, i.e. machine dependant limitations. Probably, you * should use instead, if it is available. */ #define I_VALUES /**/ /* I_VFORK: * This symbol, if defined, indicates to the C program that it should * include vfork.h. */ /*#define I_VFORK / **/ /* INTSIZE: * This symbol contains the value of sizeof(int) so that the C * preprocessor can make decisions based on it. */ /* LONGSIZE: * This symbol contains the value of sizeof(long) so that the C * preprocessor can make decisions based on it. */ /* SHORTSIZE: * This symbol contains the value of sizeof(short) so that the C * preprocessor can make decisions based on it. */ #define INTSIZE 4 /**/ #define LONGSIZE 4 /**/ #define SHORTSIZE 2 /**/ /* MULTIARCH: * This symbol, if defined, signifies that the build * process will produce some binary files that are going to be * used in a cross-platform environment. This is the case for * example with the NeXT "fat" binaries that contain executables * for several CPUs. */ /*#define MULTIARCH / **/ /* HAS_QUAD: * This symbol, if defined, tells that there's a 64-bit integer type, * Quad_t, and its unsigned counterpar, Uquad_t. QUADKIND will be one * of QUAD_IS_INT, QUAD_IS_LONG, QUAD_IS_LONG_LONG, or QUAD_IS_INT64_T. */ #define HAS_QUAD /**/ #ifdef HAS_QUAD # define Quad_t long long /**/ # define Uquad_t unsigned long long /**/ # define QUADKIND 3 /**/ # define QUAD_IS_INT 1 # define QUAD_IS_LONG 2 # define QUAD_IS_LONG_LONG 3 # define QUAD_IS_INT64_T 4 #endif /* OSNAME: * This symbol contains the name of the operating system, as determined * by Configure. You shouldn't rely on it too much; the specific * feature tests from Configure are generally more reliable. */ /* OSVERS: * This symbol contains the version of the operating system, as determined * by Configure. You shouldn't rely on it too much; the specific * feature tests from Configure are generally more reliable. */ #define OSNAME "linux" /**/ #define OSVERS "2.6.22.18-0.2-default" /**/ /* ARCHLIB: * This variable, if defined, holds the name of the directory in * which the user wants to put architecture-dependent public * library files for perl5. It is most often a local directory * such as /usr/local/lib. Programs using this variable must be * prepared to deal with filename expansion. If ARCHLIB is the * same as PRIVLIB, it is not defined, since presumably the * program already searches PRIVLIB. */ /* ARCHLIB_EXP: * This symbol contains the ~name expanded version of ARCHLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ #define ARCHLIB "/pro/lib/perl5/5.12.0/i686-linux-64int" /**/ #define ARCHLIB_EXP "/pro/lib/perl5/5.12.0/i686-linux-64int" /**/ /* ARCHNAME: * This symbol holds a string representing the architecture name. * It may be used to construct an architecture-dependant pathname * where library files may be held under a private library, for * instance. */ #define ARCHNAME "i686-linux-64int" /**/ /* BIN: * This symbol holds the path of the bin directory where the package will * be installed. Program must be prepared to deal with ~name substitution. */ /* BIN_EXP: * This symbol is the filename expanded version of the BIN symbol, for * programs that do not want to deal with that at run-time. */ /* PERL_RELOCATABLE_INC: * This symbol, if defined, indicates that we'd like to relocate entries * in @INC at run time based on the location of the perl binary. */ #define BIN "/pro/bin" /**/ #define BIN_EXP "/pro/bin" /**/ #define PERL_RELOCATABLE_INC "undef" /**/ /* CAT2: * This macro concatenates 2 tokens together. */ /* STRINGIFY: * This macro surrounds its token with double quotes. */ #if 42 == 1 #define CAT2(a,b) a/**/b #define STRINGIFY(a) "a" #endif #if 42 == 42 #define PeRl_CaTiFy(a, b) a ## b #define PeRl_StGiFy(a) #a #define CAT2(a,b) PeRl_CaTiFy(a,b) #define StGiFy(a) PeRl_StGiFy(a) #define STRINGIFY(a) PeRl_StGiFy(a) #endif #if 42 != 1 && 42 != 42 #include "Bletch: How does this C preprocessor concatenate tokens?" #endif /* CPPSTDIN: * This symbol contains the first part of the string which will invoke * the C preprocessor on the standard input and produce to standard * output. Typical value of "cc -E" or "/lib/cpp", but it can also * call a wrapper. See CPPRUN. */ /* CPPMINUS: * This symbol contains the second part of the string which will invoke * the C preprocessor on the standard input and produce to standard * output. This symbol will have the value "-" if CPPSTDIN needs a minus * to specify standard input, otherwise the value is "". */ /* CPPRUN: * This symbol contains the string which will invoke a C preprocessor on * the standard input and produce to standard output. It needs to end * with CPPLAST, after all other preprocessor flags have been specified. * The main difference with CPPSTDIN is that this program will never be a * pointer to a shell wrapper, i.e. it will be empty if no preprocessor is * available directly to the user. Note that it may well be different from * the preprocessor used to compile the C program. */ /* CPPLAST: * This symbol is intended to be used along with CPPRUN in the same manner * symbol CPPMINUS is used with CPPSTDIN. It contains either "-" or "". */ #define CPPSTDIN "cc -E" #define CPPMINUS "-" #define CPPRUN "cc -E" #define CPPLAST "-" /* HAS_ACCESS: * This manifest constant lets the C program know that the access() * system call is available to check for accessibility using real UID/GID. * (always present on UNIX.) */ #define HAS_ACCESS /**/ /* HAS_ACCESSX: * This symbol, if defined, indicates that the accessx routine is * available to do extended access checks. */ /*#define HAS_ACCESSX / **/ /* HAS_ASCTIME_R: * This symbol, if defined, indicates that the asctime_r routine * is available to asctime re-entrantly. */ /* ASCTIME_R_PROTO: * This symbol encodes the prototype of asctime_r. * It is zero if d_asctime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_asctime_r * is defined. */ /*#define HAS_ASCTIME_R / **/ #define ASCTIME_R_PROTO 0 /**/ /* HASATTRIBUTE_FORMAT: * Can we handle GCC attribute for checking printf-style formats */ /* PRINTF_FORMAT_NULL_OK: * Allows __printf__ format to be null when checking printf-style */ /* HASATTRIBUTE_MALLOC: * Can we handle GCC attribute for malloc-style functions. */ /* HASATTRIBUTE_NONNULL: * Can we handle GCC attribute for nonnull function parms. */ /* HASATTRIBUTE_NORETURN: * Can we handle GCC attribute for functions that do not return */ /* HASATTRIBUTE_PURE: * Can we handle GCC attribute for pure functions */ /* HASATTRIBUTE_UNUSED: * Can we handle GCC attribute for unused variables and arguments */ /* HASATTRIBUTE_WARN_UNUSED_RESULT: * Can we handle GCC attribute for warning on unused results */ #define HASATTRIBUTE_FORMAT /**/ #define PRINTF_FORMAT_NULL_OK /**/ #define HASATTRIBUTE_NORETURN /**/ #define HASATTRIBUTE_MALLOC /**/ #define HASATTRIBUTE_NONNULL /**/ #define HASATTRIBUTE_PURE /**/ #define HASATTRIBUTE_UNUSED /**/ #define HASATTRIBUTE_WARN_UNUSED_RESULT /**/ /* HASCONST: * This symbol, if defined, indicates that this C compiler knows about * the const type. There is no need to actually test for that symbol * within your programs. The mere use of the "const" keyword will * trigger the necessary tests. */ #define HASCONST /**/ #ifndef HASCONST #define const #endif /* HAS_CRYPT_R: * This symbol, if defined, indicates that the crypt_r routine * is available to crypt re-entrantly. */ /* CRYPT_R_PROTO: * This symbol encodes the prototype of crypt_r. * It is zero if d_crypt_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_crypt_r * is defined. */ /*#define HAS_CRYPT_R / **/ #define CRYPT_R_PROTO 0 /**/ /* HAS_CSH: * This symbol, if defined, indicates that the C-shell exists. */ /* CSH: * This symbol, if defined, contains the full pathname of csh. */ #define HAS_CSH /**/ #ifdef HAS_CSH #define CSH "/usr/bin/tcsh" /**/ #endif /* HAS_CTERMID_R: * This symbol, if defined, indicates that the ctermid_r routine * is available to ctermid re-entrantly. */ /* CTERMID_R_PROTO: * This symbol encodes the prototype of ctermid_r. * It is zero if d_ctermid_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ctermid_r * is defined. */ /*#define HAS_CTERMID_R / **/ #define CTERMID_R_PROTO 0 /**/ /* HAS_CTIME_R: * This symbol, if defined, indicates that the ctime_r routine * is available to ctime re-entrantly. */ /* CTIME_R_PROTO: * This symbol encodes the prototype of ctime_r. * It is zero if d_ctime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ctime_r * is defined. */ /*#define HAS_CTIME_R / **/ #define CTIME_R_PROTO 0 /**/ /* HAS_DRAND48_R: * This symbol, if defined, indicates that the drand48_r routine * is available to drand48 re-entrantly. */ /* DRAND48_R_PROTO: * This symbol encodes the prototype of drand48_r. * It is zero if d_drand48_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_drand48_r * is defined. */ /*#define HAS_DRAND48_R / **/ #define DRAND48_R_PROTO 0 /**/ /* HAS_DRAND48_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the drand48() function. Otherwise, it is up * to the program to supply one. A good guess is * extern double drand48(void); */ #define HAS_DRAND48_PROTO /**/ /* HAS_EACCESS: * This symbol, if defined, indicates that the eaccess routine is * available to do extended access checks. */ #define HAS_EACCESS /**/ /* HAS_ENDGRENT: * This symbol, if defined, indicates that the getgrent routine is * available for finalizing sequential access of the group database. */ #define HAS_ENDGRENT /**/ /* HAS_ENDGRENT_R: * This symbol, if defined, indicates that the endgrent_r routine * is available to endgrent re-entrantly. */ /* ENDGRENT_R_PROTO: * This symbol encodes the prototype of endgrent_r. * It is zero if d_endgrent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endgrent_r * is defined. */ /*#define HAS_ENDGRENT_R / **/ #define ENDGRENT_R_PROTO 0 /**/ /* HAS_ENDHOSTENT: * This symbol, if defined, indicates that the endhostent() routine is * available to close whatever was being used for host queries. */ #define HAS_ENDHOSTENT /**/ /* HAS_ENDHOSTENT_R: * This symbol, if defined, indicates that the endhostent_r routine * is available to endhostent re-entrantly. */ /* ENDHOSTENT_R_PROTO: * This symbol encodes the prototype of endhostent_r. * It is zero if d_endhostent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endhostent_r * is defined. */ /*#define HAS_ENDHOSTENT_R / **/ #define ENDHOSTENT_R_PROTO 0 /**/ /* HAS_ENDNETENT: * This symbol, if defined, indicates that the endnetent() routine is * available to close whatever was being used for network queries. */ #define HAS_ENDNETENT /**/ /* HAS_ENDNETENT_R: * This symbol, if defined, indicates that the endnetent_r routine * is available to endnetent re-entrantly. */ /* ENDNETENT_R_PROTO: * This symbol encodes the prototype of endnetent_r. * It is zero if d_endnetent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endnetent_r * is defined. */ /*#define HAS_ENDNETENT_R / **/ #define ENDNETENT_R_PROTO 0 /**/ /* HAS_ENDPROTOENT: * This symbol, if defined, indicates that the endprotoent() routine is * available to close whatever was being used for protocol queries. */ #define HAS_ENDPROTOENT /**/ /* HAS_ENDPROTOENT_R: * This symbol, if defined, indicates that the endprotoent_r routine * is available to endprotoent re-entrantly. */ /* ENDPROTOENT_R_PROTO: * This symbol encodes the prototype of endprotoent_r. * It is zero if d_endprotoent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endprotoent_r * is defined. */ /*#define HAS_ENDPROTOENT_R / **/ #define ENDPROTOENT_R_PROTO 0 /**/ /* HAS_ENDPWENT: * This symbol, if defined, indicates that the getgrent routine is * available for finalizing sequential access of the passwd database. */ #define HAS_ENDPWENT /**/ /* HAS_ENDPWENT_R: * This symbol, if defined, indicates that the endpwent_r routine * is available to endpwent re-entrantly. */ /* ENDPWENT_R_PROTO: * This symbol encodes the prototype of endpwent_r. * It is zero if d_endpwent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endpwent_r * is defined. */ /*#define HAS_ENDPWENT_R / **/ #define ENDPWENT_R_PROTO 0 /**/ /* HAS_ENDSERVENT: * This symbol, if defined, indicates that the endservent() routine is * available to close whatever was being used for service queries. */ #define HAS_ENDSERVENT /**/ /* HAS_ENDSERVENT_R: * This symbol, if defined, indicates that the endservent_r routine * is available to endservent re-entrantly. */ /* ENDSERVENT_R_PROTO: * This symbol encodes the prototype of endservent_r. * It is zero if d_endservent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endservent_r * is defined. */ /*#define HAS_ENDSERVENT_R / **/ #define ENDSERVENT_R_PROTO 0 /**/ /* FLEXFILENAMES: * This symbol, if defined, indicates that the system supports filenames * longer than 14 characters. */ #define FLEXFILENAMES /**/ /* HAS_GETGRENT: * This symbol, if defined, indicates that the getgrent routine is * available for sequential access of the group database. */ #define HAS_GETGRENT /**/ /* HAS_GETGRENT_R: * This symbol, if defined, indicates that the getgrent_r routine * is available to getgrent re-entrantly. */ /* GETGRENT_R_PROTO: * This symbol encodes the prototype of getgrent_r. * It is zero if d_getgrent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrent_r * is defined. */ /*#define HAS_GETGRENT_R / **/ #define GETGRENT_R_PROTO 0 /**/ /* HAS_GETGRGID_R: * This symbol, if defined, indicates that the getgrgid_r routine * is available to getgrgid re-entrantly. */ /* GETGRGID_R_PROTO: * This symbol encodes the prototype of getgrgid_r. * It is zero if d_getgrgid_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrgid_r * is defined. */ /*#define HAS_GETGRGID_R / **/ #define GETGRGID_R_PROTO 0 /**/ /* HAS_GETGRNAM_R: * This symbol, if defined, indicates that the getgrnam_r routine * is available to getgrnam re-entrantly. */ /* GETGRNAM_R_PROTO: * This symbol encodes the prototype of getgrnam_r. * It is zero if d_getgrnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrnam_r * is defined. */ /*#define HAS_GETGRNAM_R / **/ #define GETGRNAM_R_PROTO 0 /**/ /* HAS_GETHOSTBYADDR: * This symbol, if defined, indicates that the gethostbyaddr() routine is * available to look up hosts by their IP addresses. */ #define HAS_GETHOSTBYADDR /**/ /* HAS_GETHOSTBYNAME: * This symbol, if defined, indicates that the gethostbyname() routine is * available to look up host names in some data base or other. */ #define HAS_GETHOSTBYNAME /**/ /* HAS_GETHOSTENT: * This symbol, if defined, indicates that the gethostent() routine is * available to look up host names in some data base or another. */ #define HAS_GETHOSTENT /**/ /* HAS_GETHOSTNAME: * This symbol, if defined, indicates that the C program may use the * gethostname() routine to derive the host name. See also HAS_UNAME * and PHOSTNAME. */ /* HAS_UNAME: * This symbol, if defined, indicates that the C program may use the * uname() routine to derive the host name. See also HAS_GETHOSTNAME * and PHOSTNAME. */ /* PHOSTNAME: * This symbol, if defined, indicates the command to feed to the * popen() routine to derive the host name. See also HAS_GETHOSTNAME * and HAS_UNAME. Note that the command uses a fully qualified path, * so that it is safe even if used by a process with super-user * privileges. */ /* HAS_PHOSTNAME: * This symbol, if defined, indicates that the C program may use the * contents of PHOSTNAME as a command to feed to the popen() routine * to derive the host name. */ #define HAS_GETHOSTNAME /**/ #define HAS_UNAME /**/ /*#define HAS_PHOSTNAME / **/ #ifdef HAS_PHOSTNAME #define PHOSTNAME "/bin/hostname" /* How to get the host name */ #endif /* HAS_GETHOSTBYADDR_R: * This symbol, if defined, indicates that the gethostbyaddr_r routine * is available to gethostbyaddr re-entrantly. */ /* GETHOSTBYADDR_R_PROTO: * This symbol encodes the prototype of gethostbyaddr_r. * It is zero if d_gethostbyaddr_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostbyaddr_r * is defined. */ /*#define HAS_GETHOSTBYADDR_R / **/ #define GETHOSTBYADDR_R_PROTO 0 /**/ /* HAS_GETHOSTBYNAME_R: * This symbol, if defined, indicates that the gethostbyname_r routine * is available to gethostbyname re-entrantly. */ /* GETHOSTBYNAME_R_PROTO: * This symbol encodes the prototype of gethostbyname_r. * It is zero if d_gethostbyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostbyname_r * is defined. */ /*#define HAS_GETHOSTBYNAME_R / **/ #define GETHOSTBYNAME_R_PROTO 0 /**/ /* HAS_GETHOSTENT_R: * This symbol, if defined, indicates that the gethostent_r routine * is available to gethostent re-entrantly. */ /* GETHOSTENT_R_PROTO: * This symbol encodes the prototype of gethostent_r. * It is zero if d_gethostent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostent_r * is defined. */ /*#define HAS_GETHOSTENT_R / **/ #define GETHOSTENT_R_PROTO 0 /**/ /* HAS_GETHOST_PROTOS: * This symbol, if defined, indicates that includes * prototypes for gethostent(), gethostbyname(), and * gethostbyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ #define HAS_GETHOST_PROTOS /**/ /* HAS_GETLOGIN_R: * This symbol, if defined, indicates that the getlogin_r routine * is available to getlogin re-entrantly. */ /* GETLOGIN_R_PROTO: * This symbol encodes the prototype of getlogin_r. * It is zero if d_getlogin_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getlogin_r * is defined. */ /*#define HAS_GETLOGIN_R / **/ #define GETLOGIN_R_PROTO 0 /**/ /* HAS_GETNETBYADDR: * This symbol, if defined, indicates that the getnetbyaddr() routine is * available to look up networks by their IP addresses. */ #define HAS_GETNETBYADDR /**/ /* HAS_GETNETBYNAME: * This symbol, if defined, indicates that the getnetbyname() routine is * available to look up networks by their names. */ #define HAS_GETNETBYNAME /**/ /* HAS_GETNETENT: * This symbol, if defined, indicates that the getnetent() routine is * available to look up network names in some data base or another. */ #define HAS_GETNETENT /**/ /* HAS_GETNETBYADDR_R: * This symbol, if defined, indicates that the getnetbyaddr_r routine * is available to getnetbyaddr re-entrantly. */ /* GETNETBYADDR_R_PROTO: * This symbol encodes the prototype of getnetbyaddr_r. * It is zero if d_getnetbyaddr_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetbyaddr_r * is defined. */ /*#define HAS_GETNETBYADDR_R / **/ #define GETNETBYADDR_R_PROTO 0 /**/ /* HAS_GETNETBYNAME_R: * This symbol, if defined, indicates that the getnetbyname_r routine * is available to getnetbyname re-entrantly. */ /* GETNETBYNAME_R_PROTO: * This symbol encodes the prototype of getnetbyname_r. * It is zero if d_getnetbyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetbyname_r * is defined. */ /*#define HAS_GETNETBYNAME_R / **/ #define GETNETBYNAME_R_PROTO 0 /**/ /* HAS_GETNETENT_R: * This symbol, if defined, indicates that the getnetent_r routine * is available to getnetent re-entrantly. */ /* GETNETENT_R_PROTO: * This symbol encodes the prototype of getnetent_r. * It is zero if d_getnetent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetent_r * is defined. */ /*#define HAS_GETNETENT_R / **/ #define GETNETENT_R_PROTO 0 /**/ /* HAS_GETNET_PROTOS: * This symbol, if defined, indicates that includes * prototypes for getnetent(), getnetbyname(), and * getnetbyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ #define HAS_GETNET_PROTOS /**/ /* HAS_GETPROTOENT: * This symbol, if defined, indicates that the getprotoent() routine is * available to look up protocols in some data base or another. */ #define HAS_GETPROTOENT /**/ /* HAS_GETPGRP: * This symbol, if defined, indicates that the getpgrp routine is * available to get the current process group. */ /* USE_BSD_GETPGRP: * This symbol, if defined, indicates that getpgrp needs one * arguments whereas USG one needs none. */ #define HAS_GETPGRP /**/ /*#define USE_BSD_GETPGRP / **/ /* HAS_GETPROTOBYNAME: * This symbol, if defined, indicates that the getprotobyname() * routine is available to look up protocols by their name. */ /* HAS_GETPROTOBYNUMBER: * This symbol, if defined, indicates that the getprotobynumber() * routine is available to look up protocols by their number. */ #define HAS_GETPROTOBYNAME /**/ #define HAS_GETPROTOBYNUMBER /**/ /* HAS_GETPROTOBYNAME_R: * This symbol, if defined, indicates that the getprotobyname_r routine * is available to getprotobyname re-entrantly. */ /* GETPROTOBYNAME_R_PROTO: * This symbol encodes the prototype of getprotobyname_r. * It is zero if d_getprotobyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotobyname_r * is defined. */ /*#define HAS_GETPROTOBYNAME_R / **/ #define GETPROTOBYNAME_R_PROTO 0 /**/ /* HAS_GETPROTOBYNUMBER_R: * This symbol, if defined, indicates that the getprotobynumber_r routine * is available to getprotobynumber re-entrantly. */ /* GETPROTOBYNUMBER_R_PROTO: * This symbol encodes the prototype of getprotobynumber_r. * It is zero if d_getprotobynumber_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotobynumber_r * is defined. */ /*#define HAS_GETPROTOBYNUMBER_R / **/ #define GETPROTOBYNUMBER_R_PROTO 0 /**/ /* HAS_GETPROTOENT_R: * This symbol, if defined, indicates that the getprotoent_r routine * is available to getprotoent re-entrantly. */ /* GETPROTOENT_R_PROTO: * This symbol encodes the prototype of getprotoent_r. * It is zero if d_getprotoent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotoent_r * is defined. */ /*#define HAS_GETPROTOENT_R / **/ #define GETPROTOENT_R_PROTO 0 /**/ /* HAS_GETPROTO_PROTOS: * This symbol, if defined, indicates that includes * prototypes for getprotoent(), getprotobyname(), and * getprotobyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ #define HAS_GETPROTO_PROTOS /**/ /* HAS_GETPWENT: * This symbol, if defined, indicates that the getpwent routine is * available for sequential access of the passwd database. * If this is not available, the older getpw() function may be available. */ #define HAS_GETPWENT /**/ /* HAS_GETPWENT_R: * This symbol, if defined, indicates that the getpwent_r routine * is available to getpwent re-entrantly. */ /* GETPWENT_R_PROTO: * This symbol encodes the prototype of getpwent_r. * It is zero if d_getpwent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwent_r * is defined. */ /*#define HAS_GETPWENT_R / **/ #define GETPWENT_R_PROTO 0 /**/ /* HAS_GETPWNAM_R: * This symbol, if defined, indicates that the getpwnam_r routine * is available to getpwnam re-entrantly. */ /* GETPWNAM_R_PROTO: * This symbol encodes the prototype of getpwnam_r. * It is zero if d_getpwnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwnam_r * is defined. */ /*#define HAS_GETPWNAM_R / **/ #define GETPWNAM_R_PROTO 0 /**/ /* HAS_GETPWUID_R: * This symbol, if defined, indicates that the getpwuid_r routine * is available to getpwuid re-entrantly. */ /* GETPWUID_R_PROTO: * This symbol encodes the prototype of getpwuid_r. * It is zero if d_getpwuid_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwuid_r * is defined. */ /*#define HAS_GETPWUID_R / **/ #define GETPWUID_R_PROTO 0 /**/ /* HAS_GETSERVENT: * This symbol, if defined, indicates that the getservent() routine is * available to look up network services in some data base or another. */ #define HAS_GETSERVENT /**/ /* HAS_GETSERVBYNAME_R: * This symbol, if defined, indicates that the getservbyname_r routine * is available to getservbyname re-entrantly. */ /* GETSERVBYNAME_R_PROTO: * This symbol encodes the prototype of getservbyname_r. * It is zero if d_getservbyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservbyname_r * is defined. */ /*#define HAS_GETSERVBYNAME_R / **/ #define GETSERVBYNAME_R_PROTO 0 /**/ /* HAS_GETSERVBYPORT_R: * This symbol, if defined, indicates that the getservbyport_r routine * is available to getservbyport re-entrantly. */ /* GETSERVBYPORT_R_PROTO: * This symbol encodes the prototype of getservbyport_r. * It is zero if d_getservbyport_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservbyport_r * is defined. */ /*#define HAS_GETSERVBYPORT_R / **/ #define GETSERVBYPORT_R_PROTO 0 /**/ /* HAS_GETSERVENT_R: * This symbol, if defined, indicates that the getservent_r routine * is available to getservent re-entrantly. */ /* GETSERVENT_R_PROTO: * This symbol encodes the prototype of getservent_r. * It is zero if d_getservent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservent_r * is defined. */ /*#define HAS_GETSERVENT_R / **/ #define GETSERVENT_R_PROTO 0 /**/ /* HAS_GETSERV_PROTOS: * This symbol, if defined, indicates that includes * prototypes for getservent(), getservbyname(), and * getservbyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ #define HAS_GETSERV_PROTOS /**/ /* HAS_GETSPNAM_R: * This symbol, if defined, indicates that the getspnam_r routine * is available to getspnam re-entrantly. */ /* GETSPNAM_R_PROTO: * This symbol encodes the prototype of getspnam_r. * It is zero if d_getspnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getspnam_r * is defined. */ /*#define HAS_GETSPNAM_R / **/ #define GETSPNAM_R_PROTO 0 /**/ /* HAS_GETSERVBYNAME: * This symbol, if defined, indicates that the getservbyname() * routine is available to look up services by their name. */ /* HAS_GETSERVBYPORT: * This symbol, if defined, indicates that the getservbyport() * routine is available to look up services by their port. */ #define HAS_GETSERVBYNAME /**/ #define HAS_GETSERVBYPORT /**/ /* HAS_GMTIME_R: * This symbol, if defined, indicates that the gmtime_r routine * is available to gmtime re-entrantly. */ /* GMTIME_R_PROTO: * This symbol encodes the prototype of gmtime_r. * It is zero if d_gmtime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gmtime_r * is defined. */ /*#define HAS_GMTIME_R / **/ #define GMTIME_R_PROTO 0 /**/ /* HAS_HTONL: * This symbol, if defined, indicates that the htonl() routine (and * friends htons() ntohl() ntohs()) are available to do network * order byte swapping. */ /* HAS_HTONS: * This symbol, if defined, indicates that the htons() routine (and * friends htonl() ntohl() ntohs()) are available to do network * order byte swapping. */ /* HAS_NTOHL: * This symbol, if defined, indicates that the ntohl() routine (and * friends htonl() htons() ntohs()) are available to do network * order byte swapping. */ /* HAS_NTOHS: * This symbol, if defined, indicates that the ntohs() routine (and * friends htonl() htons() ntohl()) are available to do network * order byte swapping. */ #define HAS_HTONL /**/ #define HAS_HTONS /**/ #define HAS_NTOHL /**/ #define HAS_NTOHS /**/ /* HAS_LOCALTIME_R: * This symbol, if defined, indicates that the localtime_r routine * is available to localtime re-entrantly. */ /* LOCALTIME_R_NEEDS_TZSET: * Many libc's localtime_r implementations do not call tzset, * making them differ from localtime(), and making timezone * changes using $ENV{TZ} without explicitly calling tzset * impossible. This symbol makes us call tzset before localtime_r */ /*#define LOCALTIME_R_NEEDS_TZSET / **/ #ifdef LOCALTIME_R_NEEDS_TZSET #define L_R_TZSET tzset(), #else #define L_R_TZSET #endif /* LOCALTIME_R_PROTO: * This symbol encodes the prototype of localtime_r. * It is zero if d_localtime_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_localtime_r * is defined. */ /*#define HAS_LOCALTIME_R / **/ #define LOCALTIME_R_PROTO 0 /**/ /* HAS_LONG_DOUBLE: * This symbol will be defined if the C compiler supports long * doubles. */ /* LONG_DOUBLESIZE: * This symbol contains the size of a long double, so that the * C preprocessor can make decisions based on it. It is only * defined if the system supports long doubles. */ #define HAS_LONG_DOUBLE /**/ #ifdef HAS_LONG_DOUBLE #define LONG_DOUBLESIZE 12 /**/ #endif /* HAS_LONG_LONG: * This symbol will be defined if the C compiler supports long long. */ /* LONGLONGSIZE: * This symbol contains the size of a long long, so that the * C preprocessor can make decisions based on it. It is only * defined if the system supports long long. */ #define HAS_LONG_LONG /**/ #ifdef HAS_LONG_LONG #define LONGLONGSIZE 8 /**/ #endif /* HAS_LSEEK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the lseek() function. Otherwise, it is up * to the program to supply one. A good guess is * extern off_t lseek(int, off_t, int); */ #define HAS_LSEEK_PROTO /**/ /* HAS_MEMCHR: * This symbol, if defined, indicates that the memchr routine is available * to locate characters within a C string. */ #define HAS_MEMCHR /**/ /* HAS_MKSTEMP: * This symbol, if defined, indicates that the mkstemp routine is * available to exclusively create and open a uniquely named * temporary file. */ #define HAS_MKSTEMP /**/ /* HAS_MMAP: * This symbol, if defined, indicates that the mmap system call is * available to map a file into memory. */ /* Mmap_t: * This symbol holds the return type of the mmap() system call * (and simultaneously the type of the first argument). * Usually set to 'void *' or 'caddr_t'. */ #define HAS_MMAP /**/ #define Mmap_t void * /**/ /* HAS_MSG: * This symbol, if defined, indicates that the entire msg*(2) library is * supported (IPC mechanism based on message queues). */ #define HAS_MSG /**/ /* OLD_PTHREAD_CREATE_JOINABLE: * This symbol, if defined, indicates how to create pthread * in joinable (aka undetached) state. NOTE: not defined * if pthread.h already has defined PTHREAD_CREATE_JOINABLE * (the new version of the constant). * If defined, known values are PTHREAD_CREATE_UNDETACHED * and __UNDETACHED. */ /*#define OLD_PTHREAD_CREATE_JOINABLE / **/ /* HAS_PTHREAD_ATFORK: * This symbol, if defined, indicates that the pthread_atfork routine * is available to setup fork handlers. */ /*#define HAS_PTHREAD_ATFORK / **/ /* HAS_PTHREAD_YIELD: * This symbol, if defined, indicates that the pthread_yield * routine is available to yield the execution of the current * thread. sched_yield is preferable to pthread_yield. */ /* SCHED_YIELD: * This symbol defines the way to yield the execution of * the current thread. Known ways are sched_yield, * pthread_yield, and pthread_yield with NULL. */ /* HAS_SCHED_YIELD: * This symbol, if defined, indicates that the sched_yield * routine is available to yield the execution of the current * thread. sched_yield is preferable to pthread_yield. */ #define HAS_PTHREAD_YIELD /**/ #define SCHED_YIELD sched_yield() /**/ #define HAS_SCHED_YIELD /**/ /* HAS_RANDOM_R: * This symbol, if defined, indicates that the random_r routine * is available to random re-entrantly. */ /* RANDOM_R_PROTO: * This symbol encodes the prototype of random_r. * It is zero if d_random_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_random_r * is defined. */ /*#define HAS_RANDOM_R / **/ #define RANDOM_R_PROTO 0 /**/ /* HAS_READDIR64_R: * This symbol, if defined, indicates that the readdir64_r routine * is available to readdir64 re-entrantly. */ /* READDIR64_R_PROTO: * This symbol encodes the prototype of readdir64_r. * It is zero if d_readdir64_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_readdir64_r * is defined. */ /*#define HAS_READDIR64_R / **/ #define READDIR64_R_PROTO 0 /**/ /* HAS_READDIR_R: * This symbol, if defined, indicates that the readdir_r routine * is available to readdir re-entrantly. */ /* READDIR_R_PROTO: * This symbol encodes the prototype of readdir_r. * It is zero if d_readdir_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_readdir_r * is defined. */ /*#define HAS_READDIR_R / **/ #define READDIR_R_PROTO 0 /**/ /* HAS_SEM: * This symbol, if defined, indicates that the entire sem*(2) library is * supported. */ #define HAS_SEM /**/ /* HAS_SETGRENT: * This symbol, if defined, indicates that the setgrent routine is * available for initializing sequential access of the group database. */ #define HAS_SETGRENT /**/ /* HAS_SETGRENT_R: * This symbol, if defined, indicates that the setgrent_r routine * is available to setgrent re-entrantly. */ /* SETGRENT_R_PROTO: * This symbol encodes the prototype of setgrent_r. * It is zero if d_setgrent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setgrent_r * is defined. */ /*#define HAS_SETGRENT_R / **/ #define SETGRENT_R_PROTO 0 /**/ /* HAS_SETHOSTENT: * This symbol, if defined, indicates that the sethostent() routine is * available. */ #define HAS_SETHOSTENT /**/ /* HAS_SETHOSTENT_R: * This symbol, if defined, indicates that the sethostent_r routine * is available to sethostent re-entrantly. */ /* SETHOSTENT_R_PROTO: * This symbol encodes the prototype of sethostent_r. * It is zero if d_sethostent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_sethostent_r * is defined. */ /*#define HAS_SETHOSTENT_R / **/ #define SETHOSTENT_R_PROTO 0 /**/ /* HAS_SETLOCALE_R: * This symbol, if defined, indicates that the setlocale_r routine * is available to setlocale re-entrantly. */ /* SETLOCALE_R_PROTO: * This symbol encodes the prototype of setlocale_r. * It is zero if d_setlocale_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setlocale_r * is defined. */ /*#define HAS_SETLOCALE_R / **/ #define SETLOCALE_R_PROTO 0 /**/ /* HAS_SETNETENT: * This symbol, if defined, indicates that the setnetent() routine is * available. */ #define HAS_SETNETENT /**/ /* HAS_SETNETENT_R: * This symbol, if defined, indicates that the setnetent_r routine * is available to setnetent re-entrantly. */ /* SETNETENT_R_PROTO: * This symbol encodes the prototype of setnetent_r. * It is zero if d_setnetent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setnetent_r * is defined. */ /*#define HAS_SETNETENT_R / **/ #define SETNETENT_R_PROTO 0 /**/ /* HAS_SETPROTOENT: * This symbol, if defined, indicates that the setprotoent() routine is * available. */ #define HAS_SETPROTOENT /**/ /* HAS_SETPGRP: * This symbol, if defined, indicates that the setpgrp routine is * available to set the current process group. */ /* USE_BSD_SETPGRP: * This symbol, if defined, indicates that setpgrp needs two * arguments whereas USG one needs none. See also HAS_SETPGID * for a POSIX interface. */ #define HAS_SETPGRP /**/ /*#define USE_BSD_SETPGRP / **/ /* HAS_SETPROTOENT_R: * This symbol, if defined, indicates that the setprotoent_r routine * is available to setprotoent re-entrantly. */ /* SETPROTOENT_R_PROTO: * This symbol encodes the prototype of setprotoent_r. * It is zero if d_setprotoent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setprotoent_r * is defined. */ /*#define HAS_SETPROTOENT_R / **/ #define SETPROTOENT_R_PROTO 0 /**/ /* HAS_SETPWENT: * This symbol, if defined, indicates that the setpwent routine is * available for initializing sequential access of the passwd database. */ #define HAS_SETPWENT /**/ /* HAS_SETPWENT_R: * This symbol, if defined, indicates that the setpwent_r routine * is available to setpwent re-entrantly. */ /* SETPWENT_R_PROTO: * This symbol encodes the prototype of setpwent_r. * It is zero if d_setpwent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setpwent_r * is defined. */ /*#define HAS_SETPWENT_R / **/ #define SETPWENT_R_PROTO 0 /**/ /* HAS_SETSERVENT: * This symbol, if defined, indicates that the setservent() routine is * available. */ #define HAS_SETSERVENT /**/ /* HAS_SETSERVENT_R: * This symbol, if defined, indicates that the setservent_r routine * is available to setservent re-entrantly. */ /* SETSERVENT_R_PROTO: * This symbol encodes the prototype of setservent_r. * It is zero if d_setservent_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setservent_r * is defined. */ /*#define HAS_SETSERVENT_R / **/ #define SETSERVENT_R_PROTO 0 /**/ /* HAS_SETVBUF: * This symbol, if defined, indicates that the setvbuf routine is * available to change buffering on an open stdio stream. * to a line-buffered mode. */ #define HAS_SETVBUF /**/ /* HAS_SHM: * This symbol, if defined, indicates that the entire shm*(2) library is * supported. */ #define HAS_SHM /**/ /* Shmat_t: * This symbol holds the return type of the shmat() system call. * Usually set to 'void *' or 'char *'. */ /* HAS_SHMAT_PROTOTYPE: * This symbol, if defined, indicates that the sys/shm.h includes * a prototype for shmat(). Otherwise, it is up to the program to * guess one. Shmat_t shmat(int, Shmat_t, int) is a good guess, * but not always right so it should be emitted by the program only * when HAS_SHMAT_PROTOTYPE is not defined to avoid conflicting defs. */ #define Shmat_t void * /**/ #define HAS_SHMAT_PROTOTYPE /**/ /* HAS_SOCKET: * This symbol, if defined, indicates that the BSD socket interface is * supported. */ /* HAS_SOCKETPAIR: * This symbol, if defined, indicates that the BSD socketpair() call is * supported. */ /* HAS_MSG_CTRUNC: * This symbol, if defined, indicates that the MSG_CTRUNC is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_DONTROUTE: * This symbol, if defined, indicates that the MSG_DONTROUTE is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_OOB: * This symbol, if defined, indicates that the MSG_OOB is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_PEEK: * This symbol, if defined, indicates that the MSG_PEEK is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_MSG_PROXY: * This symbol, if defined, indicates that the MSG_PROXY is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ /* HAS_SCM_RIGHTS: * This symbol, if defined, indicates that the SCM_RIGHTS is supported. * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ #define HAS_SOCKET /**/ #define HAS_SOCKETPAIR /**/ #define HAS_MSG_CTRUNC /**/ #define HAS_MSG_DONTROUTE /**/ #define HAS_MSG_OOB /**/ #define HAS_MSG_PEEK /**/ #define HAS_MSG_PROXY /**/ #define HAS_SCM_RIGHTS /**/ /* HAS_SRAND48_R: * This symbol, if defined, indicates that the srand48_r routine * is available to srand48 re-entrantly. */ /* SRAND48_R_PROTO: * This symbol encodes the prototype of srand48_r. * It is zero if d_srand48_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_srand48_r * is defined. */ /*#define HAS_SRAND48_R / **/ #define SRAND48_R_PROTO 0 /**/ /* HAS_SRANDOM_R: * This symbol, if defined, indicates that the srandom_r routine * is available to srandom re-entrantly. */ /* SRANDOM_R_PROTO: * This symbol encodes the prototype of srandom_r. * It is zero if d_srandom_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_srandom_r * is defined. */ /*#define HAS_SRANDOM_R / **/ #define SRANDOM_R_PROTO 0 /**/ /* USE_STAT_BLOCKS: * This symbol is defined if this system has a stat structure declaring * st_blksize and st_blocks. */ #ifndef USE_STAT_BLOCKS #define USE_STAT_BLOCKS /**/ #endif /* USE_STRUCT_COPY: * This symbol, if defined, indicates that this C compiler knows how * to copy structures. If undefined, you'll need to use a block copy * routine of some sort instead. */ #define USE_STRUCT_COPY /**/ /* HAS_STRERROR: * This symbol, if defined, indicates that the strerror routine is * available to translate error numbers to strings. See the writeup * of Strerror() in this file before you try to define your own. */ /* HAS_SYS_ERRLIST: * This symbol, if defined, indicates that the sys_errlist array is * available to translate error numbers to strings. The extern int * sys_nerr gives the size of that table. */ /* Strerror: * This preprocessor symbol is defined as a macro if strerror() is * not available to translate error numbers to strings but sys_errlist[] * array is there. */ #define HAS_STRERROR /**/ #define HAS_SYS_ERRLIST /**/ #define Strerror(e) strerror(e) /* HAS_STRERROR_R: * This symbol, if defined, indicates that the strerror_r routine * is available to strerror re-entrantly. */ /* STRERROR_R_PROTO: * This symbol encodes the prototype of strerror_r. * It is zero if d_strerror_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_strerror_r * is defined. */ /*#define HAS_STRERROR_R / **/ #define STRERROR_R_PROTO 0 /**/ /* HAS_STRTOUL: * This symbol, if defined, indicates that the strtoul routine is * available to provide conversion of strings to unsigned long. */ #define HAS_STRTOUL /**/ /* HAS_TIME: * This symbol, if defined, indicates that the time() routine exists. */ /* Time_t: * This symbol holds the type returned by time(). It can be long, * or time_t on BSD sites (in which case should be * included). */ #define HAS_TIME /**/ #define Time_t time_t /* Time type */ /* HAS_TIMES: * This symbol, if defined, indicates that the times() routine exists. * Note that this became obsolete on some systems (SUNOS), which now * use getrusage(). It may be necessary to include . */ #define HAS_TIMES /**/ /* HAS_TMPNAM_R: * This symbol, if defined, indicates that the tmpnam_r routine * is available to tmpnam re-entrantly. */ /* TMPNAM_R_PROTO: * This symbol encodes the prototype of tmpnam_r. * It is zero if d_tmpnam_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_tmpnam_r * is defined. */ /*#define HAS_TMPNAM_R / **/ #define TMPNAM_R_PROTO 0 /**/ /* HAS_TTYNAME_R: * This symbol, if defined, indicates that the ttyname_r routine * is available to ttyname re-entrantly. */ /* TTYNAME_R_PROTO: * This symbol encodes the prototype of ttyname_r. * It is zero if d_ttyname_r is undef, and one of the * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ttyname_r * is defined. */ /*#define HAS_TTYNAME_R / **/ #define TTYNAME_R_PROTO 0 /**/ /* HAS_UNION_SEMUN: * This symbol, if defined, indicates that the union semun is * defined by including . If not, the user code * probably needs to define it as: * union semun { * int val; * struct semid_ds *buf; * unsigned short *array; * } */ /* USE_SEMCTL_SEMUN: * This symbol, if defined, indicates that union semun is * used for semctl IPC_STAT. */ /* USE_SEMCTL_SEMID_DS: * This symbol, if defined, indicates that struct semid_ds * is * used for semctl IPC_STAT. */ /*#define HAS_UNION_SEMUN / **/ #define USE_SEMCTL_SEMUN /**/ #define USE_SEMCTL_SEMID_DS /**/ /* HAS_VFORK: * This symbol, if defined, indicates that vfork() exists. */ /*#define HAS_VFORK / **/ /* HAS_PSEUDOFORK: * This symbol, if defined, indicates that an emulation of the * fork routine is available. */ /*#define HAS_PSEUDOFORK / **/ /* Signal_t: * This symbol's value is either "void" or "int", corresponding to the * appropriate return type of a signal handler. Thus, you can declare * a signal handler using "Signal_t (*handler)()", and define the * handler using "Signal_t handler(sig)". */ #define Signal_t void /* Signal handler's return type */ /* HASVOLATILE: * This symbol, if defined, indicates that this C compiler knows about * the volatile declaration. */ #define HASVOLATILE /**/ #ifndef HASVOLATILE #define volatile #endif /* Fpos_t: * This symbol holds the type used to declare file positions in libc. * It can be fpos_t, long, uint, etc... It may be necessary to include * to get any typedef'ed information. */ #define Fpos_t fpos_t /* File position type */ /* Gid_t_f: * This symbol defines the format string used for printing a Gid_t. */ #define Gid_t_f "lu" /**/ /* Gid_t_sign: * This symbol holds the signedess of a Gid_t. * 1 for unsigned, -1 for signed. */ #define Gid_t_sign 1 /* GID sign */ /* Gid_t_size: * This symbol holds the size of a Gid_t in bytes. */ #define Gid_t_size 4 /* GID size */ /* Gid_t: * This symbol holds the return type of getgid() and the type of * argument to setrgid() and related functions. Typically, * it is the type of group ids in the kernel. It can be int, ushort, * gid_t, etc... It may be necessary to include to get * any typedef'ed information. */ #define Gid_t gid_t /* Type for getgid(), etc... */ /* I_DIRENT: * This symbol, if defined, indicates to the C program that it should * include . Using this symbol also triggers the definition * of the Direntry_t define which ends up being 'struct dirent' or * 'struct direct' depending on the availability of . */ /* DIRNAMLEN: * This symbol, if defined, indicates to the C program that the length * of directory entry names is provided by a d_namlen field. Otherwise * you need to do strlen() on the d_name field. */ /* Direntry_t: * This symbol is set to 'struct direct' or 'struct dirent' depending on * whether dirent is available or not. You should use this pseudo type to * portably declare your directory entries. */ #define I_DIRENT /**/ /*#define DIRNAMLEN / **/ #define Direntry_t struct dirent /* I_GRP: * This symbol, if defined, indicates to the C program that it should * include . */ /* GRPASSWD: * This symbol, if defined, indicates to the C program that struct group * in contains gr_passwd. */ #define I_GRP /**/ #define GRPASSWD /**/ /* I_MACH_CTHREADS: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_MACH_CTHREADS / **/ /* I_NDBM: * This symbol, if defined, indicates that exists and should * be included. */ /* I_GDBMNDBM: * This symbol, if defined, indicates that exists and should * be included. This was the location of the ndbm.h compatibility file * in RedHat 7.1. */ /* I_GDBM_NDBM: * This symbol, if defined, indicates that exists and should * be included. This is the location of the ndbm.h compatibility file * in Debian 4.0. */ #define I_NDBM /**/ /*#define I_GDBMNDBM / **/ /*#define I_GDBM_NDBM / **/ /* I_NETDB: * This symbol, if defined, indicates that exists and * should be included. */ #define I_NETDB /**/ /* I_NET_ERRNO: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_NET_ERRNO / **/ /* I_PTHREAD: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_PTHREAD /**/ /* I_PWD: * This symbol, if defined, indicates to the C program that it should * include . */ /* PWQUOTA: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_quota. */ /* PWAGE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_age. */ /* PWCHANGE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_change. */ /* PWCLASS: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_class. */ /* PWEXPIRE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_expire. */ /* PWCOMMENT: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_comment. */ /* PWGECOS: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_gecos. */ /* PWPASSWD: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_passwd. */ #define I_PWD /**/ /*#define PWQUOTA / **/ /*#define PWAGE / **/ /*#define PWCHANGE / **/ /*#define PWCLASS / **/ /*#define PWEXPIRE / **/ /*#define PWCOMMENT / **/ #define PWGECOS /**/ #define PWPASSWD /**/ /* I_SYS_ACCESS: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_ACCESS / **/ /* I_SYS_SECURITY: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_SECURITY / **/ /* I_SYSUIO: * This symbol, if defined, indicates that exists and * should be included. */ #define I_SYSUIO /**/ /* I_STDARG: * This symbol, if defined, indicates that exists and should * be included. */ /* I_VARARGS: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_STDARG /**/ /*#define I_VARARGS / **/ /* PERL_INC_VERSION_LIST: * This variable specifies the list of subdirectories in over * which perl.c:incpush() and lib/lib.pm will automatically * search when adding directories to @INC, in a format suitable * for a C initialization string. See the inc_version_list entry * in Porting/Glossary for more details. */ /*#define PERL_INC_VERSION_LIST 0 / **/ /* INSTALL_USR_BIN_PERL: * This symbol, if defined, indicates that Perl is to be installed * also as /usr/bin/perl. */ /*#define INSTALL_USR_BIN_PERL / **/ /* Off_t: * This symbol holds the type used to declare offsets in the kernel. * It can be int, long, off_t, etc... It may be necessary to include * to get any typedef'ed information. */ /* LSEEKSIZE: * This symbol holds the number of bytes used by the Off_t. */ /* Off_t_size: * This symbol holds the number of bytes used by the Off_t. */ #define Off_t off_t /* type */ #define LSEEKSIZE 8 /* size */ #define Off_t_size 8 /* size */ /* Free_t: * This variable contains the return type of free(). It is usually * void, but occasionally int. */ /* Malloc_t: * This symbol is the type of pointer returned by malloc and realloc. */ #define Malloc_t void * /**/ #define Free_t void /**/ /* PERL_MALLOC_WRAP: * This symbol, if defined, indicates that we'd like malloc wrap checks. */ #define PERL_MALLOC_WRAP /**/ /* MYMALLOC: * This symbol, if defined, indicates that we're using our own malloc. */ /*#define MYMALLOC / **/ /* Mode_t: * This symbol holds the type used to declare file modes * for systems calls. It is usually mode_t, but may be * int or unsigned short. It may be necessary to include * to get any typedef'ed information. */ #define Mode_t mode_t /* file mode parameter for system calls */ /* Netdb_host_t: * This symbol holds the type used for the 1st argument * to gethostbyaddr(). */ /* Netdb_hlen_t: * This symbol holds the type used for the 2nd argument * to gethostbyaddr(). */ /* Netdb_name_t: * This symbol holds the type used for the argument to * gethostbyname(). */ /* Netdb_net_t: * This symbol holds the type used for the 1st argument to * getnetbyaddr(). */ #define Netdb_host_t const void * /**/ #define Netdb_hlen_t size_t /**/ #define Netdb_name_t const char * /**/ #define Netdb_net_t in_addr_t /**/ /* PERL_OTHERLIBDIRS: * This variable contains a colon-separated set of paths for the perl * binary to search for additional library files or modules. * These directories will be tacked to the end of @INC. * Perl will automatically search below each path for version- * and architecture-specific directories. See PERL_INC_VERSION_LIST * for more details. */ /*#define PERL_OTHERLIBDIRS " " / **/ /* Pid_t: * This symbol holds the type used to declare process ids in the kernel. * It can be int, uint, pid_t, etc... It may be necessary to include * to get any typedef'ed information. */ #define Pid_t pid_t /* PID type */ /* PRIVLIB: * This symbol contains the name of the private library for this package. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. The program * should be prepared to do ~ expansion. */ /* PRIVLIB_EXP: * This symbol contains the ~name expanded version of PRIVLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ #define PRIVLIB "/pro/lib/perl5/5.12.0" /**/ #define PRIVLIB_EXP "/pro/lib/perl5/5.12.0" /**/ /* CAN_PROTOTYPE: * If defined, this macro indicates that the C compiler can handle * function prototypes. */ /* _: * This macro is used to declare function parameters for folks who want * to make declarations with prototypes using a different style than * the above macros. Use double parentheses. For example: * * int main _((int argc, char *argv[])); */ #define CAN_PROTOTYPE /**/ #ifdef CAN_PROTOTYPE #define _(args) args #else #define _(args) () #endif /* Select_fd_set_t: * This symbol holds the type used for the 2nd, 3rd, and 4th * arguments to select. Usually, this is 'fd_set *', if HAS_FD_SET * is defined, and 'int *' otherwise. This is only useful if you * have select(), of course. */ #define Select_fd_set_t fd_set * /**/ /* SH_PATH: * This symbol contains the full pathname to the shell used on this * on this system to execute Bourne shell scripts. Usually, this will be * /bin/sh, though it's possible that some systems will have /bin/ksh, * /bin/pdksh, /bin/ash, /bin/bash, or even something such as * D:/bin/sh.exe. */ #define SH_PATH "/bin/sh" /**/ /* SIG_NAME: * This symbol contains a list of signal names in order of * signal number. This is intended * to be used as a static array initialization, like this: * char *sig_name[] = { SIG_NAME }; * The signals in the list are separated with commas, and each signal * is surrounded by double quotes. There is no leading SIG in the signal * name, i.e. SIGQUIT is known as "QUIT". * Gaps in the signal numbers (up to NSIG) are filled in with NUMnn, * etc., where nn is the actual signal number (e.g. NUM37). * The signal number for sig_name[i] is stored in sig_num[i]. * The last element is 0 to terminate the list with a NULL. This * corresponds to the 0 at the end of the sig_name_init list. * Note that this variable is initialized from the sig_name_init, * not from sig_name (which is unused). */ /* SIG_NUM: * This symbol contains a list of signal numbers, in the same order as the * SIG_NAME list. It is suitable for static array initialization, as in: * int sig_num[] = { SIG_NUM }; * The signals in the list are separated with commas, and the indices * within that list and the SIG_NAME list match, so it's easy to compute * the signal name from a number or vice versa at the price of a small * dynamic linear lookup. * Duplicates are allowed, but are moved to the end of the list. * The signal number corresponding to sig_name[i] is sig_number[i]. * if (i < NSIG) then sig_number[i] == i. * The last element is 0, corresponding to the 0 at the end of * the sig_name_init list. * Note that this variable is initialized from the sig_num_init, * not from sig_num (which is unused). */ /* SIG_SIZE: * This variable contains the number of elements of the SIG_NAME * and SIG_NUM arrays, excluding the final NULL entry. */ #define SIG_NAME "ZERO", "HUP", "INT", "QUIT", "ILL", "TRAP", "ABRT", "BUS", "FPE", "KILL", "USR1", "SEGV", "USR2", "PIPE", "ALRM", "TERM", "STKFLT", "CHLD", "CONT", "STOP", "TSTP", "TTIN", "TTOU", "URG", "XCPU", "XFSZ", "VTALRM", "PROF", "WINCH", "IO", "PWR", "SYS", "NUM32", "NUM33", "RTMIN", "NUM35", "NUM36", "NUM37", "NUM38", "NUM39", "NUM40", "NUM41", "NUM42", "NUM43", "NUM44", "NUM45", "NUM46", "NUM47", "NUM48", "NUM49", "NUM50", "NUM51", "NUM52", "NUM53", "NUM54", "NUM55", "NUM56", "NUM57", "NUM58", "NUM59", "NUM60", "NUM61", "NUM62", "NUM63", "RTMAX", "IOT", "CLD", "POLL", "UNUSED", 0 /**/ #define SIG_NUM 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 6, 17, 29, 31, 0 /**/ #define SIG_SIZE 69 /**/ /* SITEARCH: * This symbol contains the name of the private library for this package. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. The program * should be prepared to do ~ expansion. * The standard distribution will put nothing in this directory. * After perl has been installed, users may install their own local * architecture-dependent modules in this directory with * MakeMaker Makefile.PL * or equivalent. See INSTALL for details. */ /* SITEARCH_EXP: * This symbol contains the ~name expanded version of SITEARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ #define SITEARCH "/pro/lib/perl5/site_perl/5.12.0/i686-linux-64int" /**/ #define SITEARCH_EXP "/pro/lib/perl5/site_perl/5.12.0/i686-linux-64int" /**/ /* SITELIB: * This symbol contains the name of the private library for this package. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. The program * should be prepared to do ~ expansion. * The standard distribution will put nothing in this directory. * After perl has been installed, users may install their own local * architecture-independent modules in this directory with * MakeMaker Makefile.PL * or equivalent. See INSTALL for details. */ /* SITELIB_EXP: * This symbol contains the ~name expanded version of SITELIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ /* SITELIB_STEM: * This define is SITELIB_EXP with any trailing version-specific component * removed. The elements in inc_version_list (inc_version_list.U) can * be tacked onto this variable to generate a list of directories to search. */ #define SITELIB "/pro/lib/perl5/site_perl/5.12.0" /**/ #define SITELIB_EXP "/pro/lib/perl5/site_perl/5.12.0" /**/ #define SITELIB_STEM "/pro/lib/perl5/site_perl" /**/ /* Size_t_size: * This symbol holds the size of a Size_t in bytes. */ #define Size_t_size 4 /* */ /* Size_t: * This symbol holds the type used to declare length parameters * for string functions. It is usually size_t, but may be * unsigned long, int, etc. It may be necessary to include * to get any typedef'ed information. */ #define Size_t size_t /* length paramater for string functions */ /* Sock_size_t: * This symbol holds the type used for the size argument of * various socket calls (just the base type, not the pointer-to). */ #define Sock_size_t socklen_t /**/ /* STDCHAR: * This symbol is defined to be the type of char used in stdio.h. * It has the values "unsigned char" or "char". */ #define STDCHAR char /**/ /* Uid_t_f: * This symbol defines the format string used for printing a Uid_t. */ #define Uid_t_f "lu" /**/ /* Uid_t_sign: * This symbol holds the signedess of a Uid_t. * 1 for unsigned, -1 for signed. */ #define Uid_t_sign 1 /* UID sign */ /* Uid_t_size: * This symbol holds the size of a Uid_t in bytes. */ #define Uid_t_size 4 /* UID size */ /* Uid_t: * This symbol holds the type used to declare user ids in the kernel. * It can be int, ushort, uid_t, etc... It may be necessary to include * to get any typedef'ed information. */ #define Uid_t uid_t /* UID type */ /* USE_ITHREADS: * This symbol, if defined, indicates that Perl should be built to * use the interpreter-based threading implementation. */ /* USE_5005THREADS: * This symbol, if defined, indicates that Perl should be built to * use the 5.005-based threading implementation. * Only valid up to 5.8.x. */ /* OLD_PTHREADS_API: * This symbol, if defined, indicates that Perl should * be built to use the old draft POSIX threads API. */ /* USE_REENTRANT_API: * This symbol, if defined, indicates that Perl should * try to use the various _r versions of library functions. * This is extremely experimental. */ /*#define USE_5005THREADS / **/ /*#define USE_ITHREADS / **/ #if defined(USE_5005THREADS) && !defined(USE_ITHREADS) #define USE_THREADS /* until src is revised*/ #endif /*#define OLD_PTHREADS_API / **/ /*#define USE_REENTRANT_API / **/ /* PERL_VENDORARCH: * If defined, this symbol contains the name of a private library. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. * It may have a ~ on the front. * The standard distribution will put nothing in this directory. * Vendors who distribute perl may wish to place their own * architecture-dependent modules and extensions in this directory with * MakeMaker Makefile.PL INSTALLDIRS=vendor * or equivalent. See INSTALL for details. */ /* PERL_VENDORARCH_EXP: * This symbol contains the ~name expanded version of PERL_VENDORARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ /*#define PERL_VENDORARCH "" / **/ /*#define PERL_VENDORARCH_EXP "" / **/ /* PERL_VENDORLIB_EXP: * This symbol contains the ~name expanded version of VENDORLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ /* PERL_VENDORLIB_STEM: * This define is PERL_VENDORLIB_EXP with any trailing version-specific component * removed. The elements in inc_version_list (inc_version_list.U) can * be tacked onto this variable to generate a list of directories to search. */ /*#define PERL_VENDORLIB_EXP "" / **/ /*#define PERL_VENDORLIB_STEM "" / **/ /* VOIDFLAGS: * This symbol indicates how much support of the void type is given by this * compiler. What various bits mean: * * 1 = supports declaration of void * 2 = supports arrays of pointers to functions returning void * 4 = supports comparisons between pointers to void functions and * addresses of void functions * 8 = suports declaration of generic void pointers * * The package designer should define VOIDUSED to indicate the requirements * of the package. This can be done either by #defining VOIDUSED before * including config.h, or by defining defvoidused in Myinit.U. If the * latter approach is taken, only those flags will be tested. If the * level of void support necessary is not present, defines void to int. */ #ifndef VOIDUSED #define VOIDUSED 15 #endif #define VOIDFLAGS 15 #if (VOIDFLAGS & VOIDUSED) != VOIDUSED #define void int /* is void to be avoided? */ #define M_VOID /* Xenix strikes again */ #endif /* USE_CROSS_COMPILE: * This symbol, if defined, indicates that Perl is being cross-compiled. */ /* PERL_TARGETARCH: * This symbol, if defined, indicates the target architecture * Perl has been cross-compiled to. Undefined if not a cross-compile. */ #ifndef USE_CROSS_COMPILE /*#define USE_CROSS_COMPILE / **/ #define PERL_TARGETARCH "" /**/ #endif /* MEM_ALIGNBYTES: * This symbol contains the number of bytes required to align a * double, or a long double when applicable. Usual values are 2, * 4 and 8. The default is eight, for safety. */ #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH) # define MEM_ALIGNBYTES 8 #else #define MEM_ALIGNBYTES 4 #endif /* BYTEORDER: * This symbol holds the hexadecimal constant defined in byteorder, * in a UV, i.e. 0x1234 or 0x4321 or 0x12345678, etc... * If the compiler supports cross-compiling or multiple-architecture * binaries (eg. on NeXT systems), use compiler-defined macros to * determine the byte order. * On NeXT 3.2 (and greater), you can build "Fat" Multiple Architecture * Binaries (MAB) on either big endian or little endian machines. * The endian-ness is available at compile-time. This only matters * for perl, where the config.h can be generated and installed on * one system, and used by a different architecture to build an * extension. Older versions of NeXT that might not have * defined either *_ENDIAN__ were all on Motorola 680x0 series, * so the default case (for NeXT) is big endian to catch them. * This might matter for NeXT 3.0. */ #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH) # ifdef __LITTLE_ENDIAN__ # if LONGSIZE == 4 # define BYTEORDER 0x1234 # else # if LONGSIZE == 8 # define BYTEORDER 0x12345678 # endif # endif # else # ifdef __BIG_ENDIAN__ # if LONGSIZE == 4 # define BYTEORDER 0x4321 # else # if LONGSIZE == 8 # define BYTEORDER 0x87654321 # endif # endif # endif # endif # if !defined(BYTEORDER) && (defined(NeXT) || defined(__NeXT__)) # define BYTEORDER 0x4321 # endif #else #define BYTEORDER 0x12345678 /* large digits for MSB */ #endif /* NeXT */ /* CASTI32: * This symbol is defined if the C compiler can cast negative * or large floating point numbers to 32-bit ints. */ /*#define CASTI32 / **/ /* CASTNEGFLOAT: * This symbol is defined if the C compiler can cast negative * numbers to unsigned longs, ints and shorts. */ /* CASTFLAGS: * This symbol contains flags that say what difficulties the compiler * has casting odd floating values to unsigned long: * 0 = ok * 1 = couldn't cast < 0 * 2 = couldn't cast >= 0x80000000 * 4 = couldn't cast in argument expression list */ #define CASTNEGFLOAT /**/ #define CASTFLAGS 0 /**/ /* VOID_CLOSEDIR: * This symbol, if defined, indicates that the closedir() routine * does not return a value. */ /*#define VOID_CLOSEDIR / **/ /* HAS_FD_SET: * This symbol, when defined, indicates presence of the fd_set typedef * in */ #define HAS_FD_SET /**/ /* Gconvert: * This preprocessor macro is defined to convert a floating point * number to a string without a trailing decimal point. This * emulates the behavior of sprintf("%g"), but is sometimes much more * efficient. If gconvert() is not available, but gcvt() drops the * trailing decimal point, then gcvt() is used. If all else fails, * a macro using sprintf("%g") is used. Arguments for the Gconvert * macro are: value, number of digits, whether trailing zeros should * be retained, and the output buffer. * The usual values are: * d_Gconvert='gconvert((x),(n),(t),(b))' * d_Gconvert='gcvt((x),(n),(b))' * d_Gconvert='sprintf((b),"%.*g",(n),(x))' * The last two assume trailing zeros should not be kept. */ #define Gconvert(x,n,t,b) gcvt((x),(n),(b)) /* HAS_GETPAGESIZE: * This symbol, if defined, indicates that the getpagesize system call * is available to get system page size, which is the granularity of * many memory management calls. */ #define HAS_GETPAGESIZE /**/ /* HAS_GNULIBC: * This symbol, if defined, indicates to the C program that * the GNU C library is being used. A better check is to use * the __GLIBC__ and __GLIBC_MINOR__ symbols supplied with glibc. */ #define HAS_GNULIBC /**/ #if defined(HAS_GNULIBC) && !defined(_GNU_SOURCE) # define _GNU_SOURCE #endif /* HAS_ISASCII: * This manifest constant lets the C program know that isascii * is available. */ #define HAS_ISASCII /**/ /* HAS_LCHOWN: * This symbol, if defined, indicates that the lchown routine is * available to operate on a symbolic link (instead of following the * link). */ #define HAS_LCHOWN /**/ /* HAS_OPEN3: * This manifest constant lets the C program know that the three * argument form of open(2) is available. */ #define HAS_OPEN3 /**/ /* HAS_SAFE_BCOPY: * This symbol, if defined, indicates that the bcopy routine is available * to copy potentially overlapping memory blocks. Normally, you should * probably use memmove() or memcpy(). If neither is defined, roll your * own version. */ /*#define HAS_SAFE_BCOPY / **/ /* HAS_SAFE_MEMCPY: * This symbol, if defined, indicates that the memcpy routine is available * to copy potentially overlapping memory blocks. If you need to * copy overlapping memory blocks, you should check HAS_MEMMOVE and * use memmove() instead, if available. */ /*#define HAS_SAFE_MEMCPY / **/ /* HAS_SANE_MEMCMP: * This symbol, if defined, indicates that the memcmp routine is available * and can be used to compare relative magnitudes of chars with their high * bits set. If it is not defined, roll your own version. */ #define HAS_SANE_MEMCMP /**/ /* HAS_SIGACTION: * This symbol, if defined, indicates that Vr4's sigaction() routine * is available. */ #define HAS_SIGACTION /**/ /* HAS_SIGSETJMP: * This variable indicates to the C program that the sigsetjmp() * routine is available to save the calling process's registers * and stack environment for later use by siglongjmp(), and * to optionally save the process's signal mask. See * Sigjmp_buf, Sigsetjmp, and Siglongjmp. */ /* Sigjmp_buf: * This is the buffer type to be used with Sigsetjmp and Siglongjmp. */ /* Sigsetjmp: * This macro is used in the same way as sigsetjmp(), but will invoke * traditional setjmp() if sigsetjmp isn't available. * See HAS_SIGSETJMP. */ /* Siglongjmp: * This macro is used in the same way as siglongjmp(), but will invoke * traditional longjmp() if siglongjmp isn't available. * See HAS_SIGSETJMP. */ #define HAS_SIGSETJMP /**/ #ifdef HAS_SIGSETJMP #define Sigjmp_buf sigjmp_buf #define Sigsetjmp(buf,save_mask) sigsetjmp((buf),(save_mask)) #define Siglongjmp(buf,retval) siglongjmp((buf),(retval)) #else #define Sigjmp_buf jmp_buf #define Sigsetjmp(buf,save_mask) setjmp((buf)) #define Siglongjmp(buf,retval) longjmp((buf),(retval)) #endif /* USE_STDIO_PTR: * This symbol is defined if the _ptr and _cnt fields (or similar) * of the stdio FILE structure can be used to access the stdio buffer * for a file handle. If this is defined, then the FILE_ptr(fp) * and FILE_cnt(fp) macros will also be defined and should be used * to access these fields. */ /* FILE_ptr: * This macro is used to access the _ptr field (or equivalent) of the * FILE structure pointed to by its argument. This macro will always be * defined if USE_STDIO_PTR is defined. */ /* STDIO_PTR_LVALUE: * This symbol is defined if the FILE_ptr macro can be used as an * lvalue. */ /* FILE_cnt: * This macro is used to access the _cnt field (or equivalent) of the * FILE structure pointed to by its argument. This macro will always be * defined if USE_STDIO_PTR is defined. */ /* STDIO_CNT_LVALUE: * This symbol is defined if the FILE_cnt macro can be used as an * lvalue. */ /* STDIO_PTR_LVAL_SETS_CNT: * This symbol is defined if using the FILE_ptr macro as an lvalue * to increase the pointer by n has the side effect of decreasing the * value of File_cnt(fp) by n. */ /* STDIO_PTR_LVAL_NOCHANGE_CNT: * This symbol is defined if using the FILE_ptr macro as an lvalue * to increase the pointer by n leaves File_cnt(fp) unchanged. */ /*#define USE_STDIO_PTR / **/ #ifdef USE_STDIO_PTR #define FILE_ptr(fp) ((fp)->_IO_read_ptr) /*#define STDIO_PTR_LVALUE / **/ #define FILE_cnt(fp) ((fp)->_IO_read_end - (fp)->_IO_read_ptr) /*#define STDIO_CNT_LVALUE / **/ /*#define STDIO_PTR_LVAL_SETS_CNT / **/ /*#define STDIO_PTR_LVAL_NOCHANGE_CNT / **/ #endif /* USE_STDIO_BASE: * This symbol is defined if the _base field (or similar) of the * stdio FILE structure can be used to access the stdio buffer for * a file handle. If this is defined, then the FILE_base(fp) macro * will also be defined and should be used to access this field. * Also, the FILE_bufsiz(fp) macro will be defined and should be used * to determine the number of bytes in the buffer. USE_STDIO_BASE * will never be defined unless USE_STDIO_PTR is. */ /* FILE_base: * This macro is used to access the _base field (or equivalent) of the * FILE structure pointed to by its argument. This macro will always be * defined if USE_STDIO_BASE is defined. */ /* FILE_bufsiz: * This macro is used to determine the number of bytes in the I/O * buffer pointed to by _base field (or equivalent) of the FILE * structure pointed to its argument. This macro will always be defined * if USE_STDIO_BASE is defined. */ /*#define USE_STDIO_BASE / **/ #ifdef USE_STDIO_BASE #define FILE_base(fp) ((fp)->_IO_read_base) #define FILE_bufsiz(fp) ((fp)->_IO_read_end - (fp)->_IO_read_base) #endif /* HAS_VPRINTF: * This symbol, if defined, indicates that the vprintf routine is available * to printf with a pointer to an argument list. If unavailable, you * may need to write your own, probably in terms of _doprnt(). */ /* USE_CHAR_VSPRINTF: * This symbol is defined if this system has vsprintf() returning type * (char*). The trend seems to be to declare it as "int vsprintf()". It * is up to the package author to declare vsprintf correctly based on the * symbol. */ #define HAS_VPRINTF /**/ /*#define USE_CHAR_VSPRINTF / **/ /* DOUBLESIZE: * This symbol contains the size of a double, so that the C preprocessor * can make decisions based on it. */ #define DOUBLESIZE 8 /**/ /* I_TIME: * This symbol, if defined, indicates to the C program that it should * include . */ /* I_SYS_TIME: * This symbol, if defined, indicates to the C program that it should * include . */ /* I_SYS_TIME_KERNEL: * This symbol, if defined, indicates to the C program that it should * include with KERNEL defined. */ /* HAS_TM_TM_ZONE: * This symbol, if defined, indicates to the C program that * the struct tm has a tm_zone field. */ /* HAS_TM_TM_GMTOFF: * This symbol, if defined, indicates to the C program that * the struct tm has a tm_gmtoff field. */ #define I_TIME /**/ #define I_SYS_TIME /**/ /*#define I_SYS_TIME_KERNEL / **/ #define HAS_TM_TM_ZONE /**/ #define HAS_TM_TM_GMTOFF /**/ /* VAL_O_NONBLOCK: * This symbol is to be used during open() or fcntl(F_SETFL) to turn on * non-blocking I/O for the file descriptor. Note that there is no way * back, i.e. you cannot turn it blocking again this way. If you wish to * alternatively switch between blocking and non-blocking, use the * ioctl(FIOSNBIO) call instead, but that is not supported by all devices. */ /* VAL_EAGAIN: * This symbol holds the errno error code set by read() when no data was * present on the non-blocking file descriptor. */ /* RD_NODATA: * This symbol holds the return code from read() when no data is present * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is * not defined, then you can't distinguish between no data and EOF by * issuing a read(). You'll have to find another way to tell for sure! */ /* EOF_NONBLOCK: * This symbol, if defined, indicates to the C program that a read() on * a non-blocking file descriptor will return 0 on EOF, and not the value * held in RD_NODATA (-1 usually, in that case!). */ #define VAL_O_NONBLOCK O_NONBLOCK #define VAL_EAGAIN EAGAIN #define RD_NODATA -1 #define EOF_NONBLOCK /* PTRSIZE: * This symbol contains the size of a pointer, so that the C preprocessor * can make decisions based on it. It will be sizeof(void *) if * the compiler supports (void *); otherwise it will be * sizeof(char *). */ #define PTRSIZE 4 /**/ /* Drand01: * This macro is to be used to generate uniformly distributed * random numbers over the range [0., 1.[. You may have to supply * an 'extern double drand48();' in your program since SunOS 4.1.3 * doesn't provide you with anything relevant in its headers. * See HAS_DRAND48_PROTO. */ /* Rand_seed_t: * This symbol defines the type of the argument of the * random seed function. */ /* seedDrand01: * This symbol defines the macro to be used in seeding the * random number generator (see Drand01). */ /* RANDBITS: * This symbol indicates how many bits are produced by the * function used to generate normalized random numbers. * Values include 15, 16, 31, and 48. */ #define Drand01() drand48() /**/ #define Rand_seed_t long /**/ #define seedDrand01(x) srand48((Rand_seed_t)x) /**/ #define RANDBITS 48 /**/ /* SSize_t: * This symbol holds the type used by functions that return * a count of bytes or an error condition. It must be a signed type. * It is usually ssize_t, but may be long or int, etc. * It may be necessary to include or * to get any typedef'ed information. * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t). */ #define SSize_t ssize_t /* signed count of bytes */ /* EBCDIC: * This symbol, if defined, indicates that this system uses * EBCDIC encoding. */ /*#define EBCDIC / **/ /* HAS_ATOLF: * This symbol, if defined, indicates that the atolf routine is * available to convert strings into long doubles. */ /*#define HAS_ATOLF / **/ /* HAS_ATOLL: * This symbol, if defined, indicates that the atoll routine is * available to convert strings into long longs. */ #define HAS_ATOLL /**/ /* HAS__FWALK: * This symbol, if defined, indicates that the _fwalk system call is * available to apply a function to all the file handles. */ /*#define HAS__FWALK / **/ /* HAS_AINTL: * This symbol, if defined, indicates that the aintl routine is * available. If copysignl is also present we can emulate modfl. */ /*#define HAS_AINTL / **/ /* HAS_BUILTIN_CHOOSE_EXPR: * Can we handle GCC builtin for compile-time ternary-like expressions */ /* HAS_BUILTIN_EXPECT: * Can we handle GCC builtin for telling that certain values are more * likely */ #define HAS_BUILTIN_EXPECT /**/ #define HAS_BUILTIN_CHOOSE_EXPR /**/ /* HAS_C99_VARIADIC_MACROS: * If defined, the compiler supports C99 variadic macros. */ #define HAS_C99_VARIADIC_MACROS /**/ /* HAS_CLASS: * This symbol, if defined, indicates that the class routine is * available to classify doubles. Available for example in AIX. * The returned values are defined in and are: * * FP_PLUS_NORM Positive normalized, nonzero * FP_MINUS_NORM Negative normalized, nonzero * FP_PLUS_DENORM Positive denormalized, nonzero * FP_MINUS_DENORM Negative denormalized, nonzero * FP_PLUS_ZERO +0.0 * FP_MINUS_ZERO -0.0 * FP_PLUS_INF +INF * FP_MINUS_INF -INF * FP_NANS Signaling Not a Number (NaNS) * FP_NANQ Quiet Not a Number (NaNQ) */ /*#define HAS_CLASS / **/ /* HAS_CLEARENV: * This symbol, if defined, indicates that the clearenv () routine is * available for use. */ #define HAS_CLEARENV /**/ /* HAS_STRUCT_CMSGHDR: * This symbol, if defined, indicates that the struct cmsghdr * is supported. */ #define HAS_STRUCT_CMSGHDR /**/ /* HAS_COPYSIGNL: * This symbol, if defined, indicates that the copysignl routine is * available. If aintl is also present we can emulate modfl. */ #define HAS_COPYSIGNL /**/ /* USE_CPLUSPLUS: * This symbol, if defined, indicates that a C++ compiler was * used to compiled Perl and will be used to compile extensions. */ /*#define USE_CPLUSPLUS / **/ /* HAS_DBMINIT_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the dbminit() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int dbminit(char *); */ #define HAS_DBMINIT_PROTO /**/ /* HAS_DIR_DD_FD: * This symbol, if defined, indicates that the the DIR* dirstream * structure contains a member variable named dd_fd. */ /*#define HAS_DIR_DD_FD / **/ /* HAS_DIRFD: * This manifest constant lets the C program know that dirfd * is available. */ #define HAS_DIRFD /**/ /* DLSYM_NEEDS_UNDERSCORE: * This symbol, if defined, indicates that we need to prepend an * underscore to the symbol name before calling dlsym(). This only * makes sense if you *have* dlsym, which we will presume is the * case if you're using dl_dlopen.xs. */ /*#define DLSYM_NEEDS_UNDERSCORE / **/ /* HAS_FAST_STDIO: * This symbol, if defined, indicates that the "fast stdio" * is available to manipulate the stdio buffers directly. */ /*#define HAS_FAST_STDIO / **/ /* HAS_FCHDIR: * This symbol, if defined, indicates that the fchdir routine is * available to change directory using a file descriptor. */ #define HAS_FCHDIR /**/ /* FCNTL_CAN_LOCK: * This symbol, if defined, indicates that fcntl() can be used * for file locking. Normally on Unix systems this is defined. * It may be undefined on VMS. */ #define FCNTL_CAN_LOCK /**/ /* HAS_FINITE: * This symbol, if defined, indicates that the finite routine is * available to check whether a double is finite (non-infinity non-NaN). */ #define HAS_FINITE /**/ /* HAS_FINITEL: * This symbol, if defined, indicates that the finitel routine is * available to check whether a long double is finite * (non-infinity non-NaN). */ #define HAS_FINITEL /**/ /* HAS_FLOCK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the flock() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int flock(int, int); */ #define HAS_FLOCK_PROTO /**/ /* HAS_FP_CLASS: * This symbol, if defined, indicates that the fp_class routine is * available to classify doubles. Available for example in Digital UNIX. * The returned values are defined in and are: * * FP_SNAN Signaling NaN (Not-a-Number) * FP_QNAN Quiet NaN (Not-a-Number) * FP_POS_INF +infinity * FP_NEG_INF -infinity * FP_POS_NORM Positive normalized * FP_NEG_NORM Negative normalized * FP_POS_DENORM Positive denormalized * FP_NEG_DENORM Negative denormalized * FP_POS_ZERO +0.0 (positive zero) * FP_NEG_ZERO -0.0 (negative zero) */ /*#define HAS_FP_CLASS / **/ /* HAS_FPCLASS: * This symbol, if defined, indicates that the fpclass routine is * available to classify doubles. Available for example in Solaris/SVR4. * The returned values are defined in and are: * * FP_SNAN signaling NaN * FP_QNAN quiet NaN * FP_NINF negative infinity * FP_PINF positive infinity * FP_NDENORM negative denormalized non-zero * FP_PDENORM positive denormalized non-zero * FP_NZERO negative zero * FP_PZERO positive zero * FP_NNORM negative normalized non-zero * FP_PNORM positive normalized non-zero */ /*#define HAS_FPCLASS / **/ /* HAS_FPCLASSIFY: * This symbol, if defined, indicates that the fpclassify routine is * available to classify doubles. Available for example in HP-UX. * The returned values are defined in and are * * FP_NORMAL Normalized * FP_ZERO Zero * FP_INFINITE Infinity * FP_SUBNORMAL Denormalized * FP_NAN NaN * */ /*#define HAS_FPCLASSIFY / **/ /* HAS_FPCLASSL: * This symbol, if defined, indicates that the fpclassl routine is * available to classify long doubles. Available for example in IRIX. * The returned values are defined in and are: * * FP_SNAN signaling NaN * FP_QNAN quiet NaN * FP_NINF negative infinity * FP_PINF positive infinity * FP_NDENORM negative denormalized non-zero * FP_PDENORM positive denormalized non-zero * FP_NZERO negative zero * FP_PZERO positive zero * FP_NNORM negative normalized non-zero * FP_PNORM positive normalized non-zero */ /*#define HAS_FPCLASSL / **/ /* HAS_FPOS64_T: * This symbol will be defined if the C compiler supports fpos64_t. */ /*#define HAS_FPOS64_T / **/ /* HAS_FREXPL: * This symbol, if defined, indicates that the frexpl routine is * available to break a long double floating-point number into * a normalized fraction and an integral power of 2. */ #define HAS_FREXPL /**/ /* HAS_STRUCT_FS_DATA: * This symbol, if defined, indicates that the struct fs_data * to do statfs() is supported. */ /*#define HAS_STRUCT_FS_DATA / **/ /* HAS_FSEEKO: * This symbol, if defined, indicates that the fseeko routine is * available to fseek beyond 32 bits (useful for ILP32 hosts). */ #define HAS_FSEEKO /**/ /* HAS_FSTATFS: * This symbol, if defined, indicates that the fstatfs routine is * available to stat filesystems by file descriptors. */ #define HAS_FSTATFS /**/ /* HAS_FSYNC: * This symbol, if defined, indicates that the fsync routine is * available to write a file's modified data and attributes to * permanent storage. */ #define HAS_FSYNC /**/ /* HAS_FTELLO: * This symbol, if defined, indicates that the ftello routine is * available to ftell beyond 32 bits (useful for ILP32 hosts). */ #define HAS_FTELLO /**/ /* HAS_FUTIMES: * This symbol, if defined, indicates that the futimes routine is * available to change file descriptor time stamps with struct timevals. */ #define HAS_FUTIMES /**/ /* HAS_GETCWD: * This symbol, if defined, indicates that the getcwd routine is * available to get the current working directory. */ #define HAS_GETCWD /**/ /* HAS_GETESPWNAM: * This symbol, if defined, indicates that the getespwnam system call is * available to retrieve enchanced (shadow) password entries by name. */ /*#define HAS_GETESPWNAM / **/ /* HAS_GETFSSTAT: * This symbol, if defined, indicates that the getfsstat routine is * available to stat filesystems in bulk. */ /*#define HAS_GETFSSTAT / **/ /* HAS_GETITIMER: * This symbol, if defined, indicates that the getitimer routine is * available to return interval timers. */ #define HAS_GETITIMER /**/ /* HAS_GETMNT: * This symbol, if defined, indicates that the getmnt routine is * available to get filesystem mount info by filename. */ /*#define HAS_GETMNT / **/ /* HAS_GETMNTENT: * This symbol, if defined, indicates that the getmntent routine is * available to iterate through mounted file systems to get their info. */ #define HAS_GETMNTENT /**/ /* HAS_GETPRPWNAM: * This symbol, if defined, indicates that the getprpwnam system call is * available to retrieve protected (shadow) password entries by name. */ /*#define HAS_GETPRPWNAM / **/ /* HAS_GETSPNAM: * This symbol, if defined, indicates that the getspnam system call is * available to retrieve SysV shadow password entries by name. */ #define HAS_GETSPNAM /**/ /* HAS_HASMNTOPT: * This symbol, if defined, indicates that the hasmntopt routine is * available to query the mount options of file systems. */ #define HAS_HASMNTOPT /**/ /* HAS_ILOGBL: * This symbol, if defined, indicates that the ilogbl routine is * available. If scalbnl is also present we can emulate frexpl. */ #define HAS_ILOGBL /**/ /* HAS_INT64_T: * This symbol will defined if the C compiler supports int64_t. * Usually the needs to be included, but sometimes * is enough. */ #define HAS_INT64_T /**/ /* HAS_ISFINITE: * This symbol, if defined, indicates that the isfinite routine is * available to check whether a double is finite (non-infinity non-NaN). */ /*#define HAS_ISFINITE / **/ /* HAS_ISINF: * This symbol, if defined, indicates that the isinf routine is * available to check whether a double is an infinity. */ #define HAS_ISINF /**/ /* HAS_ISNAN: * This symbol, if defined, indicates that the isnan routine is * available to check whether a double is a NaN. */ #define HAS_ISNAN /**/ /* HAS_ISNANL: * This symbol, if defined, indicates that the isnanl routine is * available to check whether a long double is a NaN. */ #define HAS_ISNANL /**/ /* HAS_LDBL_DIG: * This symbol, if defined, indicates that this system's * or defines the symbol LDBL_DIG, which is the number * of significant digits in a long double precision number. Unlike * for DBL_DIG, there's no good guess for LDBL_DIG if it is undefined. */ #define HAS_LDBL_DIG /* */ /* LIBM_LIB_VERSION: * This symbol, if defined, indicates that libm exports _LIB_VERSION * and that math.h defines the enum to manipulate it. */ #define LIBM_LIB_VERSION /**/ /* HAS_MADVISE: * This symbol, if defined, indicates that the madvise system call is * available to map a file into memory. */ #define HAS_MADVISE /**/ /* HAS_MALLOC_SIZE: * This symbol, if defined, indicates that the malloc_size * routine is available for use. */ /*#define HAS_MALLOC_SIZE / **/ /* HAS_MALLOC_GOOD_SIZE: * This symbol, if defined, indicates that the malloc_good_size * routine is available for use. */ /*#define HAS_MALLOC_GOOD_SIZE / **/ /* HAS_MKDTEMP: * This symbol, if defined, indicates that the mkdtemp routine is * available to exclusively create a uniquely named temporary directory. */ #define HAS_MKDTEMP /**/ /* HAS_MKSTEMPS: * This symbol, if defined, indicates that the mkstemps routine is * available to excluslvely create and open a uniquely named * (with a suffix) temporary file. */ /*#define HAS_MKSTEMPS / **/ /* HAS_MODFL: * This symbol, if defined, indicates that the modfl routine is * available to split a long double x into a fractional part f and * an integer part i such that |f| < 1.0 and (f + i) = x. */ /* HAS_MODFL_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the modfl() function. Otherwise, it is up * to the program to supply one. */ /* HAS_MODFL_POW32_BUG: * This symbol, if defined, indicates that the modfl routine is * broken for long doubles >= pow(2, 32). * For example from 4294967303.150000 one would get 4294967302.000000 * and 1.150000. The bug has been seen in certain versions of glibc, * release 2.2.2 is known to be okay. */ #define HAS_MODFL /**/ #define HAS_MODFL_PROTO /**/ /*#define HAS_MODFL_POW32_BUG / **/ /* HAS_MPROTECT: * This symbol, if defined, indicates that the mprotect system call is * available to modify the access protection of a memory mapped file. */ #define HAS_MPROTECT /**/ /* HAS_STRUCT_MSGHDR: * This symbol, if defined, indicates that the struct msghdr * is supported. */ #define HAS_STRUCT_MSGHDR /**/ /* HAS_NL_LANGINFO: * This symbol, if defined, indicates that the nl_langinfo routine is * available to return local data. You will also need * and therefore I_LANGINFO. */ #define HAS_NL_LANGINFO /**/ /* HAS_OFF64_T: * This symbol will be defined if the C compiler supports off64_t. */ /*#define HAS_OFF64_T / **/ /* HAS_PROCSELFEXE: * This symbol is defined if PROCSELFEXE_PATH is a symlink * to the absolute pathname of the executing program. */ /* PROCSELFEXE_PATH: * If HAS_PROCSELFEXE is defined this symbol is the filename * of the symbolic link pointing to the absolute pathname of * the executing program. */ #define HAS_PROCSELFEXE /**/ #if defined(HAS_PROCSELFEXE) && !defined(PROCSELFEXE_PATH) #define PROCSELFEXE_PATH "/proc/self/exe" /**/ #endif /* HAS_PTHREAD_ATTR_SETSCOPE: * This symbol, if defined, indicates that the pthread_attr_setscope * system call is available to set the contention scope attribute of * a thread attribute object. */ #define HAS_PTHREAD_ATTR_SETSCOPE /**/ /* HAS_READV: * This symbol, if defined, indicates that the readv routine is * available to do gather reads. You will also need * and there I_SYSUIO. */ #define HAS_READV /**/ /* HAS_RECVMSG: * This symbol, if defined, indicates that the recvmsg routine is * available to send structured socket messages. */ #define HAS_RECVMSG /**/ /* HAS_SBRK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the sbrk() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern void* sbrk(int); * extern void* sbrk(size_t); */ #define HAS_SBRK_PROTO /**/ /* HAS_SCALBNL: * This symbol, if defined, indicates that the scalbnl routine is * available. If ilogbl is also present we can emulate frexpl. */ #define HAS_SCALBNL /**/ /* HAS_SENDMSG: * This symbol, if defined, indicates that the sendmsg routine is * available to send structured socket messages. */ #define HAS_SENDMSG /**/ /* HAS_SETITIMER: * This symbol, if defined, indicates that the setitimer routine is * available to set interval timers. */ #define HAS_SETITIMER /**/ /* HAS_SETPROCTITLE: * This symbol, if defined, indicates that the setproctitle routine is * available to set process title. */ /*#define HAS_SETPROCTITLE / **/ /* USE_SFIO: * This symbol, if defined, indicates that sfio should * be used. */ /*#define USE_SFIO / **/ /* HAS_SIGNBIT: * This symbol, if defined, indicates that the signbit routine is * available to check if the given number has the sign bit set. * This should include correct testing of -0.0. This will only be set * if the signbit() routine is safe to use with the NV type used internally * in perl. Users should call Perl_signbit(), which will be #defined to * the system's signbit() function or macro if this symbol is defined. */ #define HAS_SIGNBIT /**/ /* HAS_SIGPROCMASK: * This symbol, if defined, indicates that the sigprocmask * system call is available to examine or change the signal mask * of the calling process. */ #define HAS_SIGPROCMASK /**/ /* USE_SITECUSTOMIZE: * This symbol, if defined, indicates that sitecustomize should * be used. */ #ifndef USE_SITECUSTOMIZE /*#define USE_SITECUSTOMIZE / **/ #endif /* HAS_SNPRINTF: * This symbol, if defined, indicates that the snprintf () library * function is available for use. */ /* HAS_VSNPRINTF: * This symbol, if defined, indicates that the vsnprintf () library * function is available for use. */ #define HAS_SNPRINTF /**/ #define HAS_VSNPRINTF /**/ /* HAS_SOCKATMARK: * This symbol, if defined, indicates that the sockatmark routine is * available to test whether a socket is at the out-of-band mark. */ #define HAS_SOCKATMARK /**/ /* HAS_SOCKATMARK_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the sockatmark() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int sockatmark(int); */ #define HAS_SOCKATMARK_PROTO /**/ /* HAS_SOCKS5_INIT: * This symbol, if defined, indicates that the socks5_init routine is * available to initialize SOCKS 5. */ /*#define HAS_SOCKS5_INIT / **/ /* SPRINTF_RETURNS_STRLEN: * This variable defines whether sprintf returns the length of the string * (as per the ANSI spec). Some C libraries retain compatibility with * pre-ANSI C and return a pointer to the passed in buffer; for these * this variable will be undef. */ #define SPRINTF_RETURNS_STRLEN /**/ /* HAS_SQRTL: * This symbol, if defined, indicates that the sqrtl routine is * available to do long double square roots. */ #define HAS_SQRTL /**/ /* HAS_SETRESGID_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the setresgid() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern int setresgid(uid_t ruid, uid_t euid, uid_t suid); */ /*#define HAS_SETRESGID_PROTO / **/ /* HAS_SETRESUID_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the setresuid() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern int setresuid(uid_t ruid, uid_t euid, uid_t suid); */ /*#define HAS_SETRESUID_PROTO / **/ /* HAS_STRUCT_STATFS_F_FLAGS: * This symbol, if defined, indicates that the struct statfs * does have the f_flags member containing the mount flags of * the filesystem containing the file. * This kind of struct statfs is coming from (BSD 4.3), * not from (SYSV). Older BSDs (like Ultrix) do not * have statfs() and struct statfs, they have ustat() and getmnt() * with struct ustat and struct fs_data. */ /*#define HAS_STRUCT_STATFS_F_FLAGS / **/ /* HAS_STRUCT_STATFS: * This symbol, if defined, indicates that the struct statfs * to do statfs() is supported. */ #define HAS_STRUCT_STATFS /**/ /* HAS_FSTATVFS: * This symbol, if defined, indicates that the fstatvfs routine is * available to stat filesystems by file descriptors. */ #define HAS_FSTATVFS /**/ /* HAS_STRFTIME: * This symbol, if defined, indicates that the strftime routine is * available to do time formatting. */ #define HAS_STRFTIME /**/ /* HAS_STRLCAT: * This symbol, if defined, indicates that the strlcat () routine is * available to do string concatenation. */ /*#define HAS_STRLCAT / **/ /* HAS_STRLCPY: * This symbol, if defined, indicates that the strlcpy () routine is * available to do string copying. */ /*#define HAS_STRLCPY / **/ /* HAS_STRTOLD: * This symbol, if defined, indicates that the strtold routine is * available to convert strings to long doubles. */ #define HAS_STRTOLD /**/ /* HAS_STRTOLL: * This symbol, if defined, indicates that the strtoll routine is * available to convert strings to long longs. */ #define HAS_STRTOLL /**/ /* HAS_STRTOQ: * This symbol, if defined, indicates that the strtoq routine is * available to convert strings to long longs (quads). */ #define HAS_STRTOQ /**/ /* HAS_STRTOULL: * This symbol, if defined, indicates that the strtoull routine is * available to convert strings to unsigned long longs. */ #define HAS_STRTOULL /**/ /* HAS_STRTOUQ: * This symbol, if defined, indicates that the strtouq routine is * available to convert strings to unsigned long longs (quads). */ #define HAS_STRTOUQ /**/ /* HAS_SYSCALL_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the syscall() function. Otherwise, it is up * to the program to supply one. Good guesses are * extern int syscall(int, ...); * extern int syscall(long, ...); */ #define HAS_SYSCALL_PROTO /**/ /* HAS_TELLDIR_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the telldir() function. Otherwise, it is up * to the program to supply one. A good guess is * extern long telldir(DIR*); */ #define HAS_TELLDIR_PROTO /**/ /* HAS_CTIME64: * This symbol, if defined, indicates that the ctime64 () routine is * available to do the 64bit variant of ctime () */ /* HAS_LOCALTIME64: * This symbol, if defined, indicates that the localtime64 () routine is * available to do the 64bit variant of localtime () */ /* HAS_GMTIME64: * This symbol, if defined, indicates that the gmtime64 () routine is * available to do the 64bit variant of gmtime () */ /* HAS_MKTIME64: * This symbol, if defined, indicates that the mktime64 () routine is * available to do the 64bit variant of mktime () */ /* HAS_DIFFTIME64: * This symbol, if defined, indicates that the difftime64 () routine is * available to do the 64bit variant of difftime () */ /* HAS_ASCTIME64: * This symbol, if defined, indicates that the asctime64 () routine is * available to do the 64bit variant of asctime () */ /*#define HAS_CTIME64 / **/ /*#define HAS_LOCALTIME64 / **/ /*#define HAS_GMTIME64 / **/ /*#define HAS_MKTIME64 / **/ /*#define HAS_DIFFTIME64 / **/ /*#define HAS_ASCTIME64 / **/ /* HAS_TIMEGM: * This symbol, if defined, indicates that the timegm routine is * available to do the opposite of gmtime () */ #define HAS_TIMEGM /**/ /* U32_ALIGNMENT_REQUIRED: * This symbol, if defined, indicates that you must access * character data through U32-aligned pointers. */ #ifndef U32_ALIGNMENT_REQUIRED #define U32_ALIGNMENT_REQUIRED /**/ #endif /* HAS_UALARM: * This symbol, if defined, indicates that the ualarm routine is * available to do alarms with microsecond granularity. */ #define HAS_UALARM /**/ /* HAS_UNORDERED: * This symbol, if defined, indicates that the unordered routine is * available to check whether two doubles are unordered * (effectively: whether either of them is NaN) */ /*#define HAS_UNORDERED / **/ /* HAS_UNSETENV: * This symbol, if defined, indicates that the unsetenv () routine is * available for use. */ #define HAS_UNSETENV /**/ /* HAS_USLEEP_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the usleep() function. Otherwise, it is up * to the program to supply one. A good guess is * extern int usleep(useconds_t); */ #define HAS_USLEEP_PROTO /**/ /* HAS_USTAT: * This symbol, if defined, indicates that the ustat system call is * available to query file system statistics by dev_t. */ #define HAS_USTAT /**/ /* HAS_WRITEV: * This symbol, if defined, indicates that the writev routine is * available to do scatter writes. */ #define HAS_WRITEV /**/ /* USE_DYNAMIC_LOADING: * This symbol, if defined, indicates that dynamic loading of * some sort is available. */ #define USE_DYNAMIC_LOADING /**/ /* FFLUSH_NULL: * This symbol, if defined, tells that fflush(NULL) does flush * all pending stdio output. */ /* FFLUSH_ALL: * This symbol, if defined, tells that to flush * all pending stdio output one must loop through all * the stdio file handles stored in an array and fflush them. * Note that if fflushNULL is defined, fflushall will not * even be probed for and will be left undefined. */ #define FFLUSH_NULL /**/ /*#define FFLUSH_ALL / **/ /* I_ASSERT: * This symbol, if defined, indicates that exists and * could be included by the C program to get the assert() macro. */ #define I_ASSERT /**/ /* I_CRYPT: * This symbol, if defined, indicates that exists and * should be included. */ #define I_CRYPT /**/ /* DB_Prefix_t: * This symbol contains the type of the prefix structure element * in the header file. In older versions of DB, it was * int, while in newer ones it is u_int32_t. */ /* DB_Hash_t: * This symbol contains the type of the prefix structure element * in the header file. In older versions of DB, it was * int, while in newer ones it is size_t. */ /* DB_VERSION_MAJOR_CFG: * This symbol, if defined, defines the major version number of * Berkeley DB found in the header when Perl was configured. */ /* DB_VERSION_MINOR_CFG: * This symbol, if defined, defines the minor version number of * Berkeley DB found in the header when Perl was configured. * For DB version 1 this is always 0. */ /* DB_VERSION_PATCH_CFG: * This symbol, if defined, defines the patch version number of * Berkeley DB found in the header when Perl was configured. * For DB version 1 this is always 0. */ #define DB_Hash_t u_int32_t /**/ #define DB_Prefix_t size_t /**/ #define DB_VERSION_MAJOR_CFG 4 /**/ #define DB_VERSION_MINOR_CFG 5 /**/ #define DB_VERSION_PATCH_CFG 20 /**/ /* I_FP: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_FP / **/ /* I_FP_CLASS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_FP_CLASS / **/ /* I_IEEEFP: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_IEEEFP / **/ /* I_INTTYPES: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_INTTYPES /**/ /* I_LANGINFO: * This symbol, if defined, indicates that exists and * should be included. */ #define I_LANGINFO /**/ /* I_LIBUTIL: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_LIBUTIL / **/ /* I_MALLOCMALLOC: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_MALLOCMALLOC / **/ /* I_MNTENT: * This symbol, if defined, indicates that exists and * should be included. */ #define I_MNTENT /**/ /* I_NETINET_TCP: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_NETINET_TCP /**/ /* I_POLL: * This symbol, if defined, indicates that exists and * should be included. (see also HAS_POLL) */ #define I_POLL /**/ /* I_PROT: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_PROT / **/ /* I_SHADOW: * This symbol, if defined, indicates that exists and * should be included. */ #define I_SHADOW /**/ /* I_SOCKS: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SOCKS / **/ /* I_SUNMATH: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SUNMATH / **/ /* I_SYSLOG: * This symbol, if defined, indicates that exists and * should be included. */ #define I_SYSLOG /**/ /* I_SYSMODE: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSMODE / **/ /* I_SYS_MOUNT: * This symbol, if defined, indicates that exists and * should be included. */ #define I_SYS_MOUNT /**/ /* I_SYS_STATFS: * This symbol, if defined, indicates that exists. */ #define I_SYS_STATFS /**/ /* I_SYS_STATVFS: * This symbol, if defined, indicates that exists and * should be included. */ #define I_SYS_STATVFS /**/ /* I_SYSUTSNAME: * This symbol, if defined, indicates that exists and * should be included. */ #define I_SYSUTSNAME /**/ /* I_SYS_VFS: * This symbol, if defined, indicates that exists and * should be included. */ #define I_SYS_VFS /**/ /* I_USTAT: * This symbol, if defined, indicates that exists and * should be included. */ #define I_USTAT /**/ /* PERL_PRIfldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'f') for output. */ /* PERL_PRIgldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'g') for output. */ /* PERL_PRIeldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'e') for output. */ /* PERL_SCNfldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'f') for input. */ #define PERL_PRIfldbl "Lf" /**/ #define PERL_PRIgldbl "Lg" /**/ #define PERL_PRIeldbl "Le" /**/ #define PERL_SCNfldbl "Lf" /**/ /* PERL_MAD: * This symbol, if defined, indicates that the Misc Attribution * Declaration code should be conditionally compiled. */ /*#define PERL_MAD / **/ /* NEED_VA_COPY: * This symbol, if defined, indicates that the system stores * the variable argument list datatype, va_list, in a format * that cannot be copied by simple assignment, so that some * other means must be used when copying is required. * As such systems vary in their provision (or non-provision) * of copying mechanisms, handy.h defines a platform- * independent macro, Perl_va_copy(src, dst), to do the job. */ /*#define NEED_VA_COPY / **/ /* IVTYPE: * This symbol defines the C type used for Perl's IV. */ /* UVTYPE: * This symbol defines the C type used for Perl's UV. */ /* I8TYPE: * This symbol defines the C type used for Perl's I8. */ /* U8TYPE: * This symbol defines the C type used for Perl's U8. */ /* I16TYPE: * This symbol defines the C type used for Perl's I16. */ /* U16TYPE: * This symbol defines the C type used for Perl's U16. */ /* I32TYPE: * This symbol defines the C type used for Perl's I32. */ /* U32TYPE: * This symbol defines the C type used for Perl's U32. */ /* I64TYPE: * This symbol defines the C type used for Perl's I64. */ /* U64TYPE: * This symbol defines the C type used for Perl's U64. */ /* NVTYPE: * This symbol defines the C type used for Perl's NV. */ /* IVSIZE: * This symbol contains the sizeof(IV). */ /* UVSIZE: * This symbol contains the sizeof(UV). */ /* I8SIZE: * This symbol contains the sizeof(I8). */ /* U8SIZE: * This symbol contains the sizeof(U8). */ /* I16SIZE: * This symbol contains the sizeof(I16). */ /* U16SIZE: * This symbol contains the sizeof(U16). */ /* I32SIZE: * This symbol contains the sizeof(I32). */ /* U32SIZE: * This symbol contains the sizeof(U32). */ /* I64SIZE: * This symbol contains the sizeof(I64). */ /* U64SIZE: * This symbol contains the sizeof(U64). */ /* NVSIZE: * This symbol contains the sizeof(NV). */ /* NV_PRESERVES_UV: * This symbol, if defined, indicates that a variable of type NVTYPE * can preserve all the bits of a variable of type UVTYPE. */ /* NV_PRESERVES_UV_BITS: * This symbol contains the number of bits a variable of type NVTYPE * can preserve of a variable of type UVTYPE. */ /* NV_OVERFLOWS_INTEGERS_AT: * This symbol gives the largest integer value that NVs can hold. This * value + 1.0 cannot be stored accurately. It is expressed as constant * floating point expression to reduce the chance of decimale/binary * conversion issues. If it can not be determined, the value 0 is given. */ /* NV_ZERO_IS_ALLBITS_ZERO: * This symbol, if defined, indicates that a variable of type NVTYPE * stores 0.0 in memory as all bits zero. */ #define IVTYPE long long /**/ #define UVTYPE unsigned long long /**/ #define I8TYPE signed char /**/ #define U8TYPE unsigned char /**/ #define I16TYPE short /**/ #define U16TYPE unsigned short /**/ #define I32TYPE long /**/ #define U32TYPE unsigned long /**/ #ifdef HAS_QUAD #define I64TYPE long long /**/ #define U64TYPE unsigned long long /**/ #endif #define NVTYPE double /**/ #define IVSIZE 8 /**/ #define UVSIZE 8 /**/ #define I8SIZE 1 /**/ #define U8SIZE 1 /**/ #define I16SIZE 2 /**/ #define U16SIZE 2 /**/ #define I32SIZE 4 /**/ #define U32SIZE 4 /**/ #ifdef HAS_QUAD #define I64SIZE 8 /**/ #define U64SIZE 8 /**/ #endif #define NVSIZE 8 /**/ #undef NV_PRESERVES_UV #define NV_PRESERVES_UV_BITS 53 #define NV_OVERFLOWS_INTEGERS_AT 256.0*256.0*256.0*256.0*256.0*256.0*2.0*2.0*2.0*2.0*2.0 #define NV_ZERO_IS_ALLBITS_ZERO #if UVSIZE == 8 # ifdef BYTEORDER # if BYTEORDER == 0x1234 # undef BYTEORDER # define BYTEORDER 0x12345678 # else # if BYTEORDER == 0x4321 # undef BYTEORDER # define BYTEORDER 0x87654321 # endif # endif # endif #endif /* IVdf: * This symbol defines the format string used for printing a Perl IV * as a signed decimal integer. */ /* UVuf: * This symbol defines the format string used for printing a Perl UV * as an unsigned decimal integer. */ /* UVof: * This symbol defines the format string used for printing a Perl UV * as an unsigned octal integer. */ /* UVxf: * This symbol defines the format string used for printing a Perl UV * as an unsigned hexadecimal integer in lowercase abcdef. */ /* UVXf: * This symbol defines the format string used for printing a Perl UV * as an unsigned hexadecimal integer in uppercase ABCDEF. */ /* NVef: * This symbol defines the format string used for printing a Perl NV * using %e-ish floating point format. */ /* NVff: * This symbol defines the format string used for printing a Perl NV * using %f-ish floating point format. */ /* NVgf: * This symbol defines the format string used for printing a Perl NV * using %g-ish floating point format. */ #define IVdf "Ld" /**/ #define UVuf "Lu" /**/ #define UVof "Lo" /**/ #define UVxf "Lx" /**/ #define UVXf "LX" /**/ #define NVef "e" /**/ #define NVff "f" /**/ #define NVgf "g" /**/ /* SELECT_MIN_BITS: * This symbol holds the minimum number of bits operated by select. * That is, if you do select(n, ...), how many bits at least will be * cleared in the masks if some activity is detected. Usually this * is either n or 32*ceil(n/32), especially many little-endians do * the latter. This is only useful if you have select(), naturally. */ #define SELECT_MIN_BITS 32 /**/ /* STARTPERL: * This variable contains the string to put in front of a perl * script to make sure (one hopes) that it runs with perl and not * some shell. */ #define STARTPERL "#!/pro/bin/perl5.12.0" /**/ /* HAS_STDIO_STREAM_ARRAY: * This symbol, if defined, tells that there is an array * holding the stdio streams. */ /* STDIO_STREAM_ARRAY: * This symbol tells the name of the array holding the stdio streams. * Usual values include _iob, __iob, and __sF. */ /*#define HAS_STDIO_STREAM_ARRAY / **/ #ifdef HAS_STDIO_STREAM_ARRAY #define STDIO_STREAM_ARRAY #endif /* GMTIME_MAX: * This symbol contains the maximum value for the time_t offset that * the system function gmtime () accepts, and defaults to 0 */ /* GMTIME_MIN: * This symbol contains the minimum value for the time_t offset that * the system function gmtime () accepts, and defaults to 0 */ /* LOCALTIME_MAX: * This symbol contains the maximum value for the time_t offset that * the system function localtime () accepts, and defaults to 0 */ /* LOCALTIME_MIN: * This symbol contains the minimum value for the time_t offset that * the system function localtime () accepts, and defaults to 0 */ #define GMTIME_MAX 2147483647 /**/ #define GMTIME_MIN -2147483648 /**/ #define LOCALTIME_MAX 2147483647 /**/ #define LOCALTIME_MIN -2147483648 /**/ /* USE_64_BIT_INT: * This symbol, if defined, indicates that 64-bit integers should * be used when available. If not defined, the native integers * will be employed (be they 32 or 64 bits). The minimal possible * 64-bitness is used, just enough to get 64-bit integers into Perl. * This may mean using for example "long longs", while your memory * may still be limited to 2 gigabytes. */ /* USE_64_BIT_ALL: * This symbol, if defined, indicates that 64-bit integers should * be used when available. If not defined, the native integers * will be used (be they 32 or 64 bits). The maximal possible * 64-bitness is employed: LP64 or ILP64, meaning that you will * be able to use more than 2 gigabytes of memory. This mode is * even more binary incompatible than USE_64_BIT_INT. You may not * be able to run the resulting executable in a 32-bit CPU at all or * you may need at least to reboot your OS to 64-bit mode. */ #ifndef USE_64_BIT_INT #define USE_64_BIT_INT /**/ #endif #ifndef USE_64_BIT_ALL /*#define USE_64_BIT_ALL / **/ #endif /* USE_DTRACE: * This symbol, if defined, indicates that Perl should * be built with support for DTrace. */ /*#define USE_DTRACE / **/ /* USE_FAST_STDIO: * This symbol, if defined, indicates that Perl should * be built to use 'fast stdio'. * Defaults to define in Perls 5.8 and earlier, to undef later. */ #ifndef USE_FAST_STDIO /*#define USE_FAST_STDIO / **/ #endif /* USE_LARGE_FILES: * This symbol, if defined, indicates that large file support * should be used when available. */ #ifndef USE_LARGE_FILES #define USE_LARGE_FILES /**/ #endif /* USE_LONG_DOUBLE: * This symbol, if defined, indicates that long doubles should * be used when available. */ #ifndef USE_LONG_DOUBLE /*#define USE_LONG_DOUBLE / **/ #endif /* USE_MORE_BITS: * This symbol, if defined, indicates that 64-bit interfaces and * long doubles should be used when available. */ #ifndef USE_MORE_BITS /*#define USE_MORE_BITS / **/ #endif /* MULTIPLICITY: * This symbol, if defined, indicates that Perl should * be built to use multiplicity. */ #ifndef MULTIPLICITY /*#define MULTIPLICITY / **/ #endif /* USE_PERLIO: * This symbol, if defined, indicates that the PerlIO abstraction should * be used throughout. If not defined, stdio should be * used in a fully backward compatible manner. */ #ifndef USE_PERLIO #define USE_PERLIO /**/ #endif /* USE_SOCKS: * This symbol, if defined, indicates that Perl should * be built to use socks. */ #ifndef USE_SOCKS /*#define USE_SOCKS / **/ #endif #endif perl-5.12.0-RC0/Porting/valgrindpp.pl0000555000175000017500000002270211143650473016264 0ustar jessejesse#!/usr/bin/perl use IO::File (); use File::Find qw(find); use Text::Wrap qw(wrap); use Getopt::Long qw(GetOptions); use Pod::Usage qw(pod2usage); use Cwd qw(cwd); use File::Spec; use strict; my %opt = ( frames => 3, lines => 0, tests => 0, top => 0, verbose => 0, ); GetOptions(\%opt, qw( dir=s frames=i hide=s@ lines! output-file=s tests! top=i verbose+ )) or pod2usage(2); # Setup the directory to process if (exists $opt{dir}) { $opt{dir} = File::Spec->canonpath($opt{dir}); } else { # Check if we're in 't' $opt{dir} = cwd =~ /\/t$/ ? '..' : '.'; # Check if we're in the right directory -d "$opt{dir}/$_" or die "$0: must be run from the perl source directory" . " when --dir is not given\n" for qw(t lib ext); } # Assemble regex for functions whose leaks should be hidden # (no, a hash won't be significantly faster) my $hidden = do { local $"='|'; $opt{hide} ? qr/^(?:@{$opt{hide}})$/o : '' }; # Setup our output file handle # (do it early, as it may fail) my $fh = \*STDOUT; if (exists $opt{'output-file'}) { $fh = new IO::File ">$opt{'output-file'}" or die "$0: cannot open $opt{'output-file'} ($!)\n"; } # These hashes will receive the error and leak summary data: # # %error = ( # error_name => { # stack_frame => { # test_script => occurences # } # } # ); # # %leak = ( # leak_type => { # stack_frames => { # test_script => occurences # } # } # stack frames are separated by '<'s # ); my(%error, %leak); # Collect summary data find({wanted => \&filter, no_chdir => 1}, $opt{dir}); # Format the output nicely $Text::Wrap::columns = 80; $Text::Wrap::unexpand = 0; # Write summary summary($fh, \%error, \%leak); exit 0; sub summary { my($fh, $error, $leak) = @_; my(%ne, %nl, %top); # Prepare the data for my $e (keys %$error) { for my $f (keys %{$error->{$e}}) { my($func, $file, $line) = split /:/, $f; my $nf = $opt{lines} ? "$func ($file:$line)" : "$func ($file)"; $ne{$e}{$nf}{count}++; while (my($k,$v) = each %{$error->{$e}{$f}}) { $ne{$e}{$nf}{tests}{$k} += $v; $top{$k}{error}++; } } } for my $l (keys %$leak) { for my $s (keys %{$leak->{$l}}) { my $ns = join '<', map { my($func, $file, $line) = split /:/; /:/ ? $opt{lines} ? "$func ($file:$line)" : "$func ($file)" : $_ } split /{$l}{$s}}) { $nl{$l}{$ns}{tests}{$k} += $v; $top{$k}{leak}++; } } } # Print the Top N if ($opt{top}) { for my $what (qw(error leak)) { my @t = sort { $top{$b}{$what} <=> $top{$a}{$what} or $a cmp $b } grep $top{$_}{$what}, keys %top; @t > $opt{top} and splice @t, $opt{top}; my $n = @t; my $s = $n > 1 ? 's' : ''; my $prev = 0; print $fh "Top $n test scripts for ${what}s:\n\n"; for my $i (1 .. $n) { $n = $top{$t[$i-1]}{$what}; $s = $n > 1 ? 's' : ''; printf $fh " %3s %-40s %3d $what$s\n", $n != $prev ? "$i." : '', $t[$i-1], $n; $prev = $n; } print $fh "\n"; } } # Print the real summary print $fh "MEMORY ACCESS ERRORS\n\n"; for my $e (sort keys %ne) { print $fh qq("$e"\n); for my $frame (sort keys %{$ne{$e}}) { my $data = $ne{$e}{$frame}; my $count = $data->{count} > 1 ? " [$data->{count} paths]" : ''; print $fh ' 'x4, "$frame$count\n", format_tests($data->{tests}), "\n"; } print $fh "\n"; } print $fh "\nMEMORY LEAKS\n\n"; for my $l (sort keys %nl) { print $fh qq("$l"\n); for my $frames (sort keys %{$nl{$l}}) { my $data = $nl{$l}{$frames}; my @stack = split /{count} > 1 and $stack[-1] .= " [$data->{count} paths]"; print $fh join('', map { ' 'x4 . "$_:$stack[$_]\n" } 0 .. $#stack ), format_tests($data->{tests}), "\n\n"; } } } sub format_tests { my $tests = shift; my $indent = ' 'x8; if ($opt{tests}) { return wrap($indent, $indent, join ', ', sort keys %$tests); } else { my $count = keys %$tests; my $s = $count > 1 ? 's' : ''; return $indent . "triggered by $count test$s"; } } sub filter { debug(2, "$File::Find::name\n"); # Only process '*.t.valgrind' files /(.*)\.t\.valgrind$/ or return; # Strip all unnecessary stuff from the test name my $test = $1; $test =~ s/^(?:(?:\Q$opt{dir}\E|[.t])\/)+//; debug(1, "processing $test ($_)\n"); # Get all the valgrind output lines my @l = do { my $fh = new IO::File $_ or die "$0: cannot open $_ ($!)\n"; # Process outputs can interrupt each other, so sort by pid first my %pid; local $_; while (<$fh>) { chomp; s/^==(\d+)==\s?// and push @{$pid{$1}}, $_; } map @$_, values %pid; }; # Setup some useful regexes my $hexaddr = '0x[[:xdigit:]]+'; my $topframe = qr/^\s+at $hexaddr:\s+/; my $address = qr/^\s+Address $hexaddr is \d+ bytes (?:before|inside|after) a block of size \d+/; my $leak = qr/^\s*\d+ bytes in \d+ blocks are (still reachable|(?:definite|possib)ly lost)/; for my $i (0 .. $#l) { $l[$i] =~ $topframe or next; # Match on any topmost frame... $l[$i-1] =~ $address and next; # ...but not if it's only address details my $line = $l[$i-1]; # The error / leak description line my $j = $i; if ($line =~ $leak) { debug(2, "LEAK: $line\n"); my $type = $1; # Type of leak (still reachable, ...) my $inperl = 0; # Are we inside the perl source? (And how deep?) my @stack; # Call stack while ($l[$j++] =~ /^\s+(?:at|by) $hexaddr:\s+(\w+)\s+\((?:([^:]+):(\d+)|[^)]+)\)/o) { my($func, $file, $lineno) = ($1, $2, $3); # If the stack frame is inside perl => increment $inperl # If we've already been inside perl, but are no longer => leave defined $file && ++$inperl or $inperl && last; # A function that should be hidden? => clear stack and leave $hidden && $func =~ $hidden and @stack = (), last; # Add stack frame if it's within our threshold if ($inperl <= $opt{frames}) { push @stack, $inperl ? "$func:$file:$lineno" : $func; } } # If there's something on the stack and we've seen perl code, # add this memory leak to the summary data @stack and $inperl and $leak{$type}{join '<', @stack}{$test}++; } else { debug(1, "ERROR: $line\n"); # Simply find the topmost frame in the call stack within # the perl source code while ($l[$j++] =~ /^\s+(?:at|by) $hexaddr:\s+(?:(\w+)\s+\(([^:]+):(\d+)\))?/o) { if (defined $1) { $error{$line}{"$1:$2:$3"}{$test}++; last; } } } } } sub debug { my $level = shift; $opt{verbose} >= $level and print STDERR @_; } __END__ =head1 NAME valgrindpp.pl - A post processor for make test.valgrind =head1 SYNOPSIS valgrindpp.pl [B<--dir>=I] [B<--frames>=I] [B<--hide>=I] [B<--lines>] [B<--output-file>=I] [B<--tests>] [B<--top>=I] [B<--verbose>] =head1 DESCRIPTION B is a post processor for I<.valgrind> files created during I. It collects all these files, extracts most of the information and produces a significantly shorter summary of all detected memory access errors and memory leaks. =head1 OPTIONS =over 4 =item B<--dir>=I Recursively process I<.valgrind> files in I. If this options is not given, B must be run from either the perl source or the I directory and will process all I<.valgrind> files within the distribution. =item B<--frames>=I Number of stack frames within the perl source code to consider when distinguishing between memory leak sources. Increasing this value will give you a longer backtrace, while decreasing the number will show you fewer sources for memory leaks. The default is 3 frames. =item B<--hide>=I Hide all memory leaks that have I in their backtrace. Useful if you want to hide leaks from functions that are known to have lots of memory leaks. I can also be a regular expression, in which case all leaks with symbols matching the expression are hidden. Can be given multiple times. =item B<--lines> Show line numbers for stack frames. This is useful for further increasing the error/leak resolution, but makes it harder to compare different reports using I. =item B<--output-file>=I Redirect the output into I. If this option is not given, the output goes to I. =item B<--tests> List all tests that trigger memory access errors or memory leaks explicitly instead of only printing a count. =item B<--top>=I List the top I test scripts for memory access errors and memory leaks. Set to C<0> for no top-I statistics. =item B<--verbose> Increase verbosity level. Can be given multiple times. =back =head1 COPYRIGHT Copyright 2003 by Marcus Holland-Moritz . This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. =cut perl-5.12.0-RC0/Porting/bump-perl-version0000444000175000017500000002177111342547046017076 0ustar jessejesse#!/usr/bin/perl # # bump-perl-version, DAPM 14 Jul 2009 # # A utility to find, and optionally bump, references to the perl version # number in various files within the perl source # # It's designed to work in two phases. First, when run with -s (scan), # it searches all the files in MANIFEST looking for strings that appear to # match the current perl version (or which it knows are *supposed* to # contain the current version), and produces a list of them to stdout, # along with a suggested edit. For example: # # $ Porting/bump-perl-version -s 5.10.0 5.10.1 > /tmp/scan # $ cat /tmp/scan # Porting/config.sh # # 52: -archlib='/opt/perl/lib/5.10.0/i686-linux-64int' # +archlib='/opt/perl/lib/5.10.1/i686-linux-64int' # .... # # At this point there will be false positives. Edit the file to remove # those changes you don't want made. Then in the second phase, feed that # list in, and it will change those lines in the files: # # $ Porting/bump-perl-version -u < /tmp/scan # # (so line 52 of Porting/config.sh is now updated) # This utility 'knows' about certain files and formats, and so can spot # 'hidden' version numbers, like PERL_SUBVERSION=9. # # A third variant makes use of this knowledge to check that all the things # it knows about are at the current version: # # $ Porting/bump-perl-version -c 5.10.0 # # XXX this script hasn't been tested against a major version bump yet, # eg 5.11.0 to 5.12.0; there may be things it missed - DAPM 14 Jul 09 # # Note there are various files and directories that it skips; these are # ones that are unlikely to contain anything needing bumping, but which # will generate lots fo false positives (eg pod/*). These are listed on # STDERR as they are skipped. use strict; use warnings; use Getopt::Std; use ExtUtils::Manifest; sub usage { die < -s -u -c check files and warn if any known string values (eg PERL_SUBVERSION) don't match the specified version -s scan files and produce list of possible change lines to stdout -u read in the scan file from stdin, and change all the lines specified C.C.C the current perl version, eg 5.10.0 N.N.N the new perl version, eg 5.10.1 EOF my %opts; getopts('csu', \%opts) or usage; if ($opts{u}) { @ARGV == 0 or usage('no version version numbers should be speciied'); # fake to stop warnings when calculating $oldx etc @ARGV = qw(99.99.99 99.99.99); } elsif ($opts{c}) { @ARGV == 1 or usage('required one version number'); push @ARGV, $ARGV[0]; } else { @ARGV == 2 or usage('require two version numbers'); } usage('only one of -c, -s and -u') if keys %opts > 1; my ($oldx, $oldy, $oldz) = $ARGV[0] =~ /^(\d+)\.(\d+)\.(\d+)$/ or usage("bad version: $ARGV[0]"); my ($newx, $newy, $newz) = $ARGV[1] =~ /^(\d+)\.(\d+)\.(\d+)$/ or usage("bad version: $ARGV[1]"); my $old_decimal = sprintf "%d.%03d%03d", $oldx, $oldy, $oldz; # 5.011001 # each entry is # 0 a regexp that matches strings that might contain versions; # 1 a sub that returns two strings based on $1 etc values: # * string containing captured values (for -c) # * a string containing the replacement value # 2 what we expect the sub to return as its first arg; undef implies # don't match # 3 a regex restricting which files this applies to (undef is all files) # # Note that @maps entries are checks in order, and only the first to match # is used. my @maps = ( [ qr{^((?:api_)?version(?:=|\s+)'?) (\d+) ('?) (?!\.)}x, sub { $2, "$1$newy$3" }, $oldy, qr/config/, ], [ qr{^(subversion(?:=|\s+)'?) (\d+) ('?) (?!\.)}x, sub { $2, "$1$newz$3" }, $oldz, qr/config/, ], [ qr{^(api_subversion(?:=|\s+)'?) (\d+) ('?) (?!\.)}x, sub { $2, "${1}0$3" }, 0, qr/config/, ], [ qr{^(api_versionstring(?:=|\s+)'?) ([\d\.]+) ('?) (?!\.)}x, sub { $2, "$1$newx.$newy.0$3" }, "$oldx.$oldy.0", qr/config/, ], [ qr{(version\s+'?) (\d+) ('?\s+subversion\s+'?) (\d+) ('?) (?!\.)}x, sub { "$2-$4", "$1$newy$3$newz$5" }, "$oldy-$oldz", qr/config/, ], [ qr{\b (PERL_(?:API_)?VERSION(?:=|\s+)'?) (\d+) ('?) (?!\.)}x, sub { $2, "$1$newy$3"}, $oldy, ], [ qr{\b (PERL_SUBVERSION(?:=|\s+)'?) (\d+) ('?) (?!\.)}x, sub { $2, "$1$newz$3"}, $oldz, ], [ qr{\b (PERL_API_SUBVERSION(?:=|\s+)'?) (\d+) ('?) (?!\.)}x, sub { $2, "${1}0$3"}, 0, ], # these two formats are in README.vms [ qr{\b perl-(\d+\^\.\d+\^\.\d+) \b}x, sub { $1, "perl-$newx^.$newy^.$newz"}, undef, ], [ qr{\b ($oldx _ $oldy _$oldz) \b}x, sub { $1, ($newx . '_' . $newy . '_' . $newz)}, undef, ], # 5.8.9 [ qr{ $oldx\.$oldy\.$oldz \b}x, sub {"", "$newx.$newy.$newz"}, undef, ], # 5.008009 [ qr{ $old_decimal \b}x, sub {"", sprintf "%d.%03d%03d", $newx, $newy, $newz }, undef, ], # perl511, perl511.dll, perl511.lib, perl511s.lib [ qr{\b perl (\d\d\d) (s?) \b }x, sub {$1, "perl$newx$newy$2" }, "$oldx$oldy", qr/makedef|win32/, # makedef.pl, README.win32, win32/* ], ); # files and dirs that we likely don't want to change version numbers on. my %SKIP_FILES = map { ($_ => 1) } qw( Changes MANIFEST Porting/how_to_write_a_perldelta.pod Porting/release_managers_guide.pod Porting/release_schedule.pod Porting/bump-perl-version Porting/mergelog Porting/mergelog-tool pod.lst pp_ctl.c ); my @SKIP_DIRS = qw( ext lib pod t ); my @mani_files = sort keys %{ExtUtils::Manifest::maniread('MANIFEST')}; my %mani_files = map { ($_ => 1) } @mani_files; die "No entries found in MANIFEST; aborting\n" unless @mani_files; if ($opts{c} or $opts{s}) { do_scan(); } elsif ($opts{u}) { do_update(); } else { usage('one of -c, -s or -u must be specifcied'); } exit 0; sub do_scan { for my $file (@mani_files) { next if grep $file =~ m{$_/}, @SKIP_DIRS; if ($SKIP_FILES{$file}) { warn "(skipping $file)\n"; next; } open my $fh, '<', $file or die "Aborting: can't open $file: $!\n"; my $header = 0; while (<$fh>) { for my $map (@maps) { my ($pat, $sub, $expected, $file_pat) = @$map; next if defined $file_pat and $file !~ $file_pat; next unless $_ =~ $pat; my ($got, $replacement) = $sub->(); if ($opts{c}) { # only report unexpected next unless defined $expected and $got ne $expected; } my $newstr = $_; $newstr =~ s/$pat/$replacement/ or die "Internal error: substitution failed: [$pat]\n"; if ($_ ne $newstr) { print "\n$file\n" unless $header; $header=1; printf "\n%5d: -%s +%s", $., $_, $newstr; } last; } } } warn "(skipped $_/*)\n" for @SKIP_DIRS; } sub do_update { my %changes; my $file; my $line; # read in config while () { next unless /\S/; if (/^(\S+)$/) { $file = $1; die "No such file in MANIFEST: '$file'\n" unless $mani_files{$file}; die "file already seen; '$file'\n" if exists $changes{$file}; undef $line; } elsif (/^\s+(\d+): -(.*)/) { my $old; ($line, $old) = ($1,$2); die "$.: old line without preceeding filename\n" unless defined $file; die "Dup line number: $line\n" if exists $changes{$file}{$line}; $changes{$file}{$line}[0] = $old; } elsif (/^\s+\+(.*)/) { my $new = $1; die "$.: replacement line seen without old line\n" unless $line; $changes{$file}{$line}[1] = $new; undef $line; } else { die "Unexpected line at ;line $.: $_\n"; } } # suck in file contents to memory, then update that in-memory copy my %contents; for my $file (sort keys %changes) { open my $fh, '<', $file or die "open '$file': $!\n"; binmode $fh; $contents{$file} = [ <$fh> ]; chomp @{$contents{$file}}; close $fh or die "close: '$file': $!\n"; my $entries = $changes{$file}; for my $line (keys %$entries) { die "$file: no such line: $line\n" unless defined $contents{$file}[$line-1]; if ($contents{$file}[$line-1] ne $entries->{$line}[0]) { die "$file: line mismatch at line $line:\n" . "File: [$contents{$file}[$line-1]]\n" . "Config: [$entries->{$line}[0]]\n" } $contents{$file}[$line-1] = $entries->{$line}[1]; } } # check the temp files don't already exist for my $file (sort keys %contents) { my $nfile = "$file-new"; die "$nfile already exists in MANIFEST; aborting\n" if $mani_files{$nfile}; } # write out the new files for my $file (sort keys %contents) { my $nfile = "$file-new"; open my $fh, '>', $nfile or die "create '$nfile' failed: $!\n"; binmode $fh; print $fh $_, "\n" for @{$contents{$file}}; close $fh or die "failed to close $nfile; aborting: $!\n"; my @stat = stat $file or die "Can't stat $file: $!\n"; my $mode = $stat[2]; die "stat $file fgailed to give a mode!\n" unless defined $mode; chmod $mode & 0777, $nfile or die "chmod $nfile failed; aborting: $!\n"; } # and rename them for my $file (sort keys %contents) { my $nfile = "$file-new"; warn "updating $file ...\n"; rename $nfile, $file or die "rename $nfile $file: $!\n"; } } perl-5.12.0-RC0/Porting/manisort0000444000175000017500000000330211325127001015314 0ustar jessejesse#!/usr/bin/perl # Usage: manisort [-q] [-o outfile] [filename] # # Without 'filename', looks for MANIFEST in the current dir. # With '-o outfile', writes the sorted MANIFEST to the specified file. # Prints the result of the sort to stderr. '-q' silences this. # The exit code for the script is the sort result status # (i.e., 0 means already sorted properly, 1 means not properly sorted) use strict; use warnings; $| = 1; # Get command line options use Getopt::Long; my $outfile; my $check_only = 0; my $quiet = 0; GetOptions ('output=s' => \$outfile, 'check' => \$check_only, 'quiet' => \$quiet); my $file = (@ARGV) ? shift : 'MANIFEST'; # Read in the MANIFEST file open(my $IN, '<', $file) or die("Can't read '$file': $!"); my @manifest = <$IN>; close($IN) or die($!); chomp(@manifest); # Sort by dictionary order (ignore-case and # consider whitespace and alphanumeric only) my @sorted = sort { (my $aa = $a) =~ s/[^\s\da-zA-Z]//g; (my $bb = $b) =~ s/[^\s\da-zA-Z]//g; uc($aa) cmp uc($bb) } @manifest; # Check if the file is sorted or not my $exit_code = 0; for (my $ii = 0; $ii < $#manifest; $ii++) { next if ($manifest[$ii] eq $sorted[$ii]); $exit_code = 1; # Not sorted last; } # Output sorted file if (defined($outfile)) { open(my $OUT, '>', $outfile) or die("Can't open output file '$outfile': $!"); print($OUT join("\n", @sorted), "\n"); close($OUT) or die($!); } # Report on sort results printf(STDERR "'$file' is%s sorted properly\n", (($exit_code) ? ' NOT' : '')) if (! $quiet); # Exit with the sort results status exit($exit_code); # EOF perl-5.12.0-RC0/Porting/expand-macro.pl0000555000175000017500000000577311325127001016471 0ustar jessejesse#!perl -w use strict; use Pod::Usage; use Getopt::Std; $Getopt::Std::STANDARD_HELP_VERSION = 1; my $trysource = "try.c"; my $tryout = "try.i"; getopts('fF:ekvI:', \my %opt) or pod2usage(); my($expr, @headers) = @ARGV ? splice @ARGV : "-"; pod2usage "-f and -F are exclusive\n" if $opt{f} and $opt{F}; foreach($trysource, $tryout) { unlink $_ if $opt{e}; die "You already have a $_" if -e $_; } if ($expr eq '-') { warn "reading from stdin...\n"; $expr = do { local $/; <> }; } my($macro, $args) = $expr =~ /^\s*(\w+)((?:\s*\(.*\))?)\s*;?\s*$/s or pod2usage "$expr doesn't look like a macro-name or macro-expression to me"; if (!(@ARGV = @headers)) { open my $fh, '<', 'MANIFEST' or die "Can't open MANIFEST: $!"; while (<$fh>) { push @ARGV, $1 if m!^([^/]+\.h)\t!; } push @ARGV, 'config.h' if -f 'config.h'; } my $header; while (<>) { next unless /^#\s*define\s+$macro\b/; my ($def_args) = /^#\s*define\s+$macro\(([^)]*)\)/; if (defined $def_args && !$args) { my @args = split ',', $def_args; print "# macro: $macro args: @args in $_\n" if $opt{v}; my $argname = "A0"; $args = '(' . join (', ', map {$argname++} 1..@args) . ')'; } $header = $ARGV; last; } die "$macro not found\n" unless defined $header; open my $out, '>', $trysource or die "Can't open $trysource: $!"; my $sentinel = "$macro expands to"; print $out <<"EOF"; #include "EXTERN.h" #include "perl.h" EOF print $out qq{#include "$header"\n} unless $header eq 'perl.h' or $header eq 'EXTERN.h'; print $out <<"EOF"; #line 4 "$sentinel" $macro$args EOF close $out or die "Can't close $trysource: $!"; print "doing: make $tryout\n" if $opt{v}; system "make $tryout" and die; # if user wants 'indent' formatting .. my $out_fh; if ($opt{f} || $opt{F}) { # a: indent is a well behaved filter when given 0 arguments, reading from # stdin and writing to stdout # b: all our braces should be balanced, indented back to column 0, in the # headers, hence everything before our #line directive can be ignored # # We can take advantage of this to reduce the work to indent. my $indent_command = $opt{f} ? 'indent' : $opt{F}; if (defined $opt{I}) { $indent_command .= " $opt{I}"; } open $out_fh, '|-', $indent_command or die $?; } else { $out_fh = \*STDOUT; } open my $fh, '<', $tryout or die "Can't open $tryout: $!"; while (<$fh>) { print $out_fh $_ if /$sentinel/o .. 1; } unless ($opt{k}) { foreach($trysource, $tryout) { die "Can't unlink $_" unless unlink $_; } } __END__ =head1 NAME expand-macro.pl - expand C macros using the C preprocessor =head1 SYNOPSIS expand-macro.pl [options] [ < macro-name | macro-expression | - > [headers] ] options: -f use 'indent' to format output -F use to format output (instead of -f) -e erase try.[ic] instead of failing when they're present (errdetect) -k keep them after generating (for handy inspection) -v verbose -I passed into indent =cut perl-5.12.0-RC0/Porting/makerel0000555000175000017500000001455011346121271015120 0ustar jessejesse#!/usr/bin/perl -w # A tool to build a perl release tarball # Very basic but functional - if you're on a unix system. # # If you're on Win32 then it should still work, but various Unix command-line # tools will need to be available somewhere. An obvious choice is to install # Cygwin and ensure its 'bin' folder is on the PATH in the shell where you run # this script. The Cygwin 'bin' folder needs to precede the Windows 'system32' # folder so that Cygwin's 'find' command is found in preference to the Windows # 'find' command. Your Cygwin installation will need to contain at least the # 'cpio' command, in addition to the commands installed by default, and it will # also be useful to have 'curl' and 'diffstat' installed too for later stages # of the release process (namely, Porting\corelist.pl and generating the commit # statistics for the perlXYZdelta.pod file respectively). Finally, ensure that # the 'awk' and 'shasum' commands are copies of gawk.exe and sha1sum.exe # respectively, rather the links to them that only work in a Cygwin bash shell # which they are by default. # # No matter how automated this gets, you'll always need to read # and re-read pumpkin.pod and release_managers_guide.pod to # check for things to be done at various stages of the process. # # Tim Bunce, June 1997 use ExtUtils::Manifest qw(fullcheck); $ExtUtils::Manifest::Quiet = 1; use Getopt::Std; $|=1; sub usage { die <; close PATCHLEVEL; my $patchlevel_h = join "", grep { /^#\s*define/ } @patchlevel_h; print $patchlevel_h; $revision = $1 if $patchlevel_h =~ /PERL_REVISION\s+(\d+)/; $patchlevel = $1 if $patchlevel_h =~ /PERL_VERSION\s+(\d+)/; $subversion = $1 if $patchlevel_h =~ /PERL_SUBVERSION\s+(\d+)/; die "Unable to parse patchlevel.h" unless $subversion >= 0; $vers = sprintf("%d.%d.%d", $revision, $patchlevel, $subversion); # fetch list of local patches my (@local_patches, @lpatch_tags, $lpatch_tags); @local_patches = grep { /^static.*local_patches/../^};/ } @patchlevel_h; @local_patches = grep { !/^\s*,?NULL/ } @local_patches; @lpatch_tags = map { /^\s*,"(\w+)/ } @local_patches; $lpatch_tags = join "-", @lpatch_tags; $perl = "perl-$vers"; $reldir = "$perl"; $lpatch_tags = $opts{s} if defined $opts{s}; $reldir .= "-$lpatch_tags" if $lpatch_tags; print "\nMaking a release for $perl in $relroot/$reldir\n\n"; print "Cross-checking the MANIFEST...\n"; ($missfile, $missentry) = fullcheck(); @$missentry = grep {$_ !~ m!^\.git/! and $_ !~ m!(?:/|^)\.gitignore!} @$missentry; if (@$missfile ) { warn "Can't make a release with MANIFEST files missing:\n"; warn "\t".$_."\n" for (@$missfile); } if (@$missentry ) { warn "Can't make a release with files not listed in MANIFEST\n"; warn "\t".$_."\n" for (@$missentry); } if ("@$missentry" =~ m/\.orig\b/) { # Handy listing of find command and .orig files from patching work. # I tend to run 'xargs rm' and copy and paste the file list. my $cmd = "find . -name '*.orig' -print"; print "$cmd\n"; system($cmd); } die "Aborted.\n" if @$missentry or @$missfile; print "\n"; # VMS no longer has hardcoded version numbers descrip.mms print "Creating $relroot/$reldir release directory...\n"; die "$relroot/$reldir release directory already exists\n" if -e "$relroot/$reldir"; die "$relroot/$reldir.tar.gz release file already exists\n" if -e "$relroot/$reldir.tar.gz"; mkdir("$relroot/$reldir", 0755) or die "mkdir $relroot/$reldir: $!\n"; print "\n"; print "Copying files to release directory...\n"; # ExtUtils::Manifest maniread does not preserve the order $cmd = "awk '{print \$1}' MANIFEST | cpio -pdm $relroot/$reldir"; system($cmd) == 0 or die "$cmd failed"; print "\n"; chdir "$relroot/$reldir" or die $!; my $SEARCH_ROOTS = 't ext lib dist cpan'; print "Setting file permissions...\n"; system("find . -type f -print | xargs chmod 0444"); system("find . -type d -print | xargs chmod 0755"); system("find $SEARCH_ROOTS -name '*.t' -print | xargs chmod +x"); system("find $SEARCH_ROOTS -name 'test.pl' -print | xargs chmod +x"); my @exe = qw( Configure configpm configure.gnu embed.pl installperl installman keywords.pl opcode.pl t/TEST *.SH vms/ext/filespec.t x2p/*.SH Porting/findrfuncs Porting/genlog Porting/makerel Porting/*.pl mpeix/nm mpeix/relink Cross/generate_config_sh Cross/warp ); system("chmod +x @exe") == 0 or die "system: $!"; my @writables = qw( NetWare/config_H.wc NetWare/Makefile keywords.h opcode.h opnames.h pp_proto.h pp.sym proto.h embed.h embedvar.h global.sym overload.c overload.h perlapi.h perlapi.c cpan/Devel-PPPort/module2.c cpan/Devel-PPPort/module3.c reentr.c reentr.h regcharclass.h regnodes.h warnings.h lib/warnings.pm win32/Makefile win32/Makefile.ce win32/makefile.mk win32/config_H.bc win32/config_H.gc win32/config_H.vc utils/Makefile uconfig.h ); system("chmod +w @writables") == 0 or die "system: $!"; chdir ".." or die $!; exit if $opts{n}; my $src = (-e $perl) ? $perl : 'perl'; # 'perl' in maint branch print "Creating and compressing the tar.gz file...\n"; $cmd = "tar cf - $reldir | gzip --best > $reldir.tar.gz"; system($cmd) == 0 or die "$cmd failed"; if ($opts{b}) { print "Creating and compressing the tar.bz2 file...\n"; $cmd = "tar cf - $reldir | bzip2 > $reldir.tar.bz2"; system($cmd) == 0 or die "$cmd failed"; } print "\n"; system("ls -ld $perl*"); print "\n"; my $null = $^O eq 'MSWin32' ? 'NUL' : '/dev/null'; for my $sha (qw(sha1 shasum sha1sum)) { if (`which $sha 2>$null`) { system("$sha $perl*.tar.*"); last; } } perl-5.12.0-RC0/Porting/corelist-perldelta.pl0000555000175000017500000000550011347222635017712 0ustar jessejesse#!perl use 5.010; use strict; use warnings; use lib 'Porting'; use Maintainers qw/%Modules/; use Module::CoreList; my $deprecated; #--------------------------------------------------------------------------# sub added { my ($mod, $old_v, $new_v) = @_; say "=item C<$mod>\n"; say "Version $new_v has been added to the Perl core.\n"; } sub updated { my ($mod, $old_v, $new_v) = @_; say "=item C<$mod>\n"; say "Upgraded from version $old_v to $new_v.\n"; if ( $deprecated->{$mod} ) { say "NOTE: C<$mod> is deprecated and may be removed from a future version of Perl.\n"; } } sub removed { my ($mod, $old_v, $new_v) = @_; say "=item C<$mod>\n"; say "Removed from the Perl core. Prior version was $old_v.\n"; } sub generate_section { my ($title, $item_sub, @mods ) = @_; return unless @mods; say "=head2 $title\n"; say "=over 4\n"; for my $tuple ( sort { lc($a->[0]) cmp lc($b->[0]) } @mods ) { my ($mod,$old_v,$new_v) = @$tuple; $old_v //= q('undef'); $new_v //= q('undef'); $item_sub->($mod, $old_v, $new_v); } say "=back\n"; } #--------------------------------------------------------------------------# my $corelist = \%Module::CoreList::version; my @versions = sort keys %$corelist; # by default, compare latest two version in CoreList; my ($old, $new) = @ARGV; $old ||= $versions[-2]; $new ||= $versions[-1]; $deprecated = $Module::CoreList::deprecated{$new}; my (@new,@deprecated,@removed,@pragmas,@modules); # %Modules defines what is currently in core for my $k ( keys %Modules ) { warn "Considering $k"; next unless exists $corelist->{$new}{$k}; my $old_ver = $corelist->{$old}{$k}; my $new_ver = $corelist->{$new}{$k}; # in core but not in last corelist if ( ! exists $corelist->{$old}{$k} ) { push @new, [$k, undef, $new_ver]; } # otherwise just pragmas or modules else { my $old_ver = $corelist->{$old}{$k}; my $new_ver = $corelist->{$new}{$k}; next unless defined $old_ver && defined $new_ver && $old_ver ne $new_ver; my $tuple = [ $k, $old_ver, $new_ver ]; if ( $k eq lc $k ) { push @pragmas, $tuple; } else { push @modules, $tuple; } } } # in old corelist, but not this one => removed # N.B. This is exhaustive -- not just what's in %Modules, so modules removed from # distributions will show up here, too. Some person will have to review to see what's # important. That's the best we can do without a historical Maintainers.pl for my $k ( keys %{ $corelist->{$old} } ) { if ( ! exists $corelist->{$new}{$k} ) { push @removed, [$k, $corelist->{$old}{$k}, undef]; } } generate_section("New Modules and Pragmata", \&added, @new); generate_section("Pragmata Changes", \&updated, @pragmas); generate_section("Updated Modules", \&updated, @modules); generate_section("Removed Modules and Pragmata", \&removed, @removed); perl-5.12.0-RC0/Porting/config_h.pl0000555000175000017500000000346411325125741015673 0ustar jessejesse#!/usr/bin/perl # This script reorders config_h.SH after metaconfig # Changing metaconfig is too complicated # # Copyright (C) 2005-2007 by H.Merijn Brand (m)'07 [18-04-2007] # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the README file. use strict; use warnings; my ($cSH, $ch, @ch, %ch) = ("config_h.SH"); open $ch, "<$cSH" or die "Cannot open $cSH: $!\n"; { local $/ = "\n\n"; @ch = <$ch>; close $ch; } sub ch_index () { %ch = (); foreach my $ch (0 .. $#ch) { while ($ch[$ch] =~ m{^/\* ([A-Z]\w+)}gm) { $ch{$1} = $ch; } } } # ch_index my %dep = ( # This symbol must be defined BEFORE ... BYTEORDER => [ qw( UVSIZE ) ], LONGSIZE => [ qw( BYTEORDER ) ], MULTIARCH => [ qw( BYTEORDER MEM_ALIGNBYTES ) ], USE_CROSS_COMPILE => [ qw( BYTEORDER MEM_ALIGNBYTES ) ], HAS_QUAD => [ qw( I64TYPE ) ], HAS_GETGROUPS => [ qw( Groups_t ) ], HAS_SETGROUPS => [ qw( Groups_t ) ], ); my $changed; do { $changed = 0; foreach my $sym (keys %dep) { ch_index; foreach my $dep (@{$dep{$sym}}) { print STDERR "Check if $sym\t($ch{$sym}) precedes $dep\t($ch{$dep})\n"; $ch{$sym} < $ch{$dep} and next; my $ch = splice @ch, $ch{$sym}, 1; splice @ch, $ch{$dep}, 0, $ch; $changed++; ch_index; } } } while ($changed); # 30327 for (grep m{echo .Extracting \$CONFIG_H} => @ch) { my $case = join "\n", qq{case "\$CONFIG_H" in}, qq{already-done) echo "Not re-extracting config.h" ;;}, qq{*)}, ""; s{^(?=echo .Extracting)}{$case}m; } push @ch, ";;\nesac\n"; open $ch, "> $cSH" or die "Cannot write $cSH: $!\n"; print $ch < \$rank, # rank authors "thanks-applied" => \$ta, # ranks committers "acknowledged=s" => \@authors , # authors files "percentage" => \$percentage, # show as %age "cumulative" => \$cumulative, "reverse" => \$reverse, ); if (!$result or (($rank||0) + ($ta||0) + (@authors ? 1 : 0) != 1) or !@ARGV) { die <<"EOS"; $0 --rank Changelogs # rank authors by patches $0 --acknowledged Changelogs # Display unacknowledged authors $0 --thanks-applied Changelogs # ranks committers $0 --percentage ... # show rankings as percentages $0 --cumulative ... # show rankings cumulatively $0 --reverse ... # show rankings in reverse Specify stdin as - if needs be. Remember that option names can be abbreviated. EOS } my $prev = ""; my %map; while () { chomp; s/\\100/\@/g; $_ = lc; if (my ($correct, $alias) = /^\s*([^#\s]\S*)\s+(.*\S)/) { $correct =~ s/^\\043/#/; if ($correct eq '+') {$correct = $prev} else {$prev = $correct} $map {$alias} = $correct; } } # # Email addresses for we do not have names. # $map {$_} = "?" for "bah\100longitude.com", "bbucklan\100jpl-devvax.jpl.nasa.gov", "bilbo\100ua.fm", "bob\100starlabs.net", "cygwin\100cygwin.com", "david\100dhaller.de", "erik\100cs.uni-jena.de", "info\100lingo.kiev.ua", # Lingo Translation agency "jms\100mathras.comcast.net", "premchai21\100yahoo.com", "pxm\100nubz.org", "raf\100tradingpost.com.au", "smoketst\100hp46t243.cup.hp.com", "root\100chronos.fi.muni.cz", # no clue - jrv 20090803 "gomar\100md.media-web.de", # no clue - jrv 20090803 "data-drift\100so.uio.no", # no data. originally private message from 199701282014.VAA12645@selters.uio.no "arbor\100al37al08.telecel.pt", # reported perlbug ticket 5196 - no actual code contribution. no real name - jrv 20091006 "oracle\100pcr8.pcr.com", # Reported perlbug ticket 1015 - no patch - Probably Ed Eddington ed@pcr.com ; # # Email addresses for people that don't have an email address in AUTHORS # Presumably deliberately? # $map {$_} = '!' for # Nick Ing-Simmons has passed away (2006-09-25). "nick\100ing-simmons.net", "nik\100tiuk.ti.com", "nick.ing-simmons\100elixent.com", "nick\100ni-s.u-net.com", "nick.ing-simmons\100tiuk.ti.com", # Iain Truskett has passed away (2003-12-29). "perl\100dellah.anu.edu.au", "spoon\100dellah.org", "spoon\100cpan.org", # Ton Hospel "me-02\100ton.iguana.be", "perl-5.8.0\100ton.iguana.be", "perl5-porters\100ton.iguana.be", # Beau Cox "beau\100beaucox.com", # Randy W. Sims "ml-perl\100thepierianspring.org", # perl internal addresses "perl5-porters\100africa.nicoh.com", "perlbug\100perl.org",, "perl5-porters.nicoh.com", "perlbug-followup\100perl.org", "perlbug-comment\100perl.org", "bug-module-corelist\100rt.cpan.org", "bug-storable\100rt.cpan.org", "bugs-perl5\100bugs6.perl.org", "unknown", "unknown\100unknown", "unknown\100longtimeago", "unknown\100perl.org", "", "(none)", ; if (@authors) { my %raw; foreach my $filename (@authors) { open FH, "<$filename" or die "Can't open $filename: $!"; while () { next if /^\#/; next if /^-- /; if (/<([^>]+)>/) { # Easy line. $raw{$1}++; } elsif (/^([-A-Za-z0-9 .\'À-ÖØöø-ÿ]+)[\t\n]/) { # Name only $untraced{$1}++; } elsif (length $_) { chomp; warn "Can't parse line '$_'"; } else { next } } } foreach (keys %raw) { print "E-mail $_ occurs $raw{$_} times\n" if $raw{$_} > 1; $_ = lc $_; $authors{$map{$_} || $_}++; } ++$authors{'!'}; ++$authors{'?'}; } my @lines = split(/^commit\s*/sm,join('',<>)); for ( @lines) { next if m/^$/; next if m/^(\S*?)^Merge:/ism; # skip merge commits if (m/^(.*?)^Author:\s*(.*?)^Date:\s*(.*?)^(.*)$/gism) { # new patch ($patch, $committer, $date,$log) = ($1,$2,$3,$4); chomp($committer); unless ($committer) { die $_} &process ($committer, $patch, $log); } else { die "XXX $_ did not match";} } if ($rank) { &display_ordered(\%patchers); } elsif ($ta) { &display_ordered(\%committers); } elsif (%authors) { my %missing; foreach (sort keys %patchers) { next if $authors{$_}; # Sort by number of patches, then name. $missing{$patchers{$_}}->{$_}++; } foreach my $patches (sort {$b <=> $a} keys %missing) { print "\n\n=head1 $patches patch(es)\n\n"; foreach my $author (sort keys %{$missing{$patches}}) { my $xauthor = $author; $xauthor =~ s/@/\\100/g; # xxx temp hack print "".($real_names{$author}||$author) ."\t\t\t<" . $xauthor.">\n" ; } } } sub display_ordered { my $what = shift; my @sorted; my $total; while (my ($name, $count) = each %$what) { push @{$sorted[$count]}, $name; $total += $count; } my $i = @sorted; return unless @sorted; my $sum = 0; foreach my $i ($reverse ? 0 .. $#sorted : reverse 0 .. $#sorted) { next unless $sorted[$i]; my $prefix; $sum += $i * @{$sorted[$i]}; # Value to display is either this one, or the cumulative sum. my $value = $cumulative ? $sum : $i; if ($percentage) { $prefix = sprintf "%6.2f:\t", 100 * $value / $total; } else { $prefix = "$value:\t"; } print wrap ($prefix, "\t", join (" ", sort @{$sorted[$i]}), "\n"); } } sub process { my ($committer, $patch, $log) = @_; return unless $committer; my @authors = $log =~ /From:\s+.*?([^"\@ \t\n<>]+\@[^"\@ \t\n<>]+)/gm; if (@authors) { foreach my $addr (@authors) { $patchers{_raw_address($addr)}++; } # print "$patch: @authors\n"; $committers{_raw_address($committer)}++; } else { # print "$patch: $committer\n"; # Not entirely fair as this means that the maint pumpking scores for # everything intergrated that wasn't a third party patch in blead $patchers{_raw_address($committer)}++; } } sub _raw_address { my $addr = shift; my $real_name; if ($addr =~ /<.*>/) { $addr =~ s/^\s*(.*)\s*<\s*(.*?)\s*>.*$/$2/ ; $real_name = $1; } $addr = lc $addr; $addr = $map{$addr} || $addr; $addr =~ s/\\100/@/g; # Sometimes, there are encoded @ signs in the git log. if ($real_name) { $real_names{$addr} = $real_name}; return $addr; } __DATA__ # # List of mappings. First entry the "correct" email address, as appears # in the AUTHORS file. Second is any "alias" mapped to it. # # If the "correct" email address is a '+', the entry above is reused; # this for addresses with more than one alias. # # Note that all entries are in lowercase. Further, no '@' signs should # appear; use \100 instead. # # # Committers. # adi enache\100rdslink.ro alanbur alan.burlison\100sun.com + alan.burlison\100uk.sun.com + aburlison\100cix.compulink.co.uk ams ams\100toroid.org + ams\100wiw.org chip chip\100pobox.com + chip\100perl.com + salzench\100nielsenmedia.com + chip\100atlantic.net + chip\100rio.atlantic.net + salzench\100dun.nielsen.com + chip\100ci005.sv2.upperbeyond.com craigb craig.berry\100psinetcs.com + craig.berry\100metamorgs.com + craig.berry\100signaltreesolutions.com + craigberry\100mac.com + craig.a.berry\100gmail.com + craig a. berry) davem davem\100fdgroup.com + davem\100iabyn.nospamdeletethisbit.com + davem\100iabyn.com + davem\100fdgroup.co.uk + davem\100fdisolutions.com + davem\100iabyn.com demerphq demerphq\100gmail.com + yves.orton\100de.mci.com + yves.orton\100mciworldcom.de + demerphq\100dromedary.booking.com + demerphq\100gemini.(none) + demerphq\100camel.booking.com + demerphq\100hotmail.com doughera doughera\100lafayette.edu + doughera\100lafcol.lafayette.edu + doughera\100fractal.phys.lafayette.edu + doughera.lafayette.edu + doughera\100newton.phys.lafayette.edu gbarr gbarr\100pobox.com + bodg\100tiuk.ti.com + gbarr\100ti.com + graham.barr\100tiuk.ti.com + gbarr\100monty.mutatus.co.uk gisle gisle\100activestate.com + gisle\100aas.no + aas\100aas.no + aas\100bergen.sn.no gsar gsar\100activestate.com + gsar\100cpan.org + gsar\100engin.umich.edu hv hv\100crypt.compulink.co.uk + hv\100crypt.org + hv\100iii.co.uk jhi jhi\100iki.fi + jhietaniemi\100gmail.com + jhi\100kosh.hut.fi + jhi\100alpha.hut.fi + jhi\100cc.hut.fi + jhi\100hut.fi + jarkko.hietaniemi\100nokia.com + jarkko.hietaniemi\100cc.hut.fi jesse jesse\100bestpractical.com + jesse\100fsck.com + jesse\100perl.org merijn h.m.brand\100xs4all.nl + h.m.brand\100hccnet.nl + merijn\100l1.procura.nl + merijn\100a5.(none) mhx mhx-perl\100gmx.net + mhx\100r2d2.(none) nicholas nick\100unfortu.net + nick\100ccl4.org + nick\100talking.bollo.cx + nick\100plum.flirble.org + nick\100babyhippo.co.uk + nick\100bagpuss.unfortu.net + nick\100babyhippo.com + Nicholas Clark (sans From field in mail header) pudge pudge\100pobox.com rgs rgarciasuarez\100free.fr + rgarciasuarez\100mandrakesoft.com + rgarciasuarez\100mandriva.com + rgarciasuarez\100gmail.com + raphel.garcia-suarez\100hexaflux.com + rgs@consttype.org sky sky\100nanisky.com + artur\100contiller.se + arthur\100contiller.se steveh steve.m.hay\100googlemail.com + stevehay\100planit.com + steve.hay\100uk.radan.com stevep steve\100fisharerojo.org + steve.peters\100gmail.com + root\100dixie.cscaper.com timb Tim.Bunce\100pobox.com + tim.bunce\100ig.co.uk # # Mere mortals. # \043####\100juerd.nl juerd\100cpan.org + juerd\100convolution.nl 7k8lrvf02\100sneakemail.com kjx9zthh3001\100sneakemail.com + dtr8sin02\100sneakemail.com + rt8363b02\100sneakemail.com + o6hhmk002\100sneakemail.com + smueller\100cpan.org + l2ot9pa02\100sneakemail.com + wyp3rlx02\100sneakemail.com + 0mgwtfbbq\100sneakemail.com + xyey9001\100sneakemail.com a.r.ferreira\100gmail.com aferreira\100shopzilla.com abe\100ztreet.demon.nl abeltje\100cpan.org abela\100hsc.fr abela\100geneanet.org abigail\100abigail.be abigail\100foad.org + abigail\100abigail.nl + abigail\100fnx.com aburt\100isis.cs.du.edu isis!aburt ach\100mpe.mpg.de ach\100rosat.mpe-garching.mpg.de adavies\100ptc.com alex.davies\100talktalk.net ajohnson\100nvidia.com ajohnson\100wischip.com + anders\100broadcom.com alexm\100netli.com alexm\100w-m.ru alex-p5p\100earth.li alex\100rcon.rog alexmv\100mit.edu alex\100chmrr.net alian\100cpan.org alian\100alianwebserver.com allen\100grumman.com allen\100gateway.grumman.com allen\100huarp.harvard.edu nort\100bottesini.harvard.edu + nort\100qnx.com allens\100cpan.org easmith\100beatrice.rutgers.edu + root\100dogberry.rutgers.edu andreas.koenig\100anima.de andreas.koenig.gmwojprw\100franz.ak.mind.de + andreas.koenig.7os6vvqr\100franz.ak.mind.de + a.koenig\100mind.de + k\100anna.in-berlin.de + andk\100cpan.org + koenig\100anna.mind.de + k\100anna.mind.de + root\100ak-71.mind.de + root\100ak-75.mind.de + k\100sissy.in-berlin.de + a.koenig\100kulturbox.de + k\100sissy.in-berlin.de + root\100dubravka.in-berlin.de anno4000\100lublin.zrz.tu-berlin.de anno4000\100mailbox.tu-berlin.de + siegel\100zrz.tu-berlin.de arnold\100gnu.ai.mit.edu arnold\100emoryu2.arpa + gatech!skeeve!arnold arussell\100cs.uml.edu adam\100adam-pc.(none) ash\100cpan.org ash_cpan\100firemirror.com avarab\100gmail.com avar\100cpan.org bailey\100newman.upenn.edu bailey\100hmivax.humgen.upenn.edu + bailey\100genetics.upenn.edu + bailey.charles\100gmail.com bah\100ecnvantage.com bholzman\100longitude.com barries\100slaysys.com root\100jester.slaysys.com bkedryna\100home.com bart\100cg681574-a.adubn1.nj.home.com bcarter\100gumdrop.flyinganvil.org q.eibcartereio.=~m-b.{6}-cgimosx\100gumdrop.flyinganvil.org ben_tilly\100operamail.com btilly\100gmail.com + ben_tilly\100hotmail.com ben\100morrow.me.uk mauzo\100csv.warwick.ac.uk + mauzo\100.(none) bepi\100perl.it enrico.sorcinelli\100gmail.com bert\100alum.mit.edu bert\100genscan.com brian.d.foy\100gmail.com bdfoy\100cpan.org BQW10602\100nifty.com sadahiro\100cpan.org chromatic\100wgz.org chromatic\100rmci.net clintp\100geeksalad.org cpierce1\100ford.com clkao\100clkao.org clkao\100bestpractical.com corion\100corion.net corion\100cpan.org cp\100onsitetech.com publiustemp-p5p\100yahoo.com + publiustemp-p5p3\100yahoo.com cpan\100audreyt.org autrijus\100egb.elixus.org + autrijus\100geb.elixus.org + autrijus\100gmail.com + autrijus\100ossf.iis.sinica.edu.tw + autrijus\100autrijus.org + audreyt\100audreyt.org cpan\100ton.iguana.be me-01\100ton.iguana.be crt\100kiski.net perl\100ctweten.amsite.com dairiki\100dairiki.org dairiki at dairiki.org dagolden\100cpan.org xdaveg\100gmail.com damian\100conway.org damian\100cs.monash.edu.au dan\100sidhe.org sugalsd\100lbcc.cc.or.us + sugalskd\100osshe.edu daniel\100bitpusher.com daniel\100biz.bitpusher.com david.dyck\100fluke.com dcd\100tc.fluke.com david\100kineticode.com david\100wheeler.com + david\100wheeler.net dennis\100booking.com dennis\100camel.ams6.corp.booking.com dev-perl\100pimb.org knew-p5p\100pimb.org djberg86\100attbi.com djberg96\100attbi.com domo\100computer.org shouldbedomo\100mac.com + domo\100slipper.ip.lu + domo\100tcp.ip.lu dougm\100covalent.net dougm\100opengroup.org + dougm\100osf.org dougw\100cpan.org doug_wilson\100intuit.com dwegscheid\100qtm.net wegscd\100whirlpool.com edwardp\100excitehome.net epeschko\100den-mdev1 + epeschko\100elmer.tci.com + esp5\100pge.com egf7\100columbia.edu efifer\100sanwaint.com eggert\100twinsun.com eggert\100sea.sm.unisys.com fugazi\100zyx.net larrysh\100cpan.org + lshatzer\100islanddata.com gbacon\100itsc.uah.edu gbacon\100adtrn-srv4.adtran.com gerberb\100zenez.com root\100devsys0.zenez.com gfuji\100cpan.org g.psy.va\100gmail.com gerard\100ggoossen.net gerard\100tty.nl gibreel\100pobox.com stephen.zander\100interlock.mckesson.com + srz\100loopback gnat\100frii.com gnat\100prometheus.frii.com gp\100familiehaase.de gerrit\100familiehaase.de grazz\100pobox.com grazz\100nyc.rr.com gward\100ase.com greg\100bic.mni.mcgill.ca hansmu\100xs4all.nl hansm\100icgroup.nl + hansm\100icgned.nl + hans\100icgned.nl + hans\100icgroup.nl + hansm\100euronet.nl + hansm\100euro.net hio\100ymir.co.jp hio\100hio.jp hops\100sco.com hops\100scoot.pdev.sco.com ingo_weinhold\100gmx.de bonefish\100cs.tu-berlin.de james\100mastros.biz theorb\100desert-island.me.uk jand\100activestate.com jan.dubois\100ibm.net japhy\100pobox.com japhy\100pobox.org + japhy\100perlmonk.org + japhy\100cpan.org + jeffp\100crusoe.net jari.aalto\100poboxes.com jari.aalto\100cante.net jarausch\100numa1.igpm.rwth-aachen.de helmutjarausch\100unknown jasons\100cs.unm.edu jasons\100sandy-home.arc.unm.edu jbuehler\100hekimian.com jhpb\100hekimian.com jcromie\100100divsol.com jcromie\100cpan.org + jim.cromie\100gmail.com jidanni\100jidanni.org jidanni\100hoffa.dreamhost.com jdhedden\100cpan.org jerry\100hedden.us + jdhedden\1001979.usna.com + jdhedden\100gmail.com + jdhedden\100yahoo.com + jhedden\100pn100-02-2-356p.corp.bloomberg.com jeremy\100zawodny.com jzawodn\100wcnet.org jesse\100sig.bsh.com jesse\100ginger jfriedl\100yahoo.com jfriedl\100yahoo-inc.com jfs\100fluent.com jfs\100jfs.fluent.com jhannah\100omnihotels.com jay\100jays.net jjore\100cpan.org twists\100gmail.com jns\100integration-house.com jns\100gellyfish.com + gellyfish\100gellyfish.com john\100atlantech.com john\100titanic.atlantech.com john\100johnwright.org john.wright\100hp.com joseph\100cscaper.com joseph\1005sigma.com joshua\100rodd.us jrodd\100pbs.org jtobey\100john-edwin-tobey.org jtobey\100user1.channel1.com jpeacock\100rowman.com john.peacock\100havurah-software.org + jpeacock\100havurah-software.org + jpeacock\100dsl092-147-156.wdc1.dsl.speakeasy.net + jpeacock\100jpeacock-hp.doesntexist.org jql\100accessone.com jql\100jql.accessone.com jsm28\100hermes.cam.ac.uk jsm28\100cam.ac.uk kane\100dwim.org kane\100xs4all.net + kane\100cpan.org + kane\100xs4all.nl + jos\100dwim.org + jib\100ripe.net ken\100mathforum.org kenahoo\100gmail.com + ken.williams\100thomsonreuters.com kroepke\100dolphin-services.de kay\100dolphin-services.de kstar\100wolfetech.com kstar\100cpan.org + kurt_starsinic\100ml.com + kstar\100www.chapin.edu + kstar\100chapin.edu larry\100wall.org lwall\100jpl-devvax.jpl.nasa.gov + lwall\100netlabs.com + larry\100netlabs.com + lwall\100sems.com + lwall\100scalpel.netlabs.com laszlo.molnar\100eth.ericsson.se molnarl\100cdata.tvnet.hu + ml1050\100freemail.hu lewart\100uiuc.edu lewart\100vadds.cvm.uiuc.edu + d-lewart\100uiuc.edu lstein\100cshl.org lstein\100formaggio.cshl.org + lstein\100genome.wi.mit.edu lupe\100lupe-christoph.de lupe\100alanya.m.isar.de lutherh\100stratcom.com lutherh\100infinet.com mab\100wdl.loral.com markb\100rdcf.sm.unisys.com marcel\100codewerk.com gr\100univie.ac.at mark.p.lutz\100boeing.com tecmpl1\100triton.ca.boeing.com marnix\100gmail.com pttesac!marnix!vanam mats\100sm6sxl.net mats\100sm5sxl.net mbarbon\100dsi.unive.it mattia.barbon\100libero.it mcmahon\100ibiblio.org mcmahon\100metalab.unc.edu me\100davidglasser.net glasser\100tang-eleven-seventy-nine.mit.edu merijnb\100iloquent.nl merijnb\100ms.com + merijnb\100iloquent.com merlyn\100stonehenge.com merlyn\100gadget.cscaper.com mgjv\100comdyn.com.au mgjv\100tradingpost.com.au mlh\100swl.msd.ray.com webtools\100uewrhp03.msd.ray.com michael.schroeder\100informatik.uni-erlangen.de mls\100suse.de mike\100stok.co.uk mike\100exegenix.com mjtg\100cam.ac.uk mjtg\100cus.cam.ac.uk mikedlr\100tardis.ed.ac.uk mikedlr\100it.com.pl moritz\100casella.verplant.org moritz\100faui2k3.org + moritz lenz neale\100VMA.TABNSW.COM.AU neale\100pucc.princeton.edu neeracher\100mac.com neeri\100iis.ee.ethz.ch neil\100bowers.com neilb\100cre.canon.co.uk nospam-abuse\100bloodgate.com tels\100bloodgate.com + perl_dummy\100bloodgate.com ian.phillipps\100iname.com ian_phillipps\100yahoo.co.uk + ian\100dial.pipex.com ignasi.roca\100fujitsu-siemens.com ignasi.roca\100fujitsu.siemens.es ikegami\100adaelis.com eric\100fmdev10.(none) ilmari\100ilmari.org ilmari\100vesla.ilmari.org illpide\100telecel.pt arbor\100al37al08.telecel.pt # see http://www.nntp.perl.org/group/perl.perl5.porters/2001/01/msg28925.html # ilya\100math.berkeley.edu ilya\100math.ohio-state.edu + nospam-abuse\100ilyaz.org + [9]ilya\100math.ohio-state.edu ilya\100martynov.org ilya\100juil.nonet okamoto\100corp.hp.com okamoto\100hpcc123.corp.hp.com orwant\100oreilly.com orwant\100media.mit.edu p5-authors\100crystalflame.net perl\100crystalflame.net + rs\100crystalflame.net + coral\100eekeek.org + coral\100moonlight.crystalflame.net + rs\100oregonnet.com paul.green\100stratus.com paul_greenvos\100vos.stratus.com + pgreen\100seussnt.stratus.com paul.marquess\100btinternet.com paul_marquess\100yahoo.co.uk + paul.marquess\100ntlworld.com + paul.marquess\100openwave.com + pmarquess\100bfsec.bt.co.uk + pmqs\100cpan.org + paul\100paul-desktop.(none) Pavel.Zakouril\100mff.cuni.cz root\100egg.karlov.mff.cuni.cz pcg\100goof.com schmorp\100schmorp.de perl\100cadop.com cdp\100hpescdp.fc.hp.com perl\100greerga.m-l.org greerga\100m-l.org perl\100profvince.com vince\100profvince.com perl-rt\100wizbit.be p5p\100perl.wizbit.be # Maybe we should special case this to get real names out? Peter.Dintelmann\100Dresdner-Bank.com peter.dintelmann\100dresdner-bank.com # NOTE: There is an intentional trailing space in the line above pfeifer\100wait.de pfeifer\100charly.informatik.uni-dortmund.de + upf\100de.uu.net rabbit\100rabbit.us rabbit+bugs\100rabbit.us phil\100perkpartners.com phil\100finchcomputer.com pimlott\100idiomtech.com andrew\100pimlott.net + pimlott\100abel.math.harvard.edu pixel\100mandriva.com pixel\100mandrakesoft.com pne\100cpan.org philip.newton\100gmx.net + philip.newton\100datenrevision.de + pnewton\100gmx.de pprymmer\100factset.com pvhp\100forte.com public\100khwilliamson.com khw\100karl.(none) + khw\100khw-desktop.(none) radu\100netsoft.ro rgreab\100fx.ro raphael.manfredi\100pobox.com raphael_manfredi\100grenoble.hp.com renee.baecker\100smart-websolutions.de reneeb\100reneeb-desktop.(none) richard.foley\100rfi.net richard.foley\100t-online.de + richard.foley\100ubs.com + richard.foley\100ubsw.com rick\100consumercontact.com rick\100bort.ca + rick.delaney\100rogers.com + rick\100bort.ca + rick.delaney\100home.com rjbs\100cpan.org rjbs-perl-p5p\100lists.manxome.org + perl.p5p\100rjbs.manxome.org rjk\100linguist.dartmouth.edu rjk\100linguist.thayer.dartmouth.edu + rjk-perl-p5p\100tamias.net rjray\100redhat.com rjray\100uswest.com rmgiroux\100acm.org rmgiroux\100hotmail.com + mgiroux\100bear.com rmbarker\100cpan.org rmb1\100cise.npl.co.uk + robin.barker\100npl.co.uk + rmb\100cise.npl.co.uk robertmay\100cpan.org rob\100themayfamily.me.uk roberto\100keltia.freenix.fr roberto\100eurocontrol.fr robin\100cpan.org robin\100kitsite.com roderick\100argon.org roderick\100gate.net + roderick\100ibcinc.com rootbeer\100teleport.com rootbeer\100redcat.com + tomphoenix\100unknown rurban\100x-ray.at rurban\100cpan.org schubiger\100cpan.org steven\100accognoscere.org + sts\100accognoscere.org + schubiger\100gmail.com schwern\100pobox.com schwern\100gmail.com + schwern\100athens.arena-i.com + schwern\100blackrider.aocn.com + schwern\100ool-18b93024.dyn.optonline.net scotth\100sgi.com author scotth\100sgi.com 842220273 +0000 + schotth\100sgi.com schwab\100suse.de schwab\100issan.informatik.uni-dortmund.de + schwab\100ls5.informatik.uni-dortmund.de sebastien\100aperghis.net maddingue\100free.fr + saper\100cpan.org shlomif\100vipe.technion.ac.il shlomif\100iglu.org.il simon\100simon-cozens.org simon\100pembro4.pmb.ox.ac.uk + simon\100brecon.co.uk + simon\100othersideofthe.earth.li + simon\100cozens.net + simon\100netthink.co.uk slaven\100rezic.de slaven.rezic\100berlin.de + srezic\100iconmobile.com + srezic\100cpan.org + eserte\100cs.tu-berlin.de + eserte\100vran.herceg.de smcc\100mit.edu smcc\100ocf.berkeley.edu + smcc\100csua.berkeley.edu + alias\100mcs.com + smccam\100uclink4.berkeley.edu spider\100orb.nashua.nh.us spider\100web.zk3.dec.com + spider\100leggy.zk3.dec.com + spider-perl\100orb.nashua.nh.us + spider\100peano.zk3.dec.com + spider.boardman\100orb.nashua.nh.us> + spidb\100cpan.org + spider.boardman\100orb.nashua.nh.us + root\100peano.zk3.dec.com spp\100ds.net spp\100psa.pencom.com + spp\100psasolar.colltech.com + spp\100spotter.yi.org stef\100mongueurs.net stef\100payrard.net + s.payrard\100wanadoo.fr + properler\100freesurf.fr + stef\100francenet.fr sthoenna\100efn.org ysth\100raven.shiftboard.com tassilo.parseval\100post.rwth-aachen.de tassilo.von.parseval\100rwth-aachen.de tchrist\100perl.com tchrist\100mox.perl.com + tchrist\100jhereg.perl.com thomas.dorner\100start.de tdorner\100amadeus.net tjenness\100cpan.org t.jenness\100jach.hawaii.edu + timj\100jach.hawaii.edu tobez\100tobez.org tobez\100plab.ku.dk tom\100compton.nu thh\100cyberscience.com tom.horsley\100mail.ccur.com tom.horsley\100ccur.com + tom\100amber.ssd.hcsc.com vkonovalov\100lucent.com vkonovalov\100peterstar.ru + konovalo\100mail.wplus.net + vadim\100vkonovalov.ru + vkonovalov\100spb.lucent.com + vkonovalov\100alcatel-lucent.com whatever\100davidnicol.com davidnicol\100gmail.com wolfgang.laun\100alcatel.at wolfgang.laun\100chello.at + wolfgang.laun\100thalesgroup.com + wolfgang.laun\100gmail.com yath\100yath.de yath-perlbug\100yath.de perl-5.12.0-RC0/Porting/checkcfgvar.pl0000555000175000017500000000500711325125741016360 0ustar jessejesse#!/usr/bin/perl -w # # Check that the various config.sh-clones have (at least) all the # same symbols as the top-level config_h.SH so that the (potentially) # needed symbols are not lagging after how Configure thinks the world # is laid out. # # VMS is probably not handled properly here, due to their own # rather elaborate DCL scripting. # use strict; my $MASTER_CFG = "config_h.SH"; my %MASTER_CFG; my @CFG = ( # This list contains both 5.8.x and 5.9.x files, # we check from MANIFEST whether they are expected to be present. # We can't base our check on $], because that's the version of the # perl that we are running, not the version of the source tree. "Cross/config.sh-arm-linux", "epoc/config.sh", "NetWare/config.wc", "symbian/config.sh", "uconfig.sh", "plan9/config_sh.sample", "vos/config.alpha.def", "vos/config.ga.def", "win32/config.bc", "win32/config.gc", "win32/config.vc", "win32/config.vc64", "win32/config.ce", "configure.com", "Porting/config.sh", ); sub read_file { my ($fn, $sub) = @_; if (open(my $fh, $fn)) { local $_; while (<$fh>) { &$sub; } } else { die "$0: Failed to open '$fn' for reading: $!\n"; } } sub config_h_SH_reader { my $cfg = shift; return sub { while (/[^\\]\$([a-z]\w+)/g) { my $v = $1; next if $v =~ /^(CONFIG_H|CONFIG_SH)$/; $cfg->{$v}++; } } } read_file($MASTER_CFG, config_h_SH_reader(\%MASTER_CFG)); my %MANIFEST; read_file("MANIFEST", sub { $MANIFEST{$1}++ if /^(.+?)\t/; }); my @MASTER_CFG = sort keys %MASTER_CFG; sub check_cfg { my ($fn, $cfg) = @_; for my $v (@MASTER_CFG) { print "$fn: missing '$v'\n" unless exists $cfg->{$v}; } } for my $cfg (@CFG) { unless (exists $MANIFEST{$cfg}) { print STDERR "[skipping not-expected '$cfg']\n"; next; } my %cfg; read_file($cfg, sub { return if /^\#/ || /^\s*$/ || /^\:/; if ($cfg eq 'configure.com') { s/(\s*!.*|\s*)$//; # remove trailing comments or whitespace return if ! /^\$\s+WC "(\w+)='(.*)'"$/; } # foo='bar' # foo=bar # $foo='bar' # VOS 5.8.x specialty # $foo=bar # VOS 5.8.x specialty if (/^\$?(\w+)='(.*)'$/) { $cfg{$1}++; } elsif (/^\$?(\w+)=(.*)$/) { $cfg{$1}++; } elsif (/^\$\s+WC "(\w+)='(.*)'"$/) { $cfg{$1}++; } else { warn "$cfg:$.:$_"; } }); if ($cfg eq 'configure.com') { $cfg{startperl}++; # Cheat. } check_cfg($cfg, \%cfg); } perl-5.12.0-RC0/Porting/core-cpan-diff0000444000175000017500000004010111326750237016251 0ustar jessejesse#!/usr/bin/env perl # core-cpan-diff: Compare CPAN modules with their equivalent in core # Originally based on App::DualLivedDiff by Steffen Mueller. use strict; use warnings; use 5.010; use Getopt::Long; use File::Temp (); use File::Path (); use File::Spec; use Archive::Extract; use IO::Uncompress::Gunzip (); use File::Compare (); use ExtUtils::Manifest; BEGIN { die "Must be run from root of perl source tree\n" unless -d 'Porting' } use lib 'Porting'; use Maintainers (); # if running from blead, we may be doing -Ilib, which means when we # 'chdir /tmp/foo', Archive::Extract may not find Archive::Tar etc. # So preload the things we need, and tell it to check %INC first: use Archive::Tar; use IPC::Open3; use IO::Select; $Module::Load::Conditional::CHECK_INC_HASH = 1; # stop Archive::Extract whinging about lack of Archive::Zip $Archive::Extract::WARN = 0; # Files, which if they exist in CPAN but not in perl, will not generate # an 'Only in CPAN' listing # our %IGNORABLE = map { ($_ => 1) } qw(.cvsignore .dualLivedDiffConfig .gitignore ANNOUNCE Announce Artistic AUTHORS BENCHMARK BUGS Build.PL CHANGELOG ChangeLog CHANGES Changes COPYING Copying CREDITS GOALS HISTORY INSTALL INSTALL.SKIP LICENSE Makefile.PL MANIFEST MANIFEST.SKIP META.yml NEW NOTES ppport.h README SIGNATURE THANKS TODO Todo VERSION WHATSNEW); # where, under the cache dir, to untar stuff to use constant UNTAR_DIR => 'untarred'; use constant DIFF_CMD => 'diff'; use constant WGET_CMD => 'wget'; sub usage { print STDERR "\n@_\n\n" if @_; print STDERR < \$scan_all, 'c|cachedir=s' => \$cache_dir, 'd|diff' => \$use_diff, 'diffopts:s' => \$diff_opts, 'f|force' => \$force, 'h|help' => \&usage, 'o|output=s' => \$output_file, 'r|reverse' => \$reverse, 'u|upstream=s@'=> \@wanted_upstreams, 'v|verbose' => \$verbose, 'x|crosscheck' => \$do_crosscheck, ) or usage; my @modules; usage("Cannot mix -a with module list") if $scan_all && @ARGV; if ($do_crosscheck) { usage("can't use -r, -d, --diffopts, -v with --crosscheck") if ($reverse || $use_diff || $diff_opts || $verbose); } else { $diff_opts = '-u' unless defined $diff_opts; usage("can't use -f without --crosscheck") if $force; } @modules = $scan_all ? grep $Maintainers::Modules{$_}{CPAN}, (sort {lc $a cmp lc $b } keys %Maintainers::Modules) : @ARGV; usage("No modules specified") unless @modules; my $outfh; if (defined $output_file) { open $outfh, '>', $output_file or die "ERROR: could not open file '$output_file' for writing: $!\n"; } else { open $outfh, ">&STDOUT" or die "ERROR: can't dup STDOUT: $!\n"; } if (defined $cache_dir) { die "ERROR: no such directory: '$cache_dir'\n" unless -d $cache_dir; } if ($do_crosscheck) { do_crosscheck($outfh, $cache_dir, $force, \@modules); } else { do_compare(\@modules, $outfh, $output_file, $cache_dir, $verbose, $use_diff, $reverse, $diff_opts, \@wanted_upstreams); } } # compare a list of modules against their CPAN equivalents sub do_compare { my ($modules, $outfh, $output_file, $cache_dir, $verbose, $use_diff, $reverse, $diff_opts, $wanted_upstreams) = @_; # first, make sure we have a directory where they can all be untarred, # and if its a permanent directory, clear any previous content my $untar_dir; if ($cache_dir) { $untar_dir = File::Spec->catdir($cache_dir, UNTAR_DIR); if (-d $untar_dir) { File::Path::rmtree($untar_dir) or die "failed to remove $untar_dir\n"; } mkdir $untar_dir or die "mkdir $untar_dir: $!\n"; } else { $untar_dir = File::Temp::tempdir( CLEANUP => 1 ); } my %ignorable = map { ($_ => 1) } @Maintainers::IGNORABLE; my %seen_dist; for my $module (@$modules) { warn "Processing $module ...\n" if defined $output_file; my $m = $Maintainers::Modules{$module} or die "ERROR: No such module in Maintainers.pl: '$module'\n"; unless ($m->{CPAN}) { print $outfh "WARNING: $module is not dual-life; skipping\n"; next; } my $dist = $m->{DISTRIBUTION}; die "ERROR: $module has no DISTRIBUTION entry\n" unless defined $dist; if ($seen_dist{$dist}) { warn "WARNING: duplicate entry for $dist in $module\n" } my $upstream = $m->{UPSTREAM} || 'UNKNOWN'; next if @$wanted_upstreams and ! ($upstream ~~ $wanted_upstreams); print $outfh "\n$module - ".$Maintainers::Modules{$module}->{DISTRIBUTION}."\n" unless $use_diff; print $outfh " upstream is: ".($m->{UPSTREAM} || 'UNKNOWN!')."\n"; $seen_dist{$dist}++; my $cpan_dir; eval { $cpan_dir = get_distribution($cache_dir, $untar_dir, $module, $dist) }; if ($@) { print $outfh " ", $@; print $outfh " (skipping)\n"; next; } my @perl_files = Maintainers::get_module_files($module); my $manifest = File::Spec->catfile($cpan_dir, 'MANIFEST'); die "ERROR: no such file: $manifest\n" unless -f $manifest; my $cpan_files = ExtUtils::Manifest::maniread($manifest); my @cpan_files = sort keys %$cpan_files; my ($excluded, $map) = get_map($m, $module, \@perl_files); my %perl_unseen; @perl_unseen{@perl_files} = (); my %perl_files = %perl_unseen; foreach my $cpan_file (@cpan_files) { my $mapped_file = cpan_to_perl($excluded, $map, $cpan_file); unless (defined $mapped_file) { print $outfh " Excluded: $cpan_file\n" if $verbose; next; } if (exists $perl_files{$mapped_file}) { delete $perl_unseen{$mapped_file}; } else { # some CPAN files foo are stored in core as foo.packed, # which are then unpacked by 'make test_prep' my $packed_file = "$mapped_file.packed"; if (exists $perl_files{$packed_file} ) { if (! -f $mapped_file and -f $packed_file) { print $outfh <catfile($cpan_dir, $cpan_file); # should never happen die "ERROR: can't find file $abs_cpan_file\n" unless -f $abs_cpan_file; # might happen if the FILES entry in Maintainers.pl is wrong unless (-f $mapped_file) { print $outfh "WARNING: perl file not found: $mapped_file\n"; next; } my $relative_mapped_file = $mapped_file; $relative_mapped_file =~ s/^(cpan|dist|ext)\/.*?\///; if (File::Compare::compare($abs_cpan_file, $mapped_file)) { if ($use_diff) { file_diff($outfh, $abs_cpan_file, $mapped_file, $reverse, $diff_opts); } else { if ($cpan_file eq $relative_mapped_file) { print $outfh " Modified: $relative_mapped_file\n"; } else { print $outfh " Modified: $cpan_file $relative_mapped_file\n"; } } } elsif ($verbose) { if ($cpan_file eq $relative_mapped_file) { print $outfh " Unchanged: $cpan_file\n"; } else { print $outfh " Unchanged: $cpan_file $relative_mapped_file\n"; } } } for (sort keys %perl_unseen) { print $outfh " Perl only: $_\n" unless $use_diff; } } } # given FooBar-1.23_45.tar.gz, return FooBar sub distro_base { my $d = shift; $d =~ s/\.tar\.gz$//; $d =~ s/\.gip$//; $d =~ s/[\d\-_\.]+$//; return $d; } # process --crosscheck action: # ie list all distributions whose CPAN versions differ from that listed in # Maintainers.pl sub do_crosscheck { my ($outfh, $cache_dir, $force, $modules) = @_; my $file = '02packages.details.txt'; my $download_dir = $cache_dir || File::Temp::tempdir( CLEANUP => 1 ); my $path = File::Spec->catfile($download_dir, $file); my $gzfile = "$path.gz"; # grab 02packages.details.txt my $url = 'http://www.cpan.org/modules/02packages.details.txt.gz'; if (! -f $gzfile or $force) { unlink $gzfile; my_getstore($url, $gzfile); } unlink $path; IO::Uncompress::Gunzip::gunzip($gzfile, $path) or die "ERROR: failed to ungzip $gzfile: $IO::Uncompress::Gunzip::GunzipError\n"; # suck in the data from it open my $fh, '<', $path or die "ERROR: open: $file: $!\n"; my %distros; my %modules; while (<$fh>) { next if 1../^$/; chomp; my @f = split ' ', $_; if (@f != 3) { warn "WARNING: $file:$.: line doesn't have three fields (skipping)\n"; next; } my $distro = $f[2]; $distro =~ s{^[A-Z]/[A-Z]{2}/}{}; # strip leading A/AB/ $modules{$f[0]} = $distro; (my $short_distro = $distro) =~ s{^.*/}{}; $distros{distro_base($short_distro)}{$distro} = 1; } for my $module (@$modules) { my $m = $Maintainers::Modules{$module} or die "ERROR: No such module in Maintainers.pl: '$module'\n"; unless ($m->{CPAN}) { print $outfh "\nWARNING: $module is not dual-life; skipping\n"; next; } # given an entry like # Foo::Bar 1.23 foo-bar-1.23.tar.gz, # first compare the module name against Foo::Bar, and failing that, # against foo-bar my $pdist = $m->{DISTRIBUTION}; die "ERROR: $module has no DISTRIBUTION entry\n" unless defined $pdist; my $cdist = $modules{$module}; (my $short_pdist = $pdist) =~ s{^.*/}{}; unless (defined $cdist) { my $d = $distros{distro_base($short_pdist)}; unless (defined $d) { print $outfh "\n$module: Can't determine current CPAN entry\n"; next; } if (keys %$d > 1) { print $outfh "\n$module: (found more than one CPAN candidate):\n"; print $outfh " perl: $pdist\n"; print $outfh " CPAN: $_\n" for sort keys %$d; next; } $cdist = (keys %$d)[0]; } if ($cdist ne $pdist) { print $outfh "\n$module:\n Perl: $pdist\n CPAN: $cdist\n"; } } } # get the EXCLUDED and MAP entries for this module, or # make up defauts if they don't exist sub get_map { my ($m, $module_name, $perl_files) = @_; my ($excluded, $map) = @$m{qw(EXCLUDED MAP)}; $excluded ||= []; return $excluded, $map if $map; # all files under ext/foo-bar (plus maybe some under t/lib)??? my $ext; for (@$perl_files) { if (m{^((?:ext|dist|cpan)/[^/]+/)}) { if (defined $ext and $ext ne $1) { # more than one ext/$ext/ undef $ext; last; } $ext = $1; } elsif (m{^t/lib/}) { next; } else { undef $ext; last; } } if (defined $ext) { $map = { '' => $ext }, } else { (my $base = $module_name) =~ s{::}{/}g; $base ="lib/$base"; $map = { 'lib/' => 'lib/', '' => "$base/", }; } return $excluded, $map; } # Given an exclude list and a mapping hash, convert a CPAN filename # (eg 't/bar.t') to the equivalent perl filename (eg 'lib/Foo/Bar/t/bar.t'). # Returns an empty list for an excluded file sub cpan_to_perl { my ($excluded, $map, $cpan_file) = @_; for my $exclude (@$excluded) { # may be a simple string to match exactly, or a pattern if (ref $exclude) { return if $cpan_file =~ $exclude; } else { return if $cpan_file eq $exclude; } } my $perl_file = $cpan_file; # try longest prefix first, then alphabetically on tie-break for my $prefix (sort { length($b) <=> length($a) || $a cmp $b } keys %$map) { last if $perl_file =~ s/^\Q$prefix/$map->{$prefix}/; } return $perl_file; } # do LWP::Simple::getstore, possibly without LWP::Simple being available my $lwp_simple_available; sub my_getstore { my ($url, $file) = @_; unless (defined $lwp_simple_available) { eval { require LWP::Simple }; $lwp_simple_available = $@ eq ''; } if ($lwp_simple_available) { return LWP::Simple::is_success(LWP::Simple::getstore($url, $file)); } else { return system(WGET_CMD, "-O", $file, $url) == 0; } } # download and unpack a distribution # Returns the full pathname of the extracted directory # (eg '/tmp/XYZ/Foo_bar-1.23') # cache_dir: where to dowenload the .tar.gz file to # untar_dir: where to untar or unzup the file # module: name of module # dist: name of the distribution sub get_distribution { my ($cache_dir, $untar_dir, $module, $dist) = @_; $dist =~ m{.+/([^/]+)$} or die "ERROR: $module: invalid DISTRIBUTION name (no AUTHOR/ prefix): $dist\n"; my $filename = $1; my $download_dir = $cache_dir || File::Temp::tempdir( CLEANUP => 1 ); my $download_file = File::Spec->catfile($download_dir, $filename); # download distribution if (-f $download_file and ! -s $download_file ) { # wget can leave a zero-length file on failed download unlink $download_file; } unless (-f $download_file) { # not cached $dist =~ /^([A-Z])([A-Z])/ or die "ERROR: $module: invalid DISTRIBUTION name (not /^[A-Z]{2}/): $dist\n"; my $url = "http://www.cpan.org/modules/by-authors/id/$1/$1$2/$dist"; my_getstore($url, $download_file) or die "ERROR: Could not fetch '$url'\n"; } # extract distribution my $ae = Archive::Extract->new( archive => $download_file); $ae->extract( to => $untar_dir ) or die "ERROR: failed to extract distribution '$download_file to temp. dir: " . $ae->error() . "\n"; # get the name of the extracted distribution dir my $path = File::Spec->catfile($untar_dir, $filename); $path =~ s/\.tar\.gz$// or $path =~ s/\.zip$// or die "ERROR: downloaded file does not have a recognised suffix: $path\n"; die "ERROR: Extracted tarball does not appear as $path\n" unless -d $path; return $path; } # produce the diff of a single file sub file_diff { my $outfh = shift; my $cpan_file = shift; my $perl_file = shift; my $reverse = shift; my $diff_opts = shift; my @cmd = (DIFF_CMD, split ' ', $diff_opts); if ($reverse) { push @cmd, $perl_file, $cpan_file; } else { push @cmd, $cpan_file, $perl_file; } my $result = `@cmd`; $result =~ s{^(--- |\+\+\+ )/tmp/[^/]+/}{$1}gm; print $outfh $result; } run(); perl-5.12.0-RC0/Porting/corelist-diff0000444000175000017500000000120411347214635016227 0ustar jessejesseuse strict; use 5.010; use lib 'dist/Module-CoreList/lib'; use List::MoreUtils qw(uniq); use Module::CoreList; use Text::Table; my $old_ver = "5.010000"; my $new_ver = "5.011005"; my $old = $Module::CoreList::version{ $old_ver }; my $new = $Module::CoreList::version{ $new_ver }; my $table = Text::Table->new('perl', \' | ', $old_ver, \' | ', $new_ver); for my $lib (uniq sort (keys %$old, keys %$new)) { my $old = exists $old->{ $lib } ? $old->{ $lib } // '(undef)' : '(absent)'; my $new = exists $new->{ $lib } ? $new->{ $lib } // '(undef)' : '(absent)'; next if $old eq $new; $table->add($lib, $old, $new); } print $table; perl-5.12.0-RC0/Porting/perldelta_template.pod0000444000175000017500000001340211325127001020112 0ustar jessejesse=head1 NAME [ this is a template for a new perldelta file. Any text flagged as XXX needs to be processed before release. ] perldelta - what is new for perl v5.XXX.XXX =head1 DESCRIPTION This document describes differences between the 5.XXX.XXX release and the 5.XXX.XXX release. If you are upgrading from an earlier release such as 5.XXX.XXX, first read L, which describes differences between 5.XXX.XXX and 5.XXX.XXX. =head1 Notice XXX Any important notices here =head1 Incompatible Changes XXX For a release on a stable branch, this section aspires to be: There are no changes intentionally incompatible with 5.XXX.XXX. If any exist, they are bugs and reports are welcome. =head1 Core Enhancements XXX New core language features go here. Summarise user-visible core language enhancements. Particularly prominent performance optimisations could go here, but most should go in the L section. =head1 New Platforms XXX List any platforms that this version of perl compiles on, that previous versions did not. These will either be enabled by new files in the F directories, or new subdirectories and F files at the top level of the source tree. =head1 Modules and Pragmata XXX All changes to installed files in F, F, F and F go here. If Module::CoreList is updated, generate an initial draft of the following sections using F, which prints stub entries to STDOUT. Results can be pasted in place of the '=head2' entries below. A paragraph summary for important changes should then be added by hand. In an ideal world, dual-life modules would have a F file that could be cribbed. =head2 New Modules and Pragmata =head2 Pragmata Changes =head2 Updated Modules =head2 Removed Modules and Pragmata =head1 Utility Changes XXX Changes to installed programs such as F and F go here. Most of these are built within the directories F and F. =over 4 =item F XXX =back =head1 New Documentation XXX Changes which create B files in F go here. =over 4 =item L XXX =back =head1 Changes to Existing Documentation XXX Changes which significantly change existing files in F go here. Any changes to F should go in L. =head1 Performance Enhancements XXX Changes which enhance performance without changing behaviour go here. There may well be none in a stable release. =over 4 =item * XXX =back =head1 Installation and Configuration Improvements XXX Changes to F, F, F, and analogous tools go here. =head2 Configuration improvements XXX =head2 Compilation improvements XXX =head2 Platform Specific Changes =over 4 =item XXX-some-platform XXX =back =head1 Selected Bug Fixes XXX Important bug fixes in the core language are summarised here. Bug fixes in files in F and F are best summarised in L. =over 4 =item * XXX =back =head1 New or Changed Diagnostics XXX New or changed warnings emitted by the core's C code go here. =over 4 =item C XXX =back =head1 Changed Internals XXX Changes which affect the interface available to C code go here. =over 4 =item * XXX =back =head1 New Tests XXX Changes which create B files in F go here. Changes to existing files in F aren't worth summarising, although the bugs that they represent may be. =over 4 =item F XXX =back =head1 Known Problems XXX Descriptions of platform agnostic bugs we know we can't fix go here. Any tests that had to be Ced for the release would be noted here, unless they were specific to a particular platform (see below). This is a list of some significant unfixed bugs, which are regressions from either 5.XXX.XXX or 5.XXX.XXX. =over 4 =item * XXX =back =head1 Deprecations XXX Add any new known deprecations here. The following items are now deprecated. =over 4 =item * XXX =back =head1 Platform Specific Notes XXX Any changes specific to a particular platform. VMS and Win32 are the usual stars here. It's probably best to group changes under the same section layout as the main perldelta =head1 Obituary XXX If any significant core contributor has died, we've added a short obituary here. =head1 Acknowledgements XXX The list of people to thank goes here. =head1 Reporting Bugs If you find what you think is a bug, you might check the articles recently posted to the comp.lang.perl.misc newsgroup and the perl bug database at http://rt.perl.org/perlbug/ . There may also be information at http://www.perl.org/ , the Perl Home Page. If you believe you have an unreported bug, please run the B program included with your release. Be sure to trim your bug down to a tiny but sufficient test case. Your bug report, along with the output of C, will be sent off to perlbug@perl.org to be analysed by the Perl porting team. If the bug you are reporting has security implications, which make it inappropriate to send to a publicly archived mailing list, then please send it to perl5-security-report@perl.org. This points to a closed subscription unarchived mailing list, which includes all the core committers, who be able to help assess the impact of issues, figure out a resolution, and help co-ordinate the release of patches to mitigate or fix the problem across all platforms on which Perl is supported. Please only use this address for security issues in the Perl core, not for modules independently distributed on CPAN. =head1 SEE ALSO The F file for an explanation of how to view exhaustive details on what changed. The F file for how to build Perl. The F file for general stuff. The F and F files for copyright information. =cut perl-5.12.0-RC0/Porting/release_managers_guide.pod0000444000175000017500000007306411347003575020744 0ustar jessejesse=head1 NAME release_managers_guide - Releasing a new version of perl 5.x As of August 2009, this file is mostly complete, although it is missing some detail on doing a major release (e.g. 5.10.0 -> 5.12.0). Note that things change at each release, so there may be new things not covered here, or tools may need updating. =head1 SYNOPSIS This document describes the series of tasks required - some automatic, some manual - to produce a perl release of some description, be that a snaphot, release candidate, or final, numbered release of maint or blead. The release process has traditionally been executed by the current pumpking. Blead releases from 5.11.0 forward are made each month on the 20th by a non-pumpking release engineer. The release engineer roster and schedule can be found in Porting/release_schedule.pod. This document both helps as a check-list for the release engineer and is a base for ideas on how the various tasks could be automated or distributed. The outline of a typical release cycle is as follows: (5.10.1 is released, and post-release actions have been done) ...time passes... an occasional snapshot is released, that still identifies itself as 5.10.1 ...time passes... a few weeks before the release, a number of steps are performed, including bumping the version to 5.10.2 ...a few weeks passes... perl-5.10.2-RC1 is released perl-5.10.2 is released post-release actions are performed, including creating new perl5103delta.pod ... the cycle continues ... =head1 DETAILS Some of the tasks described below apply to all four types of release of Perl. (snapshot, RC, final release of maint, final release of blead). Some of these tasks apply only to a subset of these release types. If a step does not apply to a given type of release, you will see a notation to that effect at the beginning of the step. =head2 Release types =over 4 =item Snapshot A snapshot is intended to encourage in-depth testing from time-to-time, for example after a key point in the stabilisation of a branch. It requires fewer steps than a full release, and the version number of perl in the tarball will usually be the same as that of the previous release. =item Release Candidate (RC) A release candidate is an attempt to produce a tarball that is a close as possible to the final release. Indeed, unless critical faults are found during the RC testing, the final release will be identical to the RC barring a few minor fixups (updating the release date in F, removing the RC status from F, etc). If faults are found, then the fixes should be put into a new release candidate, never directly into a final release. =item Stable/Maint release At this point you should have a working release candidate with few or no changes since. It's essentially the same procedure as for making a release candidate, but with a whole bunch of extra post-release steps. =item Blead release It's essentially the same procedure as for making a release candidate, but with a whole bunch of extra post-release steps. =back =head2 Prerequisites Before you can make an official release of perl, there are a few hoops you need to jump through: =over 4 =item PAUSE account I Make sure you have a PAUSE account suitable for uploading a perl release. If you don't have a PAUSE account, then request one: https://pause.perl.org/pause/query?ACTION=request_id Check that your account is allowed to upload perl distros: goto L, login, then select 'upload file to CPAN'; there should be a "For pumpkings only: Send a CC" tickbox. If not, ask Andreas König to add your ID to the list of people allowed to upload something called perl. You can find Andreas' email address at: https://pause.perl.org/pause/query?ACTION=pause_04imprint =item search.cpan.org Make sure that search.cpan.org knows that you're allowed to upload perl distros. Contact Graham Barr to make sure that you're on the right list. =item CPAN mirror Some release engineering steps require a full mirror of the CPAN. Work to fall back to using a remote mirror via HTTP is incomplete but ongoing. (No, a minicpan mirror is not sufficient) =item git checkout and commit bit You will need a working C installation, checkout of the perl git repository and perl commit bit. For information about working with perl and git, see F. If you are not yet a perl committer, you won't be able to make a release. Have a chat with whichever evil perl porter tried to talk you into the idea in the first place to figure out the best way to resolve the issue. =item Quotation for release announcement epigraph I For a numbered blead or maint release of perl, you will need a quotation to use as an epigraph to your release announcement. (There's no harm in having one for a snapshot, but it's not required). =back =head2 Building a release - advance actions The work of building a release candidate for a numbered release of perl generally starts several weeks before the first release candidate. Some of the following steps should be done regularly, but all I be done in the run up to a release. =over 4 =item * I Ensure that dual-life CPAN modules are synchronised with CPAN. Basically, run the following: $ ./perl -Ilib Porting/core-cpan-diff -a -o /tmp/corediffs to see any inconsistencies between the core and CPAN versions of distros, then fix the core, or cajole CPAN authors as appropriate. See also the C<-d> and C<-v> options for more detail. You'll probably want to use the C<-c cachedir> option to avoid repeated CPAN downloads. To see which core distro versions differ from the current CPAN versions: $ ./perl -Ilib Porting/core-cpan-diff -x -a If you are making a maint release, run C on both blead and maint, then diff the two outputs. Compare this with what you expect, and if necessary, fix things up. For example, you might think that both blead and maint are synchronised with a particular CPAN module, but one might have some extra changes. =item * I Ensure dual-life CPAN modules are stable, which comes down to: for each module that fails its regression tests on $current did it fail identically on $previous? if yes, "SEP" (Somebody Else's Problem) else work out why it failed (a bisect is useful for this) attempt to group failure causes for each failure cause is that a regression? if yes, figure out how to fix it (more code? revert the code that broke it) else (presumably) it's relying on something un-or-under-documented should the existing behaviour stay? yes - goto "regression" no - note it in perldelta as a significant bugfix (also, try to inform the module's author) =item * I Similarly, monitor the smoking of core tests, and try to fix. =item * I Similarly, monitor the smoking of perl for compiler warnings, and try to fix. =item * I Run F to compare the current source tree with the previous version to check for for modules that have identical version numbers but different contents, e.g.: $ cd ~/some-perl-root $ ./perl -Ilib Porting/cmpVERSION.pl -xd ~/my_perl-tarballs/perl-5.10.0 . then bump the version numbers of any non-dual-life modules that have changed since the previous release, but which still have the old version number. If there is more than one maintenance branch (e.g. 5.8.x, 5.10.x), then compare against both. Note that some of the files listed may be generated (e.g. copied from ext/ to lib/, or a script like lib/lib_pm.PL is run to produce lib/lib.pm); make sure you edit the correct file! Once all version numbers have been bumped, re-run the checks. Then run again without the -x option, to check that dual-life modules are also sensible. $ ./perl -Ilib Porting/cmpVERSION.pl -d ~/my_perl-tarballs/perl-5.10.0 . =item * I Get perldelta in a mostly finished state. Read F, and try to make sure that every section it lists is, if necessary, populated and complete. Copy edit the whole document. =item * I A week or two before the first release candidate, bump the perl version number (e.g. from 5.10.0 to 5.10.1), to allow sufficient time for testing and smoking with the target version built into the perl executable. For subsequent release candidates and the final release, it it not necessary to bump the version further. There is a tool to semi-automate this process. It works in two stages. First, it generates a list of suggested changes, which you review and edit; then you feed this list back and it applies the edits. So, first scan the source directory looking for likely candidates. The command line arguments are the old and new version numbers, and -s means scan: $ Porting/bump-perl-version -s 5.10.0 5.10.1 > /tmp/scan This produces a file containing a list of suggested edits, e.g.: NetWare/Makefile 89: -MODULE_DESC = "Perl 5.10.0 for NetWare" +MODULE_DESC = "Perl 5.10.1 for NetWare" i.e. in the file F, line 89 would be changed as shown. Review the file carefully, and delete any -/+ line pairs that you don't want changing. You can also edit just the C<+> line to change the suggested replacement text. Remember that this tool is largely just grepping for '5.10.0' or whatever, so it will generate false positives. Be careful not change text like "this was fixed in 5.10.0"! Then run: $ Porting/bump-perl-version -u < /tmp/scan which will update all the files shown. Be particularly careful with F, which contains a mixture of C<5.10.0>-type strings, some of which need bumping on every release, and some of which need to be left unchanged. Also note that this tool currently only detects a single substitution per line: so in particular, this line in README.vms needs special handling: rename perl-5^.10^.1.dir perl-5_10_1.dir Commit your changes: $ git st $ git diff B $ git commit -a -m 'Bump the perl version in various places for 5.x.y' When the version number is bumped, you should also update Module::CoreList (as described below in L<"Building a release - on the day">) to reflect the new version number. =item * I Review and update INSTALL to account for the change in version number; in particular, the "Coexistence with earlier versions of perl 5" section. =item * I Update the F file to contain the git log command which would show all the changes in this release. You will need assume the existence of a not-yet created tag for the forthcoming release; e.g. git log ... perl-5.10.0..perl-5.12.0 Due to warts in the perforce-to-git migration, some branches require extra exclusions to avoid other branches being pulled in. Make sure you have the correct incantation: replace the not-yet-created tag with C and see if C produces roughly the right number of commits across roughly the right time period (you may find C useful). =item * Check some more build configurations. The check that setuid builds and installs is for < 5.11.0 only. $ sh Configure -Dprefix=/tmp/perl-5.x.y -Uinstallusrbinperl \ -Duseshrplib -Dd_dosuid $ make $ LD_LIBRARY_PATH=`pwd` make test # or similar for useshrplib $ make suidperl $ su -c 'make install' $ ls -l .../bin/sperl -rws--x--x 1 root root 69974 2009-08-22 21:55 .../bin/sperl (Then delete the installation directory.) XXX think of other configurations that need testing. =item * I Update F, using the C script, and if necessary, update the script to include new alias mappings for porters already in F $ git log | perl Porting/checkAUTHORS.pl --acknowledged AUTHORS - =back =head2 Building a release - on the day This section describes the actions required to make a release (or snapshot etc) that are performed on the actual day. =over 4 =item * Review all the items in the previous section, L<"Building a release - advance actions"> to ensure they are all done and up-to-date. =item * I Re-read the perldelta to try to find any embarrassing typos and thinkos; remove any C or C flags; update the "Known Problems" section with any serious issues for which fixes are not going to happen now; and run through pod and spell checkers, e.g. $ podchecker -warnings -warnings pod/perl5101delta.pod $ spell pod/perl5101delta.pod Also, you may want to generate and view an HTML version of it to check formatting, e.g. $ perl pod/pod2html pod/perl5101delta.pod > /tmp/perl5101delta.html =item * Make sure you have a gitwise-clean perl directory (no modified files, unpushed commits etc): $ git status =item * If not already built, Configure and build perl so that you have a Makefile and porting tools: $ ./Configure -Dusedevel -des && make =item * Check that files managed by F and friends are up to date. From within your working directory: $ git status $ make regen $ make regen_perly $ git status If any of the files managed by F have changed, then you should re-make perl to check that it's okay, then commit the updated versions: $ git commit -a -m 'make regen; make regen_perly' =item * Rebuild META.yml: $ rm META.yml $ make META.yml $ git diff XXX it would be nice to make Porting/makemeta use regen_lib.pl to get the same 'update the file if its changed' functionality we get with 'make regen' etc. Commit META.yml if it has changed: $ git commit -m 'Update META.yml' META.yml =item * I Update C with module version data for the new release. Note that if this is a maint release, you should run the following actions from the maint directory, but commit the C changes in I and subsequently cherry-pick it. F uses ftp.funet.fi to verify information about dual-lived modules on CPAN. It can use a full, local CPAN mirror or fall back to C or C to fetch only package metadata remotely. (If you're on Win32, then installing Cygwin is one way to have commands like C and C available.) (If you'd prefer to have a full CPAN mirror, see http://www.cpan.org/misc/cpan-faq.html#How_mirror_CPAN) Then change to your perl checkout, and if necessary, $ make perl If this not the first update for this version (e.g. if it was updated when the version number was originally bumped), first edit F to delete the existing entries for this version from the C<%released> and C<%version> hashes: they will have a key like C<5.010001> for 5.10.1. XXX the edit-in-place functionality of Porting/corelist.pl should be fixed to handle this automatically. Then, If you have a local CPAN mirror, run: $ ./perl -Ilib Porting/corelist.pl ~/my-cpan-mirror Otherwise, run: $ ./perl -Ilib Porting/corelist.pl cpan This will chug for a while, possibly reporting various warnings about badly-indexed CPAN modules unrelated to the modules actually in core. Assuming all goes well, it will update F. Check that file over carefully: $ git diff dist/Module-CoreList/lib/Module/CoreList.pm If necessary, bump C<$VERSION> (there's no need to do this for every RC; in RC1, bump the version to a new clean number that will appear in the final release, and leave as-is for the later RCs and final). Edit the version number in the new C<< 'Module::CoreList' => 'X.YZ' >> entry, as that is likely to reflect the previous version number. Also edit Module::CoreList's new version number in its F file and in its F file. In addition, if this is a final release (rather than a release candidate): =over 4 =item * Update this version's entry in the C<%released> hash with today's date. =item * Make sure that the script has correctly updated the C section =back Finally, commit the new version of Module::CoreList: (unless this is for maint; in which case commit it blead first, then cherry-pick it back). $ git commit -m 'Update Module::CoreList for 5.x.y' dist/Module-CoreList/lib/Module/CoreList.pm =item * Check that the manifest is sorted and correct: $ make manisort $ make distclean $ git clean -xdf # This shouldn't be necessary if distclean is correct $ perl Porting/manicheck $ git status XXX manifest _sorting_ is now checked with make test_porting Commit MANIFEST if it has changed: $ git commit -m 'Update MANIFEST' MANIFEST =item * I Add an entry to F with the current date, e.g.: David 5.10.1-RC1 2009-Aug-06 Make sure that the correct pumpking is listed in the left-hand column, and if this is the first release under the stewardship of a new pumpking, make sure that his or her name is listed in the section entitled C. Be sure to commit your changes: $ git commit -m 'add new release to perlhist' pod/perlhist.pod =item * I Update F to add a C<-RC1>-or-whatever string; or, if this is a final release, remove it. For example: static const char * const local_patches[] = { NULL + ,"RC1" PERL_GIT_UNPUSHED_COMMITS /* do not remove this line */ Be sure to commit your change: $ git commit -m 'bump version to RCnnn' patchlevel.h =item * Build perl, then make sure it passes its own test suite, and installs: $ git clean -xdf $ ./Configure -des -Dprefix=/tmp/perl-5.x.y-pretest # or if it's an odd-numbered version: $ ./Configure -des -Dusedevel -Dprefix=/tmp/perl-5.x.y-pretest $ make test install =item * Check that the output of C and C are as expected, especially as regards version numbers, patch and/or RC levels, and @INC paths. Note that as they have been been built from a git working directory, they will still identify themselves using git tags and commits. Then delete the temporary installation. =item * If this is maint release, make sure F is saved and committed. =item * Push all your recent commits: $ git push origin .... =item * I Tag the release (e.g.): $ git tag v5.11.0 -m'First release of the v5.11 series!' (Adjust the syntax appropriately if you're working on Win32, i.e. use C<-m "..."> rather than C<-m'...'>.) It is VERY important that from this point forward, you not push your git changes to the Perl master repository. If anything goes wrong before you publish your newly-created tag, you can delete and recreate it. Once you push your tag, we're stuck with it and you'll need to use a new version number for your release. =item * Create a tarball. Use the C<-s> option to specify a suitable suffix for the tarball and directory name: $ cd root/of/perl/tree $ make distclean $ git clean -xdf # make sure perl and git agree on files $ git status # and there's nothing lying around $ perl Porting/makerel -b -s `git describe` # for a snapshot $ perl Porting/makerel -b -s RC1 # for a release candidate $ perl Porting/makerel -b # for a final release This creates the directory F<../perl-x.y.z-RC1> or similar, copies all the MANIFEST files into it, sets the correct permissions on them, adds DOS line endings to some, then tars it up as F<../perl-x.y.z-RC1.tar.gz>. With C<-b>, it also creates a C file. XXX if we go for extra tags and branches stuff, then add the extra details here =item * Clean up the temporary directory, e.g. $ rm -rf ../perl-x.y.z-RC1 =item * Copy the tarballs (.gz and possibly .bz2) to a web server somewhere you have access to. =item * Download the tarball to some other machine. For a release candidate, you really want to test your tarball on two or more different platforms and architectures. The #p5p IRC channel on irc.perl.org is a good place to find willing victims. =item * Check that basic configuration and tests work on each test machine: $ ./Configure -des && make all test =item * Check that the test harness and install work on each test machine: $ make distclean $ ./Configure -des -Dprefix=/install/path && make all test_harness install $ cd /install/path =item * Check that the output of C and C are as expected, especially as regards version numbers, patch and/or RC levels, and @INC paths. Note that the results may be different without a F<.git/> directory, which is why you should test from the tarball. =item * Run the Installation Verification Procedure utility: $ bin/perlivp ... All tests successful. $ =item * Compare the pathnames of all installed files with those of the previous release (i.e. against the last installed tarball on this branch which you have previously verified using this same procedure). In particular, look for files in the wrong place, or files no longer included which should be. For example, suppose the about-to-be-released version is 5.10.1 and the previous is 5.10.0: cd installdir-5.10.0/ find . -type f | perl -pe's/5\.10\.0/5.10.1/g' | sort > /tmp/f1 cd installdir-5.10.1/ find . -type f | sort > /tmp/f2 diff -u /tmp/f[12] =item * Bootstrap the CPAN client on the clean install: $ bin/perl -MCPAN -e'shell' (Use C<... -e "shell"> instead on Win32. You probably also need a set of Unix command-line tools available for CPAN to function correctly without Perl alternatives like LWP installed. Cygwin is an obvious choice.) =item * Try installing a popular CPAN module that's reasonably complex and that has dependencies; for example: CPAN> install Inline CPAN> quit Check that your perl can run this: $ bin/perl -lwe 'use Inline C => "int f() { return 42;} "; print f' 42 $ (Use C<... -lwe "use ..."> instead on Win32.) =item * Bootstrap the CPANPLUS client on the clean install: $ bin/cpanp (Again, on Win32 you'll need something like Cygwin installed, but make sure that you don't end up with its various F programs being found on the PATH before those of the Perl that you're trying to test.) =item * Install an XS module, for example: CPAN Terminal> i DBI CPAN Terminal> quit $ bin/perl -MDBI -e 1 $ =item * I =item * Check that the C utility works. Try the following: $ bin/perlbug ... Subject: test bug report Local perl administrator [yourself]: Editor [vi]: Module: Category [core]: Severity [low]: (edit report) Action (Send/Display/Edit/Subject/Save to File): f Name of file to save message in [perlbug.rep]: Action (Send/Display/Edit/Subject/Save to File): q and carefully examine the output (in F), especially the "Locally applied patches" section. If everything appears okay, then delete the file, and try it again, this time actually submitting the bug report. Check that it shows up, then remember to close it! =item * Wait for the smoke tests to catch up with the commit which this release is based on (or at least the last commit of any consequence). Then check that the smoke tests pass (particularly on Win32). If not, go back and fix things. =item * Once smoking is okay, upload it to PAUSE. This is the point of no return. If anything goes wrong after this point, you will need to re-prepare a new release with a new minor version or RC number. https://pause.perl.org/ (Login, then select 'Upload a file to CPAN') If your workstation is not connected to a high-bandwidth, high-reliability connection to the Internet, you should probably use the "GET URL" feature (rather than "HTTP UPLOAD") to have PAUSE retrieve the new release from wherever you put it for testers to find it. This will eliminate anxious gnashing of teeth while you wait to see if your 15 megabyte HTTP upload successfully completes across your slow, twitchy cable modem. You can make use of your home directory on dromedary for this purpose: F maps to F, where F is your login account on dromedary. I: if your upload is partially successful, you may need to contact a PAUSE administrator or even bump the version of perl. Upload both the .gz and .bz2 versions of the tarball. Wait until you receive notification emails from the PAUSE indexer confirming that your uploads have been successfully indexed. Do not proceed any further until you are sure that the indexing of your uploads has been successful. =item * Now that you've shipped the new perl release to PAUSE, it's time to publish the tag you created earlier to the public git repo (e.g.): $ git push origin tag v5.11.0 =item * Disarm the F change; for example, static const char * const local_patches[] = { NULL - ,"RC1" PERL_GIT_UNPUSHED_COMMITS /* do not remove this line */ Be sure to commit your change: $ git commit -m 'disarm RCnnn bump' patchlevel.h $ git push origin .... =item * Mail p5p to announce your new release, with a quote you prepared earlier. =item * Wait 24 hours or so, then post the announcement to use.perl.org. (if you don't have access rights to post news, ask someone like Rafael to do it for you.) =item * Check http://www.cpan.org/src/ to see if the new tarballs have appeared. They should appear automatically, but if they don't then ask Jarkko to look into it, since his scripts must have broken. =item * I Ask Jarkko to update the descriptions of which tarballs are current in http://www.cpan.org/src/README.html, and Rafael to update http://dev.perl.org/perl5/ =item * I Remind the current maintainer of C to push a new release to CPAN. =item * I Bump the perlXYZdelta version number. First, create a new empty perlNNNdelta.pod file for the current release + 1; see F. You should be able to do this by just copying in a skeleton template and then doing a quick fix up of the version numbers, e.g. $ cp -i Porting/perldelta_template.pod pod/perl5102delta.pod $ (edit it) $ git add pod/perl5102delta.pod Edit F: add the new entry, flagged as 'D', and unflag the previous entry from being 'D'; for example: -D perl5101delta Perl changes in version 5.10.1 +D perl5102delta Perl changes in version 5.10.2 + perl5101delta Perl changes in version 5.10.1 Run C to update the F version in the following files: MANIFEST Makefile.SH pod.lst pod/perl.pod vms/descrip_mms.template win32/Makefile win32/makefile.mk win32/pod.mak Then manually edit (F to bump the version in the following entry: [.pod]perldelta.pod : [.pod]perl5101delta.pod XXX this previous step needs to fixed to automate it in pod/buildtoc. Manually update references to the perlNNNdelta version in these files: INSTALL README Edit the previous delta file to change the C from C to C. These two lists of files probably aren't exhaustive; do a recursive grep on the previous filename to look for suitable candidates that may have been missed. Finally, commit: $ git commit -a -m 'create perlXXXdelta' At this point you may want to compare the commit with a previous bump to see if they look similar. See commit ca8de22071 for an example of a previous version bump. =item * I If this was a maint release, then edit F to change all the C (deferred) flags to C<.> (needs review). =item * I If this was a major release (5.x.0), then create a new maint branch based on the commit tagged as the current release and bump the version in the blead branch in git, e.g. 5.12.0 to 5.13.0. [ XXX probably lots more stuff to do, including perldelta, C ] XXX need a git recipe =item * I Copy the perlNNNdelta.pod for this release into the other branches; for example: $ cp -i ../5.10.x/pod/perl5101delta.pod pod/ # for example $ git add pod/perl5101delta.pod Edit F to add an entry for the file, e.g.: perl5101delta Perl changes in version 5.10.1 Then rebuild various files: $ perl pod/buildtoc --build-all Finally, commit: $ git commit -a -m 'add perlXXXdelta' =item * Make sure any recent F entries are copied to F on other branches; typically the RC* and final entries, e.g. 5.8.9-RC1 2008-Nov-10 5.8.9-RC2 2008-Dec-06 5.8.9 2008-Dec-14 =item * I. Thanks for releasing perl! =back =head1 SOURCE Based on http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2009-05/msg00608.html, plus a whole bunch of other sources, including private correspondence. =cut perl-5.12.0-RC0/Porting/pumpkin.pod0000444000175000017500000015150011325127001015730 0ustar jessejesse=head1 NAME Pumpkin - Notes on handling the Perl Patch Pumpkin And Porting Perl =head1 SYNOPSIS There is no simple synopsis, yet. =head1 DESCRIPTION This document attempts to begin to describe some of the considerations involved in patching, porting, and maintaining perl. This document is still under construction, and still subject to significant changes. Still, I hope parts of it will be useful, so I'm releasing it even though it's not done. For the most part, it's a collection of anecdotal information that already assumes some familiarity with the Perl sources. I really need an introductory section that describes the organization of the sources and all the various auxiliary files that are part of the distribution. =head1 Where Do I Get Perl Sources and Related Material? The Comprehensive Perl Archive Network (or CPAN) is the place to go. There are many mirrors, but the easiest thing to use is probably http://www.cpan.org/README.html , which automatically points you to a mirror site "close" to you. =head2 Perl5-porters mailing list The mailing list perl5-porters@perl.org is the main group working with the development of perl. If you're interested in all the latest developments, you should definitely subscribe. The list is high volume, but generally has a fairly low noise level. Subscribe by sending the message (in the body of your letter) subscribe perl5-porters to perl5-porters-request@perl.org . Archives of the list are held at: http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/ =head1 How are Perl Releases Numbered? Beginning with v5.6.0, even versions will stand for maintenance releases and odd versions for development releases, i.e., v5.6.x for maintenance releases, and v5.7.x for development releases. Before v5.6.0, subversions _01 through _49 were reserved for bug-fix maintenance releases, and subversions _50 through _99 for unstable development versions. For example, in v5.6.1, the revision number is 5, the version is 6, and 1 is the subversion. For compatibility with the older numbering scheme the composite floating point version number continues to be available as the magic variable $], and amounts to C<$revision + $version/1000 + $subversion/100000>. This can still be used in comparisons. print "You've got an old perl\n" if $] < 5.005_03; In addition, the version is also available as a string in $^V. print "You've got a new perl\n" if $^V and $^V ge v5.6.0; You can also require particular version (or later) with: use 5.006; or using the new syntax available only from v5.6 onward: use v5.6.0; At some point in the future, we may need to decide what to call the next big revision. In the .package file used by metaconfig to generate Configure, there are two variables that might be relevant: $baserev=5 and $package=perl5. Perl releases produced by the members of perl5-porters are usually available on CPAN in the F and F directories. =head2 Maintenance and Development Subversions The first rule of maintenance work is "First, do no harm." Trial releases of bug-fix maintenance releases are announced on perl5-porters. Trial releases use the new subversion number (to avoid testers installing it over the previous release) and include a 'local patch' entry in patchlevel.h. The distribution file contains the string C to make clear that the file is not meant for public consumption. In general, the names of official distribution files for the public always match the regular expression: ^perl\d+\.(\d+)\.\d+(-MAINT_TRIAL_\d+)\.tar\.gz$ C<$1> in the pattern is always an even number for maintenance versions, and odd for developer releases. In the past it has been observed that pumpkings tend to invent new naming conventions on the fly. If you are a pumpking, before you invent a new name for any of the three types of perl distributions, please inform the guys from the CPAN who are doing indexing and provide the trees of symlinks and the like. They will have to know I what you decide. =head2 Why is it called the patch pumpkin? Chip Salzenberg gets credit for that, with a nod to his cow orker, David Croy. We had passed around various names (baton, token, hot potato) but none caught on. Then, Chip asked: [begin quote] Who has the patch pumpkin? To explain: David Croy once told me once that at a previous job, there was one tape drive and multiple systems that used it for backups. But instead of some high-tech exclusion software, they used a low-tech method to prevent multiple simultaneous backups: a stuffed pumpkin. No one was allowed to make backups unless they had the "backup pumpkin". [end quote] The name has stuck. =head1 Philosophical Issues in Patching and Porting Perl There are no absolute rules, but there are some general guidelines I have tried to follow as I apply patches to the perl sources. (This section is still under construction.) =head2 Solve problems as generally as possible Never implement a specific restricted solution to a problem when you can solve the same problem in a more general, flexible way. For example, for dynamic loading to work on some SVR4 systems, we had to build a shared libperl.so library. In order to build "FAT" binaries on NeXT 4.0 systems, we had to build a special libperl library. Rather than continuing to build a contorted nest of special cases, I generalized the process of building libperl so that NeXT and SVR4 users could still get their work done, but others could build a shared libperl if they wanted to as well. Contain your changes carefully. Assume nothing about other operating systems, not even closely related ones. Your changes must not affect other platforms. Spy shamelessly on how similar patching or porting issues have been settled elsewhere. If feasible, try to keep filenames 8.3-compliant to humor those poor souls that get joy from running Perl under such dire limitations. There's a script, check83.pl, for keeping your nose 8.3-clean. In a similar vein, do not create files or directories which differ only in case (upper versus lower). =head2 Seek consensus on major changes If you are making big changes, don't do it in secret. Discuss the ideas in advance on perl5-porters. =head2 Keep the documentation up-to-date If your changes may affect how users use perl, then check to be sure that the documentation is in sync with your changes. Be sure to check all the files F and also the F document. Consider writing the appropriate documentation first and then implementing your change to correspond to the documentation. =head2 Avoid machine-specific #ifdef's To the extent reasonable, try to avoid machine-specific #ifdef's in the sources. Instead, use feature-specific #ifdef's. The reason is that the machine-specific #ifdef's may not be valid across major releases of the operating system. Further, the feature-specific tests may help out folks on another platform who have the same problem. =head2 Machine-specific files =over 4 =item source code If you have many machine-specific #defines or #includes, consider creating an "osish.h" (os2ish.h, vmsish.h, and so on) and including that in perl.h. If you have several machine-specific files (function emulations, function stubs, build utility wrappers) you may create a separate subdirectory (djgpp, win32) and put the files in there. Remember to update C when you add files. If your system supports dynamic loading but none of the existing methods at F work for you, you must write a new one. Study the existing ones to see what kind of interface you must supply. =item build hints There are two kinds of hints: hints for building Perl and hints for extensions. The former live in the C subdirectory, the latter in C subdirectories. The top level hints are Bourne-shell scripts that set, modify and unset appropriate Configure variables, based on the Configure command line options and possibly existing config.sh and Policy.sh files from previous Configure runs. The extension hints are written in Perl (by the time they are used miniperl has been built) and control the building of their respective extensions. They can be used to for example manipulate compilation and linking flags. =item build and installation Makefiles, scripts, and so forth Sometimes you will also need to tweak the Perl build and installation procedure itself, like for example F and F. Tread very carefully, even more than usual. Contain your changes with utmost care. =item test suite Many of the tests in C subdirectory assume machine-specific things like existence of certain functions, something about filesystem semantics, certain external utilities and their error messages. Use the C<$^O> and the C module (which contains the results of the Configure run, in effect the C converted to Perl) to either skip (preferably not) or customize (preferable) the tests for your platform. =item modules Certain standard modules may need updating if your operating system sports for example a native filesystem naming. You may want to update some or all of the modules File::Basename, File::Spec, File::Path, and File::Copy to become aware of your native filesystem syntax and peculiarities. Remember to have a $VERSION in the modules. You can use the Porting/checkVERSION.pl script for checking this. =item documentation If your operating system comes from outside UNIX you almost certainly will have differences in the available operating system functionality (missing system calls, different semantics, whatever). Please document these at F. If your operating system is the first B to have a system call also update the list of "portability-bewares" at the beginning of F. A file called F at the top level that explains things like how to install perl at this platform, where to get any possibly required additional software, and for example what test suite errors to expect, is nice too. Such files are in the process of being written in pod format and will eventually be renamed F. You may also want to write a separate F<.pod> file for your operating system to tell about existing mailing lists, os-specific modules, documentation, whatever. Please name these along the lines of FI.pod. [unfinished: where to put this file (the pod/ subdirectory, of course: but more importantly, which/what index files should be updated?)] =back =head2 Allow for lots of testing We should never release a main version without testing it as a subversion first. =head2 Test popular applications and modules. We should never release a main version without testing whether or not it breaks various popular modules and applications. A partial list of such things would include majordomo, metaconfig, apache, Tk, CGI, libnet, and libwww, to name just a few. Of course it's quite possible that some of those things will be just plain broken and need to be fixed, but, in general, we ought to try to avoid breaking widely-installed things. =head2 Automated generation of derivative files The F, F, F, and F files are all automatically generated by perl scripts. In general, don't patch these directly; patch the data files instead. F and F are also automatically generated by B. In general, you should patch the metaconfig units instead of patching these files directly. However, very minor changes to F may be made in between major sync-ups with the metaconfig units, which tends to be complicated operations. But be careful, this can quickly spiral out of control. Running metaconfig is not really hard. Also F is automatically produced from F. In general, look out for all F<*.SH> files. Finally, the sample files in the F subdirectory are generated automatically by the script F included with the metaconfig units. See L<"run metaconfig"> below for information on obtaining the metaconfig units. =head1 How to Make a Distribution This section has now been expanded and moved into its own file, F. I've kept some of the subsections here for now, as they don't direclty eleate to building a release any more, but still contain what might be useful information - DAPM 7/2009. =head2 run metaconfig If you need to make changes to Configure or config_h.SH, it may be best to change the appropriate metaconfig units instead, and regenerate Configure. metaconfig -m will regenerate Configure and config_h.SH. Much more information on obtaining and running metaconfig is in the F file that comes with Perl's metaconfig units. Since metaconfig is hard to change, running correction scripts after this generation is sometimes needed. Configure gained complexity over time, and the order in which config_h.SH is generated can cause havoc when compiling perl. Therefor, you need to run Porting/config_h.pl after that generation. All that and more is described in the README files that come with the metaunits. Perl's metaconfig units should be available on CPAN. A set of units that will work with perl5.9.x is in a file with a name similar to F under http://www.cpan.org/authors/id/H/HM/HMBRAND/ . The mc_units tar file should be unpacked in your main perl source directory. Note: those units were for use with 5.9.x. There may have been changes since then. Check for later versions or contact perl5-porters@perl.org to obtain a pointer to the current version. Alternatively, do consider if the F<*ish.h> files or the hint files might be a better place for your changes. =head2 MANIFEST If you are using metaconfig to regenerate Configure, then you should note that metaconfig actually uses MANIFEST.new, so you want to be sure MANIFEST.new is up-to-date too. I haven't found the MANIFEST/MANIFEST.new distinction particularly useful, but that's probably because I still haven't learned how to use the full suite of tools in the dist distribution. =head2 Run Configure This will build a config.sh and config.h. You can skip this if you haven't changed Configure or config_h.SH at all. I use the following command sh Configure -Dprefix=/opt/perl -Doptimize=-O -Dusethreads \ -Dcf_by='yourname' \ -Dcf_email='yourname@yourhost.yourplace.com' \ -Dperladmin='yourname@yourhost.yourplace.com' \ -Dmydomain='.yourplace.com' \ -Dmyhostname='yourhost' \ -des =head2 Update Porting/config.sh and Porting/config_H [XXX This section needs revision. We're currently working on easing the task of keeping the vms, win32, and plan9 config.sh info up-to-date. The plan is to use keep up-to-date 'canned' config.sh files in the appropriate subdirectories and then generate 'canned' config.h files for vms, win32, etc. from the generic config.sh file. This is to ease maintenance. When Configure gets updated, the parts sometimes get scrambled around, and the changes in config_H can sometimes be very hard to follow. config.sh, on the other hand, can safely be sorted, so it's easy to track (typically very small) changes to config.sh and then propagate them to a canned 'config.h' by any number of means, including a perl script in win32/ or carrying config.sh and config_h.SH to a Unix system and running sh config_h.SH.) Vms uses configure.com to generate its own config.sh and config.h. If you want to add a new variable to config.sh check with vms folk how to add it to configure.com too. XXX] The Porting/config.sh and Porting/config_H files are provided to help those folks who can't run Configure. It is important to keep them up-to-date. If you have changed config_h.SH, those changes must be reflected in config_H as well. (The name config_H was chosen to distinguish the file from config.h even on case-insensitive file systems.) Simply edit the existing config_H file; keep the first few explanatory lines and then copy your new config.h below. It may also be necessary to update win32/config.?c, and plan9/config.plan9, though you should be quite careful in doing so if you are not familiar with those systems. You might want to issue your patch with a promise to quickly issue a follow-up that handles those directories. =head2 make regen_perly If perly.y has been edited, it is necessary to run this target to rebuild perly.h, perly.act and perly.tab. In fact this target just runs the Perl script regen_perly.pl. Note that perly.c is I rebuilt; this is just a plain static file now. This target relies on you having Bison installed on your system. Running the target will tell you if you haven't got the right version, and if so, where to get the right one. Or if you prefer, you could hack regen_perly.pl to work with your version of Bison. The important things are that the regexes can still extract out the right chunks of the Bison output into perly.act and perly.tab, and that the contents of those two files, plus perly.h, are functionally equivalent to those produced by the supported version of Bison. Note that in the old days, you had to do C instead. =head2 make regen_all This target takes care of the regen_headers target. (It used to also call the regen_pods target, but that has been eliminated.) =head2 make regen_headers The F, F, and F files are all automatically generated by perl scripts. Since the user isn't guaranteed to have a working perl, we can't require the user to generate them. Hence you have to, if you're making a distribution. I used to include rules like the following in the makefile: # The following three header files are generated automatically # The correct versions should be already supplied with the perl kit, # in case you don't have perl or 'sh' available. # The - is to ignore error return codes in case you have the source # installed read-only or you don't have perl yet. keywords.h: keywords.pl @echo "Don't worry if this fails." - perl keywords.pl However, I got B of mail consisting of people worrying because the command failed. I eventually decided that I would save myself time and effort by manually running C myself rather than answering all the questions and complaints about the failing command. =head2 global.sym, interp.sym and perlio.sym Make sure these files are up-to-date. Read the comments in these files and in perl_exp.SH to see what to do. =head2 Binary compatibility If you do change F or F, think carefully about what you are doing. To the extent reasonable, we'd like to maintain source and binary compatibility with older releases of perl. That way, extensions built under one version of perl will continue to work with new versions of perl. Of course, some incompatible changes may well be necessary. I'm just suggesting that we not make any such changes without thinking carefully about them first. If possible, we should provide backwards-compatibility stubs. There's a lot of XS code out there. Let's not force people to keep changing it. =head2 PPPort F needs to be synchronized to include all new macros added to .h files (normally perl.h and XSUB.h, but others as well). Since chances are that when a new macro is added the committer will forget to update F, it's the best to diff for changes in .h files when making a new release and making sure that F contains them all. The pumpking can delegate the synchronization responsibility to anybody else, but the release process is the only place where we can make sure that no new macros fell through the cracks. =head2 Todo The F file contains a roughly-categorized unordered list of aspects of Perl that could use enhancement, features that could be added, areas that could be cleaned up, and so on. During your term as pumpkin-holder, you will probably address some of these issues, and perhaps identify others which, while you decide not to address them this time around, may be tackled in the future. Update the file to reflect the situation as it stands when you hand over the pumpkin. You might like, early in your pumpkin-holding career, to see if you can find champions for particular issues on the to-do list: an issue owned is an issue more likely to be resolved. There are also some more porting-specific L items later in this file. =head2 OS/2-specific updates In the os2 directory is F, a set of OS/2-specific diffs against B. If you make changes to Configure, you may want to consider regenerating this diff file to save trouble for the OS/2 maintainer. You can also consider the OS/2 diffs as reminders of portability things that need to be fixed in Configure. =head2 VMS-specific updates The Perl revision number appears as "perl5" in configure.com. It is courteous to update that if necessary. =head2 Making a new patch I find the F utility quite handy for making patches. You can obtain it from any CPAN archive under http://www.cpan.org/authors/Johan_Vromans/ . There are a couple of differences between my version and the standard one. I have mine do a # Print a reassuring "End of Patch" note so people won't # wonder if their mailer truncated patches. print "\n\nEnd of Patch.\n"; at the end. That's because I used to get questions from people asking if their mail was truncated. It also writes Index: lines which include the new directory prefix (change Index: print, approx line 294 or 310 depending on the version, to read: print PATCH ("Index: $newdir$new\n");). That helps patches work with more POSIX conformant patch programs. Here's how I generate a new patch. I'll use the hypothetical 5.004_07 to 5.004_08 patch as an example. # unpack perl5.004_07/ gzip -d -c perl5.004_07.tar.gz | tar -xof - # unpack perl5.004_08/ gzip -d -c perl5.004_08.tar.gz | tar -xof - makepatch perl5.004_07 perl5.004_08 > perl5.004_08.pat Makepatch will automatically generate appropriate B commands to remove deleted files. Unfortunately, it will not correctly set permissions for newly created files, so you may have to do so manually. For example, patch 5.003_04 created a new test F which needs to be executable, so at the top of the patch, I inserted the following lines: # Make a new test touch t/op/gv.t chmod +x t/opt/gv.t Now, of course, my patch is now wrong because makepatch didn't know I was going to do that command, and it patched against /dev/null. So, what I do is sort out all such shell commands that need to be in the patch (including possible mv-ing of files, if needed) and put that in the shell commands at the top of the patch. Next, I delete all the patch parts of perl5.004_08.pat, leaving just the shell commands. Then, I do the following: cd perl5.004_07 sh ../perl5.004_08.pat cd .. makepatch perl5.004_07 perl5.004_08 >> perl5.004_08.pat (Note the append to preserve my shell commands.) Now, my patch will line up with what the end users are going to do. =head2 Testing your patch It seems obvious, but be sure to test your patch. That is, verify that it produces exactly the same thing as your full distribution. rm -rf perl5.004_07 gzip -d -c perl5.004_07.tar.gz | tar -xf - cd perl5.004_07 sh ../perl5.004_08.pat patch -p1 -N < ../perl5.004_08.pat cd .. gdiff -r perl5.004_07 perl5.004_08 where B is GNU diff. Other diff's may also do recursive checking. =head2 More testing Again, it's obvious, but you should test your new version as widely as you can. You can be sure you'll hear about it quickly if your version doesn't work on both ANSI and pre-ANSI compilers, and on common systems such as SunOS 4.1.[34], Solaris, and Linux. If your changes include conditional code, try to test the different branches as thoroughly as you can. For example, if your system supports dynamic loading, you can also test static loading with sh Configure -Uusedl You can also hand-tweak your config.h to try out different #ifdef branches. =head2 Other tests =over 4 =item gcc -ansi -pedantic Configure -Dgccansipedantic [ -Dcc=gcc ] will enable (via the cflags script, not $Config{ccflags}) the gcc strict ANSI C flags -ansi and -pedantic for the compilation of the core files on platforms where it knows it can do so (like Linux, see cflags.SH for the full list), and on some platforms only one (Solaris can do only -pedantic, not -ansi). The flag -DPERL_GCC_PEDANTIC also gets added, since gcc does not add any internal cpp flag to signify that -pedantic is being used, as it does for -ansi (__STRICT_ANSI__). Note that the -ansi and -pedantic are enabled only for version 3 (and later) of gcc, since even gcc version 2.95.4 finds lots of seemingly false "value computed not used" errors from Perl. The -ansi and -pedantic are useful in catching at least the following nonportable practices: =over 4 =item * gcc-specific extensions =item * lvalue casts =item * // C++ comments =item * enum trailing commas =back The -Dgccansipedantic should be used only when cleaning up the code, not for production builds, since otherwise gcc cannot inline certain things. =back =head1 Running Purify Purify is a commercial tool that is helpful in identifying memory overruns, wild pointers, memory leaks and other such badness. Perl must be compiled in a specific way for optimal testing with Purify. Use the following commands to test perl with Purify: sh Configure -des -Doptimize=-g -Uusemymalloc -Dusemultiplicity \ -Accflags=-DPURIFY setenv PURIFYOPTIONS "-chain-length=25" make all pureperl cd t ln -s ../pureperl perl setenv PERL_DESTRUCT_LEVEL 2 ./perl TEST Disabling Perl's malloc allows Purify to monitor allocations and leaks more closely; using Perl's malloc will make Purify report most leaks in the "potential" leaks category. Enabling the multiplicity option allows perl to clean up thoroughly when the interpreter shuts down, which reduces the number of bogus leak reports from Purify. The -DPURIFY enables any Purify-specific debugging code in the sources. Purify outputs messages in "Viewer" windows by default. If you don't have a windowing environment or if you simply want the Purify output to unobtrusively go to a log file instead of to the interactive window, use the following options instead: setenv PURIFYOPTIONS "-chain-length=25 -windows=no -log-file=perl.log \ -append-logfile=yes" The only currently known leaks happen when there are compile-time errors within eval or require. (Fixing these is non-trivial, unfortunately, but they must be fixed eventually.) =head1 Common Gotchas =over 4 =item Probably Prefer POSIX It's often the case that you'll need to choose whether to do something the BSD-ish way or the POSIX-ish way. It's usually not a big problem when the two systems use different names for similar functions, such as memcmp() and bcmp(). The perl.h header file handles these by appropriate #defines, selecting the POSIX mem*() functions if available, but falling back on the b*() functions, if need be. More serious is the case where some brilliant person decided to use the same function name but give it a different meaning or calling sequence :-). getpgrp() and setpgrp() come to mind. These are a real problem on systems that aim for conformance to one standard (e.g. POSIX), but still try to support the other way of doing things (e.g. BSD). My general advice (still not really implemented in the source) is to do something like the following. Suppose there are two alternative versions, fooPOSIX() and fooBSD(). #ifdef HAS_FOOPOSIX /* use fooPOSIX(); */ #else # ifdef HAS_FOOBSD /* try to emulate fooPOSIX() with fooBSD(); perhaps with the following: */ # define fooPOSIX fooBSD # else # /* Uh, oh. We have to supply our own. */ # define fooPOSIX Perl_fooPOSIX # endif #endif =item Think positively If you need to add an #ifdef test, it is usually easier to follow if you think positively, e.g. #ifdef HAS_NEATO_FEATURE /* use neato feature */ #else /* use some fallback mechanism */ #endif rather than the more impenetrable #ifndef MISSING_NEATO_FEATURE /* Not missing it, so we must have it, so use it */ #else /* Are missing it, so fall back on something else. */ #endif Of course for this toy example, there's not much difference. But when the #ifdef's start spanning a couple of screen fulls, and the #else's are marked something like #else /* !MISSING_NEATO_FEATURE */ I find it easy to get lost. =item Providing Missing Functions -- Problem Not all systems have all the neat functions you might want or need, so you might decide to be helpful and provide an emulation. This is sound in theory and very kind of you, but please be careful about what you name the function. Let me use the C function as an illustration. Perl5.003 has the following in F #ifndef HAS_PAUSE #define pause() sleep((32767<<16)+32767) #endif Configure sets HAS_PAUSE if the system has the pause() function, so this #define only kicks in if the pause() function is missing. Nice idea, right? Unfortunately, some systems apparently have a prototype for pause() in F, but don't actually have the function in the library. (Or maybe they do have it in a library we're not using.) Thus, the compiler sees something like extern int pause(void); /* . . . */ #define pause() sleep((32767<<16)+32767) and dies with an error message. (Some compilers don't mind this; others apparently do.) To work around this, 5.003_03 and later have the following in perl.h: /* Some unistd.h's give a prototype for pause() even though HAS_PAUSE ends up undefined. This causes the #define below to be rejected by the compiler. Sigh. */ #ifdef HAS_PAUSE # define Pause pause #else # define Pause() sleep((32767<<16)+32767) #endif This works. The curious reader may wonder why I didn't do the following in F instead: #ifndef HAS_PAUSE void pause() { sleep((32767<<16)+32767); } #endif That is, since the function is missing, just provide it. Then things would probably be been alright, it would seem. Well, almost. It could be made to work. The problem arises from the conflicting needs of dynamic loading and namespace protection. For dynamic loading to work on AIX (and VMS) we need to provide a list of symbols to be exported. This is done by the script F, which reads F and F. Thus, the C symbol would have to be added to F So far, so good. On the other hand, one of the goals of Perl5 is to make it easy to either extend or embed perl and link it with other libraries. This means we have to be careful to keep the visible namespace "clean". That is, we don't want perl's global variables to conflict with those in the other application library. Although this work is still in progress, the way it is currently done is via the F file. This file is built from the F and F files, since those files already list the globally visible symbols. If we had added C to global.sym, then F would contain the line #define pause Perl_pause and calls to C in the perl sources would now point to C. Now, when B is run to build the F executable, it will go looking for C, which probably won't exist in any of the standard libraries. Thus the build of perl will fail. Those systems where C is not defined would be ok, however, since they would get a C function in util.c. The rest of the world would be in trouble. And yes, this scenario has happened. On SCO, the function C is available. (I think it's in F<-lx>, the Xenix compatibility library.) Since the perl4 days (and possibly before), Perl has included a C function that gets called something akin to #ifndef HAS_CHSIZE I32 chsize(fd, length) /* . . . */ #endif When 5.003 added #define chsize Perl_chsize to F, the compile started failing on SCO systems. The "fix" is to give the function a different name. The one implemented in 5.003_05 isn't optimal, but here's what was done: #ifdef HAS_CHSIZE # ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */ # undef my_chsize # endif # define my_chsize chsize #endif My explanatory comment in patch 5.003_05 said: Undef and then re-define my_chsize from Perl_my_chsize to just plain chsize if this system HAS_CHSIZE. This probably only applies to SCO. This shows the perils of having internal functions with the same name as external library functions :-). Now, we can safely put C in F, export it, and hide it with F. To be consistent with what I did for C, I probably should have called the new function C, rather than C. However, the perl sources are quite inconsistent on this (Consider New, Mymalloc, and Myremalloc, to name just a few.) There is a problem with this fix, however, in that C was available as a F library function in 5.003, but it isn't available any more (as of 5.003_07). This means that we've broken binary compatibility. This is not good. =item Providing missing functions -- some ideas We currently don't have a standard way of handling such missing function names. Right now, I'm effectively thinking aloud about a solution. Some day, I'll try to formally propose a solution. Part of the problem is that we want to have some functions listed as exported but not have their names mangled by embed.h or possibly conflict with names in standard system headers. We actually already have such a list at the end of F (though that list is out-of-date): # extra globals not included above. cat <> perl.exp perl_init_ext perl_init_fold perl_init_i18nl14n perl_alloc perl_construct perl_destruct perl_free perl_parse perl_run perl_get_sv perl_get_av perl_get_hv perl_get_cv perl_call_argv perl_call_pv perl_call_method perl_call_sv perl_requirepv safecalloc safemalloc saferealloc safefree This still needs much thought, but I'm inclined to think that one possible solution is to prefix all such functions with C in the source and list them along with the other C functions in F. Thus, for C, we'd do something like the following: /* in perl.h */ #ifdef HAS_CHSIZE # define perl_chsize chsize #endif then in some file (e.g. F or F) do #ifndef HAS_CHSIZE I32 perl_chsize(fd, length) /* implement the function here . . . */ #endif Alternatively, we could just always use C everywhere and move C from F to the end of F. That would probably be fine as long as our C function agreed with all the C function prototypes in the various systems we'll be using. As long as the prototypes in actual use don't vary that much, this is probably a good alternative. (As a counter-example, note how Configure and perl have to go through hoops to find and use get Malloc_t and Free_t for C and C.) At the moment, this latter option is what I tend to prefer. =item All the world's a VAX Sorry, showing my age:-). Still, all the world is not BSD 4.[34], SVR4, or POSIX. Be aware that SVR3-derived systems are still quite common (do you have any idea how many systems run SCO?) If you don't have a bunch of v7 manuals handy, the metaconfig units (by default installed in F) are a good resource to look at for portability. =back =head1 Miscellaneous Topics =head2 Autoconf Why does perl use a metaconfig-generated Configure script instead of an autoconf-generated configure script? Metaconfig and autoconf are two tools with very similar purposes. Metaconfig is actually the older of the two, and was originally written by Larry Wall, while autoconf is probably now used in a wider variety of packages. The autoconf info file discusses the history of autoconf and how it came to be. The curious reader is referred there for further information. Overall, both tools are quite good, I think, and the choice of which one to use could be argued either way. In March, 1994, when I was just starting to work on Configure support for Perl5, I considered both autoconf and metaconfig, and eventually decided to use metaconfig for the following reasons: =over 4 =item Compatibility with Perl4 Perl4 used metaconfig, so many of the #ifdef's were already set up for metaconfig. Of course metaconfig had evolved some since Perl4's days, but not so much that it posed any serious problems. =item Metaconfig worked for me My system at the time was Interactive 2.2, an SVR3.2/386 derivative that also had some POSIX support. Metaconfig-generated Configure scripts worked fine for me on that system. On the other hand, autoconf-generated scripts usually didn't. (They did come quite close, though, in some cases.) At the time, I actually fetched a large number of GNU packages and checked. Not a single one configured and compiled correctly out-of-the-box with the system's cc compiler. =item Configure can be interactive With both autoconf and metaconfig, if the script works, everything is fine. However, one of my main problems with autoconf-generated scripts was that if it guessed wrong about something, it could be B hard to go back and fix it. For example, autoconf always insisted on passing the -Xp flag to cc (to turn on POSIX behavior), even when that wasn't what I wanted or needed for that package. There was no way short of editing the configure script to turn this off. You couldn't just edit the resulting Makefile at the end because the -Xp flag influenced a number of other configure tests. Metaconfig's Configure scripts, on the other hand, can be interactive. Thus if Configure is guessing things incorrectly, you can go back and fix them. This isn't as important now as it was when we were actively developing Configure support for new features such as dynamic loading, but it's still useful occasionally. =item GPL At the time, autoconf-generated scripts were covered under the GNU Public License, and hence weren't suitable for inclusion with Perl, which has a different licensing policy. (Autoconf's licensing has since changed.) =item Modularity Metaconfig builds up Configure from a collection of discrete pieces called "units". You can override the standard behavior by supplying your own unit. With autoconf, you have to patch the standard files instead. I find the metaconfig "unit" method easier to work with. Others may find metaconfig's units clumsy to work with. =back =head2 Why isn't there a directory to override Perl's library? Mainly because no one's gotten around to making one. Note that "making one" involves changing perl.c, Configure, config_h.SH (and associated files, see above), and I it all in the INSTALL file. Apparently, most folks who want to override one of the standard library files simply do it by overwriting the standard library files. =head2 APPLLIB In the perl.c sources, you'll find an undocumented APPLLIB_EXP variable, sort of like PRIVLIB_EXP and ARCHLIB_EXP (which are documented in config_h.SH). Here's what APPLLIB_EXP is for, from a mail message from Larry: The main intent of APPLLIB_EXP is for folks who want to send out a version of Perl embedded in their product. They would set the symbol to be the name of the library containing the files needed to run or to support their particular application. This works at the "override" level to make sure they get their own versions of any library code that they absolutely must have configuration control over. As such, I don't see any conflict with a sysadmin using it for a override-ish sort of thing, when installing a generic Perl. It should probably have been named something to do with overriding though. Since it's undocumented we could still change it... :-) Given that it's already there, you can use it to override distribution modules. One way to do that is to add ccflags="$ccflags -DAPPLLIB_EXP=\"/my/override\"" to your config.over file. (You have to be particularly careful to get the double quotes in. APPLLIB_EXP must be a valid C string. It might actually be easier to just #define it yourself in perl.c.) Then perl.c will put /my/override ahead of ARCHLIB and PRIVLIB. Perl will also search architecture-specific and version-specific subdirectories of APPLLIB_EXP. =head2 Shared libperl.so location Why isn't the shared libperl.so installed in /usr/lib/ along with "all the other" shared libraries? Instead, it is installed in $archlib, which is typically something like /usr/local/lib/perl5/archname/5.00404 and is architecture- and version-specific. The basic reason why a shared libperl.so gets put in $archlib is so that you can have more than one version of perl on the system at the same time, and have each refer to its own libperl.so. Three examples might help. All of these work now; none would work if you put libperl.so in /usr/lib. =over =item 1. Suppose you want to have both threaded and non-threaded perl versions around. Configure will name both perl libraries "libperl.so" (so that you can link to them with -lperl). The perl binaries tell them apart by having looking in the appropriate $archlib directories. =item 2. Suppose you have perl5.004_04 installed and you want to try to compile it again, perhaps with different options or after applying a patch. If you already have libperl.so installed in /usr/lib/, then it may be either difficult or impossible to get ld.so to find the new libperl.so that you're trying to build. If, instead, libperl.so is tucked away in $archlib, then you can always just change $archlib in the current perl you're trying to build so that ld.so won't find your old libperl.so. (The INSTALL file suggests you do this when building a debugging perl.) =item 3. The shared perl library is not a "well-behaved" shared library with proper major and minor version numbers, so you can't necessarily have perl5.004_04 and perl5.004_05 installed simultaneously. Suppose perl5.004_04 were to install /usr/lib/libperl.so.4.4, and perl5.004_05 were to install /usr/lib/libperl.so.4.5. Now, when you try to run perl5.004_04, ld.so might try to load libperl.so.4.5, since it has the right "major version" number. If this works at all, it almost certainly defeats the reason for keeping perl5.004_04 around. Worse, with development subversions, you certaily can't guarantee that libperl.so.4.4 and libperl.so.4.55 will be compatible. Anyway, all this leads to quite obscure failures that are sure to drive casual users crazy. Even experienced users will get confused :-). Upon reflection, I'd say leave libperl.so in $archlib. =back =head2 Indentation style Over the years Perl has become a mishmash of various indentation styles, but the original "Larry style" can probably be restored with (GNU) indent somewhat like this: indent -kr -nce -psl -sc A more ambitious solution would also specify a list of Perl specific types with -TSV -TAV -THV .. -TMAGIC -TPerlIO ... but that list would be quite ungainly. Also note that GNU indent also doesn't do aligning of consecutive assignments, which would truly wreck the layout in places like sv.c:Perl_sv_upgrade() or sv.c:Perl_clone_using(). Similarly nicely aligned &&s, ||s and ==s would not be respected. =head1 Upload Your Work to CPAN You can upload your work to CPAN if you have a CPAN id. Check out http://www.cpan.org/modules/04pause.html for information on _PAUSE_, the Perl Author's Upload Server. I typically upload both the patch file, e.g. F and the full tar file, e.g. F. If you want your patch to appear in the F directory on CPAN, send e-mail to the CPAN master librarian. (Check out http://www.cpan.org/CPAN.html ). =head1 Help Save the World You should definitely announce your patch on the perl5-porters list. You should also consider announcing your patch on comp.lang.perl.announce, though you should make it quite clear that a subversion is not a production release, and be prepared to deal with people who will not read your disclaimer. =head1 Todo Here, in no particular order, are some Configure and build-related items that merit consideration. This list isn't exhaustive, it's just what I came up with off the top of my head. =head2 Adding missing library functions to Perl The perl Configure script automatically determines which headers and functions you have available on your system and arranges for them to be included in the compilation and linking process. Occasionally, when porting perl to an operating system for the first time, you may find that the operating system is missing a key function. While perl may still build without this function, no perl program will be able to reference the missing function. You may be able to write the missing function yourself, or you may be able to find the missing function in the distribution files for another software package. In this case, you need to instruct the perl configure-and-build process to use your function. Perform these steps. =over 3 =item * Code and test the function you wish to add. Test it carefully; you will have a much easier time debugging your code independently than when it is a part of perl. =item * Here is an implementation of the POSIX truncate function for an operating system (VOS) that does not supply one, but which does supply the ftruncate() function. /* Beginning of modification history */ /* Written 02-01-02 by Nick Ing-Simmons (nick@ing-simmons.net) */ /* End of modification history */ /* VOS doesn't supply a truncate function, so we build one up from the available POSIX functions. */ #include #include #include int truncate(const char *path, off_t len) { int fd = open(path,O_WRONLY); int code = -1; if (fd >= 0) { code = ftruncate(fd,len); close(fd); } return code; } Place this file into a subdirectory that has the same name as the operating system. This file is named perl/vos/vos.c =item * If your operating system has a hints file (in perl/hints/XXX.sh for an operating system named XXX), then start with it. If your operating system has no hints file, then create one. You can use a hints file for a similar operating system, if one exists, as a template. =item * Add lines like the following to your hints file. The first line (d_truncate="define") instructs Configure that the truncate() function exists. The second line (archobjs="vos.o") instructs the makefiles that the perl executable depends on the existence of a file named "vos.o". (Make will automatically look for "vos.c" and compile it with the same options as the perl source code). The final line ("test -h...") adds a symbolic link to the top-level directory so that make can find vos.c. Of course, you should use your own operating system name for the source file of extensions, not "vos.c". # VOS does not have truncate() but we supply one in vos.c d_truncate="define" archobjs="vos.o" # Help gmake find vos.c test -h vos.c || ln -s vos/vos.c vos.c The hints file is a series of shell commands that are run in the top-level directory (the "perl" directory). Thus, these commands are simply executed by Configure at an appropriate place during its execution. =item * At this point, you can run the Configure script and rebuild perl. Carefully test the newly-built perl to ensure that normal paths, and error paths, behave as you expect. =back =head2 Good ideas waiting for round tuits =over 4 =item Configure -Dsrc=/blah/blah We should be able to emulate B. Tom Tromey tromey@creche.cygnus.com has submitted some patches to the dist-users mailing list along these lines. They have been folded back into the main distribution, but various parts of the perl Configure/build/install process still assume src='.'. =item Hint file fixes Various hint files work around Configure problems. We ought to fix Configure so that most of them aren't needed. =item Hint file information Some of the hint file information (particularly dynamic loading stuff) ought to be fed back into the main metaconfig distribution. =back =head2 Probably good ideas waiting for round tuits =over 4 =item GNU configure --options I've received sensible suggestions for --exec_prefix and other GNU configure --options. It's not always obvious exactly what is intended, but this merits investigation. =item make clean Currently, B isn't all that useful, though B and B are. This needs a bit of thought and documentation before it gets cleaned up. =item Try gcc if cc fails Currently, we just give up. =item bypassing safe*alloc wrappers On some systems, it may be safe to call the system malloc directly without going through the util.c safe* layers. (Such systems would accept free(0), for example.) This might be a time-saver for systems that already have a good malloc. (Recent Linux libc's apparently have a nice malloc that is well-tuned for the system.) =back =head2 Vague possibilities =over 4 =item gconvert replacement Maybe include a replacement function that doesn't lose data in rare cases of coercion between string and numerical values. =item Improve makedepend The current makedepend process is clunky and annoyingly slow, but it works for most folks. Alas, it assumes that there is a filename $firstmakefile that the B command will try to use before it uses F. Such may not be the case for all B commands, particularly those on non-Unix systems. Probably some variant of the BSD F<.depend> file will be useful. We ought to check how other packages do this, if they do it at all. We could probably pre-generate the dependencies (with the exception of malloc.o, which could probably be determined at F extraction time. =item GNU Makefile standard targets GNU software generally has standardized Makefile targets. Unless we have good reason to do otherwise, I see no reason not to support them. =item File locking Somehow, straighten out, document, and implement lockf(), flock(), and/or fcntl() file locking. It's a mess. See $d_fcntl_can_lock in recent config.sh files though. =back =head2 Copyright Issues The following is based on the consensus of a couple of IPR lawyers, but it is of course not a legally binding statement, just a common sense summary. =over 4 =item * Tacking on copyright statements is unnecessary to begin with because of the Berne convention. But assuming you want to go ahead... =item * The right form of a copyright statement is Copyright (C) Year, Year, ... by Someone The (C) is not required everywhere but it doesn't hurt and in certain jurisdictions it is required, so let's leave it in. (Yes, it's true that in some jurisdictions the "(C)" is not legally binding, one should use the true ringed-C. But we don't have that character available for Perl's source code.) The years must be listed out separately. Year-Year is not correct. Only the years when the piece has changed 'significantly' may be added. =item * One cannot give away one's copyright trivially. One can give one's copyright away by using public domain, but even that requires a little bit more than just saying 'this is in public domain'. (What it exactly requires depends on your jurisdiction.) But barring public domain, one cannot "transfer" one's copyright to another person or entity. In the context of software, it means that contributors cannot give away their copyright or "transfer" it to the "owner" of the software. Also remember that in many cases if you are employed by someone, your work may be copyrighted to your employer, even when you are contributing on your own time (this all depends on too many things to list here). But the bottom line is that you definitely can't give away a copyright you may not even have. What is possible, however, is that the software can simply state Copyright (C) Year, Year, ... by Someone and others and then list the "others" somewhere in the distribution. And this is exactly what Perl does. (The "somewhere" is AUTHORS and the Changes* files.) =item * Split files, merged files, and generated files are problematic. The rule of thumb: in split files, copy the copyright years of the original file to all the new files; in merged files make an union of the copyright years of all the old files; in generated files propagate the copyright years of the generating file(s). =item * The files of Perl source code distribution do carry a lot of copyrights, by various people. (There are many copyrights embedded in perl.c, for example.) The most straightforward thing for pumpkings to do is to simply update Larry's copyrights at the beginning of the *.[hcy], x2p/*.[hcy], *.pl, and README files, and leave all other copyrights alone. Doing more than that requires quite a bit of tracking. =back =head1 AUTHORS Original author: Andy Dougherty doughera@lafayette.edu . Additions by Chip Salzenberg chip@perl.com and Tim Bunce Tim.Bunce@ig.co.uk . All opinions expressed herein are those of the authorZ<>(s). =head1 LAST MODIFIED 2009-07-08-01 Jesse Vincent perl-5.12.0-RC0/Porting/Maintainers.pm0000444000175000017500000002201711325127001016351 0ustar jessejesse# # Maintainers.pm - show information about maintainers # package Maintainers; use strict; use warnings; use lib "Porting"; # Please don't use post 5.008 features as this module is used by # Porting/makemeta, and that in turn has to be run by the perl just built. use 5.008; require "Maintainers.pl"; use vars qw(%Modules %Maintainers); use vars qw(@ISA @EXPORT_OK $VERSION); @ISA = qw(Exporter); @EXPORT_OK = qw(%Modules %Maintainers get_module_files get_module_pat show_results process_options files_to_modules finish_tap_output reload_manifest); $VERSION = 0.04; require Exporter; use File::Find; use Getopt::Long; my %MANIFEST; # (re)read the MANIFEST file, blowing away any previous effort sub reload_manifest { %MANIFEST = (); my $manifest_path = 'MANIFEST'; if (! -e $manifest_path) { $manifest_path = "../MANIFEST"; } if (open(my $manfh, $manifest_path )) { while (<$manfh>) { if (/^(\S+)/) { $MANIFEST{$1}++; } else { warn "MANIFEST:$.: malformed line: $_\n"; } } close $manfh; } else { die "$0: Failed to open MANIFEST for reading: $!\n"; } } reload_manifest; sub get_module_pat { my $m = shift; split ' ', $Modules{$m}{FILES}; } # exand dir/ or foo* into a full list of files # sub expand_glob { sort { lc $a cmp lc $b } map { -f $_ && $_ !~ /[*?]/ ? # File as-is. $_ : -d _ && $_ !~ /[*?]/ ? # Recurse into directories. do { my @files; find( sub { push @files, $File::Find::name if -f $_ && exists $MANIFEST{$File::Find::name}; }, $_); @files; } # The rest are globbable patterns; expand the glob, then # recurively perform directory expansion on any results : expand_glob(grep -e $_,glob($_)) } @_; } sub get_module_files { my $m = shift; my %exclude; my @files; for (get_module_pat($m)) { if (s/^!//) { $exclude{$_}=1 for expand_glob($_); } else { push @files, expand_glob($_); } } return grep !$exclude{$_}, @files; } sub get_maintainer_modules { my $m = shift; sort { lc $a cmp lc $b } grep { $Modules{$_}{MAINTAINER} eq $m } keys %Modules; } sub usage { warn <<__EOF__; $0: Usage: --maintainer M | --module M [--files] List modules or maintainers matching the pattern M. With --files, list all the files associated with them or --check | --checkmani [commit | file ... | dir ... ] Check consistency of Maintainers.pl with a file checks if it has a maintainer with a dir checks all files have a maintainer with a commit checks files modified by that commit no arg checks for multiple maintainers --checkmani is like --check, but only reports on unclaimed files if they are in MANIFEST or --opened | file .... List the module ownership of modified or the listed files --tap-output Show results as valid TAP output. Currently only compatible with --check, --checkmani Matching is case-ignoring regexp, author matching is both by the short id and by the full name and email. A "module" may not be just a module, it may be a file or files or a subdirectory. The options may be abbreviated to their unique prefixes __EOF__ exit(0); } my $Maintainer; my $Module; my $Files; my $Check; my $Checkmani; my $Opened; my $TestCounter = 0; my $TapOutput; sub process_options { usage() unless GetOptions( 'maintainer=s' => \$Maintainer, 'module=s' => \$Module, 'files' => \$Files, 'check' => \$Check, 'checkmani' => \$Checkmani, 'opened' => \$Opened, 'tap-output' => \$TapOutput, ); my @Files; if ($Opened) { usage if @ARGV; chomp (@Files = `git ls-files -m --full-name`); die if $?; } elsif (@ARGV == 1 && $ARGV[0] =~ /^(?:HEAD|[0-9a-f]{4,40})(?:~\d+)?\^*$/) { my $command = "git diff --name-only $ARGV[0]^ $ARGV[0]"; chomp (@Files = `$command`); die "'$command' failed: $?" if $?; } else { @Files = @ARGV; } usage() if @Files && ($Maintainer || $Module || $Files); for my $mean ($Maintainer, $Module) { warn "$0: Did you mean '$0 $mean'?\n" if $mean && -e $mean && $mean ne '.' && !$Files; } warn "$0: Did you mean '$0 -mo $Maintainer'?\n" if defined $Maintainer && exists $Modules{$Maintainer}; warn "$0: Did you mean '$0 -ma $Module'?\n" if defined $Module && exists $Maintainers{$Module}; return ($Maintainer, $Module, $Files, @Files); } sub files_to_modules { my @Files = @_; my %ModuleByFile; for (@Files) { s:^\./:: } @ModuleByFile{@Files} = (); # First try fast match. my %ModuleByPat; for my $module (keys %Modules) { for my $pat (get_module_pat($module)) { $ModuleByPat{$pat} = $module; } } # Expand any globs. my %ExpModuleByPat; for my $pat (keys %ModuleByPat) { if (-e $pat) { $ExpModuleByPat{$pat} = $ModuleByPat{$pat}; } else { for my $exp (glob($pat)) { $ExpModuleByPat{$exp} = $ModuleByPat{$pat}; } } } %ModuleByPat = %ExpModuleByPat; for my $file (@Files) { $ModuleByFile{$file} = $ModuleByPat{$file} if exists $ModuleByPat{$file}; } # If still unresolved files... if (my @ToDo = grep { !defined $ModuleByFile{$_} } keys %ModuleByFile) { # Cannot match what isn't there. @ToDo = grep { -e $_ } @ToDo; if (@ToDo) { # Try prefix matching. # Need to try longst prefixes first, else lib/CPAN may match # lib/CPANPLUS/... and similar my @OrderedModuleByPat = sort {length $b <=> length $a} keys %ModuleByPat; # Remove trailing slashes. for (@ToDo) { s|/$|| } my %ToDo; @ToDo{@ToDo} = (); for my $pat (@OrderedModuleByPat) { last unless keys %ToDo; if (-d $pat) { my @Done; for my $file (keys %ToDo) { if ($file =~ m|^$pat|i) { $ModuleByFile{$file} = $ModuleByPat{$pat}; push @Done, $file; } } delete @ToDo{@Done}; } } } } \%ModuleByFile; } sub show_results { my ($Maintainer, $Module, $Files, @Files) = @_; if ($Maintainer) { for my $m (sort keys %Maintainers) { if ($m =~ /$Maintainer/io || $Maintainers{$m} =~ /$Maintainer/io) { my @modules = get_maintainer_modules($m); if ($Module) { @modules = grep { /$Module/io } @modules; } if ($Files) { my @files; for my $module (@modules) { push @files, get_module_files($module); } printf "%-15s @files\n", $m; } else { if ($Module) { printf "%-15s @modules\n", $m; } else { printf "%-15s $Maintainers{$m}\n", $m; } } } } } elsif ($Module) { for my $m (sort { lc $a cmp lc $b } keys %Modules) { if ($m =~ /$Module/io) { if ($Files) { my @files = get_module_files($m); printf "%-15s @files\n", $m; } else { printf "%-15s %-12s %s\n", $m, $Modules{$m}{MAINTAINER}, $Modules{$m}{UPSTREAM}||'unknown'; } } } } elsif ($Check or $Checkmani) { if( @Files ) { missing_maintainers( $Checkmani ? sub { -f $_ and exists $MANIFEST{$File::Find::name} } : sub { /\.(?:[chty]|p[lm]|xs)\z/msx }, @Files ); } else { duplicated_maintainers(); } } elsif (@Files) { my $ModuleByFile = files_to_modules(@Files); for my $file (@Files) { if (defined $ModuleByFile->{$file}) { my $module = $ModuleByFile->{$file}; my $maintainer = $Modules{$ModuleByFile->{$file}}{MAINTAINER}; my $upstream = $Modules{$module}{UPSTREAM}||'unknown'; printf "%-15s [%-7s] $module $maintainer $Maintainers{$maintainer}\n", $file, $upstream; } else { printf "%-15s ?\n", $file; } } } elsif ($Opened) { print STDERR "(No files are modified)\n"; } else { usage(); } } my %files; sub maintainers_files { %files = (); for my $k (keys %Modules) { for my $f (get_module_files($k)) { ++$files{$f}; } } } sub duplicated_maintainers { maintainers_files(); for my $f (keys %files) { if ($TapOutput) { if ($files{$f} > 1) { print "not ok ".++$TestCounter." - File $f appears $files{$f} times in Maintainers.pl\n"; } else { print "ok ".++$TestCounter." - File $f appears $files{$f} times in Maintainers.pl\n"; } } else { if ($files{$f} > 1) { warn "File $f appears $files{$f} times in Maintainers.pl\n"; } } } } sub warn_maintainer { my $name = shift; if ($TapOutput) { if ($files{$name}) { print "ok ".++$TestCounter." - $name has a maintainer\n"; } else { print "not ok ".++$TestCounter." - $name has NO maintainer\n"; } } else { warn "File $name has no maintainer\n" if not $files{$name}; } } sub missing_maintainers { my($check, @path) = @_; maintainers_files(); my @dir; for my $d (@path) { if( -d $d ) { push @dir, $d } else { warn_maintainer($d) } } find sub { warn_maintainer($File::Find::name) if $check->() }, @dir if @dir; } sub finish_tap_output { print "1..".$TestCounter."\n"; } 1; perl-5.12.0-RC0/Porting/how_to_write_a_perldelta.pod0000444000175000017500000002067711325127001021324 0ustar jessejesse=head1 How to write a perldelta This is intended as a guide for how to write a perldelta. There has never been a formal specification - the working rule is "fake up a document that looks something close to the existing perldeltas". So if it's unclear how do to do something, see if it's been done before, and if the approach works there, steal it. =head2 Template Note there is a file F which contains a skeleton version of a perldelta.pod file, which should normally be copied in at the start of a new release. =head2 Style Pod is more a physical markup language, rather than a logical markup language. Despite that it has some built in conventions. B: =over 4 =item * CE> is for File =item * CE> is for Code =item * CE> is for Link =back Whilst modules could also be links, usually in the context of the perldelta the reference is to code Cing them, rather than something within their documentation. Be consistent in how bugs are referenced. One style is =over 4 =item rt.perl.org C inline, but enclose in square brackets after a sentence. C<[RT #43010]> =item ActiveState C =item Debian C =back =head2 Copy editing Be consistent. In a list, either make every item a note, or a full sentence. Either end every item with a full stop, or ensure that no item ends with one. I B I - choose exactly one, and stick to it. =head2 Sections Historically, the perldelta has consisted of a sequence of C<=head1> sections, usually in the same order. Un-needed sections are deleted, and if something doesn't fit nicely into the existing sections, a new more appropriate section is created. =over =item NAME Follows this formula: perl5104delta - what is new for perl v5.10.4 =item DESCRIPTION For a release on a stable branch, follows this formula: This document describes differences between the 5.10.3 release and the 5.10.4 release. For the start of a new stable branch, follows this formula: This document describes differences between the 5.12.0 release and the 5.10.0 release. Clearly this sets the scope of which changes are to be summarised in the rest of the document. =item Notice There was a I section in L, to carry an important notice. =item Incompatible Changes For a release on a stable branch, this section aspires to be There are no changes intentionally incompatible with 5.10.3. If any exist, they are bugs and reports are welcome. =item Core Enhancements New core language features go here. Summarise user-visible core language enhancements. Particularly prominent performance optimisations could go here, but most should go in the L section. Feature inside modules (pure-Perl and XS) go in L =item New Platforms List any platforms that this version of perl compiles on, that previous versions did not. These will either be enabled by new files in the F directories, or new subdirectories and F files at the top level of the source tree. =item Modules and Pragmata All changes to installed files in F and F go here, in a list ordered by distribution name. Minimally it should be the module version, but it's more useful to the end user to give a paragraph's summary of the module's changes. In an ideal world, dual-life modules would have a F file that could be cribbed. Whilst this section could be built by incrementally working through change descriptions applying to files, this is prone to error. It's better to collate changes to F and F by module, and then summarise all changes to a module as a group. This can be done by partitioning directories within F and F to a number of people. B - this could be automated better If Module::CoreList has been updated, then F will automatically print out several sections if relevent that can be pasted into F: * New Modules and Pragmata * Pragmata Changes * Updated Modules * Removed Modules and Pragmata Each section will have stub entries following a template like this: =item C Upgraded from version 0.01 to 0.02 It does not include modules listed in F under C<_PERLLIB>, but it's a start. Where relevent, a summary of changes can be added by hand. A more adventurous enhancement would be to automate grabbing the changelogs for dual lived modules. For each of them, grab the relevant changes files from CPAN for the old and new versions, and if the old one is a strict subset of the new one, splice the extra lines right into the output, as a basis for summarising. (And if not, experiment with using F to get the relevant part of changelog for the particular file in core) These could also be enhanced further by using a Pod parser module to produce a parse tree of F, and splicing in the updates correctly without throwing existing entries away. If you think that's nuts, take a look at what F already does to splice into existing Makefiles on various platforms: http://perl5.git.perl.org/perl.git/blob/blead:/pod/buildtoc#l498 Perl is this really powerful language for text manipulation. And fun to play with. We need to get that message out. :-) =item Utility Changes Changes to installed programs such as F and F go here. Most of these are built within the directories F and F. =item New Documentation Changes which create B files in F go here. B - this could be automated, at least as far as generating a first draft. =over =item 1 Start with a clean exploded tarball of the previous release, and a clean checkout of the branch in question =item 2 Take the F file of each =item 3 Search for lines matching C =item 4 Diff them =item 5 Explode if anyone deleted documentation. [No idea what the policy on that is yet] =item 6 For each file only in the newer F =over =item 1 Use F to determine its Author =item 2 Open the pod file itself =item 3 Grab the description section =item 4 Write out a block of text starting roughly L, by A. U. Thor, provides @description =back =back =item Changes to Existing Documentation Changes which significantly change existing files in F go here. Any changes to F should go in L. =item Performance Enhancements Changes which enhance performance without changing behaviour go here. There may well be none in a stable release. =item Installation and Configuration Improvements Changes to F, F, F, and analogous tools go here. =item Selected Bug Fixes Important bug fixes in the core language are summarised here. Bug fixes in files in F and F are best summarised in L. =item New or Changed Diagnostics New or changed warnings emitted by the core's C code go here. =item Changed Internals Changes which affect the interface available to C code go here. =item New Tests Changes which create B files in F go here. Changes to existing files in F aren't worth summarising, although the bugs that they represent may be. Autogenerate this section by running something like this: # perl newtests-perldelta.pl v5.11.1 HEAD =item Known Problems Descriptions of platform agnostic bugs we know we can't fix go here. Any tests that had to be Ced for the release would be noted here, unless they were specific to a particular platform (see below). =item Deprecations Add any new known deprecations here. =item Platform Specific Notes Any changes specific to a particular platform. VMS and Win32 are the usual stars here. It's probably best to group changes under the same section layout as the main perldelta. =item Obituary If any significant core contributor has died, we've added a short obituary here. =item Acknowledgements The list of people to thank goes here. You can find the list of committers and authors by: % git log v5.11.1..HEAD | perl -nlwe '$seen{$1}++ if /^Author: ([^<]*)/; END { print for sort keys %seen }' And how many files where changed by: % git diff v5.11.1..HEAD | diffstat =item Reporting Bugs This doesn't usually need to be changed from the previous perldelta. =item SEE ALSO This doesn't usually need to be changed from the previous perldelta. =back perl-5.12.0-RC0/Porting/timecheck2.c0000444000175000017500000000527611325127001015733 0ustar jessejesse/* A little program to test the limits of your system's time functions * See Porting/README.y2038 for details */ #include #include #include 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; } void check_date_max( struct tm * (*date_func)(const time_t *), char *func_name ) { struct tm *date; time_t time = 0; time_t last_time = 0; time_t time_change; int i; for (i = 0; i <= 63; i++) { date = (*date_func)(&time); /* date_func() broke or tm_year overflowed */ if(date == NULL || date->tm_year < 69) break; last_time = time; time += time + 1; /* time_t overflowed */ if( time < last_time ) break; } /* Binary search for the exact failure point */ time = last_time; time_change = last_time / 2; do { time += time_change; date = (*date_func)(&time); /* date_func() broke or tm_year overflowed or time_t overflowed */ if(date == NULL || date->tm_year < 69 || time < last_time) { time = last_time; time_change = time_change / 2; } else { last_time = time; } } while(time_change > 0); printf("%20s max %.0f\n", func_name, my_difftime(last_time, Time_Zero)); } void check_date_min( struct tm * (*date_func)(const time_t *), char *func_name ) { struct tm *date; time_t time = -1; time_t last_time = 0; time_t time_change; int i; for (i = 1; i <= 63; i++) { date = (*date_func)(&time); /* date_func() broke or tm_year underflowed */ if(date == NULL || date->tm_year > 70) break; last_time = time; time += time; /* time_t underflowed */ if( time > last_time ) break; } /* Binary search for the exact failure point */ time = last_time; time_change = last_time / 2; do { time += time_change; date = (*date_func)(&time); /* gmtime() broke or tm_year overflowed or time_t overflowed */ if(date == NULL || date->tm_year > 70 || time > last_time) { time = last_time; time_change = time_change / 2; } else { last_time = time; } } while(time_change < 0); printf("%20s min %.0f\n", func_name, my_difftime(last_time, Time_Zero)); } int main(void) { check_date_max(gmtime, "gmtime"); check_date_max(localtime, "localtime"); check_date_min(gmtime, "gmtime"); check_date_min(localtime, "localtime"); return 0; } perl-5.12.0-RC0/Porting/checkansi.pl0000555000175000017500000000400011325125741016032 0ustar jessejesse#!/usr/bin/perl -w use strict; use warnings; use 5.010; use File::Find; use IO::File; use Getopt::Long; use Pod::Usage; my %limits = ( c90 => { 'logical-source-line-length' => 509, }, c99 => { 'logical-source-line-length' => 4095, }, ); my %opt = ( std => 'c99', ); GetOptions(\%opt, qw( logical-source-line-length=i std=s )) && @ARGV && exists $limits{$opt{std}} or pod2usage(2); for my $k (keys %{$limits{$opt{std}}}) { $opt{$k} //= $limits{$opt{std}}{$k}; } { my $num = 1; sub report { my $msg = shift; my $info = join '', @_; if ($info) { $info =~ s/\R+$//; $info =~ s/^/ #|\t/mg; $info = "\n$info\n\n"; } warn sprintf "[%d] %s(%d): %s\n%s", $num++, $File::Find::name, $., $msg, $info; } } find(sub { /\.([ch]|xs)$/ or return; my $fh = IO::File->new($_) or die "$_: $!\n"; my $ll = ''; while (defined(my $line = <$fh>)) { report("trailing whitespace after backslash", $line) if $line =~ /\\[[:blank:]]+$/; $ll .= $line; unless ($ll =~ /\\$/) { if (length $ll > $opt{'logical-source-line-length'}) { report(sprintf("logical source line too long (%d > %d)", length $ll, $opt{'logical-source-line-length'}), $ll); } $ll = ''; } } }, @ARGV); __END__ =head1 NAME checkansi.pl - Check source code for ANSI-C violations =head1 SYNOPSIS checkansi.pl [B<--std>=c90|c99] [B<--logical-source-line-length>=I] ... =head1 DESCRIPTION B searches =head1 OPTIONS =over 4 =item B<--std>=c90|c99 Choose the ANSI/ISO standard against which shall be checked. Defaults to C. =item B<--logical-source-line-length>=I Maximum length of a logical source line. Overrides the default given by the chosen standard. =back =head1 COPYRIGHT Copyright 2007 by Marcus Holland-Moritz . This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. =cut perl-5.12.0-RC0/Porting/Glossary0000444000175000017500000062023111337306301015276 0ustar jessejesse !!!!!!! DO NOT EDIT THIS FILE !!!!!!! This file is built by metaconfig. This file contains a description of all the shell variables whose value is determined by the Configure script. Variables intended for use in C programs (e.g. I_UNISTD) are already described in config_h.SH. [`configpm' generates pod documentation for Config.pm from this file--please try to keep the formatting regular.] _a (Unix.U): This variable defines the extension used for ordinary library files. For unix, it is '.a'. The '.' is included. Other possible values include '.lib'. _exe (Unix.U): This variable defines the extension used for executable files. DJGPP, Cygwin and OS/2 use '.exe'. Stratus VOS uses '.pm'. On operating systems which do not require a specific extension for executable files, this variable is empty. _o (Unix.U): This variable defines the extension used for object files. For unix, it is '.o'. The '.' is included. Other possible values include '.obj'. afs (afs.U): This variable is set to 'true' if AFS (Andrew File System) is used on the system, 'false' otherwise. It is possible to override this with a hint value or command line option, but you'd better know what you are doing. afsroot (afs.U): This variable is by default set to '/afs'. In the unlikely case this is not the correct root, it is possible to override this with a hint value or command line option. This will be used in subsequent tests for AFSness in the configure and test process. alignbytes (alignbytes.U): This variable holds the number of bytes required to align a double-- or a long double when applicable. Usual values are 2, 4 and 8. The default is eight, for safety. ansi2knr (ansi2knr.U): This variable is set if the user needs to run ansi2knr. Currently, this is not supported, so we just abort. aphostname (d_gethname.U): This variable contains the command which can be used to compute the host name. The command is fully qualified by its absolute path, to make it safe when used by a process with super-user privileges. api_revision (patchlevel.U): The three variables, api_revision, api_version, and api_subversion, specify the version of the oldest perl binary compatible with the present perl. In a full version string such as '5.6.1', api_revision is the '5'. Prior to 5.5.640, the format was a floating point number, like 5.00563. perl.c:incpush() and lib/lib.pm will automatically search in $sitelib/.. for older directories back to the limit specified by these api_ variables. This is only useful if you have a perl library directory tree structured like the default one. See INSTALL for how this works. The versioned site_perl directory was introduced in 5.005, so that is the lowest possible value. The version list appropriate for the current system is determined in inc_version_list.U. XXX To do: Since compatibility can depend on compile time options (such as bincompat, longlong, etc.) it should (perhaps) be set by Configure, but currently it isn't. Currently, we read a hard-wired value from patchlevel.h. Perhaps what we ought to do is take the hard-wired value from patchlevel.h but then modify it if the current Configure options warrant. patchlevel.h then would use an #ifdef guard. api_subversion (patchlevel.U): The three variables, api_revision, api_version, and api_subversion, specify the version of the oldest perl binary compatible with the present perl. In a full version string such as '5.6.1', api_subversion is the '1'. See api_revision for full details. api_version (patchlevel.U): The three variables, api_revision, api_version, and api_subversion, specify the version of the oldest perl binary compatible with the present perl. In a full version string such as '5.6.1', api_version is the '6'. See api_revision for full details. As a special case, 5.5.0 is rendered in the old-style as 5.005. (In the 5.005_0x maintenance series, this was the only versioned directory in $sitelib.) api_versionstring (patchlevel.U): This variable combines api_revision, api_version, and api_subversion in a format such as 5.6.1 (or 5_6_1) suitable for use as a directory name. This is filesystem dependent. ar (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the ar program. After Configure runs, the value is reset to a plain "ar" and is not useful. archlib (archlib.U): This variable holds the name of the directory in which the user wants to put architecture-dependent public library files for $package. It is most often a local directory such as /usr/local/lib. Programs using this variable must be prepared to deal with filename expansion. archlibexp (archlib.U): This variable is the same as the archlib variable, but is filename expanded at configuration time, for convenient use. archname (archname.U): This variable is a short name to characterize the current architecture. It is used mainly to construct the default archlib. archname64 (use64bits.U): This variable is used for the 64-bitness part of $archname. archobjs (Unix.U): This variable defines any additional objects that must be linked in with the program on this architecture. On unix, it is usually empty. It is typically used to include emulations of unix calls or other facilities. For perl on OS/2, for example, this would include os2/os2.obj. asctime_r_proto (d_asctime_r.U): This variable encodes the prototype of asctime_r. It is zero if d_asctime_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_asctime_r is defined. awk (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the awk program. After Configure runs, the value is reset to a plain "awk" and is not useful. baserev (baserev.U): The base revision level of this package, from the .package file. bash (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. bin (bin.U): This variable holds the name of the directory in which the user wants to put publicly executable images for the package in question. It is most often a local directory such as /usr/local/bin. Programs using this variable must be prepared to deal with ~name substitution. bin_ELF (dlsrc.U): This variable saves the result from configure if generated binaries are in ELF format. Only set to defined when the test has actually been performed, and the result was positive. binexp (bin.U): This is the same as the bin variable, but is filename expanded at configuration time, for use in your makefiles. bison (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the bison program. After Configure runs, the value is reset to a plain "bison" and is not useful. byacc (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the byacc program. After Configure runs, the value is reset to a plain "byacc" and is not useful. byteorder (byteorder.U): This variable holds the byte order in a UV. In the following, larger digits indicate more significance. The variable byteorder is either 4321 on a big-endian machine, or 1234 on a little-endian, or 87654321 on a Cray ... or 3412 with weird order ! c (n.U): This variable contains the \c string if that is what causes the echo command to suppress newline. Otherwise it is null. Correct usage is $echo $n "prompt for a question: $c". castflags (d_castneg.U): This variable contains a flag that precise difficulties the compiler has casting odd floating values to unsigned long: 0 = ok 1 = couldn't cast < 0 2 = couldn't cast >= 0x80000000 4 = couldn't cast in argument expression list cat (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the cat program. After Configure runs, the value is reset to a plain "cat" and is not useful. cc (cc.U): This variable holds the name of a command to execute a C compiler which can resolve multiple global references that happen to have the same name. Usual values are 'cc' and 'gcc'. Fervent ANSI compilers may be called 'c89'. AIX has xlc. cccdlflags (dlsrc.U): This variable contains any special flags that might need to be passed with 'cc -c' to compile modules to be used to create a shared library that will be used for dynamic loading. For hpux, this should be +z. It is up to the makefile to use it. ccdlflags (dlsrc.U): This variable contains any special flags that might need to be passed to cc to link with a shared library for dynamic loading. It is up to the makefile to use it. For sunos 4.1, it should be empty. ccflags (ccflags.U): This variable contains any additional C compiler flags desired by the user. It is up to the Makefile to use this. ccflags_uselargefiles (uselfs.U): This variable contains the compiler flags needed by large file builds and added to ccflags by hints files. ccname (Checkcc.U): This can set either by hints files or by Configure. If using gcc, this is gcc, and if not, usually equal to cc, unimpressive, no? Some platforms, however, make good use of this by storing the flavor of the C compiler being used here. For example if using the Sun WorkShop suite, ccname will be 'workshop'. ccsymbols (Cppsym.U): The variable contains the symbols defined by the C compiler alone. The symbols defined by cpp or by cc when it calls cpp are not in this list, see cppsymbols and cppccsymbols. The list is a space-separated list of symbol=value tokens. ccversion (Checkcc.U): This can set either by hints files or by Configure. If using a (non-gcc) vendor cc, this variable may contain a version for the compiler. cf_by (cf_who.U): Login name of the person who ran the Configure script and answered the questions. This is used to tag both config.sh and config_h.SH. cf_email (cf_email.U): Electronic mail address of the person who ran Configure. This can be used by units that require the user's e-mail, like MailList.U. cf_time (cf_who.U): Holds the output of the "date" command when the configuration file was produced. This is used to tag both config.sh and config_h.SH. charbits (charsize.U): This variable contains the value of the CHARBITS symbol, which indicates to the C program how many bits there are in a character. charsize (charsize.U): This variable contains the value of the CHARSIZE symbol, which indicates to the C program how many bytes there are in a character. chgrp (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. chmod (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the chmod program. After Configure runs, the value is reset to a plain "chmod" and is not useful. chown (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. clocktype (d_times.U): This variable holds the type returned by times(). It can be long, or clock_t on BSD sites (in which case should be included). comm (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the comm program. After Configure runs, the value is reset to a plain "comm" and is not useful. compress (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. config_arg0 (Options.U): This variable contains the string used to invoke the Configure command, as reported by the shell in the $0 variable. config_argc (Options.U): This variable countains the number of command-line arguments passed to Configure, as reported by the shell in the $# variable. The individual arguments are stored as variables config_argc1, config_argc2, etc. config_args (Options.U): This variable contains a single string giving the command-line arguments passed to Configure. Spaces within arguments, quotes, and escaped characters are not correctly preserved. To reconstruct the command line, you must assemble the individual command line pieces, given in config_arg[0-9]*. contains (contains.U): This variable holds the command to do a grep with a proper return status. On most sane systems it is simply "grep". On insane systems it is a grep followed by a cat followed by a test. This variable is primarily for the use of other Configure units. cp (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the cp program. After Configure runs, the value is reset to a plain "cp" and is not useful. cpio (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. cpp (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the cpp program. After Configure runs, the value is reset to a plain "cpp" and is not useful. cpp_stuff (cpp_stuff.U): This variable contains an identification of the concatenation mechanism used by the C preprocessor. cppccsymbols (Cppsym.U): The variable contains the symbols defined by the C compiler when it calls cpp. The symbols defined by the cc alone or cpp alone are not in this list, see ccsymbols and cppsymbols. The list is a space-separated list of symbol=value tokens. cppflags (ccflags.U): This variable holds the flags that will be passed to the C pre- processor. It is up to the Makefile to use it. cpplast (cppstdin.U): This variable has the same functionality as cppminus, only it applies to cpprun and not cppstdin. cppminus (cppstdin.U): This variable contains the second part of the string which will invoke the C preprocessor on the standard input and produce to standard output. This variable will have the value "-" if cppstdin needs a minus to specify standard input, otherwise the value is "". cpprun (cppstdin.U): This variable contains the command which will invoke a C preprocessor on standard input and put the output to stdout. It is guaranteed not to be a wrapper and may be a null string if no preprocessor can be made directly available. This preprocessor might be different from the one used by the C compiler. Don't forget to append cpplast after the preprocessor options. cppstdin (cppstdin.U): This variable contains the command which will invoke the C preprocessor on standard input and put the output to stdout. It is primarily used by other Configure units that ask about preprocessor symbols. cppsymbols (Cppsym.U): The variable contains the symbols defined by the C preprocessor alone. The symbols defined by cc or by cc when it calls cpp are not in this list, see ccsymbols and cppccsymbols. The list is a space-separated list of symbol=value tokens. crypt_r_proto (d_crypt_r.U): This variable encodes the prototype of crypt_r. It is zero if d_crypt_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_crypt_r is defined. cryptlib (d_crypt.U): This variable holds -lcrypt or the path to a libcrypt.a archive if the crypt() function is not defined in the standard C library. It is up to the Makefile to use this. csh (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the csh program. After Configure runs, the value is reset to a plain "csh" and is not useful. ctermid_r_proto (d_ctermid_r.U): This variable encodes the prototype of ctermid_r. It is zero if d_ctermid_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_ctermid_r is defined. ctime_r_proto (d_ctime_r.U): This variable encodes the prototype of ctime_r. It is zero if d_ctime_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_ctime_r is defined. d__fwalk (d__fwalk.U): This variable conditionally defines HAS__FWALK if _fwalk() is available to apply a function to all the file handles. d_access (d_access.U): This variable conditionally defines HAS_ACCESS if the access() system call is available to check for access permissions using real IDs. d_accessx (d_accessx.U): This variable conditionally defines the HAS_ACCESSX symbol, which indicates to the C program that the accessx() routine is available. d_aintl (d_aintl.U): This variable conditionally defines the HAS_AINTL symbol, which indicates to the C program that the aintl() routine is available. If copysignl is also present we can emulate modfl. d_alarm (d_alarm.U): This variable conditionally defines the HAS_ALARM symbol, which indicates to the C program that the alarm() routine is available. d_archlib (archlib.U): This variable conditionally defines ARCHLIB to hold the pathname of architecture-dependent library files for $package. If $archlib is the same as $privlib, then this is set to undef. d_asctime64 (d_timefuncs64.U): This variable conditionally defines the HAS_ASCTIME64 symbol, which indicates to the C program that the asctime64 () routine is available. d_asctime_r (d_asctime_r.U): This variable conditionally defines the HAS_ASCTIME_R symbol, which indicates to the C program that the asctime_r() routine is available. d_atolf (atolf.U): This variable conditionally defines the HAS_ATOLF symbol, which indicates to the C program that the atolf() routine is available. d_atoll (atoll.U): This variable conditionally defines the HAS_ATOLL symbol, which indicates to the C program that the atoll() routine is available. d_attribute_deprecated (d_attribut.U): This variable conditionally defines HASATTRIBUTE_DEPRECATED, which indicates that GCC can handle the attribute for marking deprecated APIs d_attribute_format (d_attribut.U): This variable conditionally defines HASATTRIBUTE_FORMAT, which indicates the C compiler can check for printf-like formats. d_attribute_malloc (d_attribut.U): This variable conditionally defines HASATTRIBUTE_MALLOC, which indicates the C compiler can understand functions as having malloc-like semantics. d_attribute_nonnull (d_attribut.U): This variable conditionally defines HASATTRIBUTE_NONNULL, which indicates that the C compiler can know that certain arguments must not be NULL, and will check accordingly at compile time. d_attribute_noreturn (d_attribut.U): This variable conditionally defines HASATTRIBUTE_NORETURN, which indicates that the C compiler can know that certain functions are guaranteed never to return. d_attribute_pure (d_attribut.U): This variable conditionally defines HASATTRIBUTE_PURE, which indicates that the C compiler can know that certain functions are "pure" functions, meaning that they have no side effects, and only rely on function input and/or global data for their results. d_attribute_unused (d_attribut.U): This variable conditionally defines HASATTRIBUTE_UNUSED, which indicates that the C compiler can know that certain variables and arguments may not always be used, and to not throw warnings if they don't get used. d_attribute_warn_unused_result (d_attribut.U): This variable conditionally defines HASATTRIBUTE_WARN_UNUSED_RESULT, which indicates that the C compiler can know that certain functions have a return values that must not be ignored, such as malloc() or open(). d_bcmp (d_bcmp.U): This variable conditionally defines the HAS_BCMP symbol if the bcmp() routine is available to compare strings. d_bcopy (d_bcopy.U): This variable conditionally defines the HAS_BCOPY symbol if the bcopy() routine is available to copy strings. d_bsd (Guess.U): This symbol conditionally defines the symbol BSD when running on a BSD system. d_bsdgetpgrp (d_getpgrp.U): This variable conditionally defines USE_BSD_GETPGRP if getpgrp needs one arguments whereas USG one needs none. d_bsdsetpgrp (d_setpgrp.U): This variable conditionally defines USE_BSD_SETPGRP if setpgrp needs two arguments whereas USG one needs none. See also d_setpgid for a POSIX interface. d_builtin_choose_expr (d_builtin.U): This conditionally defines HAS_BUILTIN_CHOOSE_EXPR, which indicates that the compiler supports __builtin_choose_expr(x,y,z). This built-in function is analogous to the "x?y:z" operator in C, except that the expression returned has its type unaltered by promotion rules. Also, the built-in function does not evaluate the expression that was not chosen. d_builtin_expect (d_builtin.U): This conditionally defines HAS_BUILTIN_EXPECT, which indicates that the compiler supports __builtin_expect(exp,c). You may use __builtin_expect to provide the compiler with branch prediction information. d_bzero (d_bzero.U): This variable conditionally defines the HAS_BZERO symbol if the bzero() routine is available to set memory to 0. d_c99_variadic_macros (d_c99_variadic.U): This variable conditionally defines the HAS_C99_VARIADIC_MACROS symbol, which indicates to the C program that C99 variadic macros are available. d_casti32 (d_casti32.U): This variable conditionally defines CASTI32, which indicates whether the C compiler can cast large floats to 32-bit ints. d_castneg (d_castneg.U): This variable conditionally defines CASTNEG, which indicates wether the C compiler can cast negative float to unsigned. d_charvspr (d_vprintf.U): This variable conditionally defines CHARVSPRINTF if this system has vsprintf returning type (char*). The trend seems to be to declare it as "int vsprintf()". d_chown (d_chown.U): This variable conditionally defines the HAS_CHOWN symbol, which indicates to the C program that the chown() routine is available. d_chroot (d_chroot.U): This variable conditionally defines the HAS_CHROOT symbol, which indicates to the C program that the chroot() routine is available. d_chsize (d_chsize.U): This variable conditionally defines the CHSIZE symbol, which indicates to the C program that the chsize() routine is available to truncate files. You might need a -lx to get this routine. d_class (d_class.U): This variable conditionally defines the HAS_CLASS symbol, which indicates to the C program that the class() routine is available. d_clearenv (d_clearenv.U): This variable conditionally defines the HAS_CLEARENV symbol, which indicates to the C program that the clearenv () routine is available. d_closedir (d_closedir.U): This variable conditionally defines HAS_CLOSEDIR if closedir() is available. d_cmsghdr_s (d_cmsghdr_s.U): This variable conditionally defines the HAS_STRUCT_CMSGHDR symbol, which indicates that the struct cmsghdr is supported. d_const (d_const.U): This variable conditionally defines the HASCONST symbol, which indicates to the C program that this C compiler knows about the const type. d_copysignl (d_copysignl.U): This variable conditionally defines the HAS_COPYSIGNL symbol, which indicates to the C program that the copysignl() routine is available. If aintl is also present we can emulate modfl. d_cplusplus (d_cplusplus.U): This variable conditionally defines the USE_CPLUSPLUS symbol, which indicates that a C++ compiler was used to compiled Perl and will be used to compile extensions. d_crypt (d_crypt.U): This variable conditionally defines the CRYPT symbol, which indicates to the C program that the crypt() routine is available to encrypt passwords and the like. d_crypt_r (d_crypt_r.U): This variable conditionally defines the HAS_CRYPT_R symbol, which indicates to the C program that the crypt_r() routine is available. d_csh (d_csh.U): This variable conditionally defines the CSH symbol, which indicates to the C program that the C-shell exists. d_ctermid (d_ctermid.U): This variable conditionally defines CTERMID if ctermid() is available to generate filename for terminal. d_ctermid_r (d_ctermid_r.U): This variable conditionally defines the HAS_CTERMID_R symbol, which indicates to the C program that the ctermid_r() routine is available. d_ctime64 (d_timefuncs64.U): This variable conditionally defines the HAS_CTIME64 symbol, which indicates to the C program that the ctime64 () routine is available. d_ctime_r (d_ctime_r.U): This variable conditionally defines the HAS_CTIME_R symbol, which indicates to the C program that the ctime_r() routine is available. d_cuserid (d_cuserid.U): This variable conditionally defines the HAS_CUSERID symbol, which indicates to the C program that the cuserid() routine is available to get character login names. d_dbl_dig (d_dbl_dig.U): This variable conditionally defines d_dbl_dig if this system's header files provide DBL_DIG, which is the number of significant digits in a double precision number. d_dbminitproto (d_dbminitproto.U): This variable conditionally defines the HAS_DBMINIT_PROTO symbol, which indicates to the C program that the system provides a prototype for the dbminit() function. Otherwise, it is up to the program to supply one. d_difftime (d_difftime.U): This variable conditionally defines the HAS_DIFFTIME symbol, which indicates to the C program that the difftime() routine is available. d_difftime64 (d_timefuncs64.U): This variable conditionally defines the HAS_DIFFTIME64 symbol, which indicates to the C program that the difftime64 () routine is available. d_dir_dd_fd (d_dir_dd_fd.U): This variable conditionally defines the HAS_DIR_DD_FD symbol, which indicates that the DIR directory stream type contains a member variable called dd_fd. d_dirfd (d_dirfd.U): This variable conditionally defines the HAS_DIRFD constant, which indicates to the C program that dirfd() is available to return the file descriptor of a directory stream. d_dirnamlen (i_dirent.U): This variable conditionally defines DIRNAMLEN, which indicates to the C program that the length of directory entry names is provided by a d_namelen field. d_dlerror (d_dlerror.U): This variable conditionally defines the HAS_DLERROR symbol, which indicates to the C program that the dlerror() routine is available. d_dlopen (d_dlopen.U): This variable conditionally defines the HAS_DLOPEN symbol, which indicates to the C program that the dlopen() routine is available. d_dlsymun (d_dlsymun.U): This variable conditionally defines DLSYM_NEEDS_UNDERSCORE, which indicates that we need to prepend an underscore to the symbol name before calling dlsym(). d_dosuid (d_dosuid.U): This variable conditionally defines the symbol DOSUID, which tells the C program that it should insert setuid emulation code on hosts which have setuid #! scripts disabled. d_drand48_r (d_drand48_r.U): This variable conditionally defines the HAS_DRAND48_R symbol, which indicates to the C program that the drand48_r() routine is available. d_drand48proto (d_drand48proto.U): This variable conditionally defines the HAS_DRAND48_PROTO symbol, which indicates to the C program that the system provides a prototype for the drand48() function. Otherwise, it is up to the program to supply one. d_dup2 (d_dup2.U): This variable conditionally defines HAS_DUP2 if dup2() is available to duplicate file descriptors. d_eaccess (d_eaccess.U): This variable conditionally defines the HAS_EACCESS symbol, which indicates to the C program that the eaccess() routine is available. d_endgrent (d_endgrent.U): This variable conditionally defines the HAS_ENDGRENT symbol, which indicates to the C program that the endgrent() routine is available for sequential access of the group database. d_endgrent_r (d_endgrent_r.U): This variable conditionally defines the HAS_ENDGRENT_R symbol, which indicates to the C program that the endgrent_r() routine is available. d_endhent (d_endhent.U): This variable conditionally defines HAS_ENDHOSTENT if endhostent() is available to close whatever was being used for host queries. d_endhostent_r (d_endhostent_r.U): This variable conditionally defines the HAS_ENDHOSTENT_R symbol, which indicates to the C program that the endhostent_r() routine is available. d_endnent (d_endnent.U): This variable conditionally defines HAS_ENDNETENT if endnetent() is available to close whatever was being used for network queries. d_endnetent_r (d_endnetent_r.U): This variable conditionally defines the HAS_ENDNETENT_R symbol, which indicates to the C program that the endnetent_r() routine is available. d_endpent (d_endpent.U): This variable conditionally defines HAS_ENDPROTOENT if endprotoent() is available to close whatever was being used for protocol queries. d_endprotoent_r (d_endprotoent_r.U): This variable conditionally defines the HAS_ENDPROTOENT_R symbol, which indicates to the C program that the endprotoent_r() routine is available. d_endpwent (d_endpwent.U): This variable conditionally defines the HAS_ENDPWENT symbol, which indicates to the C program that the endpwent() routine is available for sequential access of the passwd database. d_endpwent_r (d_endpwent_r.U): This variable conditionally defines the HAS_ENDPWENT_R symbol, which indicates to the C program that the endpwent_r() routine is available. d_endsent (d_endsent.U): This variable conditionally defines HAS_ENDSERVENT if endservent() is available to close whatever was being used for service queries. d_endservent_r (d_endservent_r.U): This variable conditionally defines the HAS_ENDSERVENT_R symbol, which indicates to the C program that the endservent_r() routine is available. d_eofnblk (nblock_io.U): This variable conditionally defines EOF_NONBLOCK if EOF can be seen when reading from a non-blocking I/O source. d_eunice (Guess.U): This variable conditionally defines the symbols EUNICE and VAX, which alerts the C program that it must deal with ideosyncracies of VMS. d_faststdio (d_faststdio.U): This variable conditionally defines the HAS_FAST_STDIO symbol, which indicates to the C program that the "fast stdio" is available to manipulate the stdio buffers directly. d_fchdir (d_fchdir.U): This variable conditionally defines the HAS_FCHDIR symbol, which indicates to the C program that the fchdir() routine is available. d_fchmod (d_fchmod.U): This variable conditionally defines the HAS_FCHMOD symbol, which indicates to the C program that the fchmod() routine is available to change mode of opened files. d_fchown (d_fchown.U): This variable conditionally defines the HAS_FCHOWN symbol, which indicates to the C program that the fchown() routine is available to change ownership of opened files. d_fcntl (d_fcntl.U): This variable conditionally defines the HAS_FCNTL symbol, and indicates whether the fcntl() function exists d_fcntl_can_lock (d_fcntl_can_lock.U): This variable conditionally defines the FCNTL_CAN_LOCK symbol and indicates whether file locking with fcntl() works. d_fd_macros (d_fd_set.U): This variable contains the eventual value of the HAS_FD_MACROS symbol, which indicates if your C compiler knows about the macros which manipulate an fd_set. d_fd_set (d_fd_set.U): This variable contains the eventual value of the HAS_FD_SET symbol, which indicates if your C compiler knows about the fd_set typedef. d_fds_bits (d_fd_set.U): This variable contains the eventual value of the HAS_FDS_BITS symbol, which indicates if your fd_set typedef contains the fds_bits member. If you have an fd_set typedef, but the dweebs who installed it did a half-fast job and neglected to provide the macros to manipulate an fd_set, HAS_FDS_BITS will let us know how to fix the gaffe. d_fgetpos (d_fgetpos.U): This variable conditionally defines HAS_FGETPOS if fgetpos() is available to get the file position indicator. d_finite (d_finite.U): This variable conditionally defines the HAS_FINITE symbol, which indicates to the C program that the finite() routine is available. d_finitel (d_finitel.U): This variable conditionally defines the HAS_FINITEL symbol, which indicates to the C program that the finitel() routine is available. d_flexfnam (d_flexfnam.U): This variable conditionally defines the FLEXFILENAMES symbol, which indicates that the system supports filenames longer than 14 characters. d_flock (d_flock.U): This variable conditionally defines HAS_FLOCK if flock() is available to do file locking. d_flockproto (d_flockproto.U): This variable conditionally defines the HAS_FLOCK_PROTO symbol, which indicates to the C program that the system provides a prototype for the flock() function. Otherwise, it is up to the program to supply one. d_fork (d_fork.U): This variable conditionally defines the HAS_FORK symbol, which indicates to the C program that the fork() routine is available. d_fp_class (d_fp_class.U): This variable conditionally defines the HAS_FP_CLASS symbol, which indicates to the C program that the fp_class() routine is available. d_fpathconf (d_pathconf.U): This variable conditionally defines the HAS_FPATHCONF symbol, which indicates to the C program that the pathconf() routine is available to determine file-system related limits and options associated with a given open file descriptor. d_fpclass (d_fpclass.U): This variable conditionally defines the HAS_FPCLASS symbol, which indicates to the C program that the fpclass() routine is available. d_fpclassify (d_fpclassify.U): This variable conditionally defines the HAS_FPCLASSIFY symbol, which indicates to the C program that the fpclassify() routine is available. d_fpclassl (d_fpclassl.U): This variable conditionally defines the HAS_FPCLASSL symbol, which indicates to the C program that the fpclassl() routine is available. d_fpos64_t (d_fpos64_t.U): This symbol will be defined if the C compiler supports fpos64_t. d_frexpl (d_frexpl.U): This variable conditionally defines the HAS_FREXPL symbol, which indicates to the C program that the frexpl() routine is available. d_fs_data_s (d_fs_data_s.U): This variable conditionally defines the HAS_STRUCT_FS_DATA symbol, which indicates that the struct fs_data is supported. d_fseeko (d_fseeko.U): This variable conditionally defines the HAS_FSEEKO symbol, which indicates to the C program that the fseeko() routine is available. d_fsetpos (d_fsetpos.U): This variable conditionally defines HAS_FSETPOS if fsetpos() is available to set the file position indicator. d_fstatfs (d_fstatfs.U): This variable conditionally defines the HAS_FSTATFS symbol, which indicates to the C program that the fstatfs() routine is available. d_fstatvfs (d_statvfs.U): This variable conditionally defines the HAS_FSTATVFS symbol, which indicates to the C program that the fstatvfs() routine is available. d_fsync (d_fsync.U): This variable conditionally defines the HAS_FSYNC symbol, which indicates to the C program that the fsync() routine is available. d_ftello (d_ftello.U): This variable conditionally defines the HAS_FTELLO symbol, which indicates to the C program that the ftello() routine is available. d_ftime (d_ftime.U): This variable conditionally defines the HAS_FTIME symbol, which indicates that the ftime() routine exists. The ftime() routine is basically a sub-second accuracy clock. d_futimes (d_futimes.U): This variable conditionally defines the HAS_FUTIMES symbol, which indicates to the C program that the futimes() routine is available. d_Gconvert (d_gconvert.U): This variable holds what Gconvert is defined as to convert floating point numbers into strings. By default, Configure sets this macro to use the first of gconvert, gcvt, or sprintf that pass sprintf-%g-like behaviour tests. If perl is using long doubles, the macro uses the first of the following functions that pass Configure's tests: qgcvt, sprintf (if Configure knows how to make sprintf format long doubles--see sPRIgldbl), gconvert, gcvt, and sprintf (casting to double). The gconvert_preference and gconvert_ld_preference variables can be used to alter Configure's preferences, for doubles and long doubles, respectively. If present, they contain a space-separated list of one or more of the above function names in the order they should be tried. d_Gconvert may be set to override Configure with a platform- specific function. If this function expects a double, a different value may need to be set by the uselongdouble.cbu call-back unit so that long doubles can be formatted without loss of precision. d_gdbm_ndbm_h_uses_prototypes (i_ndbm.U): This variable conditionally defines the NDBM_H_USES_PROTOTYPES symbol, which indicates that the gdbm-ndbm.h include file uses real ANSI C prototypes instead of K&R style function declarations. K&R style declarations are unsupported in C++, so the include file requires special handling when using a C++ compiler and this variable is undefined. Consult the different d_*ndbm_h_uses_prototypes variables to get the same information for alternative ndbm.h include files. d_gdbmndbm_h_uses_prototypes (i_ndbm.U): This variable conditionally defines the NDBM_H_USES_PROTOTYPES symbol, which indicates that the gdbm/ndbm.h include file uses real ANSI C prototypes instead of K&R style function declarations. K&R style declarations are unsupported in C++, so the include file requires special handling when using a C++ compiler and this variable is undefined. Consult the different d_*ndbm_h_uses_prototypes variables to get the same information for alternative ndbm.h include files. d_getaddrinfo (d_getaddrinfo.U): This variable conditionally defines the HAS_GETADDRINFO symbol, which indicates to the C program that the getaddrinfo() function is available. d_getcwd (d_getcwd.U): This variable conditionally defines the HAS_GETCWD symbol, which indicates to the C program that the getcwd() routine is available to get the current working directory. d_getespwnam (d_getespwnam.U): This variable conditionally defines HAS_GETESPWNAM if getespwnam() is available to retrieve enchanced (shadow) password entries by name. d_getfsstat (d_getfsstat.U): This variable conditionally defines the HAS_GETFSSTAT symbol, which indicates to the C program that the getfsstat() routine is available. d_getgrent (d_getgrent.U): This variable conditionally defines the HAS_GETGRENT symbol, which indicates to the C program that the getgrent() routine is available for sequential access of the group database. d_getgrent_r (d_getgrent_r.U): This variable conditionally defines the HAS_GETGRENT_R symbol, which indicates to the C program that the getgrent_r() routine is available. d_getgrgid_r (d_getgrgid_r.U): This variable conditionally defines the HAS_GETGRGID_R symbol, which indicates to the C program that the getgrgid_r() routine is available. d_getgrnam_r (d_getgrnam_r.U): This variable conditionally defines the HAS_GETGRNAM_R symbol, which indicates to the C program that the getgrnam_r() routine is available. d_getgrps (d_getgrps.U): This variable conditionally defines the HAS_GETGROUPS symbol, which indicates to the C program that the getgroups() routine is available to get the list of process groups. d_gethbyaddr (d_gethbyad.U): This variable conditionally defines the HAS_GETHOSTBYADDR symbol, which indicates to the C program that the gethostbyaddr() routine is available to look up hosts by their IP addresses. d_gethbyname (d_gethbynm.U): This variable conditionally defines the HAS_GETHOSTBYNAME symbol, which indicates to the C program that the gethostbyname() routine is available to look up host names in some data base or other. d_gethent (d_gethent.U): This variable conditionally defines HAS_GETHOSTENT if gethostent() is available to look up host names in some data base or another. d_gethname (d_gethname.U): This variable conditionally defines the HAS_GETHOSTNAME symbol, which indicates to the C program that the gethostname() routine may be used to derive the host name. d_gethostbyaddr_r (d_gethostbyaddr_r.U): This variable conditionally defines the HAS_GETHOSTBYADDR_R symbol, which indicates to the C program that the gethostbyaddr_r() routine is available. d_gethostbyname_r (d_gethostbyname_r.U): This variable conditionally defines the HAS_GETHOSTBYNAME_R symbol, which indicates to the C program that the gethostbyname_r() routine is available. d_gethostent_r (d_gethostent_r.U): This variable conditionally defines the HAS_GETHOSTENT_R symbol, which indicates to the C program that the gethostent_r() routine is available. d_gethostprotos (d_gethostprotos.U): This variable conditionally defines the HAS_GETHOST_PROTOS symbol, which indicates to the C program that supplies prototypes for the various gethost*() functions. See also netdbtype.U for probing for various netdb types. d_getitimer (d_getitimer.U): This variable conditionally defines the HAS_GETITIMER symbol, which indicates to the C program that the getitimer() routine is available. d_getlogin (d_getlogin.U): This variable conditionally defines the HAS_GETLOGIN symbol, which indicates to the C program that the getlogin() routine is available to get the login name. d_getlogin_r (d_getlogin_r.U): This variable conditionally defines the HAS_GETLOGIN_R symbol, which indicates to the C program that the getlogin_r() routine is available. d_getmnt (d_getmnt.U): This variable conditionally defines the HAS_GETMNT symbol, which indicates to the C program that the getmnt() routine is available to retrieve one or more mount info blocks by filename. d_getmntent (d_getmntent.U): This variable conditionally defines the HAS_GETMNTENT symbol, which indicates to the C program that the getmntent() routine is available to iterate through mounted files to get their mount info. d_getnameinfo (d_getnameinfo.U): This variable conditionally defines the HAS_GETNAMEINFO symbol, which indicates to the C program that the getnameinfo() function is available. d_getnbyaddr (d_getnbyad.U): This variable conditionally defines the HAS_GETNETBYADDR symbol, which indicates to the C program that the getnetbyaddr() routine is available to look up networks by their IP addresses. d_getnbyname (d_getnbynm.U): This variable conditionally defines the HAS_GETNETBYNAME symbol, which indicates to the C program that the getnetbyname() routine is available to look up networks by their names. d_getnent (d_getnent.U): This variable conditionally defines HAS_GETNETENT if getnetent() is available to look up network names in some data base or another. d_getnetbyaddr_r (d_getnetbyaddr_r.U): This variable conditionally defines the HAS_GETNETBYADDR_R symbol, which indicates to the C program that the getnetbyaddr_r() routine is available. d_getnetbyname_r (d_getnetbyname_r.U): This variable conditionally defines the HAS_GETNETBYNAME_R symbol, which indicates to the C program that the getnetbyname_r() routine is available. d_getnetent_r (d_getnetent_r.U): This variable conditionally defines the HAS_GETNETENT_R symbol, which indicates to the C program that the getnetent_r() routine is available. d_getnetprotos (d_getnetprotos.U): This variable conditionally defines the HAS_GETNET_PROTOS symbol, which indicates to the C program that supplies prototypes for the various getnet*() functions. See also netdbtype.U for probing for various netdb types. d_getpagsz (d_getpagsz.U): This variable conditionally defines HAS_GETPAGESIZE if getpagesize() is available to get the system page size. d_getpbyname (d_getprotby.U): This variable conditionally defines the HAS_GETPROTOBYNAME symbol, which indicates to the C program that the getprotobyname() routine is available to look up protocols by their name. d_getpbynumber (d_getprotby.U): This variable conditionally defines the HAS_GETPROTOBYNUMBER symbol, which indicates to the C program that the getprotobynumber() routine is available to look up protocols by their number. d_getpent (d_getpent.U): This variable conditionally defines HAS_GETPROTOENT if getprotoent() is available to look up protocols in some data base or another. d_getpgid (d_getpgid.U): This variable conditionally defines the HAS_GETPGID symbol, which indicates to the C program that the getpgid(pid) function is available to get the process group id. d_getpgrp (d_getpgrp.U): This variable conditionally defines HAS_GETPGRP if getpgrp() is available to get the current process group. d_getpgrp2 (d_getpgrp2.U): This variable conditionally defines the HAS_GETPGRP2 symbol, which indicates to the C program that the getpgrp2() (as in DG/UX) routine is available to get the current process group. d_getppid (d_getppid.U): This variable conditionally defines the HAS_GETPPID symbol, which indicates to the C program that the getppid() routine is available to get the parent process ID. d_getprior (d_getprior.U): This variable conditionally defines HAS_GETPRIORITY if getpriority() is available to get a process's priority. d_getprotobyname_r (d_getprotobyname_r.U): This variable conditionally defines the HAS_GETPROTOBYNAME_R symbol, which indicates to the C program that the getprotobyname_r() routine is available. d_getprotobynumber_r (d_getprotobynumber_r.U): This variable conditionally defines the HAS_GETPROTOBYNUMBER_R symbol, which indicates to the C program that the getprotobynumber_r() routine is available. d_getprotoent_r (d_getprotoent_r.U): This variable conditionally defines the HAS_GETPROTOENT_R symbol, which indicates to the C program that the getprotoent_r() routine is available. d_getprotoprotos (d_getprotoprotos.U): This variable conditionally defines the HAS_GETPROTO_PROTOS symbol, which indicates to the C program that supplies prototypes for the various getproto*() functions. See also netdbtype.U for probing for various netdb types. d_getprpwnam (d_getprpwnam.U): This variable conditionally defines HAS_GETPRPWNAM if getprpwnam() is available to retrieve protected (shadow) password entries by name. d_getpwent (d_getpwent.U): This variable conditionally defines the HAS_GETPWENT symbol, which indicates to the C program that the getpwent() routine is available for sequential access of the passwd database. d_getpwent_r (d_getpwent_r.U): This variable conditionally defines the HAS_GETPWENT_R symbol, which indicates to the C program that the getpwent_r() routine is available. d_getpwnam_r (d_getpwnam_r.U): This variable conditionally defines the HAS_GETPWNAM_R symbol, which indicates to the C program that the getpwnam_r() routine is available. d_getpwuid_r (d_getpwuid_r.U): This variable conditionally defines the HAS_GETPWUID_R symbol, which indicates to the C program that the getpwuid_r() routine is available. d_getsbyname (d_getsrvby.U): This variable conditionally defines the HAS_GETSERVBYNAME symbol, which indicates to the C program that the getservbyname() routine is available to look up services by their name. d_getsbyport (d_getsrvby.U): This variable conditionally defines the HAS_GETSERVBYPORT symbol, which indicates to the C program that the getservbyport() routine is available to look up services by their port. d_getsent (d_getsent.U): This variable conditionally defines HAS_GETSERVENT if getservent() is available to look up network services in some data base or another. d_getservbyname_r (d_getservbyname_r.U): This variable conditionally defines the HAS_GETSERVBYNAME_R symbol, which indicates to the C program that the getservbyname_r() routine is available. d_getservbyport_r (d_getservbyport_r.U): This variable conditionally defines the HAS_GETSERVBYPORT_R symbol, which indicates to the C program that the getservbyport_r() routine is available. d_getservent_r (d_getservent_r.U): This variable conditionally defines the HAS_GETSERVENT_R symbol, which indicates to the C program that the getservent_r() routine is available. d_getservprotos (d_getservprotos.U): This variable conditionally defines the HAS_GETSERV_PROTOS symbol, which indicates to the C program that supplies prototypes for the various getserv*() functions. See also netdbtype.U for probing for various netdb types. d_getspnam (d_getspnam.U): This variable conditionally defines HAS_GETSPNAM if getspnam() is available to retrieve SysV shadow password entries by name. d_getspnam_r (d_getspnam_r.U): This variable conditionally defines the HAS_GETSPNAM_R symbol, which indicates to the C program that the getspnam_r() routine is available. d_gettimeod (d_ftime.U): This variable conditionally defines the HAS_GETTIMEOFDAY symbol, which indicates that the gettimeofday() system call exists (to obtain a sub-second accuracy clock). You should probably include . d_gmtime64 (d_timefuncs64.U): This variable conditionally defines the HAS_GMTIME64 symbol, which indicates to the C program that the gmtime64 () routine is available. d_gmtime_r (d_gmtime_r.U): This variable conditionally defines the HAS_GMTIME_R symbol, which indicates to the C program that the gmtime_r() routine is available. d_gnulibc (d_gnulibc.U): Defined if we're dealing with the GNU C Library. d_grpasswd (i_grp.U): This variable conditionally defines GRPASSWD, which indicates that struct group in contains gr_passwd. d_hasmntopt (d_hasmntopt.U): This variable conditionally defines the HAS_HASMNTOPT symbol, which indicates to the C program that the hasmntopt() routine is available to query the mount options of file systems. d_htonl (d_htonl.U): This variable conditionally defines HAS_HTONL if htonl() and its friends are available to do network order byte swapping. d_ilogbl (d_ilogbl.U): This variable conditionally defines the HAS_ILOGBL symbol, which indicates to the C program that the ilogbl() routine is available. If scalbnl is also present we can emulate frexpl. d_inc_version_list (inc_version_list.U): This variable conditionally defines PERL_INC_VERSION_LIST. It is set to undef when PERL_INC_VERSION_LIST is empty. d_index (d_strchr.U): This variable conditionally defines HAS_INDEX if index() and rindex() are available for string searching. d_inetaton (d_inetaton.U): This variable conditionally defines the HAS_INET_ATON symbol, which indicates to the C program that the inet_aton() function is available to parse IP address "dotted-quad" strings. d_inetntop (d_inetntop.U): This variable conditionally defines the HAS_INETNTOP symbol, which indicates to the C program that the inet_ntop() function is available. d_inetpton (d_inetpton.U): This variable conditionally defines the HAS_INETPTON symbol, which indicates to the C program that the inet_pton() function is available. d_int64_t (d_int64_t.U): This symbol will be defined if the C compiler supports int64_t. d_isascii (d_isascii.U): This variable conditionally defines the HAS_ISASCII constant, which indicates to the C program that isascii() is available. d_isfinite (d_isfinite.U): This variable conditionally defines the HAS_ISFINITE symbol, which indicates to the C program that the isfinite() routine is available. d_isinf (d_isinf.U): This variable conditionally defines the HAS_ISINF symbol, which indicates to the C program that the isinf() routine is available. d_isnan (d_isnan.U): This variable conditionally defines the HAS_ISNAN symbol, which indicates to the C program that the isnan() routine is available. d_isnanl (d_isnanl.U): This variable conditionally defines the HAS_ISNANL symbol, which indicates to the C program that the isnanl() routine is available. d_killpg (d_killpg.U): This variable conditionally defines the HAS_KILLPG symbol, which indicates to the C program that the killpg() routine is available to kill process groups. d_lchown (d_lchown.U): This variable conditionally defines the HAS_LCHOWN symbol, which indicates to the C program that the lchown() routine is available to operate on a symbolic link (instead of following the link). d_ldbl_dig (d_ldbl_dig.U): This variable conditionally defines d_ldbl_dig if this system's header files provide LDBL_DIG, which is the number of significant digits in a long double precision number. d_libm_lib_version (d_libm_lib_version.U): This variable conditionally defines the LIBM_LIB_VERSION symbol, which indicates to the C program that math.h defines _LIB_VERSION being available in libm d_link (d_link.U): This variable conditionally defines HAS_LINK if link() is available to create hard links. d_localtime64 (d_timefuncs64.U): This variable conditionally defines the HAS_LOCALTIME64 symbol, which indicates to the C program that the localtime64 () routine is available. d_localtime_r (d_localtime_r.U): This variable conditionally defines the HAS_LOCALTIME_R symbol, which indicates to the C program that the localtime_r() routine is available. d_localtime_r_needs_tzset (d_localtime_r.U): This variable conditionally defines the LOCALTIME_R_NEEDS_TZSET symbol, which makes us call tzset before localtime_r() d_locconv (d_locconv.U): This variable conditionally defines HAS_LOCALECONV if localeconv() is available for numeric and monetary formatting conventions. d_lockf (d_lockf.U): This variable conditionally defines HAS_LOCKF if lockf() is available to do file locking. d_longdbl (d_longdbl.U): This variable conditionally defines HAS_LONG_DOUBLE if the long double type is supported. d_longlong (d_longlong.U): This variable conditionally defines HAS_LONG_LONG if the long long type is supported. d_lseekproto (d_lseekproto.U): This variable conditionally defines the HAS_LSEEK_PROTO symbol, which indicates to the C program that the system provides a prototype for the lseek() function. Otherwise, it is up to the program to supply one. d_lstat (d_lstat.U): This variable conditionally defines HAS_LSTAT if lstat() is available to do file stats on symbolic links. d_madvise (d_madvise.U): This variable conditionally defines HAS_MADVISE if madvise() is available to map a file into memory. d_malloc_good_size (d_malloc_size.U): This symbol, if defined, indicates that the malloc_good_size routine is available for use. d_malloc_size (d_malloc_size.U): This symbol, if defined, indicates that the malloc_size routine is available for use. d_mblen (d_mblen.U): This variable conditionally defines the HAS_MBLEN symbol, which indicates to the C program that the mblen() routine is available to find the number of bytes in a multibye character. d_mbstowcs (d_mbstowcs.U): This variable conditionally defines the HAS_MBSTOWCS symbol, which indicates to the C program that the mbstowcs() routine is available to convert a multibyte string into a wide character string. d_mbtowc (d_mbtowc.U): This variable conditionally defines the HAS_MBTOWC symbol, which indicates to the C program that the mbtowc() routine is available to convert multibyte to a wide character. d_memchr (d_memchr.U): This variable conditionally defines the HAS_MEMCHR symbol, which indicates to the C program that the memchr() routine is available to locate characters within a C string. d_memcmp (d_memcmp.U): This variable conditionally defines the HAS_MEMCMP symbol, which indicates to the C program that the memcmp() routine is available to compare blocks of memory. d_memcpy (d_memcpy.U): This variable conditionally defines the HAS_MEMCPY symbol, which indicates to the C program that the memcpy() routine is available to copy blocks of memory. d_memmove (d_memmove.U): This variable conditionally defines the HAS_MEMMOVE symbol, which indicates to the C program that the memmove() routine is available to copy potentatially overlapping blocks of memory. d_memset (d_memset.U): This variable conditionally defines the HAS_MEMSET symbol, which indicates to the C program that the memset() routine is available to set blocks of memory. d_mkdir (d_mkdir.U): This variable conditionally defines the HAS_MKDIR symbol, which indicates to the C program that the mkdir() routine is available to create directories.. d_mkdtemp (d_mkdtemp.U): This variable conditionally defines the HAS_MKDTEMP symbol, which indicates to the C program that the mkdtemp() routine is available to exclusively create a uniquely named temporary directory. d_mkfifo (d_mkfifo.U): This variable conditionally defines the HAS_MKFIFO symbol, which indicates to the C program that the mkfifo() routine is available. d_mkstemp (d_mkstemp.U): This variable conditionally defines the HAS_MKSTEMP symbol, which indicates to the C program that the mkstemp() routine is available to exclusively create and open a uniquely named temporary file. d_mkstemps (d_mkstemps.U): This variable conditionally defines the HAS_MKSTEMPS symbol, which indicates to the C program that the mkstemps() routine is available to exclusively create and open a uniquely named (with a suffix) temporary file. d_mktime (d_mktime.U): This variable conditionally defines the HAS_MKTIME symbol, which indicates to the C program that the mktime() routine is available. d_mktime64 (d_timefuncs64.U): This variable conditionally defines the HAS_MKTIME64 symbol, which indicates to the C program that the mktime64 () routine is available. d_mmap (d_mmap.U): This variable conditionally defines HAS_MMAP if mmap() is available to map a file into memory. d_modfl (d_modfl.U): This variable conditionally defines the HAS_MODFL symbol, which indicates to the C program that the modfl() routine is available. d_modfl_pow32_bug (d_modfl.U): This variable conditionally defines the HAS_MODFL_POW32_BUG symbol, which indicates that modfl() is broken for long doubles >= pow(2, 32). For example from 4294967303.150000 one would get 4294967302.000000 and 1.150000. The bug has been seen in certain versions of glibc, release 2.2.2 is known to be okay. d_modflproto (d_modfl.U): This symbol, if defined, indicates that the system provides a prototype for the modfl() function. Otherwise, it is up to the program to supply one. C99 says it should be long double modfl(long double, long double *); d_mprotect (d_mprotect.U): This variable conditionally defines HAS_MPROTECT if mprotect() is available to modify the access protection of a memory mapped file. d_msg (d_msg.U): This variable conditionally defines the HAS_MSG symbol, which indicates that the entire msg*(2) library is present. d_msg_ctrunc (d_socket.U): This variable conditionally defines the HAS_MSG_CTRUNC symbol, which indicates that the MSG_CTRUNC is available. #ifdef is not enough because it may be an enum, glibc has been known to do this. d_msg_dontroute (d_socket.U): This variable conditionally defines the HAS_MSG_DONTROUTE symbol, which indicates that the MSG_DONTROUTE is available. #ifdef is not enough because it may be an enum, glibc has been known to do this. d_msg_oob (d_socket.U): This variable conditionally defines the HAS_MSG_OOB symbol, which indicates that the MSG_OOB is available. #ifdef is not enough because it may be an enum, glibc has been known to do this. d_msg_peek (d_socket.U): This variable conditionally defines the HAS_MSG_PEEK symbol, which indicates that the MSG_PEEK is available. #ifdef is not enough because it may be an enum, glibc has been known to do this. d_msg_proxy (d_socket.U): This variable conditionally defines the HAS_MSG_PROXY symbol, which indicates that the MSG_PROXY is available. #ifdef is not enough because it may be an enum, glibc has been known to do this. d_msgctl (d_msgctl.U): This variable conditionally defines the HAS_MSGCTL symbol, which indicates to the C program that the msgctl() routine is available. d_msgget (d_msgget.U): This variable conditionally defines the HAS_MSGGET symbol, which indicates to the C program that the msgget() routine is available. d_msghdr_s (d_msghdr_s.U): This variable conditionally defines the HAS_STRUCT_MSGHDR symbol, which indicates that the struct msghdr is supported. d_msgrcv (d_msgrcv.U): This variable conditionally defines the HAS_MSGRCV symbol, which indicates to the C program that the msgrcv() routine is available. d_msgsnd (d_msgsnd.U): This variable conditionally defines the HAS_MSGSND symbol, which indicates to the C program that the msgsnd() routine is available. d_msync (d_msync.U): This variable conditionally defines HAS_MSYNC if msync() is available to synchronize a mapped file. d_munmap (d_munmap.U): This variable conditionally defines HAS_MUNMAP if munmap() is available to unmap a region mapped by mmap(). d_mymalloc (mallocsrc.U): This variable conditionally defines MYMALLOC in case other parts of the source want to take special action if MYMALLOC is used. This may include different sorts of profiling or error detection. d_ndbm (i_ndbm.U): This variable conditionally defines the HAS_NDBM symbol, which indicates that both the ndbm.h include file and an appropriate ndbm library exist. Consult the different i_*ndbm variables to find out the actual include location. Sometimes, a system has the header file but not the library. This variable will only be set if the system has both. d_ndbm_h_uses_prototypes (i_ndbm.U): This variable conditionally defines the NDBM_H_USES_PROTOTYPES symbol, which indicates that the ndbm.h include file uses real ANSI C prototypes instead of K&R style function declarations. K&R style declarations are unsupported in C++, so the include file requires special handling when using a C++ compiler and this variable is undefined. Consult the different d_*ndbm_h_uses_prototypes variables to get the same information for alternative ndbm.h include files. d_nice (d_nice.U): This variable conditionally defines the HAS_NICE symbol, which indicates to the C program that the nice() routine is available. d_nl_langinfo (d_nl_langinfo.U): This variable conditionally defines the HAS_NL_LANGINFO symbol, which indicates to the C program that the nl_langinfo() routine is available. d_nv_preserves_uv (perlxv.U): This variable indicates whether a variable of type nvtype can preserve all the bits a variable of type uvtype. d_nv_zero_is_allbits_zero (perlxv.U): This variable indicates whether a variable of type nvtype stores 0.0 in memory as all bits zero. d_off64_t (d_off64_t.U): This symbol will be defined if the C compiler supports off64_t. d_old_pthread_create_joinable (d_pthrattrj.U): This variable conditionally defines pthread_create_joinable. undef if pthread.h defines PTHREAD_CREATE_JOINABLE. d_oldpthreads (usethreads.U): This variable conditionally defines the OLD_PTHREADS_API symbol, and indicates that Perl should be built to use the old draft POSIX threads API. This is only potentially meaningful if usethreads is set. d_oldsock (d_socket.U): This variable conditionally defines the OLDSOCKET symbol, which indicates that the BSD socket interface is based on 4.1c and not 4.2. d_open3 (d_open3.U): This variable conditionally defines the HAS_OPEN3 manifest constant, which indicates to the C program that the 3 argument version of the open(2) function is available. d_pathconf (d_pathconf.U): This variable conditionally defines the HAS_PATHCONF symbol, which indicates to the C program that the pathconf() routine is available to determine file-system related limits and options associated with a given filename. d_pause (d_pause.U): This variable conditionally defines the HAS_PAUSE symbol, which indicates to the C program that the pause() routine is available to suspend a process until a signal is received. d_perl_otherlibdirs (otherlibdirs.U): This variable conditionally defines PERL_OTHERLIBDIRS, which contains a colon-separated set of paths for the perl binary to include in @INC. See also otherlibdirs. d_phostname (d_gethname.U): This variable conditionally defines the HAS_PHOSTNAME symbol, which contains the shell command which, when fed to popen(), may be used to derive the host name. d_pipe (d_pipe.U): This variable conditionally defines the HAS_PIPE symbol, which indicates to the C program that the pipe() routine is available to create an inter-process channel. d_poll (d_poll.U): This variable conditionally defines the HAS_POLL symbol, which indicates to the C program that the poll() routine is available to poll active file descriptors. d_portable (d_portable.U): This variable conditionally defines the PORTABLE symbol, which indicates to the C program that it should not assume that it is running on the machine it was compiled on. d_PRId64 (quadfio.U): This variable conditionally defines the PERL_PRId64 symbol, which indiciates that stdio has a symbol to print 64-bit decimal numbers. d_PRIeldbl (longdblfio.U): This variable conditionally defines the PERL_PRIfldbl symbol, which indiciates that stdio has a symbol to print long doubles. d_PRIEUldbl (longdblfio.U): This variable conditionally defines the PERL_PRIfldbl symbol, which indiciates that stdio has a symbol to print long doubles. The 'U' in the name is to separate this from d_PRIeldbl so that even case-blind systems can see the difference. d_PRIfldbl (longdblfio.U): This variable conditionally defines the PERL_PRIfldbl symbol, which indiciates that stdio has a symbol to print long doubles. d_PRIFUldbl (longdblfio.U): This variable conditionally defines the PERL_PRIfldbl symbol, which indiciates that stdio has a symbol to print long doubles. The 'U' in the name is to separate this from d_PRIfldbl so that even case-blind systems can see the difference. d_PRIgldbl (longdblfio.U): This variable conditionally defines the PERL_PRIfldbl symbol, which indiciates that stdio has a symbol to print long doubles. d_PRIGUldbl (longdblfio.U): This variable conditionally defines the PERL_PRIfldbl symbol, which indiciates that stdio has a symbol to print long doubles. The 'U' in the name is to separate this from d_PRIgldbl so that even case-blind systems can see the difference. d_PRIi64 (quadfio.U): This variable conditionally defines the PERL_PRIi64 symbol, which indiciates that stdio has a symbol to print 64-bit decimal numbers. d_printf_format_null (d_attribut.U): This variable conditionally defines PRINTF_FORMAT_NULL_OK, which indicates the C compiler allows printf-like formats to be null. d_PRIo64 (quadfio.U): This variable conditionally defines the PERL_PRIo64 symbol, which indiciates that stdio has a symbol to print 64-bit octal numbers. d_PRIu64 (quadfio.U): This variable conditionally defines the PERL_PRIu64 symbol, which indiciates that stdio has a symbol to print 64-bit unsigned decimal numbers. d_PRIx64 (quadfio.U): This variable conditionally defines the PERL_PRIx64 symbol, which indiciates that stdio has a symbol to print 64-bit hexadecimal numbers. d_PRIXU64 (quadfio.U): This variable conditionally defines the PERL_PRIXU64 symbol, which indiciates that stdio has a symbol to print 64-bit hExADECimAl numbers. The 'U' in the name is to separate this from d_PRIx64 so that even case-blind systems can see the difference. d_procselfexe (d_procselfexe.U): Defined if $procselfexe is symlink to the absolute pathname of the executing program. d_pseudofork (d_vfork.U): This variable conditionally defines the HAS_PSEUDOFORK symbol, which indicates that an emulation of the fork routine is available. d_pthread_atfork (d_pthread_atfork.U): This variable conditionally defines the HAS_PTHREAD_ATFORK symbol, which indicates to the C program that the pthread_atfork() routine is available. d_pthread_attr_setscope (d_pthread_attr_ss.U): This variable conditionally defines HAS_PTHREAD_ATTR_SETSCOPE if pthread_attr_setscope() is available to set the contention scope attribute of a thread attribute object. d_pthread_yield (d_pthread_y.U): This variable conditionally defines the HAS_PTHREAD_YIELD symbol if the pthread_yield routine is available to yield the execution of the current thread. d_pwage (i_pwd.U): This variable conditionally defines PWAGE, which indicates that struct passwd contains pw_age. d_pwchange (i_pwd.U): This variable conditionally defines PWCHANGE, which indicates that struct passwd contains pw_change. d_pwclass (i_pwd.U): This variable conditionally defines PWCLASS, which indicates that struct passwd contains pw_class. d_pwcomment (i_pwd.U): This variable conditionally defines PWCOMMENT, which indicates that struct passwd contains pw_comment. d_pwexpire (i_pwd.U): This variable conditionally defines PWEXPIRE, which indicates that struct passwd contains pw_expire. d_pwgecos (i_pwd.U): This variable conditionally defines PWGECOS, which indicates that struct passwd contains pw_gecos. d_pwpasswd (i_pwd.U): This variable conditionally defines PWPASSWD, which indicates that struct passwd contains pw_passwd. d_pwquota (i_pwd.U): This variable conditionally defines PWQUOTA, which indicates that struct passwd contains pw_quota. d_qgcvt (d_qgcvt.U): This variable conditionally defines the HAS_QGCVT symbol, which indicates to the C program that the qgcvt() routine is available. d_quad (quadtype.U): This variable, if defined, tells that there's a 64-bit integer type, quadtype. d_random_r (d_random_r.U): This variable conditionally defines the HAS_RANDOM_R symbol, which indicates to the C program that the random_r() routine is available. d_readdir (d_readdir.U): This variable conditionally defines HAS_READDIR if readdir() is available to read directory entries. d_readdir64_r (d_readdir64_r.U): This variable conditionally defines the HAS_READDIR64_R symbol, which indicates to the C program that the readdir64_r() routine is available. d_readdir_r (d_readdir_r.U): This variable conditionally defines the HAS_READDIR_R symbol, which indicates to the C program that the readdir_r() routine is available. d_readlink (d_readlink.U): This variable conditionally defines the HAS_READLINK symbol, which indicates to the C program that the readlink() routine is available to read the value of a symbolic link. d_readv (d_readv.U): This variable conditionally defines the HAS_READV symbol, which indicates to the C program that the readv() routine is available. d_recvmsg (d_recvmsg.U): This variable conditionally defines the HAS_RECVMSG symbol, which indicates to the C program that the recvmsg() routine is available. d_rename (d_rename.U): This variable conditionally defines the HAS_RENAME symbol, which indicates to the C program that the rename() routine is available to rename files. d_rewinddir (d_readdir.U): This variable conditionally defines HAS_REWINDDIR if rewinddir() is available. d_rmdir (d_rmdir.U): This variable conditionally defines HAS_RMDIR if rmdir() is available to remove directories. d_safebcpy (d_safebcpy.U): This variable conditionally defines the HAS_SAFE_BCOPY symbol if the bcopy() routine can do overlapping copies. Normally, you should probably use memmove(). d_safemcpy (d_safemcpy.U): This variable conditionally defines the HAS_SAFE_MEMCPY symbol if the memcpy() routine can do overlapping copies. For overlapping copies, memmove() should be used, if available. d_sanemcmp (d_sanemcmp.U): This variable conditionally defines the HAS_SANE_MEMCMP symbol if the memcpy() routine is available and can be used to compare relative magnitudes of chars with their high bits set. d_sbrkproto (d_sbrkproto.U): This variable conditionally defines the HAS_SBRK_PROTO symbol, which indicates to the C program that the system provides a prototype for the sbrk() function. Otherwise, it is up to the program to supply one. d_scalbnl (d_scalbnl.U): This variable conditionally defines the HAS_SCALBNL symbol, which indicates to the C program that the scalbnl() routine is available. If ilogbl is also present we can emulate frexpl. d_sched_yield (d_pthread_y.U): This variable conditionally defines the HAS_SCHED_YIELD symbol if the sched_yield routine is available to yield the execution of the current thread. d_scm_rights (d_socket.U): This variable conditionally defines the HAS_SCM_RIGHTS symbol, which indicates that the SCM_RIGHTS is available. #ifdef is not enough because it may be an enum, glibc has been known to do this. d_SCNfldbl (longdblfio.U): This variable conditionally defines the PERL_PRIfldbl symbol, which indiciates that stdio has a symbol to scan long doubles. d_seekdir (d_readdir.U): This variable conditionally defines HAS_SEEKDIR if seekdir() is available. d_select (d_select.U): This variable conditionally defines HAS_SELECT if select() is available to select active file descriptors. A inclusion may be necessary for the timeout field. d_sem (d_sem.U): This variable conditionally defines the HAS_SEM symbol, which indicates that the entire sem*(2) library is present. d_semctl (d_semctl.U): This variable conditionally defines the HAS_SEMCTL symbol, which indicates to the C program that the semctl() routine is available. d_semctl_semid_ds (d_union_semun.U): This variable conditionally defines USE_SEMCTL_SEMID_DS, which indicates that struct semid_ds * is to be used for semctl IPC_STAT. d_semctl_semun (d_union_semun.U): This variable conditionally defines USE_SEMCTL_SEMUN, which indicates that union semun is to be used for semctl IPC_STAT. d_semget (d_semget.U): This variable conditionally defines the HAS_SEMGET symbol, which indicates to the C program that the semget() routine is available. d_semop (d_semop.U): This variable conditionally defines the HAS_SEMOP symbol, which indicates to the C program that the semop() routine is available. d_sendmsg (d_sendmsg.U): This variable conditionally defines the HAS_SENDMSG symbol, which indicates to the C program that the sendmsg() routine is available. d_setegid (d_setegid.U): This variable conditionally defines the HAS_SETEGID symbol, which indicates to the C program that the setegid() routine is available to change the effective gid of the current program. d_seteuid (d_seteuid.U): This variable conditionally defines the HAS_SETEUID symbol, which indicates to the C program that the seteuid() routine is available to change the effective uid of the current program. d_setgrent (d_setgrent.U): This variable conditionally defines the HAS_SETGRENT symbol, which indicates to the C program that the setgrent() routine is available for initializing sequential access to the group database. d_setgrent_r (d_setgrent_r.U): This variable conditionally defines the HAS_SETGRENT_R symbol, which indicates to the C program that the setgrent_r() routine is available. d_setgrps (d_setgrps.U): This variable conditionally defines the HAS_SETGROUPS symbol, which indicates to the C program that the setgroups() routine is available to set the list of process groups. d_sethent (d_sethent.U): This variable conditionally defines HAS_SETHOSTENT if sethostent() is available. d_sethostent_r (d_sethostent_r.U): This variable conditionally defines the HAS_SETHOSTENT_R symbol, which indicates to the C program that the sethostent_r() routine is available. d_setitimer (d_setitimer.U): This variable conditionally defines the HAS_SETITIMER symbol, which indicates to the C program that the setitimer() routine is available. d_setlinebuf (d_setlnbuf.U): This variable conditionally defines the HAS_SETLINEBUF symbol, which indicates to the C program that the setlinebuf() routine is available to change stderr or stdout from block-buffered or unbuffered to a line-buffered mode. d_setlocale (d_setlocale.U): This variable conditionally defines HAS_SETLOCALE if setlocale() is available to handle locale-specific ctype implementations. d_setlocale_r (d_setlocale_r.U): This variable conditionally defines the HAS_SETLOCALE_R symbol, which indicates to the C program that the setlocale_r() routine is available. d_setnent (d_setnent.U): This variable conditionally defines HAS_SETNETENT if setnetent() is available. d_setnetent_r (d_setnetent_r.U): This variable conditionally defines the HAS_SETNETENT_R symbol, which indicates to the C program that the setnetent_r() routine is available. d_setpent (d_setpent.U): This variable conditionally defines HAS_SETPROTOENT if setprotoent() is available. d_setpgid (d_setpgid.U): This variable conditionally defines the HAS_SETPGID symbol if the setpgid(pid, gpid) function is available to set process group ID. d_setpgrp (d_setpgrp.U): This variable conditionally defines HAS_SETPGRP if setpgrp() is available to set the current process group. d_setpgrp2 (d_setpgrp2.U): This variable conditionally defines the HAS_SETPGRP2 symbol, which indicates to the C program that the setpgrp2() (as in DG/UX) routine is available to set the current process group. d_setprior (d_setprior.U): This variable conditionally defines HAS_SETPRIORITY if setpriority() is available to set a process's priority. d_setproctitle (d_setproctitle.U): This variable conditionally defines the HAS_SETPROCTITLE symbol, which indicates to the C program that the setproctitle() routine is available. d_setprotoent_r (d_setprotoent_r.U): This variable conditionally defines the HAS_SETPROTOENT_R symbol, which indicates to the C program that the setprotoent_r() routine is available. d_setpwent (d_setpwent.U): This variable conditionally defines the HAS_SETPWENT symbol, which indicates to the C program that the setpwent() routine is available for initializing sequential access to the passwd database. d_setpwent_r (d_setpwent_r.U): This variable conditionally defines the HAS_SETPWENT_R symbol, which indicates to the C program that the setpwent_r() routine is available. d_setregid (d_setregid.U): This variable conditionally defines HAS_SETREGID if setregid() is available to change the real and effective gid of the current process. d_setresgid (d_setregid.U): This variable conditionally defines HAS_SETRESGID if setresgid() is available to change the real, effective and saved gid of the current process. d_setresuid (d_setreuid.U): This variable conditionally defines HAS_SETREUID if setresuid() is available to change the real, effective and saved uid of the current process. d_setreuid (d_setreuid.U): This variable conditionally defines HAS_SETREUID if setreuid() is available to change the real and effective uid of the current process. d_setrgid (d_setrgid.U): This variable conditionally defines the HAS_SETRGID symbol, which indicates to the C program that the setrgid() routine is available to change the real gid of the current program. d_setruid (d_setruid.U): This variable conditionally defines the HAS_SETRUID symbol, which indicates to the C program that the setruid() routine is available to change the real uid of the current program. d_setsent (d_setsent.U): This variable conditionally defines HAS_SETSERVENT if setservent() is available. d_setservent_r (d_setservent_r.U): This variable conditionally defines the HAS_SETSERVENT_R symbol, which indicates to the C program that the setservent_r() routine is available. d_setsid (d_setsid.U): This variable conditionally defines HAS_SETSID if setsid() is available to set the process group ID. d_setvbuf (d_setvbuf.U): This variable conditionally defines the HAS_SETVBUF symbol, which indicates to the C program that the setvbuf() routine is available to change buffering on an open stdio stream. d_sfio (d_sfio.U): This variable conditionally defines the USE_SFIO symbol, and indicates whether sfio is available (and should be used). d_shm (d_shm.U): This variable conditionally defines the HAS_SHM symbol, which indicates that the entire shm*(2) library is present. d_shmat (d_shmat.U): This variable conditionally defines the HAS_SHMAT symbol, which indicates to the C program that the shmat() routine is available. d_shmatprototype (d_shmat.U): This variable conditionally defines the HAS_SHMAT_PROTOTYPE symbol, which indicates that sys/shm.h has a prototype for shmat. d_shmctl (d_shmctl.U): This variable conditionally defines the HAS_SHMCTL symbol, which indicates to the C program that the shmctl() routine is available. d_shmdt (d_shmdt.U): This variable conditionally defines the HAS_SHMDT symbol, which indicates to the C program that the shmdt() routine is available. d_shmget (d_shmget.U): This variable conditionally defines the HAS_SHMGET symbol, which indicates to the C program that the shmget() routine is available. d_sigaction (d_sigaction.U): This variable conditionally defines the HAS_SIGACTION symbol, which indicates that the Vr4 sigaction() routine is available. d_signbit (d_signbit.U): This variable conditionally defines the HAS_SIGNBIT symbol, which indicates to the C program that the signbit() routine is available and safe to use with perl's intern NV type. d_sigprocmask (d_sigprocmask.U): This variable conditionally defines HAS_SIGPROCMASK if sigprocmask() is available to examine or change the signal mask of the calling process. d_sigsetjmp (d_sigsetjmp.U): This variable conditionally defines the HAS_SIGSETJMP symbol, which indicates that the sigsetjmp() routine is available to call setjmp() and optionally save the process's signal mask. d_sitearch (sitearch.U): This variable conditionally defines SITEARCH to hold the pathname of architecture-dependent library files for $package. If $sitearch is the same as $archlib, then this is set to undef. d_snprintf (d_snprintf.U): This variable conditionally defines the HAS_SNPRINTF symbol, which indicates to the C program that the snprintf () library function is available. d_sockatmark (d_sockatmark.U): This variable conditionally defines the HAS_SOCKATMARK symbol, which indicates to the C program that the sockatmark() routine is available. d_sockatmarkproto (d_sockatmarkproto.U): This variable conditionally defines the HAS_SOCKATMARK_PROTO symbol, which indicates to the C program that the system provides a prototype for the sockatmark() function. Otherwise, it is up to the program to supply one. d_socket (d_socket.U): This variable conditionally defines HAS_SOCKET, which indicates that the BSD socket interface is supported. d_socklen_t (d_socklen_t.U): This symbol will be defined if the C compiler supports socklen_t. d_sockpair (d_socket.U): This variable conditionally defines the HAS_SOCKETPAIR symbol, which indicates that the BSD socketpair() is supported. d_socks5_init (d_socks5_init.U): This variable conditionally defines the HAS_SOCKS5_INIT symbol, which indicates to the C program that the socks5_init() routine is available. d_sprintf_returns_strlen (d_sprintf_len.U): This variable defines whether sprintf returns the length of the string (as per the ANSI spec). Some C libraries retain compatibility with pre-ANSI C and return a pointer to the passed in buffer; for these this variable will be undef. d_sqrtl (d_sqrtl.U): This variable conditionally defines the HAS_SQRTL symbol, which indicates to the C program that the sqrtl() routine is available. d_srand48_r (d_srand48_r.U): This variable conditionally defines the HAS_SRAND48_R symbol, which indicates to the C program that the srand48_r() routine is available. d_srandom_r (d_srandom_r.U): This variable conditionally defines the HAS_SRANDOM_R symbol, which indicates to the C program that the srandom_r() routine is available. d_sresgproto (d_sresgproto.U): This variable conditionally defines the HAS_SETRESGID_PROTO symbol, which indicates to the C program that the system provides a prototype for the setresgid() function. Otherwise, it is up to the program to supply one. d_sresuproto (d_sresuproto.U): This variable conditionally defines the HAS_SETRESUID_PROTO symbol, which indicates to the C program that the system provides a prototype for the setresuid() function. Otherwise, it is up to the program to supply one. d_statblks (d_statblks.U): This variable conditionally defines USE_STAT_BLOCKS if this system has a stat structure declaring st_blksize and st_blocks. d_statfs_f_flags (d_statfs_f_flags.U): This variable conditionally defines the HAS_STRUCT_STATFS_F_FLAGS symbol, which indicates to struct statfs from has f_flags member. This kind of struct statfs is coming from sys/mount.h (BSD), not from sys/statfs.h (SYSV). d_statfs_s (d_statfs_s.U): This variable conditionally defines the HAS_STRUCT_STATFS symbol, which indicates that the struct statfs is supported. d_statvfs (d_statvfs.U): This variable conditionally defines the HAS_STATVFS symbol, which indicates to the C program that the statvfs() routine is available. d_stdio_cnt_lval (d_stdstdio.U): This variable conditionally defines STDIO_CNT_LVALUE if the FILE_cnt macro can be used as an lvalue. d_stdio_ptr_lval (d_stdstdio.U): This variable conditionally defines STDIO_PTR_LVALUE if the FILE_ptr macro can be used as an lvalue. d_stdio_ptr_lval_nochange_cnt (d_stdstdio.U): This symbol is defined if using the FILE_ptr macro as an lvalue to increase the pointer by n leaves File_cnt(fp) unchanged. d_stdio_ptr_lval_sets_cnt (d_stdstdio.U): This symbol is defined if using the FILE_ptr macro as an lvalue to increase the pointer by n has the side effect of decreasing the value of File_cnt(fp) by n. d_stdio_stream_array (stdio_streams.U): This variable tells whether there is an array holding the stdio streams. d_stdiobase (d_stdstdio.U): This variable conditionally defines USE_STDIO_BASE if this system has a FILE structure declaring a usable _base field (or equivalent) in stdio.h. d_stdstdio (d_stdstdio.U): This variable conditionally defines USE_STDIO_PTR if this system has a FILE structure declaring usable _ptr and _cnt fields (or equivalent) in stdio.h. d_strchr (d_strchr.U): This variable conditionally defines HAS_STRCHR if strchr() and strrchr() are available for string searching. d_strcoll (d_strcoll.U): This variable conditionally defines HAS_STRCOLL if strcoll() is available to compare strings using collating information. d_strctcpy (d_strctcpy.U): This variable conditionally defines the USE_STRUCT_COPY symbol, which indicates to the C program that this C compiler knows how to copy structures. d_strerrm (d_strerror.U): This variable holds what Strerrr is defined as to translate an error code condition into an error message string. It could be 'strerror' or a more complex macro emulating strrror with sys_errlist[], or the "unknown" string when both strerror and sys_errlist are missing. d_strerror (d_strerror.U): This variable conditionally defines HAS_STRERROR if strerror() is available to translate error numbers to strings. d_strerror_r (d_strerror_r.U): This variable conditionally defines the HAS_STRERROR_R symbol, which indicates to the C program that the strerror_r() routine is available. d_strftime (d_strftime.U): This variable conditionally defines the HAS_STRFTIME symbol, which indicates to the C program that the strftime() routine is available. d_strlcat (d_strlcat.U): This variable conditionally defines the HAS_STRLCAT symbol, which indicates to the C program that the strlcat () routine is available. d_strlcpy (d_strlcpy.U): This variable conditionally defines the HAS_STRLCPY symbol, which indicates to the C program that the strlcpy () routine is available. d_strtod (d_strtod.U): This variable conditionally defines the HAS_STRTOD symbol, which indicates to the C program that the strtod() routine is available to provide better numeric string conversion than atof(). d_strtol (d_strtol.U): This variable conditionally defines the HAS_STRTOL symbol, which indicates to the C program that the strtol() routine is available to provide better numeric string conversion than atoi() and friends. d_strtold (d_strtold.U): This variable conditionally defines the HAS_STRTOLD symbol, which indicates to the C program that the strtold() routine is available. d_strtoll (d_strtoll.U): This variable conditionally defines the HAS_STRTOLL symbol, which indicates to the C program that the strtoll() routine is available. d_strtoq (d_strtoq.U): This variable conditionally defines the HAS_STRTOQ symbol, which indicates to the C program that the strtoq() routine is available. d_strtoul (d_strtoul.U): This variable conditionally defines the HAS_STRTOUL symbol, which indicates to the C program that the strtoul() routine is available to provide conversion of strings to unsigned long. d_strtoull (d_strtoull.U): This variable conditionally defines the HAS_STRTOULL symbol, which indicates to the C program that the strtoull() routine is available. d_strtouq (d_strtouq.U): This variable conditionally defines the HAS_STRTOUQ symbol, which indicates to the C program that the strtouq() routine is available. d_strxfrm (d_strxfrm.U): This variable conditionally defines HAS_STRXFRM if strxfrm() is available to transform strings. d_suidsafe (d_dosuid.U): This variable conditionally defines SETUID_SCRIPTS_ARE_SECURE_NOW if setuid scripts can be secure. This test looks in /dev/fd/. d_symlink (d_symlink.U): This variable conditionally defines the HAS_SYMLINK symbol, which indicates to the C program that the symlink() routine is available to create symbolic links. d_syscall (d_syscall.U): This variable conditionally defines HAS_SYSCALL if syscall() is available call arbitrary system calls. d_syscallproto (d_syscallproto.U): This variable conditionally defines the HAS_SYSCALL_PROTO symbol, which indicates to the C program that the system provides a prototype for the syscall() function. Otherwise, it is up to the program to supply one. d_sysconf (d_sysconf.U): This variable conditionally defines the HAS_SYSCONF symbol, which indicates to the C program that the sysconf() routine is available to determine system related limits and options. d_sysernlst (d_strerror.U): This variable conditionally defines HAS_SYS_ERRNOLIST if sys_errnolist[] is available to translate error numbers to the symbolic name. d_syserrlst (d_strerror.U): This variable conditionally defines HAS_SYS_ERRLIST if sys_errlist[] is available to translate error numbers to strings. d_system (d_system.U): This variable conditionally defines HAS_SYSTEM if system() is available to issue a shell command. d_tcgetpgrp (d_tcgtpgrp.U): This variable conditionally defines the HAS_TCGETPGRP symbol, which indicates to the C program that the tcgetpgrp() routine is available. to get foreground process group ID. d_tcsetpgrp (d_tcstpgrp.U): This variable conditionally defines the HAS_TCSETPGRP symbol, which indicates to the C program that the tcsetpgrp() routine is available to set foreground process group ID. d_telldir (d_readdir.U): This variable conditionally defines HAS_TELLDIR if telldir() is available. d_telldirproto (d_telldirproto.U): This variable conditionally defines the HAS_TELLDIR_PROTO symbol, which indicates to the C program that the system provides a prototype for the telldir() function. Otherwise, it is up to the program to supply one. d_time (d_time.U): This variable conditionally defines the HAS_TIME symbol, which indicates that the time() routine exists. The time() routine is normaly provided on UNIX systems. d_timegm (d_timegm.U): This variable conditionally defines the HAS_TIMEGM symbol, which indicates to the C program that the timegm () routine is available. d_times (d_times.U): This variable conditionally defines the HAS_TIMES symbol, which indicates that the times() routine exists. The times() routine is normaly provided on UNIX systems. You may have to include . d_tm_tm_gmtoff (i_time.U): This variable conditionally defines HAS_TM_TM_GMTOFF, which indicates indicates to the C program that the struct tm has the tm_gmtoff field. d_tm_tm_zone (i_time.U): This variable conditionally defines HAS_TM_TM_ZONE, which indicates indicates to the C program that the struct tm has the tm_zone field. d_tmpnam_r (d_tmpnam_r.U): This variable conditionally defines the HAS_TMPNAM_R symbol, which indicates to the C program that the tmpnam_r() routine is available. d_truncate (d_truncate.U): This variable conditionally defines HAS_TRUNCATE if truncate() is available to truncate files. d_ttyname_r (d_ttyname_r.U): This variable conditionally defines the HAS_TTYNAME_R symbol, which indicates to the C program that the ttyname_r() routine is available. d_tzname (d_tzname.U): This variable conditionally defines HAS_TZNAME if tzname[] is available to access timezone names. d_u32align (d_u32align.U): This variable tells whether you must access character data through U32-aligned pointers. d_ualarm (d_ualarm.U): This variable conditionally defines the HAS_UALARM symbol, which indicates to the C program that the ualarm() routine is available. d_umask (d_umask.U): This variable conditionally defines the HAS_UMASK symbol, which indicates to the C program that the umask() routine is available. to set and get the value of the file creation mask. d_uname (d_gethname.U): This variable conditionally defines the HAS_UNAME symbol, which indicates to the C program that the uname() routine may be used to derive the host name. d_union_semun (d_union_semun.U): This variable conditionally defines HAS_UNION_SEMUN if the union semun is defined by including . d_unordered (d_unordered.U): This variable conditionally defines the HAS_UNORDERED symbol, which indicates to the C program that the unordered() routine is available. d_unsetenv (d_unsetenv.U): This variable conditionally defines the HAS_UNSETENV symbol, which indicates to the C program that the unsetenv () routine is available. d_usleep (d_usleep.U): This variable conditionally defines HAS_USLEEP if usleep() is available to do high granularity sleeps. d_usleepproto (d_usleepproto.U): This variable conditionally defines the HAS_USLEEP_PROTO symbol, which indicates to the C program that the system provides a prototype for the usleep() function. Otherwise, it is up to the program to supply one. d_ustat (d_ustat.U): This variable conditionally defines HAS_USTAT if ustat() is available to query file system statistics by dev_t. d_vendorarch (vendorarch.U): This variable conditionally defined PERL_VENDORARCH. d_vendorbin (vendorbin.U): This variable conditionally defines PERL_VENDORBIN. d_vendorlib (vendorlib.U): This variable conditionally defines PERL_VENDORLIB. d_vendorscript (vendorscript.U): This variable conditionally defines PERL_VENDORSCRIPT. d_vfork (d_vfork.U): This variable conditionally defines the HAS_VFORK symbol, which indicates the vfork() routine is available. d_void_closedir (d_closedir.U): This variable conditionally defines VOID_CLOSEDIR if closedir() does not return a value. d_voidsig (d_voidsig.U): This variable conditionally defines VOIDSIG if this system declares "void (*signal(...))()" in signal.h. The old way was to declare it as "int (*signal(...))()". d_voidtty (i_sysioctl.U): This variable conditionally defines USE_IOCNOTTY to indicate that the ioctl() call with TIOCNOTTY should be used to void tty association. Otherwise (on USG probably), it is enough to close the standard file decriptors and do a setpgrp(). d_volatile (d_volatile.U): This variable conditionally defines the HASVOLATILE symbol, which indicates to the C program that this C compiler knows about the volatile declaration. d_vprintf (d_vprintf.U): This variable conditionally defines the HAS_VPRINTF symbol, which indicates to the C program that the vprintf() routine is available to printf with a pointer to an argument list. d_vsnprintf (d_snprintf.U): This variable conditionally defines the HAS_VSNPRINTF symbol, which indicates to the C program that the vsnprintf () library function is available. d_wait4 (d_wait4.U): This variable conditionally defines the HAS_WAIT4 symbol, which indicates the wait4() routine is available. d_waitpid (d_waitpid.U): This variable conditionally defines HAS_WAITPID if waitpid() is available to wait for child process. d_wcstombs (d_wcstombs.U): This variable conditionally defines the HAS_WCSTOMBS symbol, which indicates to the C program that the wcstombs() routine is available to convert wide character strings to multibyte strings. d_wctomb (d_wctomb.U): This variable conditionally defines the HAS_WCTOMB symbol, which indicates to the C program that the wctomb() routine is available to convert a wide character to a multibyte. d_writev (d_writev.U): This variable conditionally defines the HAS_WRITEV symbol, which indicates to the C program that the writev() routine is available. d_xenix (Guess.U): This variable conditionally defines the symbol XENIX, which alerts the C program that it runs under Xenix. date (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the date program. After Configure runs, the value is reset to a plain "date" and is not useful. db_hashtype (i_db.U): This variable contains the type of the hash structure element in the header file. In older versions of DB, it was int, while in newer ones it is u_int32_t. db_prefixtype (i_db.U): This variable contains the type of the prefix structure element in the header file. In older versions of DB, it was int, while in newer ones it is size_t. db_version_major (i_db.U): This variable contains the major version number of Berkeley DB found in the header file. db_version_minor (i_db.U): This variable contains the minor version number of Berkeley DB found in the header file. For DB version 1 this is always 0. db_version_patch (i_db.U): This variable contains the patch version number of Berkeley DB found in the header file. For DB version 1 this is always 0. defvoidused (voidflags.U): This variable contains the default value of the VOIDUSED symbol (15). direntrytype (i_dirent.U): This symbol is set to 'struct direct' or 'struct dirent' depending on whether dirent is available or not. You should use this pseudo type to portably declare your directory entries. dlext (dlext.U): This variable contains the extension that is to be used for the dynamically loaded modules that perl generaties. dlsrc (dlsrc.U): This variable contains the name of the dynamic loading file that will be used with the package. doublesize (doublesize.U): This variable contains the value of the DOUBLESIZE symbol, which indicates to the C program how many bytes there are in a double. drand01 (randfunc.U): Indicates the macro to be used to generate normalized random numbers. Uses randfunc, often divided by (double) (((unsigned long) 1 << randbits)) in order to normalize the result. In C programs, the macro 'Drand01' is mapped to drand01. drand48_r_proto (d_drand48_r.U): This variable encodes the prototype of drand48_r. It is zero if d_drand48_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_drand48_r is defined. dtrace (usedtrace.U): This variable holds the location of the dtrace executable. dynamic_ext (Extensions.U): This variable holds a list of XS extension files we want to link dynamically into the package. It is used by Makefile. eagain (nblock_io.U): This variable bears the symbolic errno code set by read() when no data is present on the file and non-blocking I/O was enabled (otherwise, read() blocks naturally). ebcdic (ebcdic.U): This variable conditionally defines EBCDIC if this system uses EBCDIC encoding. Among other things, this means that the character ranges are not contiguous. See trnl.U echo (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the echo program. After Configure runs, the value is reset to a plain "echo" and is not useful. egrep (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the egrep program. After Configure runs, the value is reset to a plain "egrep" and is not useful. emacs (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. endgrent_r_proto (d_endgrent_r.U): This variable encodes the prototype of endgrent_r. It is zero if d_endgrent_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_endgrent_r is defined. endhostent_r_proto (d_endhostent_r.U): This variable encodes the prototype of endhostent_r. It is zero if d_endhostent_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_endhostent_r is defined. endnetent_r_proto (d_endnetent_r.U): This variable encodes the prototype of endnetent_r. It is zero if d_endnetent_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_endnetent_r is defined. endprotoent_r_proto (d_endprotoent_r.U): This variable encodes the prototype of endprotoent_r. It is zero if d_endprotoent_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_endprotoent_r is defined. endpwent_r_proto (d_endpwent_r.U): This variable encodes the prototype of endpwent_r. It is zero if d_endpwent_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_endpwent_r is defined. endservent_r_proto (d_endservent_r.U): This variable encodes the prototype of endservent_r. It is zero if d_endservent_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_endservent_r is defined. eunicefix (Init.U): When running under Eunice this variable contains a command which will convert a shell script to the proper form of text file for it to be executable by the shell. On other systems it is a no-op. exe_ext (Unix.U): This is an old synonym for _exe. expr (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the expr program. After Configure runs, the value is reset to a plain "expr" and is not useful. extensions (Extensions.U): This variable holds a list of all extension files (both XS and non-xs linked into the package. It is propagated to Config.pm and is typically used to test whether a particular extesion is available. extern_C (Csym.U): ANSI C requires 'extern' where C++ requires 'extern "C"'. This variable can be used in Configure to do the right thing. extras (Extras.U): This variable holds a list of extra modules to install. fflushall (fflushall.U): This symbol, if defined, tells that to flush all pending stdio output one must loop through all the stdio file handles stored in an array and fflush them. Note that if fflushNULL is defined, fflushall will not even be probed for and will be left undefined. fflushNULL (fflushall.U): This symbol, if defined, tells that fflush(NULL) does flush all pending stdio output. find (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. firstmakefile (Unix.U): This variable defines the first file searched by make. On unix, it is makefile (then Makefile). On case-insensitive systems, it might be something else. This is only used to deal with convoluted make depend tricks. flex (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. fpossize (fpossize.U): This variable contains the size of a fpostype in bytes. fpostype (fpostype.U): This variable defines Fpos_t to be something like fpos_t, long, uint, or whatever type is used to declare file positions in libc. freetype (mallocsrc.U): This variable contains the return type of free(). It is usually void, but occasionally int. from (Cross.U): This variable contains the command used by Configure to copy files from the target host. Useful and available only during Perl build. The string ':' if not cross-compiling. full_ar (Loc_ar.U): This variable contains the full pathname to 'ar', whether or not the user has specified 'portability'. This is only used in the Makefile.SH. full_csh (d_csh.U): This variable contains the full pathname to 'csh', whether or not the user has specified 'portability'. This is only used in the compiled C program, and we assume that all systems which can share this executable will have the same full pathname to 'csh.' full_sed (Loc_sed.U): This variable contains the full pathname to 'sed', whether or not the user has specified 'portability'. This is only used in the compiled C program, and we assume that all systems which can share this executable will have the same full pathname to 'sed.' gccansipedantic (gccvers.U): If GNU cc (gcc) is used, this variable will enable (if set) the -ansi and -pedantic ccflags for building core files (through cflags script). (See Porting/pumpkin.pod for full description). gccosandvers (gccvers.U): If GNU cc (gcc) is used, this variable holds the operating system and version used to compile gcc. It is set to '' if not gcc, or if nothing useful can be parsed as the os version. gccversion (gccvers.U): If GNU cc (gcc) is used, this variable holds '1' or '2' to indicate whether the compiler is version 1 or 2. This is used in setting some of the default cflags. It is set to '' if not gcc. getgrent_r_proto (d_getgrent_r.U): This variable encodes the prototype of getgrent_r. It is zero if d_getgrent_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrent_r is defined. getgrgid_r_proto (d_getgrgid_r.U): This variable encodes the prototype of getgrgid_r. It is zero if d_getgrgid_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrgid_r is defined. getgrnam_r_proto (d_getgrnam_r.U): This variable encodes the prototype of getgrnam_r. It is zero if d_getgrnam_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrnam_r is defined. gethostbyaddr_r_proto (d_gethostbyaddr_r.U): This variable encodes the prototype of gethostbyaddr_r. It is zero if d_gethostbyaddr_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostbyaddr_r is defined. gethostbyname_r_proto (d_gethostbyname_r.U): This variable encodes the prototype of gethostbyname_r. It is zero if d_gethostbyname_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostbyname_r is defined. gethostent_r_proto (d_gethostent_r.U): This variable encodes the prototype of gethostent_r. It is zero if d_gethostent_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostent_r is defined. getlogin_r_proto (d_getlogin_r.U): This variable encodes the prototype of getlogin_r. It is zero if d_getlogin_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_getlogin_r is defined. getnetbyaddr_r_proto (d_getnetbyaddr_r.U): This variable encodes the prototype of getnetbyaddr_r. It is zero if d_getnetbyaddr_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetbyaddr_r is defined. getnetbyname_r_proto (d_getnetbyname_r.U): This variable encodes the prototype of getnetbyname_r. It is zero if d_getnetbyname_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetbyname_r is defined. getnetent_r_proto (d_getnetent_r.U): This variable encodes the prototype of getnetent_r. It is zero if d_getnetent_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetent_r is defined. getprotobyname_r_proto (d_getprotobyname_r.U): This variable encodes the prototype of getprotobyname_r. It is zero if d_getprotobyname_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotobyname_r is defined. getprotobynumber_r_proto (d_getprotobynumber_r.U): This variable encodes the prototype of getprotobynumber_r. It is zero if d_getprotobynumber_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotobynumber_r is defined. getprotoent_r_proto (d_getprotoent_r.U): This variable encodes the prototype of getprotoent_r. It is zero if d_getprotoent_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotoent_r is defined. getpwent_r_proto (d_getpwent_r.U): This variable encodes the prototype of getpwent_r. It is zero if d_getpwent_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwent_r is defined. getpwnam_r_proto (d_getpwnam_r.U): This variable encodes the prototype of getpwnam_r. It is zero if d_getpwnam_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwnam_r is defined. getpwuid_r_proto (d_getpwuid_r.U): This variable encodes the prototype of getpwuid_r. It is zero if d_getpwuid_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwuid_r is defined. getservbyname_r_proto (d_getservbyname_r.U): This variable encodes the prototype of getservbyname_r. It is zero if d_getservbyname_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservbyname_r is defined. getservbyport_r_proto (d_getservbyport_r.U): This variable encodes the prototype of getservbyport_r. It is zero if d_getservbyport_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservbyport_r is defined. getservent_r_proto (d_getservent_r.U): This variable encodes the prototype of getservent_r. It is zero if d_getservent_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservent_r is defined. getspnam_r_proto (d_getspnam_r.U): This variable encodes the prototype of getspnam_r. It is zero if d_getspnam_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_getspnam_r is defined. gidformat (gidf.U): This variable contains the format string used for printing a Gid_t. gidsign (gidsign.U): This variable contains the signedness of a gidtype. 1 for unsigned, -1 for signed. gidsize (gidsize.U): This variable contains the size of a gidtype in bytes. gidtype (gidtype.U): This variable defines Gid_t to be something like gid_t, int, ushort, or whatever type is used to declare the return type of getgid(). Typically, it is the type of group ids in the kernel. glibpth (libpth.U): This variable holds the general path (space-separated) used to find libraries. It may contain directories that do not exist on this platform, libpth is the cleaned-up version. gmake (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the gmake program. After Configure runs, the value is reset to a plain "gmake" and is not useful. gmtime_r_proto (d_gmtime_r.U): This variable encodes the prototype of gmtime_r. It is zero if d_gmtime_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_gmtime_r is defined. gnulibc_version (d_gnulibc.U): This variable contains the version number of the GNU C library. It is usually something like '2.2.5'. It is a plain '' if this is not the GNU C library, or if the version is unknown. grep (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the grep program. After Configure runs, the value is reset to a plain "grep" and is not useful. groupcat (nis.U): This variable contains a command that produces the text of the /etc/group file. This is normally "cat /etc/group", but can be "ypcat group" when NIS is used. On some systems, such as os390, there may be no equivalent command, in which case this variable is unset. groupstype (groupstype.U): This variable defines Groups_t to be something like gid_t, int, ushort, or whatever type is used for the second argument to getgroups() and setgroups(). Usually, this is the same as gidtype (gid_t), but sometimes it isn't. gzip (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the gzip program. After Configure runs, the value is reset to a plain "gzip" and is not useful. h_fcntl (h_fcntl.U): This is variable gets set in various places to tell i_fcntl that should be included. h_sysfile (h_sysfile.U): This is variable gets set in various places to tell i_sys_file that should be included. hint (Oldconfig.U): Gives the type of hints used for previous answers. May be one of "default", "recommended" or "previous". hostcat (nis.U): This variable contains a command that produces the text of the /etc/hosts file. This is normally "cat /etc/hosts", but can be "ypcat hosts" when NIS is used. On some systems, such as os390, there may be no equivalent command, in which case this variable is unset. html1dir (html1dir.U): This variable contains the name of the directory in which html source pages are to be put. This directory is for pages that describe whole programs, not libraries or modules. It is intended to correspond roughly to section 1 of the Unix manuals. html1direxp (html1dir.U): This variable is the same as the html1dir variable, but is filename expanded at configuration time, for convenient use in makefiles. html3dir (html3dir.U): This variable contains the name of the directory in which html source pages are to be put. This directory is for pages that describe libraries or modules. It is intended to correspond roughly to section 3 of the Unix manuals. html3direxp (html3dir.U): This variable is the same as the html3dir variable, but is filename expanded at configuration time, for convenient use in makefiles. i16size (perlxv.U): This variable is the size of an I16 in bytes. i16type (perlxv.U): This variable contains the C type used for Perl's I16. i32size (perlxv.U): This variable is the size of an I32 in bytes. i32type (perlxv.U): This variable contains the C type used for Perl's I32. i64size (perlxv.U): This variable is the size of an I64 in bytes. i64type (perlxv.U): This variable contains the C type used for Perl's I64. i8size (perlxv.U): This variable is the size of an I8 in bytes. i8type (perlxv.U): This variable contains the C type used for Perl's I8. i_arpainet (i_arpainet.U): This variable conditionally defines the I_ARPA_INET symbol, and indicates whether a C program should include . i_assert (i_assert.U): This variable conditionally defines the I_ASSERT symbol, which indicates to the C program that exists and could be included. i_bsdioctl (i_sysioctl.U): This variable conditionally defines the I_SYS_BSDIOCTL symbol, which indicates to the C program that exists and should be included. i_crypt (i_crypt.U): This variable conditionally defines the I_CRYPT symbol, and indicates whether a C program should include . i_db (i_db.U): This variable conditionally defines the I_DB symbol, and indicates whether a C program may include Berkeley's DB include file . i_dbm (i_dbm.U): This variable conditionally defines the I_DBM symbol, which indicates to the C program that exists and should be included. i_dirent (i_dirent.U): This variable conditionally defines I_DIRENT, which indicates to the C program that it should include . i_dld (i_dld.U): This variable conditionally defines the I_DLD symbol, which indicates to the C program that (GNU dynamic loading) exists and should be included. i_dlfcn (i_dlfcn.U): This variable conditionally defines the I_DLFCN symbol, which indicates to the C program that exists and should be included. i_fcntl (i_fcntl.U): This variable controls the value of I_FCNTL (which tells the C program to include ). i_float (i_float.U): This variable conditionally defines the I_FLOAT symbol, and indicates whether a C program may include to get symbols like DBL_MAX or DBL_MIN, i.e. machine dependent floating point values. i_fp (i_fp.U): This variable conditionally defines the I_FP symbol, and indicates whether a C program should include . i_fp_class (i_fp_class.U): This variable conditionally defines the I_FP_CLASS symbol, and indicates whether a C program should include . i_gdbm (i_gdbm.U): This variable conditionally defines the I_GDBM symbol, which indicates to the C program that exists and should be included. i_gdbm_ndbm (i_ndbm.U): This variable conditionally defines the I_GDBM_NDBM symbol, which indicates to the C program that exists and should be included. This is the location of the ndbm.h compatibility file in Debian 4.0. i_gdbmndbm (i_ndbm.U): This variable conditionally defines the I_GDBMNDBM symbol, which indicates to the C program that exists and should be included. This was the location of the ndbm.h compatibility file in RedHat 7.1. i_grp (i_grp.U): This variable conditionally defines the I_GRP symbol, and indicates whether a C program should include . i_ieeefp (i_ieeefp.U): This variable conditionally defines the I_IEEEFP symbol, and indicates whether a C program should include . i_inttypes (i_inttypes.U): This variable conditionally defines the I_INTTYPES symbol, and indicates whether a C program should include . i_langinfo (i_langinfo.U): This variable conditionally defines the I_LANGINFO symbol, and indicates whether a C program should include . i_libutil (i_libutil.U): This variable conditionally defines the I_LIBUTIL symbol, and indicates whether a C program should include . i_limits (i_limits.U): This variable conditionally defines the I_LIMITS symbol, and indicates whether a C program may include to get symbols like WORD_BIT and friends. i_locale (i_locale.U): This variable conditionally defines the I_LOCALE symbol, and indicates whether a C program should include . i_machcthr (i_machcthr.U): This variable conditionally defines the I_MACH_CTHREADS symbol, and indicates whether a C program should include . i_malloc (i_malloc.U): This variable conditionally defines the I_MALLOC symbol, and indicates whether a C program should include . i_mallocmalloc (i_mallocmalloc.U): This variable conditionally defines the I_MALLOCMALLOC symbol, and indicates whether a C program should include . i_math (i_math.U): This variable conditionally defines the I_MATH symbol, and indicates whether a C program may include . i_memory (i_memory.U): This variable conditionally defines the I_MEMORY symbol, and indicates whether a C program should include . i_mntent (i_mntent.U): This variable conditionally defines the I_MNTENT symbol, and indicates whether a C program should include . i_ndbm (i_ndbm.U): This variable conditionally defines the I_NDBM symbol, which indicates to the C program that exists and should be included. i_netdb (i_netdb.U): This variable conditionally defines the I_NETDB symbol, and indicates whether a C program should include . i_neterrno (i_neterrno.U): This variable conditionally defines the I_NET_ERRNO symbol, which indicates to the C program that exists and should be included. i_netinettcp (i_netinettcp.U): This variable conditionally defines the I_NETINET_TCP symbol, and indicates whether a C program should include . i_niin (i_niin.U): This variable conditionally defines I_NETINET_IN, which indicates to the C program that it should include . Otherwise, you may try . i_poll (i_poll.U): This variable conditionally defines the I_POLL symbol, and indicates whether a C program should include . i_prot (i_prot.U): This variable conditionally defines the I_PROT symbol, and indicates whether a C program should include . i_pthread (i_pthread.U): This variable conditionally defines the I_PTHREAD symbol, and indicates whether a C program should include . i_pwd (i_pwd.U): This variable conditionally defines I_PWD, which indicates to the C program that it should include . i_rpcsvcdbm (i_dbm.U): This variable conditionally defines the I_RPCSVC_DBM symbol, which indicates to the C program that exists and should be included. Some System V systems might need this instead of . i_sfio (i_sfio.U): This variable conditionally defines the I_SFIO symbol, and indicates whether a C program should include . i_sgtty (i_termio.U): This variable conditionally defines the I_SGTTY symbol, which indicates to the C program that it should include rather than . i_shadow (i_shadow.U): This variable conditionally defines the I_SHADOW symbol, and indicates whether a C program should include . i_socks (i_socks.U): This variable conditionally defines the I_SOCKS symbol, and indicates whether a C program should include . i_stdarg (i_varhdr.U): This variable conditionally defines the I_STDARG symbol, which indicates to the C program that exists and should be included. i_stddef (i_stddef.U): This variable conditionally defines the I_STDDEF symbol, which indicates to the C program that exists and should be included. i_stdlib (i_stdlib.U): This variable conditionally defines the I_STDLIB symbol, which indicates to the C program that exists and should be included. i_string (i_string.U): This variable conditionally defines the I_STRING symbol, which indicates that should be included rather than . i_sunmath (i_sunmath.U): This variable conditionally defines the I_SUNMATH symbol, and indicates whether a C program should include . i_sysaccess (i_sysaccess.U): This variable conditionally defines the I_SYS_ACCESS symbol, and indicates whether a C program should include . i_sysdir (i_sysdir.U): This variable conditionally defines the I_SYS_DIR symbol, and indicates whether a C program should include . i_sysfile (i_sysfile.U): This variable conditionally defines the I_SYS_FILE symbol, and indicates whether a C program should include to get R_OK and friends. i_sysfilio (i_sysioctl.U): This variable conditionally defines the I_SYS_FILIO symbol, which indicates to the C program that exists and should be included in preference to . i_sysin (i_niin.U): This variable conditionally defines I_SYS_IN, which indicates to the C program that it should include instead of . i_sysioctl (i_sysioctl.U): This variable conditionally defines the I_SYS_IOCTL symbol, which indicates to the C program that exists and should be included. i_syslog (i_syslog.U): This variable conditionally defines the I_SYSLOG symbol, and indicates whether a C program should include . i_sysmman (i_sysmman.U): This variable conditionally defines the I_SYS_MMAN symbol, and indicates whether a C program should include . i_sysmode (i_sysmode.U): This variable conditionally defines the I_SYSMODE symbol, and indicates whether a C program should include . i_sysmount (i_sysmount.U): This variable conditionally defines the I_SYSMOUNT symbol, and indicates whether a C program should include . i_sysndir (i_sysndir.U): This variable conditionally defines the I_SYS_NDIR symbol, and indicates whether a C program should include . i_sysparam (i_sysparam.U): This variable conditionally defines the I_SYS_PARAM symbol, and indicates whether a C program should include . i_syspoll (i_syspoll.U): This variable conditionally defines the I_SYS_POLL symbol, which indicates to the C program that it should include . i_sysresrc (i_sysresrc.U): This variable conditionally defines the I_SYS_RESOURCE symbol, and indicates whether a C program should include . i_syssecrt (i_syssecrt.U): This variable conditionally defines the I_SYS_SECURITY symbol, and indicates whether a C program should include . i_sysselct (i_sysselct.U): This variable conditionally defines I_SYS_SELECT, which indicates to the C program that it should include in order to get the definition of struct timeval. i_syssockio (i_sysioctl.U): This variable conditionally defines I_SYS_SOCKIO to indicate to the C program that socket ioctl codes may be found in instead of . i_sysstat (i_sysstat.U): This variable conditionally defines the I_SYS_STAT symbol, and indicates whether a C program should include . i_sysstatfs (i_sysstatfs.U): This variable conditionally defines the I_SYSSTATFS symbol, and indicates whether a C program should include . i_sysstatvfs (i_sysstatvfs.U): This variable conditionally defines the I_SYSSTATVFS symbol, and indicates whether a C program should include . i_systime (i_time.U): This variable conditionally defines I_SYS_TIME, which indicates to the C program that it should include . i_systimek (i_time.U): This variable conditionally defines I_SYS_TIME_KERNEL, which indicates to the C program that it should include with KERNEL defined. i_systimes (i_systimes.U): This variable conditionally defines the I_SYS_TIMES symbol, and indicates whether a C program should include . i_systypes (i_systypes.U): This variable conditionally defines the I_SYS_TYPES symbol, and indicates whether a C program should include . i_sysuio (i_sysuio.U): This variable conditionally defines the I_SYSUIO symbol, and indicates whether a C program should include . i_sysun (i_sysun.U): This variable conditionally defines I_SYS_UN, which indicates to the C program that it should include to get UNIX domain socket definitions. i_sysutsname (i_sysutsname.U): This variable conditionally defines the I_SYSUTSNAME symbol, and indicates whether a C program should include . i_sysvfs (i_sysvfs.U): This variable conditionally defines the I_SYSVFS symbol, and indicates whether a C program should include . i_syswait (i_syswait.U): This variable conditionally defines I_SYS_WAIT, which indicates to the C program that it should include . i_termio (i_termio.U): This variable conditionally defines the I_TERMIO symbol, which indicates to the C program that it should include rather than . i_termios (i_termio.U): This variable conditionally defines the I_TERMIOS symbol, which indicates to the C program that the POSIX file is to be included. i_time (i_time.U): This variable conditionally defines I_TIME, which indicates to the C program that it should include . i_unistd (i_unistd.U): This variable conditionally defines the I_UNISTD symbol, and indicates whether a C program should include . i_ustat (i_ustat.U): This variable conditionally defines the I_USTAT symbol, and indicates whether a C program should include . i_utime (i_utime.U): This variable conditionally defines the I_UTIME symbol, and indicates whether a C program should include . i_values (i_values.U): This variable conditionally defines the I_VALUES symbol, and indicates whether a C program may include to get symbols like MAXLONG and friends. i_varargs (i_varhdr.U): This variable conditionally defines I_VARARGS, which indicates to the C program that it should include . i_varhdr (i_varhdr.U): Contains the name of the header to be included to get va_dcl definition. Typically one of varargs.h or stdarg.h. i_vfork (i_vfork.U): This variable conditionally defines the I_VFORK symbol, and indicates whether a C program should include vfork.h. ignore_versioned_solibs (libs.U): This variable should be non-empty if non-versioned shared libraries (libfoo.so.x.y) are to be ignored (because they cannot be linked against). inc_version_list (inc_version_list.U): This variable specifies the list of subdirectories in over which perl.c:incpush() and lib/lib.pm will automatically search when adding directories to @INC. The elements in the list are separated by spaces. This is only useful if you have a perl library directory tree structured like the default one. See INSTALL for how this works. The versioned site_perl directory was introduced in 5.005, so that is the lowest possible value. This list includes architecture-dependent directories back to version $api_versionstring (e.g. 5.5.640) and architecture-independent directories all the way back to 5.005. inc_version_list_init (inc_version_list.U): This variable holds the same list as inc_version_list, but each item is enclosed in double quotes and separated by commas, suitable for use in the PERL_INC_VERSION_LIST initialization. incpath (usrinc.U): This variable must preceed the normal include path to get hte right one, as in "$incpath/usr/include" or "$incpath/usr/lib". Value can be "" or "/bsd43" on mips. inews (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. initialinstalllocation (bin.U): When userelocatableinc is true, this variable holds the location that make install should copy the perl binary to, with all the run-time relocatable paths calculated from this at install time. When used, it is initialised to the original value of binexp, and then binexp is set to '.../', as the other binaries are found relative to the perl binary. installarchlib (archlib.U): This variable is really the same as archlibexp but may differ on those systems using AFS. For extra portability, only this variable should be used in makefiles. installbin (bin.U): This variable is the same as binexp unless AFS is running in which case the user is explicitely prompted for it. This variable should always be used in your makefiles for maximum portability. installhtml1dir (html1dir.U): This variable is really the same as html1direxp, unless you are using a different installprefix. For extra portability, you should only use this variable within your makefiles. installhtml3dir (html3dir.U): This variable is really the same as html3direxp, unless you are using a different installprefix. For extra portability, you should only use this variable within your makefiles. installman1dir (man1dir.U): This variable is really the same as man1direxp, unless you are using AFS in which case it points to the read/write location whereas man1direxp only points to the read-only access location. For extra portability, you should only use this variable within your makefiles. installman3dir (man3dir.U): This variable is really the same as man3direxp, unless you are using AFS in which case it points to the read/write location whereas man3direxp only points to the read-only access location. For extra portability, you should only use this variable within your makefiles. installprefix (installprefix.U): This variable holds the name of the directory below which "make install" will install the package. For most users, this is the same as prefix. However, it is useful for installing the software into a different (usually temporary) location after which it can be bundled up and moved somehow to the final location specified by prefix. installprefixexp (installprefix.U): This variable holds the full absolute path of installprefix with all ~-expansion done. installprivlib (privlib.U): This variable is really the same as privlibexp but may differ on those systems using AFS. For extra portability, only this variable should be used in makefiles. installscript (scriptdir.U): This variable is usually the same as scriptdirexp, unless you are on a system running AFS, in which case they may differ slightly. You should always use this variable within your makefiles for portability. installsitearch (sitearch.U): This variable is really the same as sitearchexp but may differ on those systems using AFS. For extra portability, only this variable should be used in makefiles. installsitebin (sitebin.U): This variable is usually the same as sitebinexp, unless you are on a system running AFS, in which case they may differ slightly. You should always use this variable within your makefiles for portability. installsitehtml1dir (sitehtml1dir.U): This variable is really the same as sitehtml1direxp, unless you are using AFS in which case it points to the read/write location whereas html1direxp only points to the read-only access location. For extra portability, you should only use this variable within your makefiles. installsitehtml3dir (sitehtml3dir.U): This variable is really the same as sitehtml3direxp, unless you are using AFS in which case it points to the read/write location whereas html3direxp only points to the read-only access location. For extra portability, you should only use this variable within your makefiles. installsitelib (sitelib.U): This variable is really the same as sitelibexp but may differ on those systems using AFS. For extra portability, only this variable should be used in makefiles. installsiteman1dir (siteman1dir.U): This variable is really the same as siteman1direxp, unless you are using AFS in which case it points to the read/write location whereas man1direxp only points to the read-only access location. For extra portability, you should only use this variable within your makefiles. installsiteman3dir (siteman3dir.U): This variable is really the same as siteman3direxp, unless you are using AFS in which case it points to the read/write location whereas man3direxp only points to the read-only access location. For extra portability, you should only use this variable within your makefiles. installsitescript (sitescript.U): This variable is usually the same as sitescriptexp, unless you are on a system running AFS, in which case they may differ slightly. You should always use this variable within your makefiles for portability. installstyle (installstyle.U): This variable describes the "style" of the perl installation. This is intended to be useful for tools that need to manipulate entire perl distributions. Perl itself doesn't use this to find its libraries -- the library directories are stored directly in Config.pm. Currently, there are only two styles: "lib" and "lib/perl5". The default library locations (e.g. privlib, sitelib) are either $prefix/lib or $prefix/lib/perl5. The former is useful if $prefix is a directory dedicated to perl (e.g. /opt/perl), while the latter is useful if $prefix is shared by many packages, e.g. if $prefix=/usr/local. Unfortunately, while this "style" variable is used to set defaults for all three directory hierarchies (core, vendor, and site), there is no guarantee that the same style is actually appropriate for all those directories. For example, $prefix might be /opt/perl, but $siteprefix might be /usr/local. (Perhaps, in retrospect, the "lib" style should never have been supported, but it did seem like a nice idea at the time.) The situation is even less clear for tools such as MakeMaker that can be used to install additional modules into non-standard places. For example, if a user intends to install a module into a private directory (perhaps by setting PREFIX on the Makefile.PL command line), then there is no reason to assume that the Configure-time $installstyle setting will be relevant for that PREFIX. This may later be extended to include other information, so be careful with pattern-matching on the results. For compatibility with perl5.005 and earlier, the default setting is based on whether or not $prefix contains the string "perl". installusrbinperl (instubperl.U): This variable tells whether Perl should be installed also as /usr/bin/perl in addition to $installbin/perl installvendorarch (vendorarch.U): This variable is really the same as vendorarchexp but may differ on those systems using AFS. For extra portability, only this variable should be used in makefiles. installvendorbin (vendorbin.U): This variable is really the same as vendorbinexp but may differ on those systems using AFS. For extra portability, only this variable should be used in makefiles. installvendorhtml1dir (vendorhtml1dir.U): This variable is really the same as vendorhtml1direxp but may differ on those systems using AFS. For extra portability, only this variable should be used in makefiles. installvendorhtml3dir (vendorhtml3dir.U): This variable is really the same as vendorhtml3direxp but may differ on those systems using AFS. For extra portability, only this variable should be used in makefiles. installvendorlib (vendorlib.U): This variable is really the same as vendorlibexp but may differ on those systems using AFS. For extra portability, only this variable should be used in makefiles. installvendorman1dir (vendorman1dir.U): This variable is really the same as vendorman1direxp but may differ on those systems using AFS. For extra portability, only this variable should be used in makefiles. installvendorman3dir (vendorman3dir.U): This variable is really the same as vendorman3direxp but may differ on those systems using AFS. For extra portability, only this variable should be used in makefiles. installvendorscript (vendorscript.U): This variable is really the same as vendorscriptexp but may differ on those systems using AFS. For extra portability, only this variable should be used in makefiles. intsize (intsize.U): This variable contains the value of the INTSIZE symbol, which indicates to the C program how many bytes there are in an int. issymlink (issymlink.U): This variable holds the test command to test for a symbolic link (if they are supported). Typical values include 'test -h' and 'test -L'. ivdformat (perlxvf.U): This variable contains the format string used for printing a Perl IV as a signed decimal integer. ivsize (perlxv.U): This variable is the size of an IV in bytes. ivtype (perlxv.U): This variable contains the C type used for Perl's IV. known_extensions (Extensions.U): This variable holds a list of all XS extensions included in the package. ksh (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. ld (dlsrc.U): This variable indicates the program to be used to link libraries for dynamic loading. On some systems, it is 'ld'. On ELF systems, it should be $cc. Mostly, we'll try to respect the hint file setting. lddlflags (dlsrc.U): This variable contains any special flags that might need to be passed to $ld to create a shared library suitable for dynamic loading. It is up to the makefile to use it. For hpux, it should be '-b'. For sunos 4.1, it is empty. ldflags (ccflags.U): This variable contains any additional C loader flags desired by the user. It is up to the Makefile to use this. ldflags_uselargefiles (uselfs.U): This variable contains the loader flags needed by large file builds and added to ldflags by hints files. ldlibpthname (libperl.U): This variable holds the name of the shared library search path, often LD_LIBRARY_PATH. To get an empty string, the hints file must set this to 'none'. less (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the less program. After Configure runs, the value is reset to a plain "less" and is not useful. lib_ext (Unix.U): This is an old synonym for _a. libc (libc.U): This variable contains the location of the C library. libperl (libperl.U): The perl executable is obtained by linking perlmain.c with libperl, any static extensions (usually just DynaLoader), and any other libraries needed on this system. libperl is usually libperl.a, but can also be libperl.so.xxx if the user wishes to build a perl executable with a shared library. libpth (libpth.U): This variable holds the general path (space-separated) used to find libraries. It is intended to be used by other units. libs (libs.U): This variable holds the additional libraries we want to use. It is up to the Makefile to deal with it. The list can be empty. libsdirs (libs.U): This variable holds the directory names aka dirnames of the libraries we found and accepted, duplicates are removed. libsfiles (libs.U): This variable holds the filenames aka basenames of the libraries we found and accepted. libsfound (libs.U): This variable holds the full pathnames of the libraries we found and accepted. libspath (libs.U): This variable holds the directory names probed for libraries. libswanted (Myinit.U): This variable holds a list of all the libraries we want to search. The order is chosen to pick up the c library ahead of ucb or bsd libraries for SVR4. libswanted_uselargefiles (uselfs.U): This variable contains the libraries needed by large file builds and added to ldflags by hints files. It is a space separated list of the library names without the "lib" prefix or any suffix, just like libswanted.. line (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. lint (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. lkflags (ccflags.U): This variable contains any additional C partial linker flags desired by the user. It is up to the Makefile to use this. ln (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the ln program. After Configure runs, the value is reset to a plain "ln" and is not useful. lns (lns.U): This variable holds the name of the command to make symbolic links (if they are supported). It can be used in the Makefile. It is either 'ln -s' or 'ln' localtime_r_proto (d_localtime_r.U): This variable encodes the prototype of localtime_r. It is zero if d_localtime_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_localtime_r is defined. locincpth (ccflags.U): This variable contains a list of additional directories to be searched by the compiler. The appropriate '-I' directives will be added to ccflags. This is intended to simplify setting local directories from the Configure command line. It's not much, but it parallels the loclibpth stuff in libpth.U. loclibpth (libpth.U): This variable holds the paths (space-separated) used to find local libraries. It is prepended to libpth, and is intended to be easily set from the command line. longdblsize (d_longdbl.U): This variable contains the value of the LONG_DOUBLESIZE symbol, which indicates to the C program how many bytes there are in a long double, if this system supports long doubles. longlongsize (d_longlong.U): This variable contains the value of the LONGLONGSIZE symbol, which indicates to the C program how many bytes there are in a long long, if this system supports long long. longsize (intsize.U): This variable contains the value of the LONGSIZE symbol, which indicates to the C program how many bytes there are in a long. lp (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. lpr (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. ls (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the ls program. After Configure runs, the value is reset to a plain "ls" and is not useful. lseeksize (lseektype.U): This variable defines lseektype to be something like off_t, long, or whatever type is used to declare lseek offset's type in the kernel (which also appears to be lseek's return type). lseektype (lseektype.U): This variable defines lseektype to be something like off_t, long, or whatever type is used to declare lseek offset's type in the kernel (which also appears to be lseek's return type). mad (mad.U): This variable indicates that the Misc Attribute Definition code is to be compiled. madlyh (mad.U): If the Misc Attribute Decoration is to be compiled, this variable is set to the name of the extra header files to be used, else it is '' madlyobj (mad.U): If the Misc Attribute Decoration is to be compiled, this variable is set to the name of the extra object files to be used, else it is '' madlysrc (mad.U): If the Misc Attribute Decoration is to be compiled, this variable is set to the name of the extra C source files to be used, else it is '' mail (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. mailx (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. make (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the make program. After Configure runs, the value is reset to a plain "make" and is not useful. make_set_make (make.U): Some versions of 'make' set the variable MAKE. Others do not. This variable contains the string to be included in Makefile.SH so that MAKE is set if needed, and not if not needed. Possible values are: make_set_make='#' # If your make program handles this for you, make_set_make="MAKE=$make" # if it doesn't. This uses a comment character so that we can distinguish a 'set' value (from a previous config.sh or Configure '-D' option) from an uncomputed value. mallocobj (mallocsrc.U): This variable contains the name of the malloc.o that this package generates, if that malloc.o is preferred over the system malloc. Otherwise the value is null. This variable is intended for generating Makefiles. See mallocsrc. mallocsrc (mallocsrc.U): This variable contains the name of the malloc.c that comes with the package, if that malloc.c is preferred over the system malloc. Otherwise the value is null. This variable is intended for generating Makefiles. malloctype (mallocsrc.U): This variable contains the kind of ptr returned by malloc and realloc. man1dir (man1dir.U): This variable contains the name of the directory in which manual source pages are to be put. It is the responsibility of the Makefile.SH to get the value of this into the proper command. You must be prepared to do the ~name expansion yourself. man1direxp (man1dir.U): This variable is the same as the man1dir variable, but is filename expanded at configuration time, for convenient use in makefiles. man1ext (man1dir.U): This variable contains the extension that the manual page should have: one of 'n', 'l', or '1'. The Makefile must supply the '.'. See man1dir. man3dir (man3dir.U): This variable contains the name of the directory in which manual source pages are to be put. It is the responsibility of the Makefile.SH to get the value of this into the proper command. You must be prepared to do the ~name expansion yourself. man3direxp (man3dir.U): This variable is the same as the man3dir variable, but is filename expanded at configuration time, for convenient use in makefiles. man3ext (man3dir.U): This variable contains the extension that the manual page should have: one of 'n', 'l', or '3'. The Makefile must supply the '.'. See man3dir. mips_type (usrinc.U): This variable holds the environment type for the mips system. Possible values are "BSD 4.3" and "System V". mistrustnm (Csym.U): This variable can be used to establish a fallthrough for the cases where nm fails to find a symbol. If usenm is false or usenm is true and mistrustnm is false, this variable has no effect. If usenm is true and mistrustnm is "compile", a test program will be compiled to try to find any symbol that can't be located via nm lookup. If mistrustnm is "run", the test program will be run as well as being compiled. mkdir (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the mkdir program. After Configure runs, the value is reset to a plain "mkdir" and is not useful. mmaptype (d_mmap.U): This symbol contains the type of pointer returned by mmap() (and simultaneously the type of the first argument). It can be 'void *' or 'caddr_t'. modetype (modetype.U): This variable defines modetype to be something like mode_t, int, unsigned short, or whatever type is used to declare file modes for system calls. more (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the more program. After Configure runs, the value is reset to a plain "more" and is not useful. multiarch (multiarch.U): This variable conditionally defines the MULTIARCH symbol which signifies the presence of multiplatform files. This is normally set by hints files. mv (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. myarchname (archname.U): This variable holds the architecture name computed by Configure in a previous run. It is not intended to be perused by any user and should never be set in a hint file. mydomain (myhostname.U): This variable contains the eventual value of the MYDOMAIN symbol, which is the domain of the host the program is going to run on. The domain must be appended to myhostname to form a complete host name. The dot comes with mydomain, and need not be supplied by the program. myhostname (myhostname.U): This variable contains the eventual value of the MYHOSTNAME symbol, which is the name of the host the program is going to run on. The domain is not kept with hostname, but must be gotten from mydomain. The dot comes with mydomain, and need not be supplied by the program. myuname (Oldconfig.U): The output of 'uname -a' if available, otherwise the hostname. On Xenix, pseudo variables assignments in the output are stripped, thank you. The whole thing is then lower-cased. n (n.U): This variable contains the '-n' flag if that is what causes the echo command to suppress newline. Otherwise it is null. Correct usage is $echo $n "prompt for a question: $c". need_va_copy (need_va_copy.U): This symbol, if defined, indicates that the system stores the variable argument list datatype, va_list, in a format that cannot be copied by simple assignment, so that some other means must be used when copying is required. As such systems vary in their provision (or non-provision) of copying mechanisms, handy.h defines a platform- independent macro, Perl_va_copy(src, dst), to do the job. netdb_hlen_type (netdbtype.U): This variable holds the type used for the 2nd argument to gethostbyaddr(). Usually, this is int or size_t or unsigned. This is only useful if you have gethostbyaddr(), naturally. netdb_host_type (netdbtype.U): This variable holds the type used for the 1st argument to gethostbyaddr(). Usually, this is char * or void *, possibly with or without a const prefix. This is only useful if you have gethostbyaddr(), naturally. netdb_name_type (netdbtype.U): This variable holds the type used for the argument to gethostbyname(). Usually, this is char * or const char *. This is only useful if you have gethostbyname(), naturally. netdb_net_type (netdbtype.U): This variable holds the type used for the 1st argument to getnetbyaddr(). Usually, this is int or long. This is only useful if you have getnetbyaddr(), naturally. nm (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the nm program. After Configure runs, the value is reset to a plain "nm" and is not useful. nm_opt (usenm.U): This variable holds the options that may be necessary for nm. nm_so_opt (usenm.U): This variable holds the options that may be necessary for nm to work on a shared library but that can not be used on an archive library. Currently, this is only used by Linux, where nm --dynamic is *required* to get symbols from an ELF library which has been stripped, but nm --dynamic is *fatal* on an archive library. Maybe Linux should just always set usenm=false. nonxs_ext (Extensions.U): This variable holds a list of all non-xs extensions included in the package. All of them will be built. nroff (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the nroff program. After Configure runs, the value is reset to a plain "nroff" and is not useful. nv_overflows_integers_at (perlxv.U): This variable gives the largest integer value that NVs can hold as a constant floating point expression. If it could not be determined, it holds the value 0. nv_preserves_uv_bits (perlxv.U): This variable indicates how many of bits type uvtype a variable nvtype can preserve. nveformat (perlxvf.U): This variable contains the format string used for printing a Perl NV using %e-ish floating point format. nvEUformat (perlxvf.U): This variable contains the format string used for printing a Perl NV using %E-ish floating point format. nvfformat (perlxvf.U): This variable confains the format string used for printing a Perl NV using %f-ish floating point format. nvFUformat (perlxvf.U): This variable confains the format string used for printing a Perl NV using %F-ish floating point format. nvgformat (perlxvf.U): This variable contains the format string used for printing a Perl NV using %g-ish floating point format. nvGUformat (perlxvf.U): This variable contains the format string used for printing a Perl NV using %G-ish floating point format. nvsize (perlxv.U): This variable is the size of an NV in bytes. nvtype (perlxv.U): This variable contains the C type used for Perl's NV. o_nonblock (nblock_io.U): This variable bears the symbol value to be used during open() or fcntl() to turn on non-blocking I/O for a file descriptor. If you wish to switch between blocking and non-blocking, you may try ioctl(FIOSNBIO) instead, but that is only supported by some devices. obj_ext (Unix.U): This is an old synonym for _o. old_pthread_create_joinable (d_pthrattrj.U): This variable defines the constant to use for creating joinable (aka undetached) pthreads. Unused if pthread.h defines PTHREAD_CREATE_JOINABLE. If used, possible values are PTHREAD_CREATE_UNDETACHED and __UNDETACHED. optimize (ccflags.U): This variable contains any optimizer/debugger flag that should be used. It is up to the Makefile to use it. orderlib (orderlib.U): This variable is "true" if the components of libraries must be ordered (with `lorder $* | tsort`) before placing them in an archive. Set to "false" if ranlib or ar can generate random libraries. osname (Oldconfig.U): This variable contains the operating system name (e.g. sunos, solaris, hpux, etc.). It can be useful later on for setting defaults. Any spaces are replaced with underscores. It is set to a null string if we can't figure it out. osvers (Oldconfig.U): This variable contains the operating system version (e.g. 4.1.3, 5.2, etc.). It is primarily used for helping select an appropriate hints file, but might be useful elsewhere for setting defaults. It is set to '' if we can't figure it out. We try to be flexible about how much of the version number to keep, e.g. if 4.1.1, 4.1.2, and 4.1.3 are essentially the same for this package, hints files might just be os_4.0 or os_4.1, etc., not keeping separate files for each little release. otherlibdirs (otherlibdirs.U): This variable contains a colon-separated set of paths for the perl binary to search for additional library files or modules. These directories will be tacked to the end of @INC. Perl will automatically search below each path for version- and architecture-specific directories. See inc_version_list for more details. A value of ' ' means 'none' and is used to preserve this value for the next run through Configure. package (package.U): This variable contains the name of the package being constructed. It is primarily intended for the use of later Configure units. pager (pager.U): This variable contains the name of the preferred pager on the system. Usual values are (the full pathnames of) more, less, pg, or cat. passcat (nis.U): This variable contains a command that produces the text of the /etc/passwd file. This is normally "cat /etc/passwd", but can be "ypcat passwd" when NIS is used. On some systems, such as os390, there may be no equivalent command, in which case this variable is unset. patchlevel (patchlevel.U): The patchlevel level of this package. The value of patchlevel comes from the patchlevel.h file. In a version number such as 5.6.1, this is the "6". In patchlevel.h, this is referred to as "PERL_VERSION". path_sep (Unix.U): This is an old synonym for p_ in Head.U, the character used to separate elements in the command shell search PATH. perl (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. perl5 (perl5.U): This variable contains the full path (if any) to a previously installed perl5.005 or later suitable for running the script to determine inc_version_list. PERL_API_REVISION (patchlevel.h): This number describes the earliest compatible PERL_REVISION of Perl ("compatibility" here being defined as sufficient binary/API compatibility to run XS code built with the older version). Normally this does not change across maintenance releases. Please read the comment in patchlevel.h. PERL_API_SUBVERSION (patchlevel.h): This number describes the earliest compatible PERL_SUBVERSION of Perl ("compatibility" here being defined as sufficient binary/API compatibility to run XS code built with the older version). Normally this does not change across maintenance releases. Please read the comment in patchlevel.h. PERL_API_VERSION (patchlevel.h): This number describes the earliest compatible PERL_VERSION of Perl ("compatibility" here being defined as sufficient binary/API compatibility to run XS code built with the older version). Normally this does not change across maintenance releases. Please read the comment in patchlevel.h. PERL_CONFIG_SH (Oldsyms.U): This is set to 'true' in config.sh so that a shell script sourcing config.sh can tell if it has been sourced already. PERL_PATCHLEVEL (Oldsyms.U): This symbol reflects the patchlevel, if available. Will usually come from the .patch file, which is available when the perl source tree was fetched with rsync. perl_patchlevel (patchlevel.U): This is the Perl patch level, a numeric change identifier, as defined by whichever source code maintenance system is used to maintain the patches; currently Perforce. It does not correlate with the Perl version numbers or the maintenance versus development dichotomy except by also being increasing. PERL_REVISION (Oldsyms.U): In a Perl version number such as 5.6.2, this is the 5. This value is manually set in patchlevel.h PERL_SUBVERSION (Oldsyms.U): In a Perl version number such as 5.6.2, this is the 2. Values greater than 50 represent potentially unstable development subversions. This value is manually set in patchlevel.h PERL_VERSION (Oldsyms.U): In a Perl version number such as 5.6.2, this is the 6. This value is manually set in patchlevel.h perladmin (perladmin.U): Electronic mail address of the perl5 administrator. perllibs (End.U): The list of libraries needed by Perl only (any libraries needed by extensions only will by dropped, if using dynamic loading). perlpath (perlpath.U): This variable contains the eventual value of the PERLPATH symbol, which contains the name of the perl interpreter to be used in shell scripts and in the "eval 'exec'" idiom. This variable is not necessarily the pathname of the file containing the perl interpreter; you must append the executable extension (_exe) if it is not already present. Note that Perl code that runs during the Perl build process cannot reference this variable, as Perl may not have been installed, or even if installed, may be a different version of Perl. pg (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the pg program. After Configure runs, the value is reset to a plain "pg" and is not useful. phostname (myhostname.U): This variable contains the eventual value of the PHOSTNAME symbol, which is a command that can be fed to popen() to get the host name. The program should probably not presume that the domain is or isn't there already. pidtype (pidtype.U): This variable defines PIDTYPE to be something like pid_t, int, ushort, or whatever type is used to declare process ids in the kernel. plibpth (libpth.U): Holds the private path used by Configure to find out the libraries. Its value is prepend to libpth. This variable takes care of special machines, like the mips. Usually, it should be empty. pmake (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. pr (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. prefix (prefix.U): This variable holds the name of the directory below which the user will install the package. Usually, this is /usr/local, and executables go in /usr/local/bin, library stuff in /usr/local/lib, man pages in /usr/local/man, etc. It is only used to set defaults for things in bin.U, mansrc.U, privlib.U, or scriptdir.U. prefixexp (prefix.U): This variable holds the full absolute path of the directory below which the user will install the package. Derived from prefix. privlib (privlib.U): This variable contains the eventual value of the PRIVLIB symbol, which is the name of the private library for this package. It may have a ~ on the front. It is up to the makefile to eventually create this directory while performing installation (with ~ substitution). privlibexp (privlib.U): This variable is the ~name expanded version of privlib, so that you may use it directly in Makefiles or shell scripts. procselfexe (d_procselfexe.U): If d_procselfexe is defined, $procselfexe is the filename of the symbolic link pointing to the absolute pathname of the executing program. prototype (prototype.U): This variable holds the eventual value of CAN_PROTOTYPE, which indicates the C compiler can handle funciton prototypes. ptrsize (ptrsize.U): This variable contains the value of the PTRSIZE symbol, which indicates to the C program how many bytes there are in a pointer. quadkind (quadtype.U): This variable, if defined, encodes the type of a quad: 1 = int, 2 = long, 3 = long long, 4 = int64_t. quadtype (quadtype.U): This variable defines Quad_t to be something like long, int, long long, int64_t, or whatever type is used for 64-bit integers. randbits (randfunc.U): Indicates how many bits are produced by the function used to generate normalized random numbers. randfunc (randfunc.U): Indicates the name of the random number function to use. Values include drand48, random, and rand. In C programs, the 'Drand01' macro is defined to generate uniformly distributed random numbers over the range [0., 1.[ (see drand01 and nrand). random_r_proto (d_random_r.U): This variable encodes the prototype of random_r. It is zero if d_random_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_random_r is defined. randseedtype (randfunc.U): Indicates the type of the argument of the seedfunc. ranlib (orderlib.U): This variable is set to the pathname of the ranlib program, if it is needed to generate random libraries. Set to ":" if ar can generate random libraries or if random libraries are not supported rd_nodata (nblock_io.U): This variable holds the return code from read() when no data is present. It should be -1, but some systems return 0 when O_NDELAY is used, which is a shame because you cannot make the difference between no data and an EOF.. Sigh! readdir64_r_proto (d_readdir64_r.U): This variable encodes the prototype of readdir64_r. It is zero if d_readdir64_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_readdir64_r is defined. readdir_r_proto (d_readdir_r.U): This variable encodes the prototype of readdir_r. It is zero if d_readdir_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_readdir_r is defined. revision (patchlevel.U): The value of revision comes from the patchlevel.h file. In a version number such as 5.6.1, this is the "5". In patchlevel.h, this is referred to as "PERL_REVISION". rm (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the rm program. After Configure runs, the value is reset to a plain "rm" and is not useful. rm_try (Unix.U): This is a cleanup variable for try test programs. Internal Configure use only. rmail (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. run (Cross.U): This variable contains the command used by Configure to copy and execute a cross-compiled executable in the target host. Useful and available only during Perl build. Empty string '' if not cross-compiling. runnm (usenm.U): This variable contains 'true' or 'false' depending whether the nm extraction should be performed or not, according to the value of usenm and the flags on the Configure command line. sched_yield (d_pthread_y.U): This variable defines the way to yield the execution of the current thread. scriptdir (scriptdir.U): This variable holds the name of the directory in which the user wants to put publicly scripts for the package in question. It is either the same directory as for binaries, or a special one that can be mounted across different architectures, like /usr/share. Programs must be prepared to deal with ~name expansion. scriptdirexp (scriptdir.U): This variable is the same as scriptdir, but is filename expanded at configuration time, for programs not wanting to bother with it. sed (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the sed program. After Configure runs, the value is reset to a plain "sed" and is not useful. seedfunc (randfunc.U): Indicates the random number generating seed function. Values include srand48, srandom, and srand. selectminbits (selectminbits.U): This variable holds the minimum number of bits operated by select. That is, if you do select(n, ...), how many bits at least will be cleared in the masks if some activity is detected. Usually this is either n or 32*ceil(n/32), especially many little-endians do the latter. This is only useful if you have select(), naturally. selecttype (selecttype.U): This variable holds the type used for the 2nd, 3rd, and 4th arguments to select. Usually, this is 'fd_set *', if HAS_FD_SET is defined, and 'int *' otherwise. This is only useful if you have select(), naturally. sendmail (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. setgrent_r_proto (d_setgrent_r.U): This variable encodes the prototype of setgrent_r. It is zero if d_setgrent_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_setgrent_r is defined. sethostent_r_proto (d_sethostent_r.U): This variable encodes the prototype of sethostent_r. It is zero if d_sethostent_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_sethostent_r is defined. setlocale_r_proto (d_setlocale_r.U): This variable encodes the prototype of setlocale_r. It is zero if d_setlocale_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_setlocale_r is defined. setnetent_r_proto (d_setnetent_r.U): This variable encodes the prototype of setnetent_r. It is zero if d_setnetent_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_setnetent_r is defined. setprotoent_r_proto (d_setprotoent_r.U): This variable encodes the prototype of setprotoent_r. It is zero if d_setprotoent_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_setprotoent_r is defined. setpwent_r_proto (d_setpwent_r.U): This variable encodes the prototype of setpwent_r. It is zero if d_setpwent_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_setpwent_r is defined. setservent_r_proto (d_setservent_r.U): This variable encodes the prototype of setservent_r. It is zero if d_setservent_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_setservent_r is defined. sGMTIME_max (time_size.U): This variable defines the maximum value of the time_t offset that the system function gmtime () accepts sGMTIME_min (time_size.U): This variable defines the minimum value of the time_t offset that the system function gmtime () accepts sh (sh.U): This variable contains the full pathname of the shell used on this system to execute Bourne shell scripts. Usually, this will be /bin/sh, though it's possible that some systems will have /bin/ksh, /bin/pdksh, /bin/ash, /bin/bash, or even something such as D:/bin/sh.exe. This unit comes before Options.U, so you can't set sh with a '-D' option, though you can override this (and startsh) with '-O -Dsh=/bin/whatever -Dstartsh=whatever' shar (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. sharpbang (spitshell.U): This variable contains the string #! if this system supports that construct. shmattype (d_shmat.U): This symbol contains the type of pointer returned by shmat(). It can be 'void *' or 'char *'. shortsize (intsize.U): This variable contains the value of the SHORTSIZE symbol which indicates to the C program how many bytes there are in a short. shrpenv (libperl.U): If the user builds a shared libperl.so, then we need to tell the 'perl' executable where it will be able to find the installed libperl.so. One way to do this on some systems is to set the environment variable LD_RUN_PATH to the directory that will be the final location of the shared libperl.so. The makefile can use this with something like $shrpenv $(CC) -o perl perlmain.o $libperl $libs Typical values are shrpenv="env LD_RUN_PATH=$archlibexp/CORE" or shrpenv='' See the main perl Makefile.SH for actual working usage. Alternatively, we might be able to use a command line option such as -R $archlibexp/CORE (Solaris) or -Wl,-rpath $archlibexp/CORE (Linux). shsharp (spitshell.U): This variable tells further Configure units whether your sh can handle # comments. sig_count (sig_name.U): This variable holds a number larger than the largest valid signal number. This is usually the same as the NSIG macro. sig_name (sig_name.U): This variable holds the signal names, space separated. The leading SIG in signal name is removed. A ZERO is prepended to the list. This is currently not used, sig_name_init is used instead. sig_name_init (sig_name.U): This variable holds the signal names, enclosed in double quotes and separated by commas, suitable for use in the SIG_NAME definition below. A "ZERO" is prepended to the list, and the list is terminated with a plain 0. The leading SIG in signal names is removed. See sig_num. sig_num (sig_name.U): This variable holds the signal numbers, space separated. A ZERO is prepended to the list (corresponding to the fake SIGZERO). Those numbers correspond to the value of the signal listed in the same place within the sig_name list. This is currently not used, sig_num_init is used instead. sig_num_init (sig_name.U): This variable holds the signal numbers, enclosed in double quotes and separated by commas, suitable for use in the SIG_NUM definition below. A "ZERO" is prepended to the list, and the list is terminated with a plain 0. sig_size (sig_name.U): This variable contains the number of elements of the sig_name and sig_num arrays. signal_t (d_voidsig.U): This variable holds the type of the signal handler (void or int). sitearch (sitearch.U): This variable contains the eventual value of the SITEARCH symbol, which is the name of the private library for this package. It may have a ~ on the front. It is up to the makefile to eventually create this directory while performing installation (with ~ substitution). The standard distribution will put nothing in this directory. After perl has been installed, users may install their own local architecture-dependent modules in this directory with MakeMaker Makefile.PL or equivalent. See INSTALL for details. sitearchexp (sitearch.U): This variable is the ~name expanded version of sitearch, so that you may use it directly in Makefiles or shell scripts. sitebin (sitebin.U): This variable holds the name of the directory in which the user wants to put add-on publicly executable files for the package in question. It is most often a local directory such as /usr/local/bin. Programs using this variable must be prepared to deal with ~name substitution. The standard distribution will put nothing in this directory. After perl has been installed, users may install their own local executables in this directory with MakeMaker Makefile.PL or equivalent. See INSTALL for details. sitebinexp (sitebin.U): This is the same as the sitebin variable, but is filename expanded at configuration time, for use in your makefiles. sitehtml1dir (sitehtml1dir.U): This variable contains the name of the directory in which site-specific html source pages are to be put. It is the responsibility of the Makefile.SH to get the value of this into the proper command. You must be prepared to do the ~name expansion yourself. The standard distribution will put nothing in this directory. After perl has been installed, users may install their own local html pages in this directory with MakeMaker Makefile.PL or equivalent. See INSTALL for details. sitehtml1direxp (sitehtml1dir.U): This variable is the same as the sitehtml1dir variable, but is filename expanded at configuration time, for convenient use in makefiles. sitehtml3dir (sitehtml3dir.U): This variable contains the name of the directory in which site-specific library html source pages are to be put. It is the responsibility of the Makefile.SH to get the value of this into the proper command. You must be prepared to do the ~name expansion yourself. The standard distribution will put nothing in this directory. After perl has been installed, users may install their own local library html pages in this directory with MakeMaker Makefile.PL or equivalent. See INSTALL for details. sitehtml3direxp (sitehtml3dir.U): This variable is the same as the sitehtml3dir variable, but is filename expanded at configuration time, for convenient use in makefiles. sitelib (sitelib.U): This variable contains the eventual value of the SITELIB symbol, which is the name of the private library for this package. It may have a ~ on the front. It is up to the makefile to eventually create this directory while performing installation (with ~ substitution). The standard distribution will put nothing in this directory. After perl has been installed, users may install their own local architecture-independent modules in this directory with MakeMaker Makefile.PL or equivalent. See INSTALL for details. sitelib_stem (sitelib.U): This variable is $sitelibexp with any trailing version-specific component removed. The elements in inc_version_list (inc_version_list.U) can be tacked onto this variable to generate a list of directories to search. sitelibexp (sitelib.U): This variable is the ~name expanded version of sitelib, so that you may use it directly in Makefiles or shell scripts. siteman1dir (siteman1dir.U): This variable contains the name of the directory in which site-specific manual source pages are to be put. It is the responsibility of the Makefile.SH to get the value of this into the proper command. You must be prepared to do the ~name expansion yourself. The standard distribution will put nothing in this directory. After perl has been installed, users may install their own local man1 pages in this directory with MakeMaker Makefile.PL or equivalent. See INSTALL for details. siteman1direxp (siteman1dir.U): This variable is the same as the siteman1dir variable, but is filename expanded at configuration time, for convenient use in makefiles. siteman3dir (siteman3dir.U): This variable contains the name of the directory in which site-specific library man source pages are to be put. It is the responsibility of the Makefile.SH to get the value of this into the proper command. You must be prepared to do the ~name expansion yourself. The standard distribution will put nothing in this directory. After perl has been installed, users may install their own local man3 pages in this directory with MakeMaker Makefile.PL or equivalent. See INSTALL for details. siteman3direxp (siteman3dir.U): This variable is the same as the siteman3dir variable, but is filename expanded at configuration time, for convenient use in makefiles. siteprefix (siteprefix.U): This variable holds the full absolute path of the directory below which the user will install add-on packages. See INSTALL for usage and examples. siteprefixexp (siteprefix.U): This variable holds the full absolute path of the directory below which the user will install add-on packages. Derived from siteprefix. sitescript (sitescript.U): This variable holds the name of the directory in which the user wants to put add-on publicly executable files for the package in question. It is most often a local directory such as /usr/local/bin. Programs using this variable must be prepared to deal with ~name substitution. The standard distribution will put nothing in this directory. After perl has been installed, users may install their own local scripts in this directory with MakeMaker Makefile.PL or equivalent. See INSTALL for details. sitescriptexp (sitescript.U): This is the same as the sitescript variable, but is filename expanded at configuration time, for use in your makefiles. sizesize (sizesize.U): This variable contains the size of a sizetype in bytes. sizetype (sizetype.U): This variable defines sizetype to be something like size_t, unsigned long, or whatever type is used to declare length parameters for string functions. sleep (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. sLOCALTIME_max (time_size.U): This variable defines the maximum value of the time_t offset that the system function localtime () accepts sLOCALTIME_min (time_size.U): This variable defines the minimum value of the time_t offset that the system function localtime () accepts smail (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. so (so.U): This variable holds the extension used to identify shared libraries (also known as shared objects) on the system. Usually set to 'so'. sockethdr (d_socket.U): This variable has any cpp '-I' flags needed for socket support. socketlib (d_socket.U): This variable has the names of any libraries needed for socket support. socksizetype (socksizetype.U): This variable holds the type used for the size argument for various socket calls like accept. Usual values include socklen_t, size_t, and int. sort (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the sort program. After Configure runs, the value is reset to a plain "sort" and is not useful. spackage (package.U): This variable contains the name of the package being constructed, with the first letter uppercased, i.e. suitable for starting sentences. spitshell (spitshell.U): This variable contains the command necessary to spit out a runnable shell on this system. It is either cat or a grep '-v' for # comments. sPRId64 (quadfio.U): This variable, if defined, contains the string used by stdio to format 64-bit decimal numbers (format 'd') for output. sPRIeldbl (longdblfio.U): This variable, if defined, contains the string used by stdio to format long doubles (format 'e') for output. sPRIEUldbl (longdblfio.U): This variable, if defined, contains the string used by stdio to format long doubles (format 'E') for output. The 'U' in the name is to separate this from sPRIeldbl so that even case-blind systems can see the difference. sPRIfldbl (longdblfio.U): This variable, if defined, contains the string used by stdio to format long doubles (format 'f') for output. sPRIFUldbl (longdblfio.U): This variable, if defined, contains the string used by stdio to format long doubles (format 'F') for output. The 'U' in the name is to separate this from sPRIfldbl so that even case-blind systems can see the difference. sPRIgldbl (longdblfio.U): This variable, if defined, contains the string used by stdio to format long doubles (format 'g') for output. sPRIGUldbl (longdblfio.U): This variable, if defined, contains the string used by stdio to format long doubles (format 'G') for output. The 'U' in the name is to separate this from sPRIgldbl so that even case-blind systems can see the difference. sPRIi64 (quadfio.U): This variable, if defined, contains the string used by stdio to format 64-bit decimal numbers (format 'i') for output. sPRIo64 (quadfio.U): This variable, if defined, contains the string used by stdio to format 64-bit octal numbers (format 'o') for output. sPRIu64 (quadfio.U): This variable, if defined, contains the string used by stdio to format 64-bit unsigned decimal numbers (format 'u') for output. sPRIx64 (quadfio.U): This variable, if defined, contains the string used by stdio to format 64-bit hexadecimal numbers (format 'x') for output. sPRIXU64 (quadfio.U): This variable, if defined, contains the string used by stdio to format 64-bit hExADECimAl numbers (format 'X') for output. The 'U' in the name is to separate this from sPRIx64 so that even case-blind systems can see the difference. srand48_r_proto (d_srand48_r.U): This variable encodes the prototype of srand48_r. It is zero if d_srand48_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_srand48_r is defined. srandom_r_proto (d_srandom_r.U): This variable encodes the prototype of srandom_r. It is zero if d_srandom_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_srandom_r is defined. src (src.U): This variable holds the (possibly relative) path of the package source. It is up to the Makefile to use this variable and set VPATH accordingly to find the sources remotely. Use $pkgsrc to have an absolute path. sSCNfldbl (longdblfio.U): This variable, if defined, contains the string used by stdio to format long doubles (format 'f') for input. ssizetype (ssizetype.U): This variable defines ssizetype to be something like ssize_t, long or int. It is used by functions that return a count of bytes or an error condition. It must be a signed type. We will pick a type such that sizeof(SSize_t) == sizeof(Size_t). startperl (startperl.U): This variable contains the string to put on the front of a perl script to make sure (hopefully) that it runs with perl and not some shell. Of course, that leading line must be followed by the classical perl idiom: eval 'exec perl -S $0 ${1+"$@"}' if $running_under_some_shell; to guarantee perl startup should the shell execute the script. Note that this magic incatation is not understood by csh. startsh (startsh.U): This variable contains the string to put on the front of a shell script to make sure (hopefully) that it runs with sh and not some other shell. static_ext (Extensions.U): This variable holds a list of XS extension files we want to link statically into the package. It is used by Makefile. stdchar (stdchar.U): This variable conditionally defines STDCHAR to be the type of char used in stdio.h. It has the values "unsigned char" or "char". stdio_base (d_stdstdio.U): This variable defines how, given a FILE pointer, fp, to access the _base field (or equivalent) of stdio.h's FILE structure. This will be used to define the macro FILE_base(fp). stdio_bufsiz (d_stdstdio.U): This variable defines how, given a FILE pointer, fp, to determine the number of bytes store in the I/O buffer pointer to by the _base field (or equivalent) of stdio.h's FILE structure. This will be used to define the macro FILE_bufsiz(fp). stdio_cnt (d_stdstdio.U): This variable defines how, given a FILE pointer, fp, to access the _cnt field (or equivalent) of stdio.h's FILE structure. This will be used to define the macro FILE_cnt(fp). stdio_filbuf (d_stdstdio.U): This variable defines how, given a FILE pointer, fp, to tell stdio to refill its internal buffers (?). This will be used to define the macro FILE_filbuf(fp). stdio_ptr (d_stdstdio.U): This variable defines how, given a FILE pointer, fp, to access the _ptr field (or equivalent) of stdio.h's FILE structure. This will be used to define the macro FILE_ptr(fp). stdio_stream_array (stdio_streams.U): This variable tells the name of the array holding the stdio streams. Usual values include _iob, __iob, and __sF. strerror_r_proto (d_strerror_r.U): This variable encodes the prototype of strerror_r. It is zero if d_strerror_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_strerror_r is defined. strings (i_string.U): This variable holds the full path of the string header that will be used. Typically /usr/include/string.h or /usr/include/strings.h. submit (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. subversion (patchlevel.U): The subversion level of this package. The value of subversion comes from the patchlevel.h file. In a version number such as 5.6.1, this is the "1". In patchlevel.h, this is referred to as "PERL_SUBVERSION". This is unique to perl. sysman (sysman.U): This variable holds the place where the manual is located on this system. It is not the place where the user wants to put his manual pages. Rather it is the place where Configure may look to find manual for unix commands (section 1 of the manual usually). See mansrc. tail (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. tar (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. targetarch (Cross.U): If cross-compiling, this variable contains the target architecture. If not, this will be empty. tbl (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. tee (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. test (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the test program. After Configure runs, the value is reset to a plain "test" and is not useful. timeincl (i_time.U): This variable holds the full path of the included time header(s). timetype (d_time.U): This variable holds the type returned by time(). It can be long, or time_t on BSD sites (in which case should be included). Anyway, the type Time_t should be used. tmpnam_r_proto (d_tmpnam_r.U): This variable encodes the prototype of tmpnam_r. It is zero if d_tmpnam_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_tmpnam_r is defined. to (Cross.U): This variable contains the command used by Configure to copy to from the target host. Useful and available only during Perl build. The string ':' if not cross-compiling. touch (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the touch program. After Configure runs, the value is reset to a plain "touch" and is not useful. tr (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the tr program. After Configure runs, the value is reset to a plain "tr" and is not useful. trnl (trnl.U): This variable contains the value to be passed to the tr(1) command to transliterate a newline. Typical values are '\012' and '\n'. This is needed for EBCDIC systems where newline is not necessarily '\012'. troff (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. ttyname_r_proto (d_ttyname_r.U): This variable encodes the prototype of ttyname_r. It is zero if d_ttyname_r is undef, and one of the REENTRANT_PROTO_T_ABC macros of reentr.h if d_ttyname_r is defined. u16size (perlxv.U): This variable is the size of an U16 in bytes. u16type (perlxv.U): This variable contains the C type used for Perl's U16. u32size (perlxv.U): This variable is the size of an U32 in bytes. u32type (perlxv.U): This variable contains the C type used for Perl's U32. u64size (perlxv.U): This variable is the size of an U64 in bytes. u64type (perlxv.U): This variable contains the C type used for Perl's U64. u8size (perlxv.U): This variable is the size of an U8 in bytes. u8type (perlxv.U): This variable contains the C type used for Perl's U8. uidformat (uidf.U): This variable contains the format string used for printing a Uid_t. uidsign (uidsign.U): This variable contains the signedness of a uidtype. 1 for unsigned, -1 for signed. uidsize (uidsize.U): This variable contains the size of a uidtype in bytes. uidtype (uidtype.U): This variable defines Uid_t to be something like uid_t, int, ushort, or whatever type is used to declare user ids in the kernel. uname (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the uname program. After Configure runs, the value is reset to a plain "uname" and is not useful. uniq (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the uniq program. After Configure runs, the value is reset to a plain "uniq" and is not useful. uquadtype (quadtype.U): This variable defines Uquad_t to be something like unsigned long, unsigned int, unsigned long long, uint64_t, or whatever type is used for 64-bit integers. use5005threads (usethreads.U): This variable conditionally defines the USE_5005THREADS symbol, and indicates that Perl should be built to use the 5.005-based threading implementation. Only valid up to 5.8.x. use64bitall (use64bits.U): This variable conditionally defines the USE_64_BIT_ALL symbol, and indicates that 64-bit integer types should be used when available. The maximal possible 64-bitness is employed: LP64 or ILP64, meaning that you will be able to use more than 2 gigabytes of memory. This mode is even more binary incompatible than USE_64_BIT_INT. You may not be able to run the resulting executable in a 32-bit CPU at all or you may need at least to reboot your OS to 64-bit mode. use64bitint (use64bits.U): This variable conditionally defines the USE_64_BIT_INT symbol, and indicates that 64-bit integer types should be used when available. The minimal possible 64-bitness is employed, just enough to get 64-bit integers into Perl. This may mean using for example "long longs", while your memory may still be limited to 2 gigabytes. usecrosscompile (Cross.U): This variable conditionally defines the USE_CROSS_COMPILE symbol, and indicates that Perl has been cross-compiled. usedevel (Devel.U): This variable indicates that Perl was configured with development features enabled. This should not be done for production builds. usedl (dlsrc.U): This variable indicates if the system supports dynamic loading of some sort. See also dlsrc and dlobj. usedtrace (usedtrace.U): This variable indicates whether we are compiling with dtrace support. See also dtrace. usefaststdio (usefaststdio.U): This variable conditionally defines the USE_FAST_STDIO symbol, and indicates that Perl should be built to use 'fast stdio'. Defaults to define in Perls 5.8 and earlier, to undef later. useithreads (usethreads.U): This variable conditionally defines the USE_ITHREADS symbol, and indicates that Perl should be built to use the interpreter-based threading implementation. uselargefiles (uselfs.U): This variable conditionally defines the USE_LARGE_FILES symbol, and indicates that large file interfaces should be used when available. uselongdouble (uselongdbl.U): This variable conditionally defines the USE_LONG_DOUBLE symbol, and indicates that long doubles should be used when available. usemallocwrap (mallocsrc.U): This variable contains y if we are wrapping malloc to prevent integer overflow during size calculations. usemorebits (usemorebits.U): This variable conditionally defines the USE_MORE_BITS symbol, and indicates that explicit 64-bit interfaces and long doubles should be used when available. usemultiplicity (usemultiplicity.U): This variable conditionally defines the MULTIPLICITY symbol, and indicates that Perl should be built to use multiplicity. usemymalloc (mallocsrc.U): This variable contains y if the malloc that comes with this package is desired over the system's version of malloc. People often include special versions of malloc for effiency, but such versions are often less portable. See also mallocsrc and mallocobj. If this is 'y', then -lmalloc is removed from $libs. usenm (usenm.U): This variable contains 'true' or 'false' depending whether the nm extraction is wanted or not. useopcode (Extensions.U): This variable holds either 'true' or 'false' to indicate whether the Opcode extension should be used. The sole use for this currently is to allow an easy mechanism for users to skip the Opcode extension from the Configure command line. useperlio (useperlio.U): This variable conditionally defines the USE_PERLIO symbol, and indicates that the PerlIO abstraction should be used throughout. useposix (Extensions.U): This variable holds either 'true' or 'false' to indicate whether the POSIX extension should be used. The sole use for this currently is to allow an easy mechanism for hints files to indicate that POSIX will not compile on a particular system. usereentrant (usethreads.U): This variable conditionally defines the USE_REENTRANT_API symbol, which indicates that the thread code may try to use the various _r versions of library functions. This is only potentially meaningful if usethreads is set and is very experimental, it is not even prompted for. userelocatableinc (bin.U): This variable is set to true to indicate that perl should relocate @INC entries at runtime based on the path to the perl binary. Any @INC paths starting ".../" are relocated relative to the directory containing the perl binary, and a logical cleanup of the path is then made around the join point (removing "dir/../" pairs) usesfio (d_sfio.U): This variable is set to true when the user agrees to use sfio. It is set to false when sfio is not available or when the user explicitely requests not to use sfio. It is here primarily so that command-line settings can override the auto-detection of d_sfio without running into a "WHOA THERE". useshrplib (libperl.U): This variable is set to 'true' if the user wishes to build a shared libperl, and 'false' otherwise. usesitecustomize (d_sitecustomize.U): This variable is set to true when the user requires a mechanism that allows the sysadmin to add entries to @INC at runtime. This variable being set, makes perl run '$sitelib/sitecustomize.pl' at startup. usesocks (usesocks.U): This variable conditionally defines the USE_SOCKS symbol, and indicates that Perl should be built to use SOCKS. usethreads (usethreads.U): This variable conditionally defines the USE_THREADS symbol, and indicates that Perl should be built to use threads. usevendorprefix (vendorprefix.U): This variable tells whether the vendorprefix and consequently other vendor* paths are in use. usevfork (d_vfork.U): This variable is set to true when the user accepts to use vfork. It is set to false when no vfork is available or when the user explicitely requests not to use vfork. usrinc (usrinc.U): This variable holds the path of the include files, which is usually /usr/include. It is mainly used by other Configure units. uuname (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. uvoformat (perlxvf.U): This variable contains the format string used for printing a Perl UV as an unsigned octal integer. uvsize (perlxv.U): This variable is the size of a UV in bytes. uvtype (perlxv.U): This variable contains the C type used for Perl's UV. uvuformat (perlxvf.U): This variable contains the format string used for printing a Perl UV as an unsigned decimal integer. uvxformat (perlxvf.U): This variable contains the format string used for printing a Perl UV as an unsigned hexadecimal integer in lowercase abcdef. uvXUformat (perlxvf.U): This variable contains the format string used for printing a Perl UV as an unsigned hexadecimal integer in uppercase ABCDEF. vaproto (vaproto.U): This variable conditionally defines CAN_VAPROTO on systems supporting prototype declaration of functions with a variable number of arguments. See also prototype. vendorarch (vendorarch.U): This variable contains the value of the PERL_VENDORARCH symbol. It may have a ~ on the front. The standard distribution will put nothing in this directory. Vendors who distribute perl may wish to place their own architecture-dependent modules and extensions in this directory with MakeMaker Makefile.PL INSTALLDIRS=vendor or equivalent. See INSTALL for details. vendorarchexp (vendorarch.U): This variable is the ~name expanded version of vendorarch, so that you may use it directly in Makefiles or shell scripts. vendorbin (vendorbin.U): This variable contains the eventual value of the VENDORBIN symbol. It may have a ~ on the front. The standard distribution will put nothing in this directory. Vendors who distribute perl may wish to place additional binaries in this directory with MakeMaker Makefile.PL INSTALLDIRS=vendor or equivalent. See INSTALL for details. vendorbinexp (vendorbin.U): This variable is the ~name expanded version of vendorbin, so that you may use it directly in Makefiles or shell scripts. vendorhtml1dir (vendorhtml1dir.U): This variable contains the name of the directory for html pages. It may have a ~ on the front. The standard distribution will put nothing in this directory. Vendors who distribute perl may wish to place their own html pages in this directory with MakeMaker Makefile.PL INSTALLDIRS=vendor or equivalent. See INSTALL for details. vendorhtml1direxp (vendorhtml1dir.U): This variable is the ~name expanded version of vendorhtml1dir, so that you may use it directly in Makefiles or shell scripts. vendorhtml3dir (vendorhtml3dir.U): This variable contains the name of the directory for html library pages. It may have a ~ on the front. The standard distribution will put nothing in this directory. Vendors who distribute perl may wish to place their own html pages for modules and extensions in this directory with MakeMaker Makefile.PL INSTALLDIRS=vendor or equivalent. See INSTALL for details. vendorhtml3direxp (vendorhtml3dir.U): This variable is the ~name expanded version of vendorhtml3dir, so that you may use it directly in Makefiles or shell scripts. vendorlib (vendorlib.U): This variable contains the eventual value of the VENDORLIB symbol, which is the name of the private library for this package. The standard distribution will put nothing in this directory. Vendors who distribute perl may wish to place their own modules in this directory with MakeMaker Makefile.PL INSTALLDIRS=vendor or equivalent. See INSTALL for details. vendorlib_stem (vendorlib.U): This variable is $vendorlibexp with any trailing version-specific component removed. The elements in inc_version_list (inc_version_list.U) can be tacked onto this variable to generate a list of directories to search. vendorlibexp (vendorlib.U): This variable is the ~name expanded version of vendorlib, so that you may use it directly in Makefiles or shell scripts. vendorman1dir (vendorman1dir.U): This variable contains the name of the directory for man1 pages. It may have a ~ on the front. The standard distribution will put nothing in this directory. Vendors who distribute perl may wish to place their own man1 pages in this directory with MakeMaker Makefile.PL INSTALLDIRS=vendor or equivalent. See INSTALL for details. vendorman1direxp (vendorman1dir.U): This variable is the ~name expanded version of vendorman1dir, so that you may use it directly in Makefiles or shell scripts. vendorman3dir (vendorman3dir.U): This variable contains the name of the directory for man3 pages. It may have a ~ on the front. The standard distribution will put nothing in this directory. Vendors who distribute perl may wish to place their own man3 pages in this directory with MakeMaker Makefile.PL INSTALLDIRS=vendor or equivalent. See INSTALL for details. vendorman3direxp (vendorman3dir.U): This variable is the ~name expanded version of vendorman3dir, so that you may use it directly in Makefiles or shell scripts. vendorprefix (vendorprefix.U): This variable holds the full absolute path of the directory below which the vendor will install add-on packages. See INSTALL for usage and examples. vendorprefixexp (vendorprefix.U): This variable holds the full absolute path of the directory below which the vendor will install add-on packages. Derived from vendorprefix. vendorscript (vendorscript.U): This variable contains the eventual value of the VENDORSCRIPT symbol. It may have a ~ on the front. The standard distribution will put nothing in this directory. Vendors who distribute perl may wish to place additional executable scripts in this directory with MakeMaker Makefile.PL INSTALLDIRS=vendor or equivalent. See INSTALL for details. vendorscriptexp (vendorscript.U): This variable is the ~name expanded version of vendorscript, so that you may use it directly in Makefiles or shell scripts. version (patchlevel.U): The full version number of this package, such as 5.6.1 (or 5_6_1). This combines revision, patchlevel, and subversion to get the full version number, including any possible subversions. This is suitable for use as a directory name, and hence is filesystem dependent. version_patchlevel_string (patchlevel.U): This is a string combining version, subversion and perl_patchlevel (if perl_patchlevel is non-zero). It is typically something like 'version 7 subversion 1' or 'version 7 subversion 1 patchlevel 11224' It is computed here to avoid duplication of code in myconfig.SH and lib/Config.pm. versiononly (versiononly.U): If set, this symbol indicates that only the version-specific components of a perl installation should be installed. This may be useful for making a test installation of a new version without disturbing the existing installation. Setting versiononly is equivalent to setting installperl's -v option. In particular, the non-versioned scripts and programs such as a2p, c2ph, h2xs, pod2*, and perldoc are not installed (see INSTALL for a more complete list). Nor are the man pages installed. Usually, this is undef. vi (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. voidflags (voidflags.U): This variable contains the eventual value of the VOIDFLAGS symbol, which indicates how much support of the void type is given by this compiler. See VOIDFLAGS for more info. xlibpth (libpth.U): This variable holds extra path (space-separated) used to find libraries on this platform, for example CPU-specific libraries (on multi-CPU platforms) may be listed here. yacc (yacc.U): This variable holds the name of the compiler compiler we want to use in the Makefile. It can be yacc, byacc, or bison -y. yaccflags (yacc.U): This variable contains any additional yacc flags desired by the user. It is up to the Makefile to use this. zcat (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. zip (Loc.U): This variable is used internally by Configure to determine the full pathname (if any) of the zip program. After Configure runs, the value is reset to a plain "zip" and is not useful. perl-5.12.0-RC0/Porting/GitUtils.pm0000444000175000017500000000457711325127001015656 0ustar jessejesse#!/usr/bin/perl use strict; use warnings; use POSIX qw(strftime); use base qw/Exporter/; our @EXPORT_OK=qw(iso_time_with_dot gen_dot_patch); sub iso_time_with_dot { strftime "%Y-%m-%d.%H:%M:%S",gmtime(shift||time) } # generate the contents of a .patch file for an arbitrary commitish, or for HEAD if none is supplied # assumes the CWD is inside of a perl git repository. If the repository is bare then refs/heads/* # is used to determine the branch. If the repository is not bare then refs/remotes/origin/* is used # to determine the branch. (The assumption being that if its bare then this is running inside of # the master git repo - if its not bare then it is a checkout which may not have all the branches) sub gen_dot_patch { my $target= shift || 'HEAD'; chomp(my ($git_dir, $is_bare, $sha1)=`git rev-parse --git-dir --is-bare-repository $target`); die "Not in a git repository!" if !$git_dir; $is_bare= "" if $is_bare and $is_bare eq 'false'; # which branches to scan - the order here is important, the first hit we find we use # so if two branches can both reach a ref we want the right one first. my @branches=( 'blead', 'maint-5.10', 'maint-5.8', 'maint-5.8-dor', 'maint-5.6', 'maint-5.005', 'maint-5.004', # and more generalized searches... 'refs/heads/*', 'refs/remotes/*', 'refs/*', ); my $reftype= $is_bare ? "heads" : "remotes/origin"; my $branch; foreach my $name (@branches) { my $refs= $name=~m!^refs/! ? $name : "refs/$reftype/$name"; my $cmd= "git name-rev --name-only --refs=$refs $sha1"; chomp($branch= `$cmd`); last if $branch ne 'undefined'; } for ($branch) { $_ ||= "error"; # hmm, we didnt get /anything/ from name-rev? s!^\Q$reftype\E/!! || # strip off the reftype s!^refs/heads/!! || # possible other places it was found s!^refs/remotes/!! || # ... s!^refs/!!; # might even be a tag or something weirdo... s![~^].*\z!!; # strip off how far we are from the item } my $tstamp= iso_time_with_dot(`git log -1 --pretty="format:%ct" $sha1`); chomp(my $describe= `git describe $sha1`); join(" ", $branch, $tstamp, $sha1, $describe); } 1; perl-5.12.0-RC0/Porting/makemeta0000444000175000017500000000314611351321222015252 0ustar jessejesse#!./perl -w # this script must be run by the current perl to get perl's version right # # Create a META.yml file in the current directory. Must be run from the # root directory of a perl source tree. use strict; use warnings; use lib "Porting"; use File::Basename qw( dirname ); my $file = "META.yml"; die "$0: will not override $file, delete it first.\n" if -e $file; use Maintainers qw(%Modules get_module_files get_module_pat); my @CPAN = grep { $Modules{$_}{CPAN} } keys %Modules; my @files = ('lib/unicore/mktables', 'TestInit.pm', 'Porting/Maintainers.pm', 'Porting/perldelta_template.pod', map { get_module_files($_) } @CPAN); my @dirs = ('cpan', 'win32', grep { -d $_ && $_ !~ /^cpan/ } map { get_module_pat($_) } @CPAN); my %dirs; @dirs{@dirs} = (); my $files = join '', map { " - $_\n" } grep { my $d = $_; while(($d = dirname($d)) ne "."){ last if exists $dirs{$d}; } # if $d is "." it means we tried every parent dir of the file and none # of them were in the private list $d eq "."; } sort { lc $a cmp lc $b } @files; my $dirs = join '', map { " - $_\n" } sort { lc $a cmp lc $b } @dirs; open my $fh, ">$file" or die "Can't open $file: $!"; print $fh <<"EOI"; name: perl version: $] abstract: Practical Extraction and Report Language author: perl5-porters\@perl.org license: perl resources: homepage: http://www.perl.org/ bugtracker: http://rt.perl.org/perlbug/ license: http://dev.perl.org/licenses/ repository: http://perl5.git.perl.org/ distribution_type: core generated_by: $0 no_index: directory: $dirs file: $files EOI close $fh; perl-5.12.0-RC0/Porting/fixvars0000444000175000017500000000271411143650473015164 0ustar jessejesse#!/usr/bin/perl -w use Data::Dumper; my $targ = (@ARGV) ? join(' ',@ARGV) : 'miniperl' ; my $work = 1; while ($work) { open(PIPE,"make $targ 2>&1 |") || die "Cannot open pipe to make:$!"; my %fix; while () { if (/^(.*):(\d+):\s+\`(\w+)'\s+undeclared/ && -f $1 ) { my ($file,$line,$var) = ($1,$2,$3); $fix{$file} = [] unless exists $fix{$file}; push(@{$fix{$file}},[$line => $var]) unless ($var =~ /^PL_/ || $file =~ /\.h$/); } print; } close(PIPE); warn "Make retured $?\n"; last unless $?; my $changed = 0; foreach my $file (keys %fix) { my @ar = sort( { $a->[0] <=> $b->[0] } @{delete $fix{$file}}); my @miss; my $fixed = 0; unless (-w $file) { system("d4","edit",$file); } @ARGV = ($file); $. = 0; local $^I = '.sav'; while (<>) { while (@ar && $. == $ar[0][0]) { my ($line,$var) = @{shift(@ar)}; if (s/\b$var\b/PL_$var/) { warn "$file:$line: FIX $var\n"; $fixed++; $changed++; } else { push(@miss,[$line,$var,$_]); } } print; } unless ($fixed) { rename("$file$^I",$file); if (@miss) { while (@miss) { my ($line,$var,$txt) = @{shift(@miss)}; warn "$file:$line:$var | $txt"; } } } } last unless $changed; } perl-5.12.0-RC0/Porting/corelist.pl0000555000175000017500000002150111325127001015722 0ustar jessejesse#!perl # Generates info for Module::CoreList from this perl tree # run this from the root of a perl tree # # Data is on STDOUT. # # With an optional arg specifying the root of a CPAN mirror, outputs the # %upstream and %bug_tracker hashes too. use strict; use warnings; use File::Find; use ExtUtils::MM_Unix; use version; use lib "Porting"; use Maintainers qw(%Modules files_to_modules); use File::Spec; use Parse::CPAN::Meta; use IPC::Cmd 'can_run'; my $corelist_file = 'dist/Module-CoreList/lib/Module/CoreList.pm'; my %lines; my %module_to_file; my %modlist; die "usage: $0 [ cpan-mirror/ ] [ 5.x.y] \n" unless @ARGV <= 2; my $cpan = shift; my $raw_version = shift || $]; my $perl_version = version->parse("$raw_version"); my $perl_vnum = $perl_version->numify; my $perl_vstring = $perl_version->normal; # how do we get version.pm to not give us leading v? $perl_vstring =~ s/^v//; if ( !-f 'MANIFEST' ) { die "Must be run from the root of a clean perl tree\n"; } open( my $corelist_fh, '<', $corelist_file ) || die "Could not open $corelist_file: $!"; my $corelist = join( '', <$corelist_fh> ); if ($cpan) { my $modlistfile = File::Spec->catfile( $cpan, 'modules', '02packages.details.txt' ); my $content; my $fh; if ( -e $modlistfile ) { warn "Reading the module list from $modlistfile"; open $fh, '<', $modlistfile or die "Couldn't open $modlistfile: $!"; } elsif ( -e $modlistfile . ".gz" ) { my $zcat = can_run('gzcat') || can_run('zcat') or die "Can't find gzcat or zcat"; warn "Reading the module list from $modlistfile.gz"; open $fh, '-|', "$zcat $modlistfile.gz" or die "Couldn't zcat $modlistfile.gz: $!"; } else { warn "About to fetch 02packages from ftp.funet.fi. This may take a few minutes\n"; $content = fetch_url('http://ftp.funet.fi/pub/CPAN/modules/02packages.details.txt'); unless ($content) { die "Unable to read 02packages.details.txt from either your CPAN mirror or ftp.funet.fi"; } } if ( $fh and !$content ) { local $/ = "\n"; $content = join( '', <$fh> ); } die "Incompatible modlist format" unless $content =~ /^Columns: +package name, version, path/m; # Converting the file to a hash is about 5 times faster than a regexp flat # lookup. for ( split( qr/\n/, $content ) ) { next unless /^([A-Za-z_:0-9]+) +[-0-9.undefHASHVERSIONvsetwhenloadingbogus]+ +(\S+)/; $modlist{$1} = $2; } } find( sub { /(\.pm|_pm\.PL)$/ or return; /PPPort\.pm$/ and return; my $module = $File::Find::name; $module =~ /\b(demo|t|private)\b/ and return; # demo or test modules my $version = MM->parse_version($_); defined $version or $version = 'undef'; $version =~ /\d/ and $version = "'$version'"; # some heuristics to figure out the module name from the file name $module =~ s{^(lib|cpan|dist|(?:vms/|symbian/)?ext)/}{} and $1 ne 'lib' and ( $module =~ s{\b(\w+)/\1\b}{$1}, $module =~ s{^B/O}{O}, $module =~ s{^Devel-PPPort}{Devel}, $module =~ s{^libnet/}{}, $module =~ s{^Encode/encoding}{encoding}, $module =~ s{^IPC-SysV/}{IPC/}, $module =~ s{^MIME-Base64/QuotedPrint}{MIME/QuotedPrint}, $module =~ s{^(?:DynaLoader|Errno|Opcode)/}{}, ); $module =~ s{^lib/}{}g; $module =~ s{/}{::}g; $module =~ s{-}{::}g; $module =~ s{^.*::lib::}{}; # turns Foo/lib/Foo.pm into Foo.pm $module =~ s/(\.pm|_pm\.PL)$//; $lines{$module} = $version; $module_to_file{$module} = $File::Find::name; }, 'vms/ext', 'symbian/ext', 'lib', 'ext', 'cpan', 'dist' ); -e 'configpm' and $lines{Config} = 'undef'; if ( open my $ucdv, "<", "lib/unicore/version" ) { chomp( my $ucd = <$ucdv> ); $lines{Unicode} = "'$ucd'"; close $ucdv; } my $versions_in_release = " " . $perl_vnum . " => {\n"; foreach my $key ( sort keys %lines ) { $versions_in_release .= sprintf "\t%-24s=> %s,\n", "'$key'", $lines{$key}; } $versions_in_release .= " },\n"; $corelist =~ s/^(%version\s*=\s*.*?)(^\);)$/$1$versions_in_release$2/xism; exit unless %modlist; # We have to go through this two stage lookup, given how Maintainers.pl keys its # data by "Module", which is really a dist. my $file_to_M = files_to_modules( values %module_to_file ); my %module_to_upstream; my %module_to_dist; my %dist_to_meta_YAML; my %module_to_deprecated; while ( my ( $module, $file ) = each %module_to_file ) { my $M = $file_to_M->{$file}; next unless $M; next if $Modules{$M}{MAINTAINER} eq 'p5p'; $module_to_upstream{$module} = $Modules{$M}{UPSTREAM}; $module_to_deprecated{$module} = 1 if $Modules{$M}{DEPRECATED}; next if defined $module_to_upstream{$module} && $module_to_upstream{$module} =~ /^(?:blead|first-come)$/; my $dist = $modlist{$module}; unless ($dist) { warn "Can't find a distribution for $module\n"; next; } $module_to_dist{$module} = $dist; next if exists $dist_to_meta_YAML{$dist}; $dist_to_meta_YAML{$dist} = undef; # Like it or lump it, this has to be Unix format. my $meta_YAML_path = "authors/id/$dist"; $meta_YAML_path =~ s/(?:tar\.gz|tar\.bz2|zip)$/meta/ or die "$meta_YAML_path"; my $meta_YAML_url = 'http://ftp.funet.fi/pub/CPAN/' . $meta_YAML_path; if ( -e "$cpan/$meta_YAML_path" ) { $dist_to_meta_YAML{$dist} = Parse::CPAN::Meta::LoadFile( $cpan . "/" . $meta_YAML_path ); } elsif ( my $content = fetch_url($meta_YAML_url) ) { unless ($content) { warn "Failed to fetch $meta_YAML_url\n"; next; } eval { $dist_to_meta_YAML{$dist} = Parse::CPAN::Meta::Load($content); }; if ( my $err = $@ ) { warn "$meta_YAML_path: ".$err; next; } } else { warn "$meta_YAML_path does not exist for $module\n"; # I tried code to open the tarballs with Archive::Tar to find and # extract META.yml, but only Text-Tabs+Wrap-2006.1117.tar.gz had one, # so it's not worth including. next; } } my $upstream_stanza = "%upstream = (\n"; foreach my $module ( sort keys %module_to_upstream ) { my $upstream = defined $module_to_upstream{$module} ? "'$module_to_upstream{$module}'" : 'undef'; $upstream_stanza .= sprintf " %-24s=> %s,\n", "'$module'", $upstream; } $upstream_stanza .= ");"; $corelist =~ s/^%upstream .*? ;$/$upstream_stanza/ismx; # Deprecation generation my $deprecated_stanza = " " . $perl_vnum . " => {\n"; foreach my $module ( sort keys %module_to_deprecated ) { my $deprecated = defined $module_to_deprecated{$module} ? "'$module_to_deprecated{$module}'" : 'undef'; $deprecated_stanza .= sprintf "\t%-24s=> %s,\n", "'$module'", $deprecated; } $deprecated_stanza .= " },\n"; $corelist =~ s/^(%deprecated\s*=\s*.*?)(^\);)$/$1$deprecated_stanza$2/xism; my $tracker = "%bug_tracker = (\n"; foreach my $module ( sort keys %module_to_upstream ) { my $upstream = defined $module_to_upstream{$module}; next if defined $upstream and $upstream eq 'blead' || $upstream eq 'first-come'; my $bug_tracker; my $dist = $module_to_dist{$module}; $bug_tracker = $dist_to_meta_YAML{$dist}->{resources}{bugtracker} if $dist; $bug_tracker = defined $bug_tracker ? "'$bug_tracker'" : 'undef'; next if $bug_tracker eq "'http://rt.perl.org/perlbug/'"; $tracker .= sprintf " %-24s=> %s,\n", "'$module'", $bug_tracker; } $tracker .= ");"; $corelist =~ s/^%bug_tracker .*? ;/$tracker/eismx; unless ( $corelist =~ /and $perl_vstring releases of perl/ ) { warn "Adding $perl_vstring to the list of perl versions covered by Module::CoreList\n"; $corelist =~ s/\s*and (.*?) releases of perl/, $1 and $perl_vstring releases of perl/ism; } unless ( $corelist =~ /^%released \s* = \s* \( .*? $perl_vnum => .*? \);/ismx ) { warn "Adding $perl_vnum to the list of released perl versions. Please consider adding a release date.\n"; $corelist =~ s/^(%released \s* = \s* .*?) ( \) ) /$1 $perl_vnum => '????-??-??',\n $2/ismx; } write_corelist($corelist); warn "All done. Please check over $corelist_file carefully before committing. Thanks!\n"; sub write_corelist { my $content = shift; open (my $clfh, ">", $corelist_file) || die "Failed to open $corelist_file for writing: $!"; print $clfh $content || die "Failed to write the new CoreList.pm: $!"; close($clfh); } sub fetch_url { my $url = shift; eval { require LWP::Simple }; if ( LWP::Simple->can('get') ) { return LWP::Simple->get($url); } elsif (`which curl`) { return `curl -s $url`; } elsif (`which wget`) { return `wget -q -O - $url`; } } perl-5.12.0-RC0/Porting/findvars0000444000175000017500000000722111325125741015311 0ustar jessejesse#!/usr/bin/perl -w $pat = ''; # construct word list while () { chomp; next unless $_; $pat .= "$_|"; } chop $pat if $pat =~ /\|$/; # grep while (<>) { print "$ARGV\:$.\:$_" if s/\b($pat)\b/#$1#/og; # this variant might useful if the transformation is more complicated # if (/^(.*?)\b($pat)\b(.*)$/o) { # my $head = "$1#$2#"; # $_ = $3; # while (/^(.*?)\b($pat)\b(.*)$/o) { # $head .= "$1#$2#"; # $_ = $3; # } # print "$ARGV\:$.\:$head$_\n"; # } } continue { close ARGV if eof; } __END__ Argv Cmd DBcv DBgv DBline DBsignal DBsingle DBsub DBtrace No Sv Xpv Yes amagic_generation ampergv an archpat_auto argvgv argvoutgv av_fetch_sv basetime beginav bodytarget bostr bufend bufptr cddir chopset collation_ix collation_name collation_standard collxfrm_base collxfrm_mult colors colorset compcv compiling comppad comppad_name comppad_name_fill comppad_name_floor cop_seqmax copline cryptseen cshlen cshname curcop curcopdb curinterp curpad curpm curstack curstackinfo curstash curstname dbargs debdelim debname debstash debug defgv defoutgv defstash delaymagic diehook dirty dlevel dlmax do_undump doextract doswitches dowarn dumplvl e_script egid endav envgv errgv error_count euid eval_root eval_start evalseq exitlist exitlistlen expect extralen fdpid filemode firstgv forkprocess formfeed formtarget generation gensym gid globalstash he_root hexdigit hintgv hints hv_fetch_ent_mh hv_fetch_sv in_clean_all in_clean_objs in_eval in_my in_my_stash incgv initav inplace last_in_gv last_lop last_lop_op last_proto last_uni lastfd lastgotoprobe lastscream lastsize lastspbase laststatval laststype leftgv lex_brackets lex_brackstack lex_casemods lex_casestack lex_defer lex_dojoin lex_expect lex_fakebrack lex_formbrack lex_inpat lex_inwhat lex_op lex_repl lex_starts lex_state lex_stuff lineary linestart linestr localizing localpatches main_cv main_root main_start mainstack malloc_mutex markstack markstack_max markstack_ptr max_intro_pending maxo maxscream maxsysfd mess_sv min_intro_pending minus_F minus_a minus_c minus_l minus_n minus_p modcount modglobal multi_close multi_end multi_open multi_start multiline mystrk na nexttoke nexttype nextval nice_chunk nice_chunk_size ninterps nomemok numeric_local numeric_name numeric_standard ofmt ofs ofslen oldbufptr oldlastpm oldname oldoldbufptr op op_mask op_seqmax opsave origalen origargc origargv origenviron origfilename ors orslen osname pad_reset_pending padix padix_floor patchlevel patleave pending_ident perl_destruct_level perldb pidstatus preambleav preambled preprocess profiledata reg_eval_set reg_flags reg_start_tmp reg_start_tmpl regbol regcc regcode regcomp_parse regcomp_rx regcompp regdata regdummy regendp regeol regexecp regflags regindent reginput reginterp_cnt reglastparen regnarrate regnaughty regnpar regprecomp regprev regprogram regsawback regseen regsize regstartp regtill regxend replgv restartop retstack retstack_ix retstack_max rightgv rs rsfp rsfp_filters runops savestack savestack_ix savestack_max sawampersand sawstudy sawvec scopestack scopestack_ix scopestack_max screamfirst screamnext secondgv seen_evals seen_zerolen sh_path siggv sighandlerp sortcop sortcxix sortstash specialsv_list splitstr stack_base stack_max stack_sp start_env statbuf statcache statgv statname statusvalue statusvalue_vms stdingv strchop strtab sub_generation sublex_info subline subname sv_arenaroot sv_count sv_no sv_objcount sv_root sv_undef sv_yes sys_intern tainted tainting thisexpr thr_key timesbuf tmps_floor tmps_ix tmps_max tmps_stack tokenbuf top_env toptarget uid unsafe warnhook xiv_arenaroot xiv_root xnv_root xpv_root xrv_root piMem piENV piStdIO piLIO piDir piSock piProc perl-5.12.0-RC0/Porting/genlog0000555000175000017500000000753111325125741014757 0ustar jessejesse#!/usr/bin/perl -w # # Generate a nice changelist by querying perforce. # # Each change is described with the change number, description, # which branch the change happened in, files modified, # and who was responsible for entering the change. # # Can be called with a list of change numbers or a range of the # form "12..42". Changelog will be printed from highest number # to lowest. # # Outputs the changelist to stdout. # # Gurusamy Sarathy # use Text::Wrap; use Text::Tabs; $0 =~ s|^.*/||; unless (@ARGV) { die < USAGE } my @changes; my %editkind; @editkind{ qw( add edit delete integrate branch )} = qw( + ! - !> +> ); my $p4port = $ENV{P4PORT} || 'localhost:1666'; my @branch_include; my @branch_exclude; my %branch_include; my %branch_exclude; while (@ARGV) { $_ = shift; if (/^(\d+)\.\.(\d+)?$/) { push @changes, $1 .. ($2 || (split(' ', `p4 changes -m 1`))[1]); } elsif (/^\d+$/) { push @changes, $_; } elsif (/^-p(.*)$/) { $p4port = $1 || shift; } elsif (/^-bi(.*)$/) { push @branch_include, $1 || shift; } elsif (/^-be(.*)$/) { push @branch_exclude, $1 || shift; } else { warn "Arguments must be change numbers, ignoring `$_'\n"; } } @changes = sort { $b <=> $a } @changes; @branch_include{@branch_include} = @branch_include if @branch_include; @branch_exclude{@branch_exclude} = @branch_exclude if @branch_exclude; my @desc = `p4 -p $p4port describe -s @changes`; if ($?) { die "$0: `p4 -p $p4port describe -s @changes` failed, status[$?]\n"; } else { tr/\r/\n/ foreach @desc; chomp @desc; while (@desc) { my ($change,$who,$date,$time,@log,$branch,$file,$type,%files); my $skip = 0; my $nbranch = 0; $_ = shift @desc; if (/^Change (\d+) by (\w+)\@.+ on (\S+) (\S+)\s*$/) { ($change, $who, $date, $time) = ($1,$2,$3,$4); $_ = shift @desc; # get rid of empty line while (@desc) { $_ = shift @desc; last if /^Affected/; push @log, $_; } if (/^Affected/) { $_ = shift @desc; # get rid of empty line while ($_ = shift @desc) { last unless /^\.\.\./; if (m{^\.\.\. //depot/(.*?perl|[^/]*)/([^#]+)#\d+ (\w+)\s*$}) { ($branch,$file,$type) = ($1,$2,$3); $nbranch++; if (exists $branch_exclude{$branch} or @branch_include and not exists $branch_include{$branch}) { $skip++; } $files{$branch} = {} unless exists $files{$branch}; $files{$branch}{$type} = [] unless exists $files{$branch}{$type}; push @{$files{$branch}{$type}}, $file; } else { warn "Unknown line [$_], ignoring\n"; } } } } next if ((not $change) or $skip); my $output = ("_" x 76) . "\n"; $output .= sprintf < 25 && ($kind eq 'integrate' || $kind eq 'branch')) || @$files > 100; $output .= wrap(sprintf("%12s ", $editkind{$kind}), sprintf("%12s ", $editkind{$kind}), "@$files\n"); } } print unexpand($output); } } perl-5.12.0-RC0/Porting/manicheck0000444000175000017500000000120411325127001015401 0ustar jessejesse#!/usr/bin/perl # output a list of: # a) files listed in MANIFEST which don't exist # b) files which exist but which aren't in MANIFEST use strict; use warnings; use File::Find; open my $fh, 'MANIFEST' or die "Can't read MANIFEST: $!\n"; my @files = map { (split)[0] } <$fh>; close $fh; for (@files) { print "$_ from MANIFEST doesn't exist\n" if ! -f; } my %files = map { $_ => 1 } @files; find { wanted => sub { my $x = $File::Find::name; $x =~ s/^..//; return if -d; return if $_ eq '.gitignore'; return if $x =~ /^\.git\b/; print "$x\t\tnot in MANIFEST\n" if !$files{$x}; }, }, "."; perl-5.12.0-RC0/Porting/check83.pl0000555000175000017500000000423311325125741015342 0ustar jessejesse#!/usr/bin/perl -w use strict; # Check whether there are naming conflicts when names are truncated to # the DOSish case-ignoring 8.3 format, plus other portability no-nos. # The "8.3 rule" is loose: "if reducing the directory entry names # within one directory to lowercase and 8.3-truncated causes # conflicts, that's a bad thing". So the rule is NOT the strict # "no filename shall be longer than eight and a suffix if present # not longer than three". # The 8-level depth rule is for older VMS systems that likely won't # even be able to unpack the tarball if more than eight levels # (including the top of the source tree) are present. my %seen; my $maxl = 30; # make up a limit for a maximum filename length sub eight_dot_three { return () if $seen{$_[0]}++; my ($dir, $base, $ext) = ($_[0] =~ m{^(?:(.+)/)?([^/.]+)(?:\.([^/.]+))?$}); my $file = $base . ( defined $ext ? ".$ext" : "" ); $base = substr($base, 0, 8); $ext = substr($ext, 0, 3) if defined $ext; if (defined $dir && $dir =~ /\./) { print "directory name contains '.': $dir\n"; } if ($file =~ /[^A-Za-z0-9\._-]/) { print "filename contains non-portable characters: $_[0]\n"; } if (length $file > $maxl) { print "filename longer than $maxl characters: $file\n"; } if (defined $dir) { return ($dir, defined $ext ? "$dir/$base.$ext" : "$dir/$base"); } else { return ('.', defined $ext ? "$base.$ext" : $base); } } my %dir; if (open(MANIFEST, "MANIFEST")) { while () { chomp; s/\s.+//; unless (-f) { print "missing: $_\n"; next; } if (tr/././ > 1) { print "more than one dot: $_\n"; next; } if ((my $slashes = $_ =~ tr|\/|\/|) > 7) { print "more than eight levels deep: $_\n"; next; } while (m!/|\z!g) { my ($dir, $edt) = eight_dot_three($`); next unless defined $dir; ($dir, $edt) = map { lc } ($dir, $edt); push @{$dir{$dir}->{$edt}}, $_; } } } else { die "$0: MANIFEST: $!\n"; } for my $dir (sort keys %dir) { for my $edt (keys %{$dir{$dir}}) { my @files = @{$dir{$dir}{$edt}}; if (@files > 1) { print "conflict on filename $edt:\n", map " $_\n", @files; } } } perl-5.12.0-RC0/Porting/cmpVERSION.pl0000555000175000017500000000536611325127001015736 0ustar jessejesse#!/usr/bin/perl -w # # cmpVERSION - compare two Perl source trees for modules # that have identical version numbers but different contents. # # with -d option, output the diffs too # with -x option, exclude dual-life modules (after all, there are tools # like core-cpan-diff that can already deal with them) # With this option, one of the directories must be '.'. # # Original by slaven@rezic.de, modified by jhi. # use strict; use ExtUtils::MakeMaker; use File::Compare; use File::Find; use File::Spec::Functions qw(rel2abs abs2rel catfile catdir curdir); use Getopt::Std; use lib 'Porting'; use Maintainers; sub usage { die <<'EOF'; usage: $0 [ -d -x ] source_dir1 source_dir2 EOF } my %opts; getopts('dx', \%opts) or usage; @ARGV == 2 or usage; for (@ARGV[0, 1]) { die "$0: '$_' does not look like Perl directory\n" unless -f catfile($_, "perl.h") && -d catdir($_, "Porting"); } my %dual_files; if ($opts{x}) { die "With -x, one of the directories must be '.'\n" unless $ARGV[0] eq '.' or $ARGV[1] eq '.'; for my $m (grep $Maintainers::Modules{$_}{CPAN}, keys %Maintainers::Modules) { $dual_files{"./$_"} = 1 for Maintainers::get_module_files($m); } } my $dir2 = rel2abs($ARGV[1]); chdir $ARGV[0] or die "$0: chdir '$ARGV[0]' failed: $!\n"; # Files to skip from the check for one reason or another, # usually because they pull in their version from some other file. my %skip; @skip{ './lib/Carp/Heavy.pm', './lib/Config.pm', # no version number but contents will vary './lib/Exporter/Heavy.pm', './win32/FindExt.pm', } = (); my $skip_dirs = qr|^\./t/lib|; my @wanted; my @diffs; find( sub { /\.pm$/ && $File::Find::dir !~ $skip_dirs && ! exists $skip{$File::Find::name} && ! exists $dual_files{$File::Find::name} && do { my $file2 = catfile(catdir($dir2, $File::Find::dir), $_); (my $xs_file1 = $_) =~ s/\.pm$/.xs/; (my $xs_file2 = $file2) =~ s/\.pm$/.xs/; my $eq1 = compare($_, $file2) == 0; my $eq2 = 1; if (-e $xs_file1 && -e $xs_file2) { $eq2 = compare($xs_file1, $xs_file2) == 0; } return if $eq1 && $eq2; my $version1 = eval {MM->parse_version($_)}; my $version2 = eval {MM->parse_version($file2)}; return unless defined $version1 && defined $version2 && $version1 eq $version2; push @wanted, $File::Find::name; push @diffs, [ "$File::Find::dir/$_", $file2 ] unless $eq1; push @diffs, [ "$File::Find::dir/$xs_file1", $xs_file2 ] unless $eq2; } }, curdir); for (sort @wanted) { print "$_\n"; } exit unless $opts{d}; for (sort { $a->[0] cmp $b->[0] } @diffs) { print "\n"; system "diff -du '$_->[0]' '$_->[1]'"; } perl-5.12.0-RC0/Porting/Maintainers.pl0000555000175000017500000013472111340037012016360 0ustar jessejesse# A simple listing of core files that have specific maintainers, # or at least someone that can be called an "interested party". # Also, a "module" does not necessarily mean a CPAN module, it # might mean a file or files or a subdirectory. # Most (but not all) of the modules have dual lives in the core # and in CPAN. Those that have a CPAN existence, have the CPAN # attribute set to true. package Maintainers; use File::Glob qw(:case); %Maintainers = ( 'abergman' => 'Arthur Bergman ', 'abigail' => 'Abigail ', 'ams' => 'Abhijit Menon-Sen ', 'andk' => 'Andreas J. Koenig ', 'andya' => 'Andy Armstrong ', 'arandal' => 'Allison Randal ', 'audreyt' => 'Audrey Tang ', 'avar' => 'Ævar Arnfjörð Bjarmason ', 'bingos' => 'Chris Williams ', 'chorny' => 'Alexandr Ciornii ', 'corion' => 'Max Maischein ', 'craig' => 'Craig Berry ', 'dankogai' => 'Dan Kogai ', 'dconway' => 'Damian Conway ', 'dland' => 'David Landgren ', 'dmanura' => 'David Manura ', 'drolsky' => 'Dave Rolsky ', 'elizabeth' => 'Elizabeth Mattijsen ', 'ferreira' => 'Adriano Ferreira ', 'gbarr' => 'Graham Barr ', 'gaas' => 'Gisle Aas ', 'gsar' => 'Gurusamy Sarathy ', 'ilyam' => 'Ilya Martynov ', 'ilyaz' => 'Ilya Zakharevich ', 'jand' => 'Jan Dubois ', 'jdhedden' => 'Jerry D. Hedden ', 'jesse' => 'Jesse Vincent ', 'jhi' => 'Jarkko Hietaniemi ', 'jjore' => 'Joshua ben Jore ', 'jpeacock' => 'John Peacock ', 'jstowe' => 'Jonathan Stowe ', 'jv' => 'Johan Vromans ', 'kane' => 'Jos Boumans ', 'kwilliams' => 'Ken Williams ', 'laun' => 'Wolfgang Laun ', 'lstein' => 'Lincoln D. Stein ', 'lwall' => 'Larry Wall ', 'marekr' => 'Marek Rouchal ', 'markm' => 'Mark Mielke ', 'mhx' => 'Marcus Holland-Moritz ', 'mjd' => 'Mark-Jason Dominus ', 'msergeant' => 'Matt Sergeant ', 'mshelor' => 'Mark Shelor ', 'muir' => 'David Muir Sharnoff ', 'neilb' => 'Neil Bowers ', 'nuffin' => 'Yuval Kogman ', 'nwclark' => 'Nicholas Clark ', 'osfameron' => 'Hakim Cassimally ', 'p5p' => 'perl5-porters ', 'perlfaq' => 'perlfaq-workers ', 'petdance' => 'Andy Lester ', 'pjf' => 'Paul Fenwick ', 'pmqs' => 'Paul Marquess ', 'pvhp' => 'Peter Prymmer ', 'rafl' => 'Florian Ragwitz ', 'rclamp' => 'Richard Clamp ', 'rgarcia' => 'Rafael Garcia-Suarez ', 'rkobes' => 'Randy Kobes ', 'rmbarker' => 'Robin Barker ', 'rra' => 'Russ Allbery ', 'rurban' => 'Reini Urban ', 'sadahiro' => 'SADAHIRO Tomoyuki ', 'salva' => 'Salvador Fandiño García ', 'saper' => 'Sébastien Aperghis-Tramoni ', 'sburke' => 'Sean Burke ', 'mschwern' => 'Michael Schwern ', 'simonw' => 'Simon Wistow ', 'smccam' => 'Stephen McCamant ', 'smpeters' => 'Steve Peters ', 'smueller' => 'Steffen Mueller ', 'tels' => 'Tels ', 'tomhughes' => 'Tom Hughes ', 'tjenness' => 'Tim Jenness ', 'tyemq' => 'Tye McQueen ', 'yves' => 'Yves Orton ', 'zefram' => 'Andrew Main ', ); # IGNORABLE: files which, if they appear in the root of a CPAN # distribution, need not appear in core (i.e. core-cpan-diff won't # complain if it can't find them) @IGNORABLE = qw( .cvsignore .dualLivedDiffConfig .gitignore ANNOUNCE Announce Artistic AUTHORS BENCHMARK BUGS Build.PL CHANGELOG ChangeLog CHANGES Changes COPYING Copying CREDITS GOALS HISTORY INSTALL INSTALL.SKIP LICENSE Makefile.PL MANIFEST MANIFEST.SKIP META.yml MYMETA.yml NEW NOTES ppport.h README SIGNATURE THANKS TODO Todo VERSION WHATSNEW ); # Each entry in the %Modules hash roughly represents a distribution, # except in the case of CPAN=1, where it *exactly* represents a single # CPAN distribution. # The keys of %Modules are human descriptions of the distributions, and # may not exactly match a module or distribution name. Distributions # which have an obvious top-level module associated with them will usually # have a key named for that module, e.g. 'Archive::Extract' for # Archive-Extract-N.NN.tar.gz; the remaining keys are likely to be based # on the name of the distribution, e.g. 'Locale-Codes' for # Locale-Codes-N.NN.tar.gz'. # # FILES is a list of filenames, glob patterns, and directory # names to be recursed down, which collectively generate a complete list # of the files associated with the distribution. # CPAN can be either 1 (this distribution is also available on CPAN), # or 0 (there is no # valid CPAN release). # UPSTREAM indicates where patches should go. undef implies # that this hasn't been discussed for the module at hand. # "blead" indicates that the copy of the module in the blead # sources is to be considered canonical, "cpan" means that the # module on CPAN is to be patched first. "first-come" means # that blead can be patched freely if it is in sync with the # latest release on CPAN. # BUGS is an email or url to post bug reports. For modules with # UPSTREAM => 'blead', use perl5-porters@perl.org. rt.cpan.org # appears to automatically provide a URL for CPAN modules; any value # given here overrides the default: # http://rt.cpan.org/Public/Dist/Display.html?Name=$ModuleName # DISTRIBUTION names the tarball on CPAN which (allegedly) the files # included in core are derived from. Note that the file's version may not # necessarily match the newest version on CPAN. # EXCLUDED is a list of files to be excluded from a CPAN tarball before # comparing the remaining contents with core. Each item can either be a # full pathname (eg 't/foo.t') or a pattern (e.g. qr{^t/}). # It defaults to the empty list. # DEPRECATED contains the *first* version of Perl in which the module # was considered deprecated. It should only be present if the module is # actually deprecated. Such modules should use deprecated.pm to # issue a warning if used. E.g.: # # use if $] >= 5.011, 'deprecate'; # # MAP is a hash that maps CPAN paths to their core equivalents. # Each key reprepresents a string prefix, with longest prefixes checked # first. The first match causes that prefix to be replaced with the # corresponding key. For example, with the following MAP: # { # 'lib/' => 'lib/', # '' => 'lib/Foo/', # }, # # these files are mapped as shown: # # README becomes lib/Foo/README # lib/Foo.pm becomes lib/Foo.pm # # The default is dependent on the type of module. # For distributions which appear to be stored under ext/, it defaults to: # # { '' => 'ext/Foo-Bar/' } # # otherwise, it's # # { # 'lib/' => 'lib/', # '' => 'lib/Foo/Bar/', # } %Modules = ( 'Archive::Extract' => { 'MAINTAINER' => 'kane', 'DISTRIBUTION' => 'BINGOS/Archive-Extract-0.38.tar.gz', 'FILES' => q[cpan/Archive-Extract], 'CPAN' => 1, 'UPSTREAM' => 'cpan', 'BUGS' => 'bug-archive-extract@rt.cpan.org', }, 'Archive::Tar' => { 'MAINTAINER' => 'kane', 'DISTRIBUTION' => 'BINGOS/Archive-Tar-1.54.tar.gz', 'FILES' => q[cpan/Archive-Tar], 'CPAN' => 1, 'UPSTREAM' => 'cpan', 'BUGS' => 'bug-archive-tar@rt.cpan.org', }, 'Attribute::Handlers' => { 'MAINTAINER' => 'rgarcia', 'DISTRIBUTION' => 'SMUELLER/Attribute-Handlers-0.87.tar.gz', 'FILES' => q[dist/Attribute-Handlers], 'CPAN' => 1, 'UPSTREAM' => 'blead', }, 'autodie' => { 'MAINTAINER' => 'pjf', 'DISTRIBUTION' => 'PJF/autodie-2.06_01.tar.gz', 'FILES' => q[cpan/autodie], 'EXCLUDED' => [ qr{^inc/Module/}, # All these tests depend upon external # modules that don't exist when we're # building the core. Hence, they can # never run, and should not be merged. qw( t/boilerplate.t t/critic.t t/fork.t t/kwalitee.t t/lex58.t t/pod-coverage.t t/pod.t t/socket.t t/system.t ) ], 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'AutoLoader' => { 'MAINTAINER' => 'smueller', 'DISTRIBUTION' => 'SMUELLER/AutoLoader-5.70.tar.gz', 'FILES' => q[cpan/AutoLoader], 'EXCLUDED' => [ qw( t/00pod.t ) ], 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'B::Concise' => { 'MAINTAINER' => 'smccam', 'FILES' => q[ext/B/B/Concise.pm ext/B/t/concise.t], 'CPAN' => 0, 'UPSTREAM' => undef, }, 'B::Debug' => { 'MAINTAINER' => 'rurban', 'DISTRIBUTION' => 'RURBAN/B-Debug-1.12.tar.gz', 'FILES' => q[cpan/B-Debug], 'EXCLUDED' => [ qw( t/coverage.html t/pod.t ) ], 'CPAN' => 1, 'UPSTREAM' => undef, }, 'B::Deparse' => { 'MAINTAINER' => 'smccam', 'FILES' => q[dist/B-Deparse], 'CPAN' => 0, 'UPSTREAM' => 'blead', }, 'B::Lint' => { 'MAINTAINER' => 'jjore', 'DISTRIBUTION' => 'JJORE/B-Lint-1.11.tar.gz', 'FILES' => q[cpan/B-Lint], 'EXCLUDED' => [ qw( t/test.pl ) ], 'CPAN' => 1, 'UPSTREAM' => undef, }, 'base' => { 'MAINTAINER' => 'rgarcia', 'DISTRIBUTION' => 'RGARCIA/base-2.15.tar.gz', 'FILES' => q[dist/base], 'CPAN' => 1, 'UPSTREAM' => 'blead', }, 'bignum' => { 'MAINTAINER' => 'tels', 'DISTRIBUTION' => 'TELS/math/bignum-0.23.tar.gz', 'FILES' => q[cpan/bignum], 'EXCLUDED' => [ qr{^inc/Module/}, qw(t/pod.t t/pod_cov.t) ], 'CPAN' => 1, 'UPSTREAM' => undef, }, 'CGI' => { 'MAINTAINER' => 'lstein', 'DISTRIBUTION' => 'LDS/CGI.pm-3.48.tar.gz', 'FILES' => q[cpan/CGI], 'EXCLUDED' => [ qr{^t/lib/Test}, qw( cgi-lib_porting.html cgi_docs.html examples/WORLD_WRITABLE/18.157.1.253.sav t/gen-tests/gen-start-end-tags.pl t/fast.t ) ], 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'Class::ISA' => { 'MAINTAINER' => 'smueller', 'DISTRIBUTION' => 'SMUELLER/Class-ISA-0.36.tar.gz', 'FILES' => q[cpan/Class-ISA], 'CPAN' => 1, 'UPSTREAM' => 'cpan', 'DEPRECATED' => 5.011, }, 'Compress::Raw::Bzip2' => { 'MAINTAINER' => 'pmqs', 'DISTRIBUTION' => 'PMQS/Compress-Raw-Bzip2-2.021.tar.gz', 'FILES' => q[cpan/Compress-Raw-Bzip2], 'EXCLUDED' => [ qr{^t/Test/}, qw( bzip2-src/bzip2-cpp.patch ) ], 'CPAN' => 1, 'UPSTREAM' => undef, }, 'Compress::Raw::Zlib' => { 'MAINTAINER' => 'pmqs', 'DISTRIBUTION' => 'PMQS/Compress-Raw-Zlib-2.021.tar.gz', 'FILES' => q[cpan/Compress-Raw-Zlib], 'EXCLUDED' => [ qr{^t/Test/}, qw( t/000prereq.t t/99pod.t ) ], 'CPAN' => 1, 'UPSTREAM' => undef, }, 'constant' => { 'MAINTAINER' => 'saper', 'DISTRIBUTION' => 'SAPER/constant-1.19.tar.gz', 'FILES' => q[dist/constant], 'EXCLUDED' => [ qw( t/00-load.t t/more-tests.t t/pod-coverage.t t/pod.t eg/synopsis.pl ) ], 'CPAN' => 1, 'UPSTREAM' => 'blead', }, 'CPAN' => { 'MAINTAINER' => 'andk', 'DISTRIBUTION' => 'ANDK/CPAN-1.94_56.tar.gz', 'FILES' => q[cpan/CPAN], 'EXCLUDED' => [ qr{^distroprefs/}, qr{^inc/Test/}, qr{^t/CPAN/authors/}, qw{ lib/CPAN/Admin.pm Makefile.PL SlayMakefile t/00signature.t t/04clean_load.t t/12cpan.t t/13tarzip.t t/14forkbomb.t t/30shell.coverage t/30shell.t t/31sessions.t t/41distribution.t t/42distroprefs.t t/43distroprefspref.t t/50pod.t t/51pod.t t/52podcover.t t/60credentials.t t/70_critic.t t/CPAN/CpanTestDummies-1.55.pm t/CPAN/TestConfig.pm t/CPAN/TestMirroredBy t/CPAN/TestPatch.txt t/CPAN/modules/02packages.details.txt t/CPAN/modules/03modlist.data t/data/META-dynamic.yml t/data/META-static.yml t/local_utils.pm t/perlcriticrc t/yaml_code.yml }, ], 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'CPANPLUS' => { 'MAINTAINER' => 'kane', 'DISTRIBUTION' => 'BINGOS/CPANPLUS-0.90.tar.gz', 'FILES' => q[cpan/CPANPLUS], 'EXCLUDED' => [ qr{^inc/}, qr{^t/dummy-.*\.hidden$}, qw{ bin/cpanp-boxed }, # SQLite tests would be skipped in core, and # the filenames are too long for VMS! qw{ t/031_CPANPLUS-Internals-Source-SQLite.t t/032_CPANPLUS-Internals-Source-via-sqlite.t }, ], 'CPAN' => 1, 'UPSTREAM' => 'cpan', 'BUGS' => 'bug-cpanplus@rt.cpan.org', }, 'CPANPLUS::Dist::Build' => { 'MAINTAINER' => 'bingos', 'DISTRIBUTION' => 'BINGOS/CPANPLUS-Dist-Build-0.46.tar.gz', 'FILES' => q[cpan/CPANPLUS-Dist-Build], 'EXCLUDED' => [ qr{^inc/}, qw{ t/99_pod.t t/99_pod_coverage.t }, ], 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'Data::Dumper' => { 'MAINTAINER' => 'p5p', # Not gsar. Not ilyam 'DISTRIBUTION' => 'SMUELLER/Data-Dumper-2.125.tar.gz', 'FILES' => q[dist/Data-Dumper], 'CPAN' => 1, 'UPSTREAM' => 'blead', }, 'DB_File' => { 'MAINTAINER' => 'pmqs', 'DISTRIBUTION' => 'PMQS/DB_File-1.820.tar.gz', 'FILES' => q[cpan/DB_File], 'EXCLUDED' => [ qr{^patches/}, qw{ t/pod.t fallback.h fallback.xs }, ], 'CPAN' => 1, 'UPSTREAM' => undef, }, 'Devel::PPPort' => { 'MAINTAINER' => 'mhx', 'DISTRIBUTION' => 'MHX/Devel-PPPort-3.19.tar.gz', 'FILES' => q[cpan/Devel-PPPort], 'EXCLUDED' => [ qw{PPPort.pm} ], # we use PPPort_pm.PL instead 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'Digest' => { 'MAINTAINER' => 'gaas', 'DISTRIBUTION' => 'GAAS/Digest-1.16.tar.gz', 'FILES' => q[cpan/Digest], 'EXCLUDED' => [ qw{digest-bench} ], 'CPAN' => 1, 'UPSTREAM' => undef, }, 'Digest::MD5' => { 'MAINTAINER' => 'gaas', 'DISTRIBUTION' => 'GAAS/Digest-MD5-2.39.tar.gz', 'FILES' => q[cpan/Digest-MD5], 'EXCLUDED' => [ qw{rfc1321.txt} ], 'CPAN' => 1, 'UPSTREAM' => undef, }, 'Digest::SHA' => { 'MAINTAINER' => 'mshelor', 'DISTRIBUTION' => 'MSHELOR/Digest-SHA-5.47.tar.gz', 'FILES' => q[cpan/Digest-SHA], 'EXCLUDED' => [ qw{t/pod.t t/podcover.t examples/dups} ], 'CPAN' => 1, 'UPSTREAM' => undef, }, 'Encode' => { 'MAINTAINER' => 'dankogai', 'DISTRIBUTION' => 'DANKOGAI/Encode-2.39.tar.gz', 'FILES' => q[cpan/Encode], 'CPAN' => 1, 'UPSTREAM' => undef, }, 'encoding::warnings' => { 'MAINTAINER' => 'audreyt', 'DISTRIBUTION' => 'AUDREYT/encoding-warnings-0.11.tar.gz', 'FILES' => q[cpan/encoding-warnings], 'EXCLUDED' => [ qr{^inc/Module/}, qw{t/0-signature.t Makefile.PL MANIFEST META.yml README SIGNATURE}, ], 'CPAN' => 1, 'UPSTREAM' => undef, }, 'Exporter' => { 'MAINTAINER' => 'ferreira', 'DISTRIBUTION' => 'FERREIRA/Exporter-5.63.tar.gz', 'FILES' => q[lib/Exporter.pm lib/Exporter.t lib/Exporter/Heavy.pm ], 'EXCLUDED' => [ qw{t/pod.t t/use.t}, ], 'MAP' => { 't/' => 'lib/', 'lib/' => 'lib/', }, 'CPAN' => 1, 'UPSTREAM' => 'blead', }, 'ExtUtils::CBuilder' => { 'MAINTAINER' => 'kwilliams', 'DISTRIBUTION' => 'DAGOLDEN/ExtUtils-CBuilder-0.27.tar.gz', 'FILES' => q[cpan/ExtUtils-CBuilder], 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'ExtUtils::Command' => { 'MAINTAINER' => 'rkobes', 'DISTRIBUTION' => 'RKOBES/ExtUtils-Command-1.16.tar.gz', 'FILES' => q[cpan/ExtUtils-Command], 'EXCLUDED' => [ qw{ t/shell_command.t t/shell_exit.t lib/Shell/Command.pm }, ], 'CPAN' => 1, 'UPSTREAM' => undef, }, 'ExtUtils::Constant' => { 'MAINTAINER' => 'nwclark', # Nick has confirmed that while we have diverged from CPAN, # this package isn't primarily maintained in core # Another release wll happen "Sometime" 'DISTRIBUTION' => '',#'NWCLARK/ExtUtils-Constant-0.16.tar.gz', 'FILES' => q[cpan/ExtUtils-Constant], 'EXCLUDED' => [ qw{ lib/ExtUtils/Constant/Aaargh56Hash.pm examples/perl_keyword.pl examples/perl_regcomp_posix_keyword.pl }, ], 'CPAN' => 1, 'UPSTREAM' => undef, }, 'ExtUtils::Install' => { 'MAINTAINER' => 'yves', 'DISTRIBUTION' => 'YVES/ExtUtils-Install-1.54.tar.gz', 'FILES' => q[dist/ExtUtils-Install], 'EXCLUDED' => [ qw{ t/lib/Test/Builder.pm t/lib/Test/Builder/Module.pm t/lib/Test/More.pm t/lib/Test/Simple.pm t/pod-coverage.t t/pod.t }, ], 'CPAN' => 1, 'UPSTREAM' => 'blead', }, 'ExtUtils::MakeMaker' => { 'MAINTAINER' => 'mschwern', 'DISTRIBUTION' => 'MSCHWERN/ExtUtils-MakeMaker-6.56.tar.gz', 'FILES' => q[cpan/ExtUtils-MakeMaker], 'EXCLUDED' => [ qr{^t/lib/Test/}, qr{^inc/ExtUtils/}, ], 'CPAN' => 1, 'UPSTREAM' => 'first-come', }, 'ExtUtils::Manifest' => { 'MAINTAINER' => 'rkobes', 'DISTRIBUTION' => 'RKOBES/ExtUtils-Manifest-1.57.tar.gz', 'FILES' => q[cpan/ExtUtils-Manifest], 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'ExtUtils::ParseXS' => { 'MAINTAINER' => 'kwilliams', 'DISTRIBUTION' => 'DAGOLDEN/ExtUtils-ParseXS-2.21.tar.gz', 'EXCLUDED' => [ qw{ t/bugs/RT48104.xs t/bugs/typemap t/include/nsUniversalDetector.h t/include/nscore.h }], 'FILES' => q[cpan/ExtUtils-ParseXS], 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'faq' => { 'MAINTAINER' => 'perlfaq', 'FILES' => q[pod/perlfaq*], 'CPAN' => 0, 'UPSTREAM' => undef, }, 'File::Fetch' => { 'MAINTAINER' => 'kane', 'DISTRIBUTION' => 'BINGOS/File-Fetch-0.24.tar.gz', 'FILES' => q[cpan/File-Fetch], 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'File::Path' => { 'MAINTAINER' => 'dland', 'DISTRIBUTION' => 'DLAND/File-Path-2.08.tar.gz', 'FILES' => q[cpan/File-Path], 'EXCLUDED' => [ qw{eg/setup-extra-tests t/pod.t } ], 'MAP' => { '' => 'cpan/File-Path/lib/File/', 't/' => 'cpan/File-Path/t/', }, 'CPAN' => 1, 'UPSTREAM' => undef, }, 'File::Temp' => { 'MAINTAINER' => 'tjenness', 'DISTRIBUTION' => 'TJENNESS/File-Temp-0.22.tar.gz', 'FILES' => q[cpan/File-Temp], 'EXCLUDED' => [ qw{misc/benchmark.pl misc/results.txt } ], 'CPAN' => 1, 'UPSTREAM' => undef, }, 'Filter::Simple' => { 'MAINTAINER' => 'smueller', 'DISTRIBUTION' => 'SMUELLER/Filter-Simple-0.84.tar.gz', 'FILES' => q[dist/Filter-Simple], 'EXCLUDED' => [ qw(Makefile.PL MANIFEST README META.yml), qr{^demo/} ], 'CPAN' => 1, 'UPSTREAM' => 'blead', }, 'Filter::Util::Call' => { 'MAINTAINER' => 'pmqs', 'DISTRIBUTION' => 'PMQS/Filter-1.37.tar.gz', 'FILES' => q[cpan/Filter-Util-Call t/lib/filter-util.pl pod/perlfilter.pod ], 'EXCLUDED' => [ qr{^decrypt/}, qr{^examples/}, qr{^Exec/}, qr{^lib/Filter/}, qr{^tee/}, qw{ Call/Makefile.PL Call/ppport.h Call/typemap mytest t/cpp.t t/decrypt.t t/exec.t t/order.t t/pod.t t/sh.t t/tee.t } ], 'MAP' => { 'Call/' => 'cpan/Filter-Util-Call/', 'filter-util.pl' => 'cpan/Filter-Util-Call/filter-util.pl', 'perlfilter.pod' => 'pod/perlfilter.pod', '' => 'cpan/Filter-Util-Call/', }, 'CPAN' => 1, 'UPSTREAM' => undef, }, 'Getopt::Long' => { 'MAINTAINER' => 'jv', 'DISTRIBUTION' => 'JV/Getopt-Long-2.38.tar.gz', 'FILES' => q[cpan/Getopt-Long lib/newgetopt.pl ], 'EXCLUDED' => [ qr{^examples/}, qw{perl-Getopt-Long.spec}, ], 'MAP' => { '' => 'cpan/Getopt-Long/', 'lib/newgetopt.pl' => 'lib/newgetopt.pl', }, 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, # Sean has donated it to us. # Nothing has changed since his last CPAN release. # (not strictly true: there have been some trivial typo fixes; DAPM 6/2009) 'I18N::LangTags' => { 'MAINTAINER' => 'p5p', 'DISTRIBUTION' => 'SBURKE/I18N-LangTags-0.35.tar.gz', 'FILES' => q[dist/I18N-LangTags], 'CPAN' => 0, 'UPSTREAM' => 'blead', }, 'if' => { 'MAINTAINER' => 'ilyaz', 'DISTRIBUTION' => 'ILYAZ/modules/if-0.0401.tar.gz', 'FILES' => q[cpan/if], 'CPAN' => 1, 'UPSTREAM' => undef, }, 'IO' => { 'MAINTAINER' => 'p5p', 'DISTRIBUTION' => 'GBARR/IO-1.25.tar.gz', 'FILES' => q[dist/IO/], 'EXCLUDED' => [ qw{t/test.pl}, ], 'CPAN' => 1, 'UPSTREAM' => 'blead', }, 'IO-Compress' => { 'MAINTAINER' => 'pmqs', 'DISTRIBUTION' => 'PMQS/IO-Compress-2.021.tar.gz', 'FILES' => q[cpan/IO-Compress], 'EXCLUDED' => [ qr{t/Test/} ], 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'IO::Zlib' => { 'MAINTAINER' => 'tomhughes', 'DISTRIBUTION' => 'TOMHUGHES/IO-Zlib-1.10.tar.gz', 'FILES' => q[cpan/IO-Zlib], 'CPAN' => 1, 'UPSTREAM' => undef, }, 'IPC::Cmd' => { 'MAINTAINER' => 'kane', 'DISTRIBUTION' => 'BINGOS/IPC-Cmd-0.54.tar.gz', 'FILES' => q[cpan/IPC-Cmd], 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'IPC::SysV' => { 'MAINTAINER' => 'mhx', 'DISTRIBUTION' => 'MHX/IPC-SysV-2.01.tar.gz', 'FILES' => q[cpan/IPC-SysV], 'EXCLUDED' => [ qw{const-c.inc const-xs.inc} ], 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'lib' => { 'MAINTAINER' => 'smueller', 'DISTRIBUTION' => 'SMUELLER/lib-0.62.tar.gz', 'FILES' => q[dist/lib/], 'EXCLUDED' => [ qw{forPAUSE/lib.pm t/00pod.t} ], 'CPAN' => 1, 'UPSTREAM' => 'blead', }, 'libnet' => { 'MAINTAINER' => 'gbarr', 'DISTRIBUTION' => 'GBARR/libnet-1.22.tar.gz', 'FILES' => q[cpan/libnet], 'EXCLUDED' => [ qw{Configure install-nomake} ], 'CPAN' => 1, 'UPSTREAM' => undef, }, 'Locale-Codes' => { 'MAINTAINER' => 'neilb', 'DISTRIBUTION' => 'NEILB/Locale-Codes-2.07.tar.gz', 'FILES' => q[cpan/Locale-Codes], 'CPAN' => 1, 'UPSTREAM' => undef, }, 'Locale::Maketext' => { 'MAINTAINER' => 'ferreira', 'DISTRIBUTION' => 'FERREIRA/Locale-Maketext-1.13.tar.gz', 'FILES' => q[dist/Locale-Maketext], 'EXCLUDED' => [ qw{perlcriticrc t/00_load.t t/pod.t} ], 'CPAN' => 1, 'UPSTREAM' => 'blead', }, 'Locale::Maketext::Simple' => { 'MAINTAINER' => 'audreyt', 'DISTRIBUTION' => 'JESSE/Locale-Maketext-Simple-0.21.tar.gz', 'FILES' => q[cpan/Locale-Maketext-Simple], 'EXCLUDED' => [ qr{^inc/} ], 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'Log::Message' => { 'MAINTAINER' => 'kane', 'DISTRIBUTION' => 'KANE/Log-Message-0.02.tar.gz', 'FILES' => q[cpan/Log-Message], 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'Log::Message::Simple' => { 'MAINTAINER' => 'kane', 'DISTRIBUTION' => 'BINGOS/Log-Message-Simple-0.06.tar.gz', 'FILES' => q[cpan/Log-Message-Simple], 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'mad' => { 'MAINTAINER' => 'lwall', 'FILES' => q[mad], 'CPAN' => 0, 'UPSTREAM' => undef, }, 'Math::BigInt' => { 'MAINTAINER' => 'tels', 'DISTRIBUTION' => 'TELS/math/Math-BigInt-1.89.tar.gz', 'FILES' => q[cpan/Math-BigInt], 'EXCLUDED' => [ qr{^inc/}, qr{^examples/}, qw{t/pod.t t/pod_cov.t } ], 'CPAN' => 1, 'UPSTREAM' => undef, }, 'Math::BigInt::FastCalc' => { 'MAINTAINER' => 'tels', 'DISTRIBUTION' => 'TELS/math/Math-BigInt-FastCalc-0.19.tar.gz', 'FILES' => q[cpan/Math-BigInt-FastCalc], 'EXCLUDED' => [ qr{^inc/}, qw{ t/pod.t t/pod_cov.t }, # instead we use the versions of these test # files that come with Math::BigInt: qw{t/bigfltpm.inc t/bigfltpm.t t/bigintpm.inc t/bigintpm.t t/mbimbf.inc t/mbimbf.t }, ], 'MAP' => { '' => 'cpan/Math-BigInt-FastCalc/', 'lib/Math/BigInt/FastCalc.pm' => 'cpan/Math-BigInt-FastCalc/FastCalc.pm', }, 'CPAN' => 1, 'UPSTREAM' => undef, }, 'Math::BigRat' => { 'MAINTAINER' => 'tels', 'DISTRIBUTION' => 'LETO/Math-BigRat-0.24.tar.gz', 'FILES' => q[cpan/Math-BigRat], 'EXCLUDED' => [ qr{^inc/}, qw{ t/pod.t t/pod_cov.t }, ], 'CPAN' => 1, 'UPSTREAM' => undef, }, 'Math::Complex' => { 'MAINTAINER' => 'zefram', 'DISTRIBUTION' => 'JHI/Math-Complex-1.56.tar.gz', 'FILES' => q[cpan/Math-Complex], 'EXCLUDED' => [ qw{ t/pod.t t/pod-coverage.t }, ], 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'Memoize' => { 'MAINTAINER' => 'mjd', 'DISTRIBUTION' => 'MJD/Memoize-1.01.tar.gz', 'FILES' => q[cpan/Memoize], 'EXCLUDED' => [ qw{ article.html Memoize/Saves.pm }, ], 'CPAN' => 1, 'UPSTREAM' => undef, }, 'MIME::Base64' => { 'MAINTAINER' => 'gaas', 'DISTRIBUTION' => 'GAAS/MIME-Base64-3.08.tar.gz', 'FILES' => q[cpan/MIME-Base64], 'EXCLUDED' => [ qw{ t/bad-sv.t }, ], 'CPAN' => 1, 'UPSTREAM' => undef, }, 'Module::Build' => { 'MAINTAINER' => 'kwilliams', 'DISTRIBUTION' => 'DAGOLDEN/Module-Build-0.3603.tar.gz', 'FILES' => q[cpan/Module-Build], 'EXCLUDED' => [ qw{ t/par.t t/signature.t }, qr!^contrib/!, qr!^devtools! ], 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'Module::CoreList' => { 'MAINTAINER' => 'rgarcia', 'DISTRIBUTION' => 'BINGOS/Module-CoreList-2.23.tar.gz', 'FILES' => q[dist/Module-CoreList], 'CPAN' => 1, 'UPSTREAM' => 'blead', }, 'Module::Load' => { 'MAINTAINER' => 'kane', 'DISTRIBUTION' => 'KANE/Module-Load-0.16.tar.gz', 'FILES' => q[cpan/Module-Load], 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'Module::Load::Conditional' => { 'MAINTAINER' => 'kane', 'DISTRIBUTION' => 'BINGOS/Module-Load-Conditional-0.34.tar.gz', 'FILES' => q[cpan/Module-Load-Conditional], 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'Module::Loaded' => { 'MAINTAINER' => 'kane', 'DISTRIBUTION' => 'BINGOS/Module-Loaded-0.06.tar.gz', 'FILES' => q[cpan/Module-Loaded], 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'Module::Pluggable' => { 'MAINTAINER' => 'simonw', 'DISTRIBUTION' => 'SIMONW/Module-Pluggable-3.9.tar.gz', 'FILES' => q[cpan/Module-Pluggable], 'CPAN' => 1, 'UPSTREAM' => undef, }, 'Net::Ping' => { 'MAINTAINER' => 'smpeters', 'DISTRIBUTION' => 'SMPETERS/Net-Ping-2.36.tar.gz', 'FILES' => q[dist/Net-Ping], 'CPAN' => 1, 'UPSTREAM' => 'blead', }, 'NEXT' => { 'MAINTAINER' => 'rafl', 'DISTRIBUTION' => 'FLORA/NEXT-0.64.tar.gz', 'FILES' => q[cpan/NEXT], 'EXCLUDED' => [ qr{^demo/} ], 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'Object::Accessor' => { 'MAINTAINER' => 'kane', 'DISTRIBUTION' => 'BINGOS/Object-Accessor-0.36.tar.gz', 'FILES' => q[cpan/Object-Accessor], 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'Package::Constants' => { 'MAINTAINER' => 'kane', 'DISTRIBUTION' => 'KANE/Package-Constants-0.02.tar.gz', 'FILES' => q[cpan/Package-Constants], 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'Params::Check' => { 'MAINTAINER' => 'kane', 'DISTRIBUTION' => 'KANE/Params-Check-0.26.tar.gz', # For some reason a file of this name appears within # the tarball. Russell's Paradox eat your heart out. 'EXCLUDED' => [ qw( Params-Check-0.26.tar.gz ) ], 'FILES' => q[cpan/Params-Check], 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'parent' => { 'MAINTAINER' => 'corion', 'DISTRIBUTION' => 'CORION/parent-0.223.tar.gz', 'FILES' => q[cpan/parent], 'CPAN' => 1, 'UPSTREAM' => undef, }, 'Parse::CPAN::Meta' => { 'MAINTAINER' => 'smueller', 'DISTRIBUTION' => 'SMUELLER/Parse-CPAN-Meta-1.40.tar.gz', 'FILES' => q[cpan/Parse-CPAN-Meta], 'EXCLUDED' => [ qw( t/97_meta.t t/98_pod.t t/99_pmv.t ) ], 'CPAN' => 1, 'UPSTREAM' => 'cpan', # NOTE: 'perl uupacktool.pl t/data/utf_16_le_bom.yml.packed' # run by hand after import, as the core's test harness doesn't # run dists' "make test" steps }, 'PathTools' => { 'MAINTAINER' => 'kwilliams', 'DISTRIBUTION' => 'SMUELLER/PathTools-3.31.tar.gz', 'FILES' => q[cpan/Cwd], 'EXCLUDED' => [ qr{^t/lib/Test/} ], 'CPAN' => 1, 'UPSTREAM' => "cpan", # NOTE: PathTools is in cpan/Cwd/ because it contains Cwd.xs and # something, possibly Makefile.SH, makes an assumption that the # leafname of some file corresponds with the pathname of the directory. }, 'perlebcdic' => { 'MAINTAINER' => 'pvhp', 'FILES' => q[pod/perlebcdic.pod], 'CPAN' => 0, 'UPSTREAM' => undef, }, 'PerlIO' => { 'MAINTAINER' => 'p5p', 'FILES' => q[ext/PerlIO], 'CPAN' => 0, 'UPSTREAM' => undef, }, 'PerlIO::via::QuotedPrint' => { 'MAINTAINER' => 'elizabeth', 'DISTRIBUTION' => 'ELIZABETH/PerlIO-via-QuotedPrint-0.06.tar.gz', 'FILES' => q[cpan/PerlIO-via-QuotedPrint], 'CPAN' => 1, 'UPSTREAM' => undef, }, 'perlpacktut' => { 'MAINTAINER' => 'laun', 'FILES' => q[pod/perlpacktut.pod], 'CPAN' => 0, 'UPSTREAM' => undef, }, 'perlpodspec' => { 'MAINTAINER' => 'sburke', 'FILES' => q[pod/perlpodspec.pod], 'CPAN' => 0, 'UPSTREAM' => undef, }, 'perlre' => { 'MAINTAINER' => 'abigail', 'FILES' => q[pod/perlrecharclass.pod pod/perlrebackslash.pod], 'CPAN' => 0, 'UPSTREAM' => undef, }, 'perlreapi' => { MAINTAINER => 'avar', FILES => q[pod/perlreapi.pod], CPAN => 0, 'UPSTREAM' => undef, }, 'perlreftut' => { 'MAINTAINER' => 'mjd', 'FILES' => q[pod/perlreftut.pod], 'CPAN' => 0, 'UPSTREAM' => undef, }, 'perlthrtut' => { 'MAINTAINER' => 'elizabeth', 'FILES' => q[pod/perlthrtut.pod], 'CPAN' => 0, 'UPSTREAM' => undef, }, 'Pod::Escapes' => { 'MAINTAINER' => 'arandal', 'DISTRIBUTION' => 'SBURKE/Pod-Escapes-1.04.tar.gz', 'FILES' => q[cpan/Pod-Escapes], 'CPAN' => 1, 'UPSTREAM' => undef, }, 'Pod::LaTeX' => { 'MAINTAINER' => 'tjenness', 'DISTRIBUTION' => 'TJENNESS/Pod-LaTeX-0.58.tar.gz', 'FILES' => q[cpan/Pod-LaTeX pod/pod2latex.PL ], 'EXCLUDED' => [ qw( t/require.t ) ], 'MAP' => { '' => 'cpan/Pod-LaTeX/', 'pod2latex.PL' => 'pod/pod2latex.PL', }, 'CPAN' => 1, 'UPSTREAM' => undef, }, 'Pod::Parser' => { 'MAINTAINER' => 'marekr', # XXX Parser.pm in the 1.38 distribution identifies itself as # version 1.37! 'DISTRIBUTION' => 'MAREKR/Pod-Parser-1.38.tar.gz', 'FILES' => q[cpan/Pod-Parser pod/pod{2usage,checker,select}.PL ], 'MAP' => { '' => 'cpan/Pod-Parser/', 'scripts/' => 'pod/', }, 'CPAN' => 1, 'UPSTREAM' => undef, }, 'Pod::Perldoc' => { 'MAINTAINER' => 'ferreira', 'DISTRIBUTION' => 'FERREIRA/Pod-Perldoc-3.15_01.tar.gz', # I don't know whether it's conceptually cleaner to a rule to copy # ext/Pod-Perldoc/pod/perldoc.pod to pod/perldoc.pod at make time # (in 4 places), or leave it as 1 mapping here. 'FILES' => q[dist/Pod-Perldoc pod/perldoc.pod ], # in blead, the perldoc executable is generated by perldoc.PL # instead # XXX We can and should fix this, but clean up the DRY-failure in utils # first 'EXCLUDED' => [ qw( perldoc ) ], 'MAP' => { '' => 'dist/Pod-Perldoc/', 'lib/perldoc.pod' => 'pod/perldoc.pod', }, 'CPAN' => 1, 'UPSTREAM' => 'blead', }, 'Pod::Plainer' => { 'DISTRIBUTION' => 'RMBARKER/Pod-Plainer-1.02.tar.gz', 'MAINTAINER' => 'rmbarker', 'FILES' => q[dist/Pod-Plainer], 'CPAN' => 1, 'UPSTREAM' => 'blead', 'EXCLUDED' => [ qw(t/pod.t t/pod-coverage.t) ], 'DEPRECATED' => 5.011, }, 'Pod::Simple' => { 'MAINTAINER' => 'arandal', 'DISTRIBUTION' => 'DWHEELER/Pod-Simple-3.13.tar.gz', 'FILES' => q[cpan/Pod-Simple], # XXX these two files correspond to similar ones in blead under # pod/, but the blead ones have newer changes, and also seem to # have been in blead a long time. I'm going to assume then that # the blead versions of these two files are authoritative - DAPM 'EXCLUDED' => [ qw( lib/perlpod.pod lib/perlpodspec.pod ) ], 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'podlators' => { 'MAINTAINER' => 'rra', 'DISTRIBUTION' => 'RRA/podlators-2.3.1.tar.gz', 'FILES' => q[cpan/podlators pod/pod2man.PL pod/pod2text.PL ], 'MAP' => { '' => 'cpan/podlators/', 'scripts/' => 'pod/', }, 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'Safe' => { 'MAINTAINER' => 'rgarcia', 'DISTRIBUTION' => 'RGARCIA/Safe-2.22.tar.gz', 'FILES' => q[dist/Safe], 'CPAN' => 1, 'UPSTREAM' => 'blead', }, 'Scalar-List-Utils' => { 'MAINTAINER' => 'gbarr', 'DISTRIBUTION' => 'GBARR/Scalar-List-Utils-1.21.tar.gz', # Note that perl uses its own version of Makefile.PL 'FILES' => q[cpan/List-Util], 'EXCLUDED' => [ qr{^inc/Module/}, qr{^inc/Test/}, qw{ mytypemap }, ], 'CPAN' => 1, 'UPSTREAM' => undef, }, 'SelfLoader' => { 'MAINTAINER' => 'smueller', 'DISTRIBUTION' => 'SMUELLER/SelfLoader-1.17.tar.gz', 'FILES' => q[dist/SelfLoader], 'EXCLUDED' => [ qw{ t/00pod.t } ], 'CPAN' => 1, 'UPSTREAM' => 'blead', }, 'Shell' => { 'MAINTAINER' => 'ferreira', 'DISTRIBUTION' => 'FERREIRA/Shell-0.72_01.tar.gz', 'FILES' => q[cpan/Shell], 'EXCLUDED' => [ qw{ t/01_use.t t/99_pod.t } ], 'CPAN' => 1, 'UPSTREAM' => undef, 'DEPRECATED' => 5.011, }, 'Storable' => { 'MAINTAINER' => 'ams', 'DISTRIBUTION' => 'AMS/Storable-2.21.tar.gz', 'FILES' => q[dist/Storable], 'EXCLUDED' => [ qr{^t/Test/} ], 'CPAN' => 1, 'UPSTREAM' => 'blead', }, 'Switch' => { 'MAINTAINER' => 'rgarcia', 'DISTRIBUTION' => 'RGARCIA/Switch-2.15.tar.gz', 'FILES' => q[dist/Switch], 'CPAN' => 1, 'UPSTREAM' => 'blead', 'DEPRECATED' => 5.011, }, 'Sys::Syslog' => { 'MAINTAINER' => 'saper', 'DISTRIBUTION' => 'SAPER/Sys-Syslog-0.27.tar.gz', 'FILES' => q[cpan/Sys-Syslog], 'EXCLUDED' => [ qr{^eg/}, qw{t/data-validation.t t/distchk.t t/pod.t t/podcover.t t/podspell.t t/portfs.t win32/PerlLog.RES }, ], 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'Term::ANSIColor' => { 'MAINTAINER' => 'rra', 'DISTRIBUTION' => 'RRA/ANSIColor-2.02.tar.gz', 'FILES' => q[cpan/Term-ANSIColor], 'EXCLUDED' => [ qr{^tests/}, qw(t/pod-spelling.t t/pod.t) ], 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'Term::Cap' => { 'MAINTAINER' => 'jstowe', 'DISTRIBUTION' => 'JSTOWE/Term-Cap-1.12.tar.gz', 'FILES' => q[cpan/Term-Cap], 'CPAN' => 1, 'UPSTREAM' => undef, }, 'Term::UI' => { 'MAINTAINER' => 'kane', 'DISTRIBUTION' => 'KANE/Term-UI-0.20.tar.gz', 'FILES' => q[cpan/Term-UI], 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'Test' => { 'MAINTAINER' => 'jesse', 'DISTRIBUTION' => 'JESSE/Test-1.25_02.tar.gz', 'FILES' => q[cpan/Test], 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'Test::Harness' => { 'MAINTAINER' => 'andya', 'DISTRIBUTION' => 'ANDYA/Test-Harness-3.17.tar.gz', 'FILES' => q[cpan/Test-Harness], 'EXCLUDED' => [ qr{^examples/}, qr{^inc/}, qr{^t/lib/Test/}, qr{^xt/}, qw{Changes-2.64 HACKING.pod perlcriticrc t/lib/if.pm } ], 'CPAN' => 1, 'UPSTREAM' => undef, }, 'Test::Simple' => { 'MAINTAINER' => 'mschwern', 'DISTRIBUTION' => 'MSCHWERN/Test-Simple-0.94.tar.gz', 'FILES' => q[cpan/Test-Simple], 'EXCLUDED' => [ qw{.perlcriticrc .perltidyrc t/00compile.t t/pod.t t/pod-coverage.t t/Builder/reset_outputs.t lib/Test/Builder/IO/Scalar.pm } ], 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'Text::Balanced' => { 'MAINTAINER' => 'dmanura', 'DISTRIBUTION' => 'ADAMK/Text-Balanced-2.02.tar.gz', 'FILES' => q[cpan/Text-Balanced], 'EXCLUDED' => [ qw( t/97_meta.t t/98_pod.t t/99_pmv.t ) ], 'CPAN' => 1, 'UPSTREAM' => undef, }, 'Text::ParseWords' => { 'MAINTAINER' => 'chorny', 'DISTRIBUTION' => 'CHORNY/Text-ParseWords-3.27.zip', 'FILES' => q[cpan/Text-ParseWords], 'EXCLUDED' => [ qw( t/pod.t ) ], # For the benefit of make_ext.pl, we have to have this accessible: 'MAP' => { 'ParseWords.pm' => 'cpan/Text-ParseWords/lib/Text/ParseWords.pm', '' => 'cpan/Text-ParseWords/', }, 'CPAN' => 1, 'UPSTREAM' => undef, }, 'Text::Soundex' => { 'MAINTAINER' => 'markm', 'DISTRIBUTION' => 'MARKM/Text-Soundex-3.03.tar.gz', 'FILES' => q[cpan/Text-Soundex], 'MAP' => { '' => 'cpan/Text-Soundex/', # XXX these two files are clearly related, # but they appear to have diverged # considerably over the years 'test.pl' => 'cpan/Text-Soundex/t/Soundex.t', }, 'CPAN' => 1, 'UPSTREAM' => undef, }, 'Text-Tabs+Wrap' => { 'MAINTAINER' => 'muir', 'DISTRIBUTION' => 'MUIR/modules/Text-Tabs+Wrap-2009.0305.tar.gz', 'FILES' => q[cpan/Text-Tabs], 'EXCLUDED' => [ qw( t/dnsparks.t ) ], # see af6492bf9e 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'Thread::Queue' => { 'MAINTAINER' => 'jdhedden', 'DISTRIBUTION' => 'JDHEDDEN/Thread-Queue-2.11.tar.gz', 'FILES' => q[dist/Thread-Queue], 'EXCLUDED' => [ qw(examples/queue.pl t/00_load.t t/99_pod.t t/test.pl ) ], 'CPAN' => 1, 'UPSTREAM' => 'blead', }, 'Thread::Semaphore' => { 'MAINTAINER' => 'jdhedden', 'DISTRIBUTION' => 'JDHEDDEN/Thread-Semaphore-2.09.tar.gz', 'FILES' => q[dist/Thread-Semaphore], 'EXCLUDED' => [ qw(examples/semaphore.pl t/00_load.t t/99_pod.t t/test.pl ) ], 'CPAN' => 1, 'UPSTREAM' => 'blead', }, 'threads' => { 'MAINTAINER' => 'jdhedden', 'DISTRIBUTION' => 'JDHEDDEN/threads-1.75.tar.gz', 'FILES' => q[dist/threads], 'EXCLUDED' => [ qw(examples/pool.pl t/pod.t t/test.pl threads.h ) ], 'CPAN' => 1, 'UPSTREAM' => 'blead', }, 'threads::shared' => { 'MAINTAINER' => 'jdhedden', 'DISTRIBUTION' => 'JDHEDDEN/threads-shared-1.32.tar.gz', 'FILES' => q[dist/threads-shared], 'EXCLUDED' => [ qw(examples/class.pl shared.h t/pod.t t/test.pl ) ], 'CPAN' => 1, 'UPSTREAM' => 'blead', }, 'Tie::File' => { 'MAINTAINER' => 'mjd', 'DISTRIBUTION' => 'MJD/Tie-File-0.96.tar.gz', 'FILES' => q[cpan/Tie-File], 'CPAN' => 1, 'UPSTREAM' => undef, }, 'Tie::RefHash' => { 'MAINTAINER' => 'nuffin', 'DISTRIBUTION' => 'NUFFIN/Tie-RefHash-1.38.tar.gz', 'FILES' => q[cpan/Tie-RefHash], 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'Time::HiRes' => { 'MAINTAINER' => 'zefram', 'DISTRIBUTION' => 'JHI/Time-HiRes-1.9719.tar.gz', 'FILES' => q[cpan/Time-HiRes], 'CPAN' => 1, 'UPSTREAM' => undef, }, 'Time::Local' => { 'MAINTAINER' => 'drolsky', 'DISTRIBUTION' => 'DROLSKY/Time-Local-1.1901.tar.gz', 'FILES' => q[ext/Time-Local], 'EXCLUDED' => [ qw(t/pod-coverage.t t/pod.t) ], 'CPAN' => 1, 'UPSTREAM' => 'blead', # Currently Time::Local is no longer backwards compatible with Pre-5.11 perls # the version in core has now deviated from the CPAN version. To re-dual-life # this module, we'll need to rewrite a hybrid version }, 'Time::Piece' => { 'MAINTAINER' => 'msergeant', 'DISTRIBUTION' => 'MSERGEANT/Time-Piece-1.15.tar.gz', 'FILES' => q[cpan/Time-Piece], 'CPAN' => 1, 'UPSTREAM' => undef, }, 'Unicode::Collate' => { 'MAINTAINER' => 'sadahiro', 'DISTRIBUTION' => 'SADAHIRO/Unicode-Collate-0.52.tar.gz', 'FILES' => q[cpan/Unicode-Collate], # ignore experimental XS version 'EXCLUDED' => [ qr{X$}, qw{disableXS enableXS } ], 'CPAN' => 1, 'UPSTREAM' => 'first-come', }, 'Unicode::Normalize' => { 'MAINTAINER' => 'sadahiro', 'DISTRIBUTION' => 'SADAHIRO/Unicode-Normalize-1.03.tar.gz', 'FILES' => q[cpan/Unicode-Normalize], 'EXCLUDED' => [ qw{MANIFEST.N Normalize.pmN disableXS enableXS }], 'CPAN' => 1, 'UPSTREAM' => 'first-come', }, 'version' => { 'MAINTAINER' => 'jpeacock', 'DISTRIBUTION' => 'JPEACOCK/version-0.77.tar.gz', 'FILES' => q[lib/version.pm lib/version.pod lib/version.t lib/version], 'EXCLUDED' => [ qr{^t/.*\.t$}, qw{t/survey_locales}, qr{^vutil/}, qw{lib/version/typemap}, qw{vperl/vpp.pm}, ], 'MAP' => { 'lib/' => 'lib/', 't/coretests.pm' => 'lib/version.t', }, 'CPAN' => 1, 'UPSTREAM' => undef, }, 'vms' => { 'MAINTAINER' => 'craig', 'FILES' => q[vms configure.com README.vms], 'CPAN' => 0, 'UPSTREAM' => undef, }, 'VMS::DCLsym' => { 'MAINTAINER' => 'craig', 'FILES' => q[ext/VMS-DCLsym], 'CPAN' => 0, 'UPSTREAM' => undef, }, 'VMS::Stdio' => { 'MAINTAINER' => 'craig', 'FILES' => q[ext/VMS-Stdio], 'CPAN' => 0, 'UPSTREAM' => undef, }, 'warnings' => { 'MAINTAINER' => 'pmqs', 'FILES' => q[warnings.pl lib/warnings.{pm,t} lib/warnings t/lib/warnings ], 'CPAN' => 0, 'UPSTREAM' => undef, }, 'win32' => { 'MAINTAINER' => 'jand', 'FILES' => q[win32 t/win32 README.win32 ext/Win32CORE], 'CPAN' => 0, 'UPSTREAM' => undef, }, 'Win32' => { 'MAINTAINER' => 'jand', 'DISTRIBUTION' => "JDB/Win32-0.39.tar.gz", 'FILES' => q[cpan/Win32], 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'Win32API::File' => { 'MAINTAINER' => 'chorny', 'DISTRIBUTION' => 'CHORNY/Win32API-File-0.1101.zip', 'FILES' => q[cpan/Win32API-File], 'EXCLUDED' => [ qr{^ex/}, qw{t/pod.t}, ], 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, 'XS::APItest::KeywordRPN' => { 'MAINTAINER' => 'zefram', 'FILES' => q[ext/XS-APItest-KeywordRPN], 'CPAN' => 0, 'UPSTREAM' => 'blead', }, 'XSLoader' => { 'MAINTAINER' => 'saper', 'DISTRIBUTION' => 'SAPER/XSLoader-0.10.tar.gz', 'FILES' => q[dist/XSLoader], 'EXCLUDED' => [ qr{^eg/}, qw{t/pod.t t/podcover.t t/portfs.t XSLoader.pm}, # we use XSLoader_pm.PL ], 'CPAN' => 1, 'UPSTREAM' => 'blead', }, 's2p' => { 'MAINTAINER' => 'laun', 'FILES' => q[x2p/s2p.PL], 'CPAN' => 0, 'UPSTREAM' => undef, }, # this pseudo-module represents all the files under ext/ and lib/ # that aren't otherwise claimed. This means that the following two # commands will check that every file under ext/ and lib/ is # accounted for, and that there are no duplicates: # # perl Porting/Maintainers --checkmani lib ext # perl Porting/Maintainers --checkmani '_PERLLIB' => { 'MAINTAINER' => 'p5p', 'FILES' => q[ ext/autouse/lib ext/autouse/t ext/B/B.pm ext/B/typemap ext/B/Makefile.PL ext/B/defsubs_h.PL ext/B/O.pm ext/B/B.xs ext/B/B/Terse.pm ext/B/B/Showlex.pm ext/B/B/Xref.pm ext/B/t/f_map ext/B/t/showlex.t ext/B/t/o.t ext/B/t/optree_varinit.t ext/B/t/concise-xs.t ext/B/t/optree_check.t ext/B/t/OptreeCheck.pm ext/B/t/optree_specials.t ext/B/t/f_sort.t ext/B/t/pragma.t ext/B/t/f_sort ext/B/t/b.t ext/B/t/optree_samples.t ext/B/t/optree_concise.t ext/B/t/optree_constants.t ext/B/t/optree_sort.t ext/B/t/terse.t ext/B/t/xref.t ext/B/t/f_map.t ext/B/t/optree_misc.t ext/B/hints/openbsd.pl ext/B/hints/darwin.pl ext/Devel-DProf/ ext/Devel-Peek/ ext/Devel-SelfStubber/ ext/DynaLoader/ !ext/DynaLoader/t/XSLoader.t !ext/DynaLoader/XSLoader_pm.PL ext/Errno ext/Fcntl/ ext/File-Glob/ ext/FileCache/lib ext/FileCache/t ext/GDBM_File/ ext/Hash-Util-FieldHash/ ext/Hash-Util/ ext/I18N-Langinfo/ ext/IPC-Open2/ ext/IPC-Open3/ ext/NDBM_File/ ext/ODBM_File/ ext/Opcode/ ext/POSIX/ ext/PerlIO-encoding/ ext/PerlIO-scalar/ ext/PerlIO-via/ ext/SDBM_File/ ext/Socket/ ext/Sys-Hostname/ ext/Tie-Memoize/ ext/XS-APItest/ ext/XS-Typemap/ ext/attributes/ ext/mro/ ext/re/ lib/AnyDBM_File.{pm,t} lib/Benchmark.{pm,t} lib/CORE.pod lib/Carp.{pm,t} lib/Carp/Heavy.pm lib/Class/Struct.{pm,t} lib/Config.t lib/Config/Extensions.{pm,t} lib/DB.{pm,t} lib/DBM_Filter.pm lib/DBM_Filter/ lib/DirHandle.{pm,t} lib/Dumpvalue.{pm,t} lib/English.{pm,t} lib/Env.pm lib/Env/t/ lib/ExtUtils/Embed.pm lib/ExtUtils/XSSymSet.pm lib/ExtUtils/t/Embed.t lib/ExtUtils/typemap lib/File/Basename.{pm,t} lib/File/CheckTree.{pm,t} lib/File/Compare.{pm,t} lib/File/Copy.{pm,t} lib/File/DosGlob.{pm,t} lib/File/Find.pm lib/File/Find/ lib/File/stat.{pm,t} lib/FileHandle.{pm,t} lib/FindBin.{pm,t} lib/Getopt/Std.{pm,t} lib/I18N/Collate.{pm,t} lib/Internals.t lib/Module/Build/ConfigData.pm lib/Net/hostent.{pm,t} lib/Net/netent.{pm,t} lib/Net/protoent.{pm,t} lib/Net/servent.{pm,t} lib/PerlIO.pm lib/Pod/Functions.pm lib/Pod/Html.pm lib/Pod/t/Functions.t lib/Pod/t/InputObjects.t lib/Pod/t/Select.t lib/Pod/t/Usage.t lib/Pod/t/eol.t lib/Pod/t/html* lib/Pod/t/pod2html-lib.pl lib/Pod/t/utils.t lib/Search/Dict.{pm,t} lib/SelectSaver.{pm,t} lib/Symbol.{pm,t} lib/Term/Complete.{pm,t} lib/Term/ReadLine.{pm,t} lib/Text/Abbrev.{pm,t} lib/Thread.{pm,t} lib/Tie/Array.pm lib/Tie/Array/ lib/Tie/Handle.pm lib/Tie/Handle/ lib/Tie/Hash.pm lib/Tie/Hash/NamedCapture.pm lib/Tie/Scalar.{pm,t} lib/Tie/StdHandle.pm lib/Tie/SubstrHash.{pm,t} lib/Time/gmtime.{pm,t} lib/Time/localtime.{pm,t} lib/Time/tm.pm lib/UNIVERSAL.pm lib/Unicode/README lib/Unicode/UCD.{pm,t} lib/User/grent.{pm,t} lib/User/pwent.{pm,t} lib/abbrev.pl lib/assert.pl lib/bigfloat{.pl,pl.t} lib/bigint{.pl,pl.t} lib/bigrat.pl lib/blib.{pm,t} lib/bytes.{pm,t} lib/bytes_heavy.pl lib/cacheout.pl lib/charnames.{pm,t} lib/complete.pl lib/ctime.pl lib/dbm_filter_util.pl lib/deprecate.pm lib/diagnostics.{pm,t} lib/dotsh.pl lib/dumpvar.{pl,t} lib/exceptions.pl lib/fastcwd.pl lib/feature.{pm,t} lib/feature/ lib/filetest.{pm,t} lib/find.pl lib/finddepth.pl lib/flush.pl lib/getcwd.pl lib/getopt.pl lib/getopts.pl lib/h2ph.t lib/h2xs.t lib/hostname.pl lib/importenv.pl lib/integer.{pm,t} lib/legacy.{pm,t} lib/less.{pm,t} lib/locale.{pm,t} lib/look.pl lib/open.{pm,t} lib/open2.pl lib/open3.pl lib/overload{.pm,.t,64.t} lib/overload/numbers.pm lib/overloading.{pm,t} lib/perl5db.{pl,t} lib/perl5db/ lib/pwd.pl lib/shellwords.pl lib/sigtrap.{pm,t} lib/sort.{pm,t} lib/stat.pl lib/strict.{pm,t} lib/subs.{pm,t} lib/syslog.pl lib/tainted.pl lib/termcap.pl lib/timelocal.pl lib/unicore/ lib/utf8.{pm,t} lib/utf8_heavy.pl lib/validate.pl lib/vars{.pm,.t,_carp.t} lib/vmsish.{pm,t} ], 'CPAN' => 0, 'UPSTREAM' => undef, }, ); 1; perl-5.12.0-RC0/Porting/git-find-p4-change0000444000175000017500000000161111325125741016737 0ustar jessejesse#!/usr/bin/perl # given a perforce change number, output the equivalent git commit id # with -c, checks out the specified commit die "usage: $0 [-c|--checkout] [git-log-options] changenum" unless @ARGV; my $num = 1; my $checkout = 0; my $before = '--before=2008-12-18'; # only changes made under perforce for (@ARGV) { m{^\d+$} && (($change,$_) = ($_,undef)); m{^-\d+$} && (($num,$_) = (-$_,undef)); $_ eq '-c' || $_ eq '--checkout' and $checkout = 1; } my $grep = "--grep=^p4raw-id:.*\@$change\$"; @ARGV = grep { defined } @ARGV; if ($checkout) { my $commit = qx(git rev-list -1 --all $before '$grep'); chomp $commit; die "no commit found" unless $commit; system(git => checkout => $commit); } else { if ( -t STDOUT or @ARGV ) { system(qw(git log), $grep, "-$num", "--all", $before, @ARGV); } else { system(qw(git rev-list -1 --all), $before, $grep); } } perl-5.12.0-RC0/Porting/timecheck.c0000444000175000017500000000702211325127001015640 0ustar jessejesse/* A helper tool for perl's 2038 support. * See Porting/README.y2038 for details */ #include #include #include #include #include int opt_v = 0; int i; struct tm *tmp; time_t pt, pt_max, pt_min; static char hexbuf[80]; char *hex (time_t t) { if ((long long)t < 0) sprintf (hexbuf, " -0x%016lx", -t); else sprintf (hexbuf, " 0x%016lx", t); return (hexbuf); } /* hex */ 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); } else { if (opt_v) fprintf (stderr, "%3d:%s: %12ld-%02d-%02d %02d:%02d:%02d\n", i, hex (t), 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 () { 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); } } pt_max = pt; return (0); } /* check_gm_max */ 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); } } pt_min = pt; return (0); } /* check_gm_min */ void lt_check (time_t t, int min_year, int max_year) { if (sizeof (time_t) > 4 && t > 0x7ffffffffffff000LL) tmp = NULL; else 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); } else { if (opt_v) fprintf (stderr, "%3d:%s: %12ld-%02d-%02d %02d:%02d:%02d\n", i, hex (t), 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 () { 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); } } pt_max = pt; return (0); } /* check_lt_max */ 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); } } pt_min = pt; return (0); } /* check_lt_min */ int main (int argc, char *argv[]) { time_t gm_max, gm_min, lt_max, lt_min; if (argc > 1 && strcmp (argv[1], "-v") == 0) opt_v++; check_gm_max (); gm_max = pt_max; check_gm_min (); gm_min = pt_min; check_lt_max (); lt_max = pt_max; check_lt_min (); lt_min = pt_min; opt_v++; printf ("======================\n"); printf ("Sizeof time_t = %ld\n", (i = sizeof (time_t))); printf ("gmtime () boundaries:\n"); gm_check (gm_max, 69, 0x7fffffff); gm_check (gm_min, -1900, 70); printf ("localtime () boundaries:\n"); lt_check (lt_max, 69, 0x7fffffff); lt_check (lt_min, -1900, 70); printf ("Configure variables:\n"); printf ("sGMTIME_max='%ld'\n", gm_max); printf ("sGMTIME_min='%ld'\n", gm_min); printf ("sLOCALTIME_max='%ld'\n", lt_max); printf ("sLOCALTIME_min='%ld'\n", lt_min); return (0); } /* main */ perl-5.12.0-RC0/Porting/sort_perldiag.pl0000555000175000017500000000260111143650473016750 0ustar jessejesse#!/usr/bin/perl -w use strict; no locale; my %items; my $item_key; $/ = ''; while (<>) { if (/^=item\s+(.+)/) { # new item $item_key = get_item_key($1); $items{$item_key} .= $_; } elsif (/^=back\b/) { # no more items in this group foreach my $item_key (sort keys %items) { print $items{$item_key}; } $item_key = undef; %items = (); print; } elsif (defined $item_key) { # part of the current item $items{$item_key} .= $_; } else { # not part of an item print; } } if (keys %items) { warn "Missing =back after final =item.\n"; foreach my $item_key (sort keys %items) { print $items{$item_key}; } } # get the sortable key for an item sub get_item_key { my($item) = @_; # remove POD formatting $item =~ s/[A-Z]<(.*?)>/$1/g; # remove printf-style escapes # note: be careful not to remove things like %hash $item =~ s/%(?:[scg]|lx|#o)//g; # remove all non-letter characters $item =~ tr/A-Za-z//cd; return lc $item; } __END__ =pod =head1 NAME sort_perldiag.pl - Sort warning and error messages in perldiag.pod =head1 SYNOPSIS B I =head1 DESCRIPTION B is a script for sorting the warning and error messages in F. POD formatting, printf-style escapes, non-letter characters, and case are ignored, as explained in L. =cut perl-5.12.0-RC0/Porting/newtests-perldelta.pl0000555000175000017500000000344311325127001017731 0ustar jessejesse#!perl -w use 5.010; use strict; use Getopt::Long; use Pod::Usage; use Module::CoreList; GetOptions( 'spec|s:s' => \my $manifest, ) or pod2usage(); =head1 SYNOPSIS newtests-perldelta.pl [FROM TO] Output the added tests between the two last released versions of Perl newtests-perldelta.pl Output the added tests between the version tagged v5.11.1 and this version newtests-perldelta.pl v5.11.1 HEAD =cut my $corelist = \%Module::CoreList::version; my @versions = sort keys %$corelist; # by default, compare latest two version in CoreList; my ($from, $to) = @ARGV; # Convert the numbers to git version tags sub num2git { my ($num) = @_; $num =~ /^(5)\.(\d\d\d)(\d\d\d)/ or die "Couldn't make sense of version number '$num'"; sprintf 'v%d.%d.%d', $1,$2,$3; }; $from //= num2git($versions[-2]); # / $to //= num2git($versions[-1]); # / $manifest //= 'MANIFEST'; # / warn "Finding newly added tests between $from..$to\n"; my @new_tests = grep { m!^[-+](?:t|ext)/.*\.t\s+! } # only added/removed tests `git diff $from..$to -- $manifest`; chomp @new_tests; if (! @new_tests) { die "No new tests found between $from and $to."; }; # Now remove those files whose lines were just shuffled around # within MANIFEST my %desc; my %removed; for (@new_tests) { die "Weird diff line '$_' " unless /^([+-])(\S+\.t)(?:\s+(.*))?$/; my ($mod,$file,$desc) = ($1,$2,$3); $desc //= ''; # / to placate Padre highlighting if ($mod eq '-') { $removed{ $file } = $file; }; $desc{ $file } = $desc; }; print < 'git'; sub usage { print < []] Scans the commit logs for commits that are potentially, illegitimately touching modules that are primarily maintained outside of the perl core. Also checks for commits that span multiple distributions in cpan/ or dist/. Makes sure that updated CPAN distributions also update Porting/Maintainers.pl, but otherwise ignores changes to that file (and MANIFEST). Skip the to go back indefinitely. defaults to HEAD. -h/--help shows this help -v/--verbose shows the output of "git show --stat " for each commit -c/--color uses colored output HERE exit(1); } our $Verbose = 0; our $Color = 0; GetOptions( 'h|help' => \&usage, 'v|verbose' => \$Verbose, 'c|color|colour' => \$Color, ); my $start_commit = shift; my $end_commit = shift; $end_commit = 'HEAD' if not defined $end_commit; my $commit_range_cmd = defined($start_commit) ? " $start_commit..$end_commit" : ""; # format: hash\0author\0committer\0short_msg our $LogCmd = GITCMD() . q{ log --no-color -M -C --name-only '--pretty=format:%h%x00%an%x00%cn%x00%s'} . $commit_range_cmd; our @ColumnSpec = qw(hash author committer commit_msg); open my $fh, '-|', $LogCmd or die "Can't run '$LogCmd' to get the commit log: $!"; my ($safe_commits, $unsafe_commits) = parse_log($fh); if (@$unsafe_commits) { my $header = "Potentially unsafe commits:"; print color("red") if $Color; print $header, "\n"; print("=" x length($header), "\n\n") if $Verbose; print color("reset") if $Color; print_commit_info($_) foreach reverse @$unsafe_commits; print "\n"; } if (@$safe_commits) { my $header = "Presumably safe commits:"; print color("green") if $Color; print $header, "\n"; print("=" x length($header), "\n") if $Verbose; print color("reset") if $Color; print_commit_info($_) foreach reverse @$safe_commits; print "\n"; } exit(0); # single-line info about the commit at hand sub print_commit_info { my $commit = shift; my $author_info = "by $commit->{author}" . ($commit->{author} eq $commit->{committer} ? '' : " committed by $commit->{committer}"); if ($Verbose) { print color("yellow") if $Color; my $header = "$commit->{hash} $author_info: $commit->{msg}"; print "$header\n", ("-" x length($header)), "\n"; print color("reset") if $Color; my $cmd = GITCMD() . ' show --stat ' . ($Color?'--color ':'') . $commit->{hash}; print `$cmd`; # make sure git knows this isn't a terminal print "\n"; } else { print color("yellow") if $Color; print " $commit->{hash} $author_info: $commit->{msg}\n"; print color("reset") if $Color; } } # check whether the commit at hand is safe, unsafe or uninteresting sub check_commit { my $commit = shift; my $safe = shift; my $unsafe = shift; # Note to self: Adding any more greps and such will make this # look even more silly. Just use a single foreach, smart guy! my $touches_maintainers_pl = 0; my @files = grep { $touches_maintainers_pl = 1 if $_ eq 'Porting/Maintainers.pl'; $_ ne 'MANIFEST' and $_ ne 'Porting/Maintainers.pl' } @{$commit->{files}}; my @touching_cpan = grep {/^cpan\//} @files; return if not @touching_cpan; # check for unsafe commits to cpan/ my %touched_cpan_dirs; $touched_cpan_dirs{$_}++ for grep {defined $_} map {s/^cpan\/([^\/]*).*$/$1/; $_} @touching_cpan; my $touches_multiple_cpan_dists = (keys(%touched_cpan_dirs) > 1); my $touches_others = @files - @touching_cpan; if (@touching_cpan) { if ($touches_others) { $commit->{msg} = 'Touched files under cpan/ and other locations'; push @$unsafe, $commit; } elsif ($touches_multiple_cpan_dists) { $commit->{msg} = 'Touched multiple directories under cpan/'; push @$unsafe, $commit; } elsif (not $touches_maintainers_pl) { $commit->{msg} = 'Touched files under cpan/, but does not update ' . 'Porting/Maintainers.pl'; push @$unsafe, $commit; } elsif ($commit->{commit_msg} =~ /(?:up(?:grad|dat)|import)(?:ed?|ing)/i) { $commit->{msg} = 'Touched files under cpan/ with ' . '"upgrading"-like commit message'; push @$safe, $commit; } else { $commit->{msg} = 'Touched files under cpan/ without ' . '"upgrading"-like commit message'; push @$unsafe, $commit; } } # check for unsafe commits to dist/ my @touching_dist = grep {/^dist\//} @files; my %touched_dist_dirs; $touched_dist_dirs{$_}++ for grep {defined $_} map {s/^dist\/([^\/]*).*$/$1/; $_} @touching_dist; $touches_others = @files - @touching_dist; my $touches_multiple_dists = (keys(%touched_dist_dirs) > 1); if (@touching_dist) { if ($touches_others) { $commit->{msg} = 'Touched files under dist/ and other locations'; push @$unsafe, $commit; } elsif ($touches_multiple_dists) { $commit->{msg} = 'Touched multiple directories under cpan/'; push @$unsafe, $commit; } } } # given file handle, parse the git log output and put the resulting commit # structure into safe/unsafe compartments sub parse_log { my $fh = shift; my @safe_commits; my @unsafe_commits; my $commit; while (defined(my $line = <$fh>)) { chomp $line; if (not $commit) { next if $line =~ /^\s*$/; my @cols = split /\0/, $line; @cols == @ColumnSpec && !grep {!defined($_)} @cols or die "Malformed commit header line: '$line'"; $commit = { files => [], map {$ColumnSpec[$_] => $cols[$_]} (0..$#cols) }; next; } elsif ($line =~ /^\s*$/) { # within commit, blank line check_commit($commit, \@safe_commits, \@unsafe_commits); $commit = undef; } else { # within commit, non-blank (file) line push @{$commit->{files}}, $line; } } return(\@safe_commits, \@unsafe_commits); } perl-5.12.0-RC0/Porting/release_schedule.pod0000444000175000017500000000361611342547046017563 0ustar jessejesse=head1 Release schedule This document lists the release engineers for at least the next four months of releases of bleadperl. If there are fewer than four months listed as you make a release, it's important that you extend the schedule AND B. Before adding a release engineer, you B contact them and they B consent to ship the release. When shipping a release, you should include the schedule for (at least) the next four releases. If a stable version of Perl is released, you should reset the version numbers to the next blead series. =head2 2009 October 2 - 5.11.0 - Jesse Vincent October 20 - 5.11.1 - Jesse Vincent November 20 - 5.11.2 - Leon Brocard December 20 - 5.11.3 - Jesse Vincent =head2 2010 January 20 - 5.11.4 - Ricardo Signes February 20 - 5.11.5 - Steve Hay March 20 - 5.11.6 - Ask Bjørn Hansen April 20 - 5.11.7 - Leon Brocard May 20 - 5.11.8 - Ricardo Signes June 20 - 5.11.9 - Philippe Bruhat July 20 - 5.11.10 - Matt Trout August 20 - 5.11.11 - David Golden September 20 - 5.11.12 - Steve Hay =head1 VICTIMS The following porters have all consented to do at least one release of bleadperl. If you can't do a release and can't find a substitute amongst this list, mail p5p. Jesse Vincent > Leon Brocard > Yves Orton > Ricardo Signes > Steve Hay > Ask Bjørn Hansen > David Golden > Philippe Bruhat > Matt Trout > =head2 Reticent victims These folks have said that they'd be willing to release Perl but would prefer that others have the opportunity before they pitch in: =head1 AUTHOR Jesse Vincent > =cut perl-5.12.0-RC0/Porting/git-make-p4-refs0000444000175000017500000000062511325125741016452 0ustar jessejesse#!/bin/sh # this script creates a tag for every p4raw-id # the output can be appended to .git/packed-refs, but make sure to back up # first # then you can do: # git show perl@1234 where 1234 is a perforce change, and 'perl' is the p4 # depot git log -z -F --grep='p4raw-id:' --pretty='format:%H %b' | \ perl -0ne 'chomp; if ( @t = m{([a-f0-9]{40}).*?p4raw-id: //depot/(.*?\@\d+)}s ) { print "@t\n" }' perl-5.12.0-RC0/Porting/fixCORE0000444000175000017500000000274611143650473014746 0ustar jessejesse#!/usr/bin/perl -w use Data::Dumper; my $targ = shift; my $inc = join(' ',map("-I$_",@INC)); my $work = 1; while ($work) { open(PIPE,"$^X -w $inc -M$targ -e '' 2>&1 |") || die "Cannot open pipe to child:$!"; my %fix; while () { if (/^Ambiguous call resolved as CORE::(\w+)\(\), qualify as such or use \& at (\S+) line (\d+)/ && -f $2 ) { my ($var,$file,$line) = ($1,$2,$3); $fix{$file} = [] unless exists $fix{$file}; push(@{$fix{$file}},[$line => $var]) unless ($var =~ /^PL_/ || $file =~ /\.h$/); } print; } close(PIPE); # warn "Make retured $?\n"; # last unless $?; my $changed = 0; foreach my $file (keys %fix) { my @ar = sort( { $a->[0] <=> $b->[0] } @{delete $fix{$file}}); my @miss; my $fixed = 0; @ARGV = ($file); $. = 0; local $^I = '.sav'; while (<>) { while (@ar && $. == $ar[0][0]) { my ($line,$var) = @{shift(@ar)}; if (s/(? /dev/null if cd .. then if test -f all.Counts then prof -pixie -merge new.Counts -L. -incobj libperl.so perl t/perl.Counts all.Counts mv new.Counts all.Counts else mv t/perl.Counts all.Counts fi cd t fi done exit 0 perl-5.12.0-RC0/Porting/Maintainers0000444000175000017500000000030211143650473015743 0ustar jessejesse#!/usr/bin/perl -w # # Maintainers - show information about maintainers # use strict; use lib "Porting"; use Maintainers qw(show_results process_options); show_results(process_options()); perl-5.12.0-RC0/Porting/corecpan.pl0000555000175000017500000001076611325127001015703 0ustar jessejesse#!perl # Reports, in a perl source tree, which dual-lived core modules have not the # same version than the corresponding module on CPAN. # with -t option, can compare multiple source trees in tabular form. use 5.9.0; use strict; use Getopt::Std; use ExtUtils::MM_Unix; use lib 'Porting'; use Maintainers qw(get_module_files reload_manifest %Modules); use Cwd; use List::Util qw(max); our $packagefile = '02packages.details.txt'; sub usage () { die <) { my ($p, $v) = split ' '; next if 1../^\s*$/; # skip header $cpanversions{$p} = $v; } close $fh; my %results; # scan source tree(s) and CPAN module list, and put results in %results foreach my $source (@sources) { my ($srcdir, $label) = @$source; my $olddir = getcwd(); chdir $srcdir or die "chdir $srcdir: $!\n"; # load the MANIFEST file in the new directory reload_manifest; for my $dist (sort keys %Modules) { next unless $Modules{$dist}{CPAN}; for my $file (get_module_files($dist)) { next if $file !~ /(\.pm|_pm.PL)\z/ or $file =~ m{^t/} or $file =~ m{/t/}; my $vcore = '!EXIST'; $vcore = MM->parse_version($file) // 'undef' if -f $file; # get module name from filename to lookup CPAN version my $module = $file; $module =~ s/\_pm.PL\z//; $module =~ s/\.pm\z//; # some heuristics to figure out the module name from the file name $module =~ s{^(lib|ext|dist|cpan)/}{} and $1 =~ /(?:ext|dist|cpan)/ and ( # ext/Foo-Bar/Bar.pm $module =~ s{^(\w+)-(\w+)/\2$}{$1/lib/$1/$2}, # ext/Encode/Foo/Foo.pm $module =~ s{^(Encode)/(\w+)/\2$}{$1/lib/$1/$2}, $module =~ s{^[^/]+/}{}, $module =~ s{^lib/}{}, ); $module =~ s{/}{::}g; my $vcpan = $cpanversions{$module} // 'undef'; $results{$dist}{$file}{$label} = $vcore; $results{$dist}{$file}{CPAN} = $vcpan; } } chdir $olddir or die "chdir $olddir: $!\n"; } # output %results in the requested format my @labels = ((map $_->[1], @sources), 'CPAN' ); if ($opt_t) { my %changed; my @fields; for my $dist (sort { lc $a cmp lc $b } keys %results) { for my $file (sort keys %{$results{$dist}}) { my @versions = @{$results{$dist}{$file}}{@labels}; for (0..$#versions) { $fields[$_] = max($fields[$_], length $versions[$_], length $labels[$_], length '!EXIST' ); } if (our $opt_v or grep $_ ne $versions[0], @versions) { $changed{$dist} = 1; } } } printf "%*s ", $fields[$_], $labels[$_] for 0..$#labels; print "\n"; printf "%*s ", $fields[$_], '-' x length $labels[$_] for 0..$#labels; print "\n"; my $field_total; $field_total += $_ + 1 for @fields; for my $dist (sort { lc $a cmp lc $b } keys %results) { next unless $changed{$dist}; print " " x $field_total, " $dist\n"; for my $file (sort keys %{$results{$dist}}) { my @versions = @{$results{$dist}{$file}}{@labels}; for (0..$#versions) { printf "%*s ", $fields[$_], $versions[$_]//'!EXIST' } print " $file\n"; } } } else { for my $dist (sort { lc $a cmp lc $b } keys %results) { my $distname_printed = 0; for my $file (sort keys %{$results{$dist}}) { my ($vcore, $vcpan) = @{$results{$dist}{$file}}{@labels}; if (our $opt_v or $vcore ne $vcpan) { print "\n$dist:\n" unless ($distname_printed++); print "\t$file: core=$vcore, cpan=$vcpan\n"; } } } } perl-5.12.0-RC0/Porting/findrfuncs0000555000175000017500000000611011143650473015640 0ustar jessejesse#!/usr/bin/perl -ws # # findrfuncs: find reentrant variants of functions used in an executable. # # Requires a functional "nm -u". Searches headers in /usr/include # to find available *_r functions and looks for non-reentrant # variants used in the supplied executable. # # Requires debug info in the shared libraries/executables. # # Gurusamy Sarathy # gsar@ActiveState.com # # Hacked to automatically find the executable and shared objects. # --jhi use strict; use File::Find; my @EXES; my $NMU = 'nm -u'; my @INCDIRS = qw(/usr/include); my $SO = 'so'; my $EXE = ''; if (open(CONFIG, "config.sh")) { local $/; my $CONFIG = ; $SO = $1 if $CONFIG =~ /^so='(\w+)'/m; $EXE = $1 if $CONFIG =~ /^_exe='\.(\w+)'/m; close(CONFIG); } push @EXES, "perl$EXE"; find(sub {push @EXES, $File::Find::name if /\.$SO$/}, '.' ); push @EXES, @ARGV; if ($^O eq 'dec_osf') { $NMU = 'nm -Bu'; } elsif ($^O eq 'irix') { $NMU = 'nm -pu'; } my %rfuncs; my @syms; find(sub { return unless -f $File::Find::name; local *F; open F, "<$File::Find::name" or die "Can't open $File::Find::name: $!"; my $line; while (defined ($line = )) { if ($line =~ /\b(\w+_r)\b/) { #warn "$1 => $File::Find::name\n"; $rfuncs{$1}->{$File::Find::name}++; } } close F; }, @INCDIRS); # delete bogus symbols grepped out of comments and such delete $rfuncs{setlocale_r} if $^O eq 'linux'; # delete obsolete (as promised by man pages) symbols my $netdb_r_obsolete; if ($^O eq 'hpux') { delete $rfuncs{crypt_r}; delete $rfuncs{drand48_r}; delete $rfuncs{endgrent_r}; delete $rfuncs{endpwent_r}; delete $rfuncs{getgrent_r}; delete $rfuncs{getpwent_r}; delete $rfuncs{setlocale_r}; delete $rfuncs{srand48_r}; delete $rfuncs{strerror_r}; $netdb_r_obsolete = 1; } elsif ($^O eq 'dec_osf') { delete $rfuncs{crypt_r}; delete $rfuncs{strerror_r}; $netdb_r_obsolete = 1; } if ($netdb_r_obsolete) { delete @rfuncs{qw(endhostent_r endnetent_r endprotoent_r endservent_r gethostbyaddr_r gethostbyname_r gethostent_r getnetbyaddr_r getnetbyname_r getnetent_r getprotobyname_r getprotobynumber_r getprotoent_r getservbyname_r getservbyport_r getservent_r sethostent_r setnetent_r setprotoent_r setservent_r)}; } my %syms; for my $exe (@EXES) { # warn "#--- $exe\n"; for my $sym (`$NMU $exe 2>/dev/null`) { chomp $sym; $sym =~ s/^\s+//; $sym =~ s/^([0-9A-Fa-f]+\s+)?[Uu]\s+//; $sym =~ s/\s+[Uu]\s+-$//; next if $sym =~ /\s/; $sym =~ s/\@.*\z//; # remove @@GLIBC_2.0 etc # warn "#### $sym\n"; if (exists $rfuncs{"${sym}_r"} && ! $syms{"$sym:$exe"}++) { push @syms, $sym; } } if (@syms) { print "\nFollowing symbols in $exe have reentrant versions:\n"; for my $sym (@syms) { my @f = sort keys %{$rfuncs{$sym . '_r'}}; print "$sym => $sym" . "_r (@f)\n"; } } @syms = (); } perl-5.12.0-RC0/regcomp.sym0000444000175000017500000002070311325125742014317 0ustar jessejesse# regcomp.sym # # File has two sections, divided by a line of dashes '-'. # # Empty rows after #-comment are removed from input are ignored # # First section is for regops, second sectionis for regmatch-states # # Note that the order in this file is important. # # Format for first section: # NAME \t TYPE, arg-description [num-args] [longjump-len] \t DESCRIPTION # # # run perl regen.pl after editing this file #* Exit points (0,1) END END, no End of program. SUCCEED END, no Return from a subroutine, basically. #* Anchors: (2..13) BOL BOL, no Match "" at beginning of line. MBOL BOL, no Same, assuming multiline. SBOL BOL, no Same, assuming singleline. EOS EOL, no Match "" at end of string. EOL EOL, no Match "" at end of line. MEOL EOL, no Same, assuming multiline. SEOL EOL, no Same, assuming singleline. BOUND BOUND, no Match "" at any word boundary BOUNDL BOUND, no Match "" at any word boundary NBOUND NBOUND, no Match "" at any word non-boundary NBOUNDL NBOUND, no Match "" at any word non-boundary GPOS GPOS, no Matches where last m//g left off. #* [Special] alternatives: (14..30) REG_ANY REG_ANY, no Match any one character (except newline). SANY REG_ANY, no Match any one character. CANY REG_ANY, no Match any one byte. ANYOF ANYOF, sv Match character in (or not in) this class. ALNUM ALNUM, no Match any alphanumeric character ALNUML ALNUM, no Match any alphanumeric char in locale NALNUM NALNUM, no Match any non-alphanumeric character NALNUML NALNUM, no Match any non-alphanumeric char in locale SPACE SPACE, no Match any whitespace character SPACEL SPACE, no Match any whitespace char in locale NSPACE NSPACE, no Match any non-whitespace character NSPACEL NSPACE, no Match any non-whitespace char in locale DIGIT DIGIT, no Match any numeric character DIGITL DIGIT, no Match any numeric character in locale NDIGIT NDIGIT, no Match any non-numeric character NDIGITL NDIGIT, no Match any non-numeric character in locale CLUMP CLUMP, no Match any combining character sequence #* Alternation (31) # BRANCH The set of branches constituting a single choice are hooked # together with their "next" pointers, since precedence prevents # anything being concatenated to any individual branch. The # "next" pointer of the last BRANCH in a choice points to the # thing following the whole choice. This is also where the # final "next" pointer of each individual branch points; each # branch starts with the operand node of a BRANCH node. # BRANCH BRANCH, node Match this alternative, or the next... #*Back pointer (32) # BACK Normal "next" pointers all implicitly point forward; BACK # exists to make loop structures possible. # not used BACK BACK, no Match "", "next" ptr points backward. #*Literals (33..35) EXACT EXACT, str Match this string (preceded by length). EXACTF EXACT, str Match this string, folded (prec. by length). EXACTFL EXACT, str Match this string, folded in locale (w/len). #*Do nothing types (36..37) NOTHING NOTHING,no Match empty string. # A variant of above which delimits a group, thus stops optimizations TAIL NOTHING,no Match empty string. Can jump here from outside. #*Loops (38..44) # STAR,PLUS '?', and complex '*' and '+', are implemented as circular # BRANCH structures using BACK. Simple cases (one character # per match) are implemented with STAR and PLUS for speed # and to minimize recursive plunges. # STAR STAR, node Match this (simple) thing 0 or more times. PLUS PLUS, node Match this (simple) thing 1 or more times. CURLY CURLY, sv 2 Match this simple thing {n,m} times. CURLYN CURLY, no 2 Capture next-after-this simple thing CURLYM CURLY, no 2 Capture this medium-complex thing {n,m} times. CURLYX CURLY, sv 2 Match this complex thing {n,m} times. # This terminator creates a loop structure for CURLYX WHILEM WHILEM, no Do curly processing and see if rest matches. #*Buffer related (45..49) # OPEN,CLOSE,GROUPP ...are numbered at compile time. OPEN OPEN, num 1 Mark this point in input as start of #n. CLOSE CLOSE, num 1 Analogous to OPEN. REF REF, num 1 Match some already matched string REFF REF, num 1 Match already matched string, folded REFFL REF, num 1 Match already matched string, folded in loc. #*Grouping assertions (50..54) IFMATCH BRANCHJ,off 1 2 Succeeds if the following matches. UNLESSM BRANCHJ,off 1 2 Fails if the following matches. SUSPEND BRANCHJ,off 1 1 "Independent" sub-RE. IFTHEN BRANCHJ,off 1 1 Switch, should be preceeded by switcher . GROUPP GROUPP, num 1 Whether the group matched. #*Support for long RE (55..56) LONGJMP LONGJMP,off 1 1 Jump far away. BRANCHJ BRANCHJ,off 1 1 BRANCH with long offset. #*The heavy worker (57..58) EVAL EVAL, evl 1 Execute some Perl code. #*Modifiers (59..60) MINMOD MINMOD, no Next operator is not greedy. LOGICAL LOGICAL,no Next opcode should set the flag only. # This is not used yet (61) RENUM BRANCHJ,off 1 1 Group with independently numbered parens. #*Trie Related (62..64) # Behave the same as A|LIST|OF|WORDS would. The '..C' variants have # inline charclass data (ascii only), the 'C' store it in the structure. # NOTE: the relative order of the TRIE-like regops is signifigant TRIE TRIE, trie 1 Match many EXACT(FL?)? at once. flags==type TRIEC TRIE,trie charclass Same as TRIE, but with embedded charclass data # For start classes, contains an added fail table. AHOCORASICK TRIE, trie 1 Aho Corasick stclass. flags==type AHOCORASICKC TRIE,trie charclass Same as AHOCORASICK, but with embedded charclass data #*Regex Subroutines (65..66) GOSUB GOSUB, num/ofs 2L recurse to paren arg1 at (signed) ofs arg2 GOSTART GOSTART, no recurse to start of pattern #*Named references (67..69) NREF REF, no-sv 1 Match some already matched string NREFF REF, no-sv 1 Match already matched string, folded NREFFL REF, no-sv 1 Match already matched string, folded in loc. #*Special conditionals (70..72) NGROUPP NGROUPP, no-sv 1 Whether the group matched. INSUBP INSUBP, num 1 Whether we are in a specific recurse. DEFINEP DEFINEP, none 1 Never execute directly. #*Bactracking Verbs ENDLIKE ENDLIKE, none Used only for the type field of verbs OPFAIL ENDLIKE, none Same as (?!) ACCEPT ENDLIKE, parno 1 Accepts the current matched string. #*Verbs With Arguments VERB VERB, no-sv 1 Used only for the type field of verbs PRUNE VERB, no-sv 1 Pattern fails at this startpoint if no-backtracking through this MARKPOINT VERB, no-sv 1 Push the current location for rollback by cut. SKIP VERB, no-sv 1 On failure skip forward (to the mark) before retrying COMMIT VERB, no-sv 1 Pattern fails outright if backtracking through this CUTGROUP VERB, no-sv 1 On failure go to the next alternation in the group #*Control what to keep in $&. KEEPS KEEPS, no $& begins here. #*New charclass like patterns LNBREAK LNBREAK, none generic newline pattern VERTWS VERTWS, none vertical whitespace (Perl 6) NVERTWS NVERTWS, none not vertical whitespace (Perl 6) HORIZWS HORIZWS, none horizontal whitespace (Perl 6) NHORIZWS NHORIZWS, none not horizontal whitespace (Perl 6) FOLDCHAR FOLDCHAR, codepoint 1 codepoint with tricky case folding properties. # NEW STUFF ABOVE THIS LINE ################################################################################ #*SPECIAL REGOPS # This is not really a node, but an optimized away piece of a "long" node. # To simplify debugging output, we mark it as if it were a node OPTIMIZED NOTHING,off Placeholder for dump. # Special opcode with the property that no opcode in a compiled program # will ever be of this type. Thus it can be used as a flag value that # no other opcode has been seen. END is used similarly, in that an END # node cant be optimized. So END implies "unoptimizable" and PSEUDO mean # "not seen anything to optimize yet". PSEUDO PSEUDO,off Pseudo opcode for internal use. ------------------------------------------------------------------------------- # Format for second section: # REGOP \t typelist [ \t typelist] [# Comment] # typelist= namelist # = namelist:FAIL # = name:count # Anything below is a state # # TRIE next:FAIL EVAL AB:FAIL CURLYX end:FAIL WHILEM A_pre,A_min,A_max,B_min,B_max:FAIL BRANCH next:FAIL CURLYM A,B:FAIL IFMATCH A:FAIL CURLY B_min_known,B_min,B_max:FAIL COMMIT next:FAIL MARKPOINT next:FAIL SKIP next:FAIL CUTGROUP next:FAIL KEEPS next:FAIL perl-5.12.0-RC0/dosish.h0000444000175000017500000001403411325125741013572 0ustar jessejesse/* dosish.h * * Copyright (C) 1993, 1994, 1996, 1997, 1998, 1999, * 2000, 2001, 2002, 2007, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ #define ABORT() abort(); #ifndef SH_PATH #define SH_PATH "/bin/sh" #endif #ifdef DJGPP # 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 # define init_os_extras Perl_init_os_extras # define HAS_UTIME # define HAS_KILL char *djgpp_pathexp (const char*); void Perl_DJGPP_init (int *argcp,char ***argvp); # if (DJGPP==2 && DJGPP_MINOR < 2) # define NO_LOCALECONV_MON_THOUSANDS_SEP # endif # ifndef PERL_CORE # define PERL_FS_VER_FMT "%d_%d_%d" # endif # define PERL_FS_VERSION STRINGIFY(PERL_REVISION) "_" \ STRINGIFY(PERL_VERSION) "_" \ STRINGIFY(PERL_SUBVERSION) #else /* DJGPP */ # ifdef WIN32 # define PERL_SYS_INIT_BODY(c,v) \ MALLOC_CHECK_TAINT2(*c,*v) Perl_win32_init(c,v); PERLIO_INIT # define PERL_SYS_TERM_BODY() Perl_win32_term() # define BIT_BUCKET "nul" # else # ifdef NETWARE # define PERL_SYS_INIT_BODY(c,v) \ MALLOC_CHECK_TAINT2(*c,*v) Perl_nw5_init(c,v); PERLIO_INIT # define BIT_BUCKET "nwnul" # else # define PERL_SYS_INIT_BODY(c,v) \ MALLOC_CHECK_TAINT2(*c,*v); PERLIO_INIT # define BIT_BUCKET "\\dev\\nul" /* "wanna be like, umm, Newlined, or somethin?" */ # endif /* NETWARE */ # endif #endif /* DJGPP */ #ifndef PERL_SYS_TERM_BODY # define PERL_SYS_TERM_BODY() HINTS_REFCNT_TERM; OP_REFCNT_TERM; PERLIO_TERM; MALLOC_TERM #endif #define dXSUB_SYS /* * 5.003_07 and earlier keyed on #ifdef MSDOS for determining if we were * running on DOS, *and* if we had to cope with 16 bit memory addressing * constraints, *and* we need to have memory allocated as unsigned long. * * with the advent of *real* compilers for DOS, they are not locked together. * MSDOS means "I am running on MSDOS". HAS_64K_LIMIT means "I have * 16 bit memory addressing constraints". * * if you need the last, try #DEFINE MEM_SIZE unsigned long. */ #ifdef MSDOS # ifndef DJGPP # define HAS_64K_LIMIT # endif #endif /* USEMYBINMODE * This symbol, if defined, indicates that the program should * use the routine my_binmode(FILE *fp, char iotype, int mode) to insure * that a file is in "binary" mode -- that is, that no translation * of bytes occurs on read or write operations. */ #undef USEMYBINMODE /* Stat_t: * This symbol holds the type used to declare buffers for information * returned by stat(). It's usually just struct stat. It may be necessary * to include and to get any typedef'ed * information. */ #if defined(WIN64) || defined(USE_LARGE_FILES) # if defined(__BORLANDC__) /* buk */ # include # define Stat_t struct stati64 # else #define Stat_t struct _stati64 # endif #else #if defined(UNDER_CE) #define Stat_t struct xcestat #else #define Stat_t struct stat #endif #endif /* USE_STAT_RDEV: * This symbol is defined if this system has a stat structure declaring * st_rdev */ #define USE_STAT_RDEV /**/ /* ACME_MESS: * This symbol, if defined, indicates that error messages should be * should be generated in a format that allows the use of the Acme * GUI/editor's autofind feature. */ #undef ACME_MESS /**/ /* ALTERNATE_SHEBANG: * This symbol, if defined, contains a "magic" string which may be used * as the first line of a Perl program designed to be executed directly * by name, instead of the standard Unix #!. If ALTERNATE_SHEBANG * begins with a character other then #, then Perl will only treat * it as a command line if it finds the string "perl" in the first * word; otherwise it's treated as the first line of code in the script. * (IOW, Perl won't hand off to another interpreter via an alternate * shebang sequence that might be legal Perl code.) */ /* #define ALTERNATE_SHEBANG "#!" / **/ #include /* * fwrite1() should be a routine with the same calling sequence as fwrite(), * but which outputs all of the bytes requested as a single stream (unlike * fwrite() itself, which on some systems outputs several distinct records * if the number_of_items parameter is >1). */ #define fwrite1 fwrite #define Fstat(fd,bufptr) fstat((fd),(bufptr)) #ifdef DJGPP # define Fflush(fp) djgpp_fflush(fp) #else # define Fflush(fp) fflush(fp) #endif #define Mkdir(path,mode) mkdir((path),(mode)) #ifndef WIN32 # define Stat(fname,bufptr) stat((fname),(bufptr)) #else # define HAS_IOCTL # define HAS_UTIME # define HAS_KILL # define HAS_WAIT # define HAS_CHOWN #endif /* WIN32 */ /* * : The DJGPP port has code that converts * the return code of system() into the form that Unixy wait usually * returns: * * - signal number in bits 0-6; * - core dump flag in bit 7; * - exit code in bits 8-15. * * Bits 0-7 are always zero for DJGPP, because it uses system(). * See djgpp.c. * * POSIX::W* use the W* macros from to decode * the return code. Unfortunately the W* macros for DJGPP use * a different format than Unixy wait does. So there's a mismatch * and, say, WEXITSTATUS($?) will return bogus values. * * So here we add hack to redefine the W* macros from DJGPP's * to work with our return-code conversion. */ #ifdef DJGPP #include #undef WEXITSTATUS #undef WIFEXITED #undef WIFSIGNALED #undef WIFSTOPPED #undef WNOHANG #undef WSTOPSIG #undef WTERMSIG #undef WUNTRACED #define WEXITSTATUS(stat_val) ((stat_val) >> 8) #define WIFEXITED(stat_val) 0 #define WIFSIGNALED(stat_val) 0 #define WIFSTOPPED(stat_val) 0 #define WNOHANG 0 #define WSTOPSIG(stat_val) 0 #define WTERMSIG(stat_val) 0 #define WUNTRACED 0 #endif /* Don't go reading from /dev/urandom */ #define PERL_NO_DEV_RANDOM /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */ perl-5.12.0-RC0/README.freebsd0000444000175000017500000000363611143650473014432 0ustar jessejesseIf you read this file _as_is_, just ignore the funny characters you see. It is written in the POD format (see pod/perlpod.pod) which is specifically designed to be readable as is. =head1 NAME README.freebsd - Perl version 5 on FreeBSD systems =head1 DESCRIPTION This document describes various features of FreeBSD that will affect how Perl version 5 (hereafter just Perl) is compiled and/or runs. =head2 FreeBSD core dumps from readdir_r with ithreads When perl is configured to use ithreads, it will use re-entrant library calls in preference to non-re-entrant versions. There is a bug in FreeBSD's C function in versions 4.5 and earlier that can cause a SEGV when reading large directories. A patch for FreeBSD libc is available (see http://www.freebsd.org/cgi/query-pr.cgi?pr=misc/30631 ) which has been integrated into FreeBSD 4.6. =head2 $^X doesn't always contain a full path in FreeBSD perl 5.8.0 sets C<$^X> where possible to a full path by asking the operating system. On FreeBSD the full path of the perl interpreter is found by reading the symlink F. There is a bug on FreeBSD, where the result of reading this symlink is can be wrong in certain circumstances (see http://www.freebsd.org/cgi/query-pr.cgi?pr=35703 ). In these cases perl will fall back to the old behaviour of using C's argv[0] value for C<$^X>. =head2 Perl will no longer be part of "base FreeBSD" Not as bad as it sounds--what this means is that Perl will no longer be part of the B of FreeBSD. Perl will still very probably be part of the "default install", and in any case the latest version will be in the ports system. The first FreeBSD version this change will affect is 5.0, all 4.n versions will keep the status quo. =head1 AUTHOR Nicholas Clark , collating wisdom supplied by Slaven Rezic and Tim Bunce. Please report any errors, updates, or suggestions to F. perl-5.12.0-RC0/perlapi.c0000644000175000017500000000557211325125742013742 0ustar jessejesse/* -*- buffer-read-only: t -*- * * perlapi.c * * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * * !!!!!!! DO NOT EDIT THIS FILE !!!!!!! * This file is built by embed.pl from data in embed.fnc, embed.pl, * pp.sym, intrpvar.h, and perlvars.h. * Any changes made here will be lost! * * Edit those files and run 'make regen_headers' to effect changes. * * * Up to the threshold of the door there mounted a flight of twenty-seven * broad stairs, hewn by some unknown art of the same black stone. This * was the only entrance to the tower; ... * * [p.577 of _The Lord of the Rings_, III/x: "The Voice of Saruman"] * */ #include "EXTERN.h" #include "perl.h" #include "perlapi.h" #if defined (MULTIPLICITY) /* accessor functions for Perl variables (provides binary compatibility) */ START_EXTERN_C #undef PERLVAR #undef PERLVARA #undef PERLVARI #undef PERLVARIC #undef PERLVARISC #define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \ { dVAR; PERL_UNUSED_CONTEXT; return &(aTHX->v); } #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \ { dVAR; PERL_UNUSED_CONTEXT; return &(aTHX->v); } #define PERLVARI(v,t,i) PERLVAR(v,t) #define PERLVARIC(v,t,i) PERLVAR(v, const t) #define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX) \ { dVAR; PERL_UNUSED_CONTEXT; return &(aTHX->v); } #include "intrpvar.h" #undef PERLVAR #undef PERLVARA #define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \ { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); } #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \ { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); } #undef PERLVARIC #undef PERLVARISC #define PERLVARIC(v,t,i) \ const t* Perl_##v##_ptr(pTHX) \ { PERL_UNUSED_CONTEXT; return (const t *)&(PL_##v); } #define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX) \ { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); } #include "perlvars.h" #undef PERLVAR #undef PERLVARA #undef PERLVARI #undef PERLVARIC #undef PERLVARISC #ifndef PERL_GLOBAL_STRUCT /* A few evil special cases. Could probably macrofy this. */ #undef PL_ppaddr #undef PL_check #undef PL_fold_locale Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX) { static Perl_ppaddr_t* const ppaddr_ptr = PL_ppaddr; PERL_UNUSED_CONTEXT; return (Perl_ppaddr_t**)&ppaddr_ptr; } Perl_check_t** Perl_Gcheck_ptr(pTHX) { static Perl_check_t* const check_ptr = PL_check; PERL_UNUSED_CONTEXT; return (Perl_check_t**)&check_ptr; } unsigned char** Perl_Gfold_locale_ptr(pTHX) { static unsigned char* const fold_locale_ptr = PL_fold_locale; PERL_UNUSED_CONTEXT; return (unsigned char**)&fold_locale_ptr; } #endif END_EXTERN_C #endif /* MULTIPLICITY */ /* ex: set ro: */ perl-5.12.0-RC0/pod.lst0000444000175000017500000001704511347251146013446 0ustar jessejesse# h - Header # o - Omit from toc # r - top level READMEs to be copied/symlinked # g - other autogenerated pods # a - for auxiliary documentation # number - indent by # D - this version's perldelta # d - copied to this name h Overview perl Perl overview (this section) perlintro Perl introduction for beginners go perltoc Perl documentation table of contents h Tutorials perlreftut Perl references short introduction perldsc Perl data structures intro perllol Perl data structures: arrays of arrays perlrequick Perl regular expressions quick start perlretut Perl regular expressions tutorial perlboot Perl OO tutorial for beginners perltoot Perl OO tutorial, part 1 perltooc Perl OO tutorial, part 2 perlbot Perl OO tricks and examples perlperf Perl Performance and Optimization Techniques perlstyle Perl style guide perlcheat Perl cheat sheet perltrap Perl traps for the unwary perldebtut Perl debugging tutorial perlfaq Perl frequently asked questions 2 perlfaq1 General Questions About Perl 2 perlfaq2 Obtaining and Learning about Perl 2 perlfaq3 Programming Tools 2 perlfaq4 Data Manipulation 2 perlfaq5 Files and Formats 2 perlfaq6 Regexes 2 perlfaq7 Perl Language Issues 2 perlfaq8 System Interaction 2 perlfaq9 Networking h Reference Manual perlsyn Perl syntax perldata Perl data structures perlop Perl operators and precedence perlsub Perl subroutines perlfunc Perl built-in functions 2 perlopentut Perl open() tutorial 2 perlpacktut Perl pack() and unpack() tutorial perlpod Perl plain old documentation perlpodspec Perl plain old documentation format specification perlrun Perl execution and options perldiag Perl diagnostic messages perllexwarn Perl warnings and their control perldebug Perl debugging perlvar Perl predefined variables perlre Perl regular expressions, the rest of the story perlrebackslash Perl regular expression backslash sequences perlrecharclass Perl regular expression character classes perlreref Perl regular expressions quick reference perlref Perl references, the rest of the story perlform Perl formats perlobj Perl objects perltie Perl objects hidden behind simple variables 2 perldbmfilter Perl DBM filters perlipc Perl interprocess communication perlfork Perl fork() information perlnumber Perl number semantics perlthrtut Perl threads tutorial perlport Perl portability guide perllocale Perl locale support perluniintro Perl Unicode introduction perlunicode Perl Unicode support perlunifaq Perl Unicode FAQ g perluniprops Complete index of Unicode Version 5.1.0 properties perlunitut Perl Unicode tutorial perlebcdic Considerations for running Perl on EBCDIC platforms perlsec Perl security perlmod Perl modules: how they work g perlmodlib Perl modules: how to write and use perlmodstyle Perl modules: how to write modules with style perlmodinstall Perl modules: how to install from CPAN perlnewmod Perl modules: preparing a new module for distribution perlpragma Perl modules: writing a user pragma perlutil utilities packaged with the Perl distribution perlcompile Perl compiler suite intro perlfilter Perl source filters perlglossary Perl Glossary h Internals and C Language Interface perlembed Perl ways to embed perl in your C or C++ application perldebguts Perl debugging guts and tips perlxstut Perl XS tutorial perlxs Perl XS application programming interface perlclib Internal replacements for standard C library functions perlguts Perl internal functions for those doing extensions perlcall Perl calling conventions from C perlmroapi Perl method resolution plugin interface perlreapi Perl regular expression plugin interface perlreguts Perl regular expression engine internals g perlapi Perl API listing (autogenerated) g perlintern Perl internal functions (autogenerated) perliol C API for Perl's implementation of IO in Layers perlapio Perl internal IO abstraction interface perlhack Perl hackers guide perlpolicy Perl development policies perlrepository Perl source repository h Miscellaneous perlbook Perl book information perlcommunity Perl community information perltodo Perl things to do perldoc Look up Perl documentation in Pod format perlhist Perl history records D perl5120delta Perl changes in version 5.12.0 d perldelta Perl changes since previous version perl5116delta Perl changes in version 5.11.6 perl5115delta Perl changes in version 5.11.5 perl5114delta Perl changes in version 5.11.4 perl5113delta Perl changes in version 5.11.3 perl5112delta Perl changes in version 5.11.2 perl5111delta Perl changes in version 5.11.1 perl5110delta Perl changes in version 5.11.0 perl5101delta Perl changes in version 5.10.1 perl5100delta Perl changes in version 5.10.0 perl595delta Perl changes in version 5.9.5 perl594delta Perl changes in version 5.9.4 perl593delta Perl changes in version 5.9.3 perl592delta Perl changes in version 5.9.2 perl591delta Perl changes in version 5.9.1 perl590delta Perl changes in version 5.9.0 perl589delta Perl changes in version 5.8.9 perl588delta Perl changes in version 5.8.8 perl587delta Perl changes in version 5.8.7 perl586delta Perl changes in version 5.8.6 perl585delta Perl changes in version 5.8.5 perl584delta Perl changes in version 5.8.4 perl583delta Perl changes in version 5.8.3 perl582delta Perl changes in version 5.8.2 perl581delta Perl changes in version 5.8.1 perl58delta Perl changes in version 5.8.0 perl573delta Perl changes in version 5.7.3 perl572delta Perl changes in version 5.7.2 perl571delta Perl changes in version 5.7.1 perl570delta Perl changes in version 5.7.0 perl561delta Perl changes in version 5.6.1 perl56delta Perl changes in version 5.6 perl5005delta Perl changes in version 5.005 perl5004delta Perl changes in version 5.004 perlartistic Perl Artistic License perlgpl GNU General Public License ho Language-Specific ro perlcn Perl for Simplified Chinese (in EUC-CN) ro perljp Perl for Japanese (in EUC-JP) ro perlko Perl for Korean (in EUC-KR) ro perltw Perl for Traditional Chinese (in Big5) h Platform-Specific r perlaix Perl notes for AIX r perlamiga Perl notes for AmigaOS r perlapollo Perl notes for Apollo DomainOS r perlbeos Perl notes for BeOS r perlbs2000 Perl notes for POSIX-BC BS2000 r perlce Perl notes for WinCE r perlcygwin Perl notes for Cygwin r perldgux Perl notes for DG/UX r perldos Perl notes for DOS r perlepoc Perl notes for EPOC r perlfreebsd Perl notes for FreeBSD r perlhaiku Perl notes for Haiku r perlhpux Perl notes for HP-UX r perlhurd Perl notes for Hurd r perlirix Perl notes for Irix r perllinux Perl notes for Linux r perlmacos Perl notes for Mac OS (Classic) r perlmacosx Perl notes for Mac OS X r perlmpeix Perl notes for MPE/iX r perlnetware Perl notes for NetWare r perlopenbsd Perl notes for OpenBSD r perlos2 Perl notes for OS/2 r perlos390 Perl notes for OS/390 r perlos400 Perl notes for OS/400 r perlplan9 Perl notes for Plan 9 r perlqnx Perl notes for QNX r perlriscos Perl notes for RISC OS r perlsolaris Perl notes for Solaris r perlsymbian Perl notes for Symbian r perltru64 Perl notes for Tru64 r perluts Perl notes for UTS r perlvmesa Perl notes for VM/ESA perlvms Perl notes for VMS r perlvos Perl notes for Stratus VOS r perlwin32 Perl notes for Windows aoh Auxiliary Documentation ao a2p ao c2ph ao dprofpp ao h2ph ao h2xs ao perlbug ao perldoc ao pl2pm ao pod2html ao pod2man ao s2p ao splain ao xsubpp perl-5.12.0-RC0/Makefile.SH0000555000175000017500000014021311342547046014110 0ustar jessejessecase $PERL_CONFIG_SH in '') if test -f config.sh then TOP=. else echo "Can't find config.sh."; exit 1 fi . $TOP/config.sh ;; esac case $CROSS_NAME in '') Makefile=Makefile ;; *) # if cross-compilation, the Makefile named accordingly Makefile=Makefile-cross-$CROSS_NAME . Cross/config-${CROSS_NAME}.sh ;; esac # H.Merijn Brand [17 Feb 2004] # This comment is just to ensure that Configure will find variables that # are removed/replaced in patches on blead, but are still needed in the # 5.8.x, 5.6.x and 5.005.x maintainance tracks. # metaconfig -m will scan all .SH files on this level (not deeper), and # not in x2p and other subfolders. This file is as good as any .SH # patch references # #22227 $baserev # #22302 $yacc $byacc # H.Merijn Brand [30 Oct 2004] # Mentioned for the same reason for future reference # #23434 $d_strlcat $d_strlcpy : This forces SH files to create target in same directory as SH file. : This is so that make depend always knows where to find SH derivatives. case "$0" in */*) cd `expr X$0 : 'X\(.*\)/'` ;; esac linklibperl='$(LIBPERL)' linklibperl_nonshr='' shrpldflags='$(LDDLFLAGS)' ldlibpth='' DPERL_EXTERNAL_GLOB='-DPERL_EXTERNAL_GLOB' DPERL_IS_MINIPERL='-DPERL_IS_MINIPERL' case "$useshrplib" in true) # Prefix all runs of 'miniperl' and 'perl' with # $ldlibpth so that ./perl finds *this* shared libperl. case "$LD_LIBRARY_PATH" in '') ldlibpth="LD_LIBRARY_PATH=`pwd`";; *) ldlibpth="LD_LIBRARY_PATH=`pwd`:${LD_LIBRARY_PATH}";; esac pldlflags="$cccdlflags" static_ldflags='' case "${osname}${osvers}" in next4*) ld=libtool lddlflags="-dynamic -undefined warning -framework System \ -compatibility_version 1 -current_version $patchlevel \ -prebind -seg1addr 0x27000000 -install_name \$(shrpdir)/\$@" ;; rhapsody*|darwin*) shrpldflags="${ldflags} -dynamiclib \ -compatibility_version \ ${api_revision}.${api_version}.${api_subversion} \ -current_version \ ${revision}.${patchlevel}.${subversion} \ -install_name \$(shrpdir)/\$@" ;; cygwin*) shrpldflags="$shrpldflags -Wl,--out-implib=libperl.dll.a -Wl,--image-base,0x52000000" linklibperl="-L. -lperl" ;; sunos*) linklibperl="-lperl" ;; netbsd*|freebsd[234]*|openbsd*|dragonfly*) linklibperl="-L. -lperl" ;; interix*) linklibperl="-L. -lperl" shrpldflags="$shrpldflags -Wl,--image-base,0x57000000" ;; aix*) case "$cc" in gcc*) shrpldflags="-shared -Wl,-H512 -Wl,-T512 -Wl,-bhalt:4 -Wl,-bM:SRE -Wl,-bE:perl.exp" case "$osvers" in 3*) shrpldflags="$shrpldflags -e _nostart" ;; *) shrpldflags="$shrpldflags -Wl,-bnoentry" ;; esac shrpldflags="$shrpldflags $ldflags $perllibs $cryptlib" linklibperl="-L $archlibexp/CORE -L `pwd | sed 's/\/UU$//'` -lperl" linklibperl_nonshr='-lperl_nonshr' ;; *) shrpldflags="-H512 -T512 -bhalt:4 -bM:SRE -bE:perl.exp" case "$osvers" in 3*) shrpldflags="$shrpldflags -e _nostart" ;; *) shrpldflags="$shrpldflags -b noentry" ;; esac shrpldflags="$shrpldflags $ldflags $perllibs $cryptlib" linklibperl="-L $archlibexp/CORE -L `pwd | sed 's/\/UU$//'` -lperl" linklibperl_nonshr='-lperl_nonshr' ;; esac ;; hpux*) linklibperl="-L `pwd | sed 's/\/UU$//'` -Wl,+s -Wl,+b$archlibexp/CORE -lperl" ;; os390*) shrpldflags='-W l,XPLINK,dll' linklibperl='libperl.x' DPERL_EXTERNAL_GLOB='' ;; esac case "$ldlibpthname" in '') ;; *) case "$osname" in os2) ldlibpth='' ;; *) eval "ldlibpth=\"$ldlibpthname=`pwd`:\$$ldlibpthname\"" ;; esac # Strip off any trailing :'s ldlibpth=`echo $ldlibpth | sed 's/:*$//'` ;; esac case "$ldlibpth" in # Protect any spaces *" "*) ldlibpth=`echo $ldlibpth|sed 's/ /\\\\ /g'` ;; esac case "$osname" in linux) # If there is a pre-existing $libperl from a previous # installation, Linux needs to use LD_PRELOAD to # override the LD_LIBRARY_PATH setting. See the # INSTALL file, under "Building a shared perl library". # If there is no pre-existing $libperl, we don't need # to do anything further. if test -f $archlib/CORE/$libperl; then rm -f preload cat <<'EOT' > preload #! /bin/sh lib=$1 shift test -r $lib && export LD_PRELOAD="$lib $LD_PRELOAD" exec "$@" EOT chmod 755 preload ldlibpth="$ldlibpth `pwd`/preload `pwd`/$libperl" fi ;; os390) test -f /bin/env && ldlibpth="/bin/env $ldlibpth" ;; esac ;; *) pldlflags='' static_ldflags='CCCDLFLAGS=' ;; esac : Prepare dependency lists for Makefile. dynamic_list=' ' dynamic_ext_re="lib/auto/re/re.$dlext" extra_dep='' for f in $dynamic_ext; do : the dependency named here will never exist base=`echo "$f" | sed 's/.*\///'` this_target="lib/auto/$f/$base.$dlext" dynamic_list="$dynamic_list $this_target" : Parallel makes reveal that we have some interdependencies case $f in Encode) extra_dep="$extra_dep $this_target: lib/auto/Cwd/Cwd.$dlext" ;; Math/BigInt/FastCalc|Devel/NYTProf) extra_dep="$extra_dep $this_target: lib/auto/List/Util/Util.$dlext" ;; Unicode/Normalize) extra_dep="$extra_dep $this_target: uni.data" ;; Text/ParseWords) extra_dep="$extra_dep $this_target: lib/auto/Scalar/Util.$dlext" ;; esac done static_list=' ' for f in $static_ext; do base=`echo "$f" | sed 's/.*\///'` static_list="$static_list lib/auto/$f/$base\$(LIB_EXT)" : Parallel makes reveal that we have some interdependencies this_target="lib/auto/$f/$base\$(LIB_EXT)" case $f in Math/BigInt/FastCalc|Devel/NYTProf) extra_dep="$extra_dep $this_target: lib/auto/List/Util/Util\$(LIB_EXT)" ;; Unicode/Normalize) extra_dep="$extra_dep $this_target: uni.data" ;; esac done nonxs_list=' ' for f in $nonxs_ext; do p=`echo "$f" | tr / -` for d in ext dist cpan; do if test -d $d/$p; then nonxs_list="$nonxs_list $d/$p/pm_to_blib" fi done done dtrace_h='' dtrace_o='' case "$usedtrace" in define|true) dtrace_h='perldtrace.h' $dtrace -G -s perldtrace.d -o perldtrace.tmp >/dev/null 2>&1 \ && rm -f perldtrace.tmp && dtrace_o='perldtrace$(OBJ_EXT)' ;; esac echo "Extracting $Makefile (with variable substitutions)" $spitshell >$Makefile <>$Makefile <>$Makefile <<'!NO!SUBS!' CCCMD = `sh $(shellflags) cflags "optimize='$(OPTIMIZE)'" $@` CCCMDSRC = `sh $(shellflags) cflags "optimize='$(OPTIMIZE)'" $<` CONFIGPM_FROM_CONFIG_SH = lib/Config.pm lib/Config_heavy.pl CONFIGPM = $(CONFIGPM_FROM_CONFIG_SH) lib/Config_git.pl CONFIGPOD = lib/Config.pod CONFIGH = config.h !NO!SUBS! ;; *) # if cross-compilation $spitshell >>$Makefile <>$Makefile <<'!NO!SUBS!' private = preplibrary $(CONFIGPM) $(CONFIGPOD) lib/ExtUtils/Miniperl.pm git_version.h # Files to be built with variable substitution before miniperl # is available. sh = Makefile.SH cflags.SH config_h.SH makeaperl.SH makedepend.SH \ myconfig.SH writemain.SH pod/Makefile.SH shextract = Makefile cflags config.h makeaperl makedepend \ makedir myconfig writemain pod/Makefile # Files to be built with variable substitution after miniperl is # available. Dependencies handled manually below (for now). pl = pod/pod2html.PL pod/pod2latex.PL pod/pod2man.PL pod/pod2text.PL \ pod/pod2usage.PL pod/podchecker.PL pod/podselect.PL plextract = pod/pod2html pod/pod2latex pod/pod2man pod/pod2text \ pod/pod2usage pod/podchecker pod/podselect addedbyconf = UU $(shextract) $(plextract) pstruct # Unicode data files generated by mktables unidatafiles = lib/unicore/Decomposition.pl lib/unicore/TestProp.pl \ lib/unicore/CombiningClass.pl lib/unicore/Name.pl \ lib/unicore/Heavy.pl lib/unicore/mktables.lst # Directories of Unicode data files generated by mktables unidatadirs = lib/unicore/To lib/unicore/lib h1 = EXTERN.h INTERN.h XSUB.h av.h $(CONFIGH) cop.h cv.h dosish.h h2 = embed.h form.h gv.h handy.h hv.h keywords.h mg.h op.h opcode.h h3 = pad.h patchlevel.h perl.h perlapi.h perly.h pp.h proto.h regcomp.h h4 = regexp.h scope.h sv.h unixish.h util.h iperlsys.h thread.h h5 = utf8.h warnings.h mydtrace.h h = $(h1) $(h2) $(h3) $(h4) $(h5) c1 = av.c scope.c op.c doop.c doio.c dump.c gv.c hv.c mg.c reentr.c mro.c perl.c c2 = perly.c pp.c pp_hot.c pp_ctl.c pp_sys.c regcomp.c regexec.c utf8.c sv.c c3 = taint.c toke.c util.c deb.c run.c universal.c pad.c globals.c c4 = perlio.c perlapi.c numeric.c mathoms.c locale.c pp_pack.c pp_sort.c c5 = $(madlysrc) $(mallocsrc) c = $(c1) $(c2) $(c3) $(c4) $(c5) miniperlmain.c perlmain.c opmini.c perlmini.c obj0 = op$(OBJ_EXT) perl$(OBJ_EXT) obj1 = $(madlyobj) $(mallocobj) gv$(OBJ_EXT) toke$(OBJ_EXT) perly$(OBJ_EXT) pad$(OBJ_EXT) regcomp$(OBJ_EXT) dump$(OBJ_EXT) util$(OBJ_EXT) mg$(OBJ_EXT) reentr$(OBJ_EXT) mro$(OBJ_EXT) obj2 = hv$(OBJ_EXT) av$(OBJ_EXT) run$(OBJ_EXT) pp_hot$(OBJ_EXT) sv$(OBJ_EXT) pp$(OBJ_EXT) scope$(OBJ_EXT) pp_ctl$(OBJ_EXT) pp_sys$(OBJ_EXT) obj3 = doop$(OBJ_EXT) doio$(OBJ_EXT) regexec$(OBJ_EXT) utf8$(OBJ_EXT) taint$(OBJ_EXT) deb$(OBJ_EXT) universal$(OBJ_EXT) globals$(OBJ_EXT) perlio$(OBJ_EXT) perlapi$(OBJ_EXT) numeric$(OBJ_EXT) mathoms$(OBJ_EXT) locale$(OBJ_EXT) pp_pack$(OBJ_EXT) pp_sort$(OBJ_EXT) mini_obj = $(obj1) $(obj2) $(obj3) $(ARCHOBJS) $(DTRACE_O) ndt_obj = $(obj0) $(obj1) $(obj2) $(obj3) $(ARCHOBJS) obj = $(ndt_obj) $(DTRACE_O) perltoc_pod_prereqs = extra.pods pod/perlapi.pod pod/perldelta.pod pod/perlintern.pod pod/perlmodlib.pod pod/perluniprops.pod generated_pods = pod/perltoc.pod $(perltoc_pod_prereqs) Icwd = -Icpan/Cwd -Icpan/Cwd/lib lintflags = \ -b \ -n \ -p \ -Ncheck=%all \ -Nlevel=4 \ -errchk=parentheses \ -errhdr=%all \ -errfmt=src \ -errtags \ -erroff=E_ASSIGN_NARROW_CONV \ -erroff=E_BAD_PTR_CAST \ -erroff=E_BAD_PTR_CAST_ALIGN \ -erroff=E_BAD_PTR_INT_COMBINATION \ -erroff=E_BAD_SIGN_EXTEND \ -erroff=E_BLOCK_DECL_UNUSED \ -erroff=E_CASE_FALLTHRU \ -erroff=E_CONST_EXPR \ -erroff=E_CONSTANT_CONDITION \ -erroff=E_END_OF_LOOP_CODE_NOT_REACHED \ -erroff=E_EQUALITY_NOT_ASSIGNMENT \ -erroff=E_EXPR_NULL_EFFECT \ -erroff=E_FALSE_LOGICAL_EXPR \ -erroff=E_INCL_NUSD \ -erroff=E_LOOP_EMPTY \ -erroff=E_MAIN_PARAM \ -erroff=E_POINTER_TO_OBJECT \ -erroff=E_PTRDIFF_OVERFLOW \ -erroff=E_SHIFT_CNT_NEG_TOO_BIG_L \ -erroff=E_STATIC_UNUSED \ -erroff=E_TRUE_LOGICAL_EXPR splintflags = \ -I/usr/lib/gcc/i486-linux-gnu/4.0.2/include/ \ -D__builtin_va_list=va_list \ -Dsigjmp_buf=jmp_buf \ -warnposix \ \ +boolint \ +charintliteral \ -fixedformalarray \ -mustfreefresh \ -nestedextern \ -predboolint \ -predboolothers \ -preproc \ -boolops \ -shadow \ -nullstate \ +longintegral \ +matchanyintegral \ -type \ \ +line-len 999 \ +weak splintfiles = $(c1) .c$(OBJ_EXT): $(CCCMD) $(PLDLFLAGS) $*.c .c.i: $(CCCMDSRC) -E $*.c > $*.i .c.s: $(CCCMDSRC) -S $*.c all: $(FIRSTMAKEFILE) $(MINIPERL_EXE) miniperl $(generated_pods) $(private) $(unidatafiles) $(public) $(dynamic_ext) $(nonxs_ext) extras.make @echo " "; @echo " Everything is up to date. Type '$(MAKE) test' to run test suite." .PHONY: all translators utilities # Both git_version.h and lib/Config_git.pl are built # by make_patchnum.pl. git_version.h: lib/Config_git.pl lib/Config_git.pl: $(MINIPERL_EXE) make_patchnum.pl $(MINIPERL) make_patchnum.pl # make sure that we recompile perl.c if the git version changes perl$(OBJ_EXT): git_version.h translators: $(MINIPERL_EXE) $(CONFIGPM) $(dynamic_ext) FORCE @echo " "; echo " Making x2p stuff"; cd x2p; $(LDLIBPTH) $(MAKE) all utilities: $(MINIPERL_EXE) $(CONFIGPM) $(plextract) FORCE @echo " "; echo " Making utilities"; cd utils; $(LDLIBPTH) $(MAKE) all # This is now done by installman only if you actually want the man pages. # @echo " "; echo " Making docs"; cd pod; $(MAKE) all; # Phony target to force checking subdirectories. # Apparently some makes require an action for the FORCE target. .PHONY: FORCE FORCE: @sh -c true !NO!SUBS! $spitshell >>$Makefile <>$Makefile <<'!NO!SUBS!' miniperlmain$(OBJ_EXT): miniperlmain.c patchlevel.h $(CCCMD) $(PLDLFLAGS) $*.c perlmain.c: miniperlmain.c config.sh $(FIRSTMAKEFILE) sh writemain $(DYNALOADER) $(static_ext) > perlmain.c perlmain$(OBJ_EXT): perlmain.c $(CCCMD) $(PLDLFLAGS) $*.c # The file ext.libs is a list of libraries that must be linked in # for static extensions, e.g. -lm -lgdbm, etc. The individual # static extension Makefile's add to it. ext.libs: $(static_ext) -@test -f ext.libs || touch ext.libs !NO!SUBS! # How to build libperl. This is still rather convoluted. # Load up custom Makefile.SH fragment for shared loading and executables: case "$osname" in *) Makefile_s="$osname/Makefile.SHs" ;; esac case "$osname" in aix) $spitshell >>$Makefile <>$Makefile <<'!NO!SUBS!' LIBPERL_NONSHR = libperl_nonshr$(LIB_EXT) MINIPERL_NONSHR = miniperl_nonshr$(EXE_EXT) $(LIBPERL_NONSHR): $(obj) $(RMS) $(LIBPERL_NONSHR) $(AR) rcu $(LIBPERL_NONSHR) $(obj) $(MINIPERL_NONSHR): $(LIBPERL_NONSHR) miniperlmain$(OBJ_EXT) opmini$(OBJ_EXT) perlmini$(OBJ_EXT) $(CC) $(LDFLAGS) -o $(MINIPERL_NONSHR) miniperlmain$(OBJ_EXT) \ opmini$(OBJ_EXT) perlmini$(OBJ_EXT) $(LIBPERL_NONSHR) $(LIBS) MINIPERLEXP = $(MINIPERL_NONSHR) LIBPERLEXPORT = perl.exp !NO!SUBS! ;; *) $spitshell >>$Makefile <<'!NO!SUBS!' MINIPERLEXP = $(MINIPERL_EXE) PERLEXPORT = perl.exp !NO!SUBS! ;; esac $spitshell >>$Makefile <<'!NO!SUBS!' perl.exp: $(MINIPERLEXP) makedef.pl config.sh $(SYM) $(SYMH) ./$(MINIPERLEXP) makedef.pl PLATFORM=aix CC_FLAGS="$(OPTIMIZE)" | sort -u | sort -f > perl.exp !NO!SUBS! ;; os2) $spitshell >>$Makefile <<'!NO!SUBS!' MINIPERLEXP = miniperl perl5.def: $(MINIPERLEXP) makedef.pl config.sh $(SYM) $(SYMH) miniperl.map ./$(MINIPERLEXP) makedef.pl PLATFORM=os2 -DPERL_DLL=$(PERL_DLL) CC_FLAGS="$(OPTIMIZE)" > perl5.def !NO!SUBS! ;; cygwin) $spitshell >>$Makefile <<'!NO!SUBS!' cygwin.c: cygwin/cygwin.c $(LNS) cygwin/cygwin.c LIBPERL_NONSHR = libperl$(LIB_EXT) $(LIBPERL_NONSHR): $(obj) $(RMS) $(LIBPERL_NONSHR) $(AR) rcu $(LIBPERL_NONSHR) $(obj) !NO!SUBS! ;; esac if test -s $Makefile_s ; then . $Makefile_s $spitshell >>$Makefile <>$Makefile <<'!NO!SUBS!' $(DTRACE_H): perldtrace.d $(DTRACE) -h -s perldtrace.d -o $(DTRACE_H) mydtrace.h: $(DTRACE_H) !NO!SUBS! ;; esac case "$dtrace_o" in ?*) $spitshell >>$Makefile <<'!NO!SUBS!' $(DTRACE_O): perldtrace.d $(DTRACE) -G -s perldtrace.d -o $(DTRACE_O) $(ndt_obj) !NO!SUBS! ;; esac $spitshell >>$Makefile <<'!NO!SUBS!' $(LIBPERL): $& $(obj) $(DYNALOADER) $(LIBPERLEXPORT) !NO!SUBS! case "$useshrplib" in true) $spitshell >>$Makefile <<'!NO!SUBS!' rm -f $@ $(LD) -o $@ $(SHRPLDFLAGS) $(obj) $(DYNALOADER) $(libs) !NO!SUBS! case "$osname" in aix) $spitshell >>$Makefile <<'!NO!SUBS!' rm -f libperl$(OBJ_EXT) mv $@ libperl$(OBJ_EXT) $(AR) qv $(LIBPERL) libperl$(OBJ_EXT) !NO!SUBS! ;; esac ;; *) $spitshell >>$Makefile <<'!NO!SUBS!' rm -f $(LIBPERL) $(AR) rcu $(LIBPERL) $(obj) $(DYNALOADER) @$(ranlib) $(LIBPERL) !NO!SUBS! ;; esac $spitshell >>$Makefile <<'!NO!SUBS!' # How to build executables. # The $& notation tells Sequent machines that it can do a parallel make, # and is harmless otherwise. # The miniperl -w -MExporter line is a basic cheap test to catch errors # before make goes on to run preplibrary and then MakeMaker on extensions. # This is very handy because later errors are often caused by miniperl # build problems but that's not obvious to the novice. # The Module used here must not depend on Config or any extensions. !NO!SUBS! case "${osname}${osvers}" in aix*|beos*) $spitshell >>$Makefile <<'!NO!SUBS!' $(MINIPERL_EXE): $& miniperlmain$(OBJ_EXT) $(mini_obj) opmini$(OBJ_EXT) perlmini$(OBJ_EXT) $(CC) -o $(MINIPERL_EXE) $(CLDFLAGS) \ $(mini_obj) \ miniperlmain$(OBJ_EXT) opmini$(OBJ_EXT) perlmini$(OBJ_EXT) $(libs) $(LDLIBPTH) $(RUN) ./miniperl$(HOST_EXE_EXT) -w -Ilib -MExporter -e '' || $(MAKE) minitest !NO!SUBS! ;; next4*) $spitshell >>$Makefile <<'!NO!SUBS!' $(MINIPERL_EXE): $& miniperlmain$(OBJ_EXT) $(mini_obj) perlmini$(OBJ_EXT) opmini$(OBJ_EXT) $(CC) -o $(MINIPERL_EXE) $(mini_obj) \ miniperlmain$(OBJ_EXT) opmini$(OBJ_EXT) perlmini$(OBJ_EXT) $(libs) $(LDLIBPTH) $(RUN) ./miniperl$(HOST_EXE_EXT) -w -Ilib -MExporter -e '' || $(MAKE) minitest !NO!SUBS! ;; darwin*) case "$osvers" in [1-6].*) ;; *) case "$ldflags" in *"-flat_namespace"*) ;; *) # to allow opmini.o to override stuff in libperl.dylib $spitshell >>$Makefile <>$Makefile <<'!NO!SUBS!' $(MINIPERL_EXE): $& miniperlmain$(OBJ_EXT) $(mini_obj) opmini$(OBJ_EXT) perlmini$(OBJ_EXT) -@rm -f miniperl.xok $(CC) $(CLDFLAGS) $(NAMESPACEFLAGS) -o $(MINIPERL_EXE) \ $(mini_obj) \ miniperlmain$(OBJ_EXT) opmini$(OBJ_EXT) perlmini$(OBJ_EXT) $(libs) $(LDLIBPTH) $(RUN) ./miniperl$(HOST_EXE_EXT) -w -Ilib -MExporter -e '' || $(MAKE) minitest !NO!SUBS! ;; *) $spitshell >>$Makefile <<'!NO!SUBS!' $(MINIPERL_EXE): $& miniperlmain$(OBJ_EXT) $(mini_obj) opmini$(OBJ_EXT) perlmini$(OBJ_EXT) -@rm -f miniperl.xok $(LDLIBPTH) $(CC) $(CLDFLAGS) -o $(MINIPERL_EXE) \ $(mini_obj) \ miniperlmain$(OBJ_EXT) opmini$(OBJ_EXT) perlmini$(OBJ_EXT) $(libs) $(LDLIBPTH) $(RUN) ./miniperl$(HOST_EXE_EXT) -w -Ilib -MExporter -e '' || $(MAKE) minitest !NO!SUBS! ;; esac $spitshell >>$Makefile <<'!NO!SUBS!' $(PERL_EXE): $& perlmain$(OBJ_EXT) $(LIBPERL) $(static_ext) ext.libs $(PERLEXPORT) -@rm -f miniperl.xok $(SHRPENV) $(LDLIBPTH) $(CC) -o perl$(PERL_SUFFIX) $(PERL_PROFILE_LDFLAGS) $(CLDFLAGS) $(CCDLFLAGS) perlmain$(OBJ_EXT) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) # Purify/Quantify Perls. pure$(PERL_EXE): $& perlmain$(OBJ_EXT) $(LIBPERL) $(static_ext) ext.libs $(PERLEXPORT) $(SHRPENV) $(LDLIBPTH) purify $(CC) -o pureperl $(CLDFLAGS) $(CCDLFLAGS) perlmain$(OBJ_EXT) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) purecov$(PERL_EXE): $& perlmain$(OBJ_EXT) $(LIBPERL) $(static_ext) ext.libs $(PERLEXPORT) $(SHRPENV) $(LDLIBPTH) purecov $(CC) -o purecovperl $(CLDFLAGS) $(CCDLFLAGS) perlmain$(OBJ_EXT) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) quant$(PERL_EXE): $& perlmain$(OBJ_EXT) $(LIBPERL) $(static_ext) ext.libs $(PERLEXPORT) $(SHRPENV) $(LDLIBPTH) quantify $(CC) -o quantperl $(CLDFLAGS) $(CCDLFLAGS) perlmain$(OBJ_EXT) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) # Valgrind perl (currently Linux only) perl.valgrind.config: config.sh @echo "To build perl.valgrind you must Configure -Doptimize=-g -Uusemymalloc, checking..." @$(MAKE) perl.config.dashg @echo "Checking usemymalloc='n' in config.sh..." @grep "^usemymalloc=" config.sh @grep "^usemymalloc='n'" config.sh >/dev/null || exit 1 @echo "And of course you have to have valgrind..." $(VALGRIND) ./perl -e 1 2>/dev/null || exit 1 # Third Degree Perl (Tru64 only) perl.config.dashg: @echo "Checking optimize='-g' in config.sh..." @grep "^optimize=" config.sh @egrep "^optimize='(.*-g.*)'" config.sh >/dev/null || exit 1 perl.third.config: config.sh @echo "To build perl.third you must Configure -Doptimize=-g -Uusemymalloc, checking..." @$(MAKE) perl.config.dashg @echo "Checking usemymalloc='n' in config.sh..." @grep "^usemymalloc=" config.sh @grep "^usemymalloc='n'" config.sh >/dev/null || exit 1 perl.third: /usr/bin/atom perl.third.config perl atom -tool third -L. -all -gp -toolargs="-invalid -uninit heap+stack+copy -min 0" perl @echo "Now you may run perl.third and then study perl.3log." # Pixie Perls (Tru64 and IRIX only) perl.pixie.config: config.sh @echo "To build perl.pixie you must Configure -Doptimize=-g, checking..." @$(MAKE) perl.config.dashg perl.pixie.atom: /usr/bin/atom perl atom -tool pixie -L. -all -toolargs="-quiet" perl perl.pixie.irix: perl pixie perl perl.pixie: /usr/bin/pixie perl.pixie.config perl if test -x /usr/bin/atom; then \ $(MAKE) perl.pixie.atom; \ else \ $(MAKE) perl.pixie.irix; \ fi @echo "Now you may run perl.pixie and then run pixie." # Gprof Perl perl.config.dashpg: @echo "Checking optimize='-pg' in config.sh..." @grep "^optimize=" config.sh @grep "^optimize='.*-pg.*'" config.sh >/dev/null || exit 1 perl.gprof.config: config.sh @echo "To build perl.gprof you must Configure -Doptimize=-pg, checking..." @$(MAKE) perl.config.dashpg perl.gprof: /usr/bin/gprof perl.gprof.config @-rm -f perl $(MAKE) PERL_SUFFIX=.gprof PERL_PROFILE_LDFLAGS=-pg perl @echo "Now you may run perl.gprof and then run gprof perl.gprof." # Gcov Perl perl.config.gcov: @echo "To build perl.gcov you must use gcc 3.0 or newer, checking..." @echo "Checking gccversion in config.sh..." @grep "^gccversion=" config.sh @grep "^gccversion='[3-9]\." config.sh >/dev/null || exit 1 @echo "To build perl.gcov you must Configure -Dccflags=-fprofile-arcs -ftest-coverage, checking..." @echo "Checking ccflags='-fprofile-arcs -ftest-coverage' in config.sh..." @grep "^ccflags=" config.sh @grep "^ccflags='.*-fprofile-arcs -ftest-coverage.*'" config.sh >/dev/null || exit 1 perl.gcov: perl.config.gcov @-rm -f perl $(MAKE) PERL_SUFFIX=.gcov PERL_PROFILE_LDFLAGS='' perl @echo "Now you may run perl.gcov and then run gcov some.c." # Microperl. This is just a convenience thing if one happens to # build also the full Perl and therefore the real big Makefile: # usually one should manually explicitly issue the below command. .PHONY: microperl microperl: $(MAKE) -f Makefile.micro !NO!SUBS! fi # Some environment have no system(), which mkpport uses. # Let's try running the commands with shell. case "${osname}" in catamount) $spitshell >>$Makefile <>$Makefile <<'!NO!SUBS!' .PHONY: makeppport makeppport: $(MINIPERL_EXE) $(CONFIGPM) $(nonxs_ext) $(MINIPERL) $(Icwd) mkppport !NO!SUBS! ;; esac $spitshell >>$Makefile <<'!NO!SUBS!' .PHONY: preplibrary preplibrary: $(MINIPERL_EXE) $(CONFIGPM) lib/re.pm $(PREPLIBRARY_LIBPERL) $(CONFIGPM_FROM_CONFIG_SH): $(CONFIGPOD) $(CONFIGPOD): config.sh $(MINIPERL_EXE) configpm Porting/Glossary lib/Config_git.pl $(MINIPERL) configpm lib/ExtUtils/Miniperl.pm: miniperlmain.c $(MINIPERL_EXE) minimod.pl $(CONFIGPM) $(MINIPERL) minimod.pl > lib/ExtUtils/Miniperl.pm lib/re.pm: ext/re/re.pm @-rm -f $@ cp ext/re/re.pm lib/re.pm $(plextract): $(MINIPERL_EXE) $(CONFIGPM) x2p/s2p $(dynamic_ext) @-rm -f $@ $(MINIPERL) $@.PL x2p/s2p: $(MINIPERL_EXE) $(CONFIGPM) $(dynamic_ext) x2p/s2p.PL cd x2p; $(LDLIBPTH) $(MAKE) s2p unidatafiles $(unidatafiles) pod/perluniprops.pod: uni.data uni.data: $(MINIPERL_EXE) $(CONFIGPM) lib/unicore/mktables $(nonxs_ext) $(MINIPERL) $(Icwd) lib/unicore/mktables -C lib/unicore -P pod -maketest -makelist -p # Commented out so always runs, mktables looks at far more files than we # can in this makefile to decide if needs to run or not # touch uni.data # $(PERL_EXE) and ext because buildtoc uses Text::Wrap uses re # But also this ensures that all extensions are built before we try to scan # them, which picks up Devel::PPPort's documentation. pod/perltoc.pod: $(perltoc_pod_prereqs) $(PERL_EXE) $(ext) pod/buildtoc $(RUN_PERL) -f -Ilib pod/buildtoc --build-toc -q pod/perlapi.pod: pod/perlintern.pod pod/perlintern.pod: $(MINIPERL_EXE) autodoc.pl embed.fnc $(MINIPERL) autodoc.pl pod/perlmodlib.pod: $(MINIPERL_EXE) pod/perlmodlib.PL MANIFEST $(MINIPERL) $(Icwd) pod/perlmodlib.PL -q pod/perldelta.pod: pod/perl5116delta.pod $(LNS) perl5116delta.pod pod/perldelta.pod extra.pods: $(MINIPERL_EXE) -@test ! -f extra.pods || rm -f `cat extra.pods` -@rm -f extra.pods -@for x in `grep -l '^=[a-z]' README.* | grep -v README.vms` ; do \ nx=`echo $$x | sed -e "s/README\.//"`; \ $(LNS) ../$$x "pod/perl"$$nx".pod" ; \ echo "pod/perl"$$nx".pod" >> extra.pods ; \ done extras.make: $(PERL_EXE) -@test ! -s extras.lst || PATH="`pwd`:${PATH}" PERL5LIB="`pwd`/lib" $(RUN_PERL) -Ilib -MCPAN -e '@ARGV&&make(@ARGV)' `cat extras.lst` extras.test: $(PERL_EXE) -@test ! -s extras.lst || PATH="`pwd`:${PATH}" PERL5LIB="`pwd`/lib" $(RUN_PERL) -Ilib -MCPAN -e '@ARGV&&test(@ARGV)' `cat extras.lst` extras.install: $(PERL_EXE) -@test ! -s extras.lst || PATH="`pwd`:${PATH}" PERL5LIB="`pwd`/lib" $(RUN_PERL) -Ilib -MCPAN -e '@ARGV&&install(@ARGV)' `cat extras.lst` .PHONY: install install-strip install-all install-verbose install-silent \ no-install install.perl install.man install.html META.yml: Porting/makemeta Porting/Maintainers.pl Porting/Maintainers.pm PATH="`pwd`:${PATH}" PERL5LIB="`pwd`/lib" $(RUN_PERL) -Ilib Porting/makemeta install-strip: $(MAKE) STRIPFLAGS=-s install DESTDIR="$(DESTDIR)" install install-all: $(MAKE) install.perl install.man STRIPFLAGS=$(STRIPFLAGS) DESTDIR="$(DESTDIR)" install-verbose: $(MAKE) install.perl install.man STRIPFLAGS=$(STRIPFLAGS) INSTALLFLAGS=-V DESTDIR="$(DESTDIR)" install-silent: $(MAKE) install.perl install.man STRIPFLAGS=$(STRIPFLAGS) INSTALLFLAGS=-S DESTDIR="$(DESTDIR)" no-install: $(MAKE) install.perl install.man STRIPFLAGS=$(STRIPFLAGS) INSTALLFLAGS=-n DESTDIR="$(DESTDIR)" # Set this to an empty string to avoid an attempt of rebuild before install INSTALL_DEPENDENCE = all install.perl: $(INSTALL_DEPENDENCE) installperl $(RUN_PERL) installperl --destdir=$(DESTDIR) $(INSTALLFLAGS) $(STRIPFLAGS) -@test ! -s extras.lst || $(MAKE) extras.install install.man: all installman $(RUN_PERL) installman --destdir=$(DESTDIR) $(INSTALLFLAGS) # XXX Experimental. Hardwired values, but useful for testing. # Eventually Configure could ask for some of these values. install.html: all installhtml -@test -f README.vms && cd vms && $(LNS) ../README.vms README_vms.pod && cd .. $(RUN_PERL) installhtml \ --podroot=. --podpath=. --recurse \ --htmldir=$(privlib)/html \ --htmlroot=$(privlib)/html \ --splithead=pod/perlipc \ --splititem=pod/perlfunc \ --libpods=perlfunc:perlguts:perlvar:perlrun:perlop \ --ignore=Porting/Maintainers.pm,Porting/pumpkin.pod,Porting/repository.pod \ --verbose # I now supply perly.c with the kits, so the following section is # used only if you force bison to run by saying # make regen_perly # You normally shouldn't remake perly.[ch]. .PHONY: regen_perly run_byacc: @echo "run_byacc is obsolete; try 'make regen_perly' instead" # this outputs perly.h, perly.act and perly.tab regen_perly: perl regen_perly.pl # We don't want to regenerate perly.c and perly.h, but they might # appear out-of-date after a patch is applied or a new distribution is # made. perly.c: perly.y -@sh -c true perly.h: perly.y -@sh -c true # No compat3.sym here since and including the 5.004_50. # No interp.sym since 5.005_03. SYM = global.sym globvar.sym perlio.sym pp.sym SYMH = perlvars.h intrpvar.h CHMOD_W = chmod +w # The following files are generated automatically # embed.pl: proto.h embed.h embedvar.h global.sym # perlapi.h perlapi.c # [* embed.pl needs pp.sym generated by opcode.pl! *] # keywords.pl: keywords.h # opcode.pl: opcode.h opnames.h pp_proto.h pp.sym # regcomp.pl: regnodes.h # warnings.pl: warnings.h lib/warnings.pm # The correct versions should be already supplied with the perl kit, # in case you don't have perl available. # To force them to be regenerated, run # perl regen.pl # with your existing copy of perl # (make regen_headers is kept for backwards compatibility) AUTOGEN_FILES = keywords.h opcode.h opnames.h pp_proto.h pp.sym proto.h \ embed.h embedvar.h global.sym \ perlapi.h perlapi.c regnodes.h \ warnings.h lib/warnings.pm .PHONY: regen_headers regen_all regen: FORCE -perl regen.pl regen_headers: FORCE -perl regen.pl -v regen_all: regen .PHONY: manisort manicheck manisort: FORCE @perl Porting/manisort -q || (echo "WARNING: re-sorting MANIFEST"; \ perl Porting/manisort -q -o MANIFEST; sh -c true) manicheck: FORCE perl Porting/manicheck # Extensions: # Names added to $(dynamic_ext) or $(static_ext) or $(nonxs_ext) will # automatically get built. There should ordinarily be no need to change # any of this part of makefile. # # The dummy dependency is a place holder in case $(dynamic_ext) or # $(static_ext) is empty. # # DynaLoader may be needed for extensions that use Makefile.PL. $(DYNALOADER): $(MINIPERL_EXE) preplibrary FORCE $(nonxs_ext) $(MINIPERL) make_ext.pl $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) LINKTYPE=static $(STATIC_LDFLAGS) d_dummy $(dynamic_ext): $(MINIPERL_EXE) preplibrary makeppport $(DYNALOADER) FORCE $(PERLEXPORT) $(MINIPERL) make_ext.pl $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) LINKTYPE=dynamic s_dummy $(static_ext): $(MINIPERL_EXE) preplibrary makeppport $(DYNALOADER) FORCE $(MINIPERL) make_ext.pl $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) LINKTYPE=static $(STATIC_LDFLAGS) n_dummy $(nonxs_ext): $(MINIPERL_EXE) preplibrary FORCE $(MINIPERL) make_ext.pl $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) !NO!SUBS! $spitshell >>$Makefile <>$Makefile <<'!NO!SUBS!' .PHONY: printconfig printconfig: @eval `$(RUN_PERL) -Ilib -V:$(CONFIGVAR)`; echo $$$(CONFIGVAR) .PHONY: clean _tidy _mopup _cleaner1 _cleaner2 \ realclean _realcleaner clobber _clobber \ distclean veryclean _verycleaner clean: _tidy _mopup realclean: _realcleaner _mopup @echo "Note that '$(MAKE) realclean' does not delete config.sh or Policy.sh" _clobber: -@rm -f Cross/run-* Cross/to-* Cross/from-* rm -f t/test_state rm -f config.sh cppstdin Policy.sh extras.lst clobber: _realcleaner _mopup _clobber distclean: clobber # Like distclean but also removes emacs backups and *.orig. veryclean: _verycleaner _mopup _clobber -@rm -f Obsolete Wanted # Do not 'make _mopup' directly. _mopup: rm -f *$(OBJ_EXT) *$(LIB_EXT) all perlmain.c opmini.c perlmini.c uudmap.h generate_uudmap$(EXE_EXT) bitcount.h -rmdir .depending -@test -f extra.pods && rm -f `cat extra.pods` -@test -f vms/README_vms.pod && rm -f vms/README_vms.pod -rm -f perl.exp ext.libs $(generated_pods) uni.data opmini.o perlmini.o -rm -f perl.export perl.dll perl.libexp perl.map perl.def -rm -f perl.loadmap miniperl.loadmap perl.prelmap miniperl.prelmap -rm -f perl.third lib*.so.perl.third perl.3log t/perl.third t/perl.3log -rm -f perl.pixie lib*.so.perl.pixie lib*.so.Addrs -rm -f perl.Addrs perl.Counts t/perl.Addrs t/perl.Counts *perl.xok -rm -f cygwin.c libperl*.def libperl*.dll cygperl*.dll *.exe.stackdump -rm -f $(PERL_EXE) $(MINIPERL_EXE) $(LIBPERL) libperl.* microperl -rm -f opcode.h-old opnames.h-old pp.sym-old pp_proto.h-old -rm -f config.arch config.over $(DTRACE_H) runtests # Do not 'make _tidy' directly. _tidy: -cd pod; $(LDLIBPTH) $(MAKE) clean -cd utils; $(LDLIBPTH) $(MAKE) clean -cd x2p; $(LDLIBPTH) $(MAKE) clean -rm -f lib/Config_git.pl git_version.h -@for x in $(DYNALOADER) $(dynamic_ext) $(static_ext) $(nonxs_ext) ; do \ $(MINIPERL) make_ext.pl --target=clean $$x MAKE=$(MAKE) ; \ done _cleaner1: -cd os2; rm -f Makefile -cd pod; $(LDLIBPTH) $(MAKE) $(CLEAN) -cd utils; $(LDLIBPTH) $(MAKE) $(CLEAN) -cd x2p; $(LDLIBPTH) $(MAKE) $(CLEAN) -@if test -f $(MINIPERL_EXE) ; then \ for x in $(DYNALOADER) $(dynamic_ext) $(static_ext) $(nonxs_ext) ; do \ $(MINIPERL) make_ext.pl --target=$(CLEAN) $$x MAKE=$(MAKE) ; \ done ; \ else \ sh $(CLEAN).sh ; \ fi rm -f realclean.sh veryclean.sh -for file in `find cpan dist ext -name ppport.h` ; do rm -f $$file; done # Dear POSIX, thanks for making the default to xargs to be # run once if nothhing is passed in. It is such a great help. # Some systems do not support "?", so keep these files separate. _cleaner2: -rm -f core.*perl.*.? t/core.perl.*.? .?*.c rm -f core *perl.core t/core t/*perl.core core.* t/core.* rm -f t/misctmp* t/forktmp* t/tmp* t/c t/$(PERL_EXE) t/rantests rm -f so_locations $(LIBPERL_NONSHR) $(MINIPERL_NONSHR) rm -rf $(addedbyconf) rm -f $(FIRSTMAKEFILE) $(FIRSTMAKEFILE).old makefile.old rm -f $(private) rm -rf $(unidatafiles) $(unidatadirs) rm -rf lib/auto rm -f lib/.exists lib/*/.exists lib/*/*/.exists rm -f h2ph.man pstruct rm -rf .config rm -f preload lib/re.pm rm -rf lib/Encode lib/Compress lib/Hash lib/re rm -rf lib/TAP lib/Module/Pluggable lib/App rm -rf lib/mro rm -rf lib/IO/Compress lib/IO/Uncompress rm -f lib/ExtUtils/ParseXS/t/XSTest.c rm -f lib/ExtUtils/ParseXS/t/XSTest$(OBJ_EXT) rm -f lib/ExtUtils/ParseXS/t/XSTest$(DLSUFFIX) rm -fr lib/B rm -fr lib/CPAN lib/CPANPLUS rm -fr lib/ExtUtils/CBuilder -rmdir cpan/CPANPLUS-Dist-Build/t/dummy-cpanplus cpan/CPANPLUS/t/dummy-cpanplus cpan/CPANPLUS/t/dummy-localmirror -rmdir ext/B/lib -rmdir lib/Archive/Tar lib/Archive lib/Attribute -rmdir lib/CGI -rmdir lib/Data lib/Devel lib/Digest -rmdir lib/ExtUtils/Command lib/ExtUtils/Constant lib/ExtUtils/Liblist lib/ExtUtils/MakeMaker -rmdir lib/File/Spec lib/Filter/Util lib/Filter -rmdir lib/I18N/LangTags lib/IO/Socket lib/IO lib/IPC -rmdir lib/List/Util lib/List -rmdir lib/Locale/Maketext lib/Locale -rmdir lib/Log/Message lib/Log -rmdir lib/Math/Big* lib/Math -rmdir lib/Memoize lib/MIME -rmdir lib/Module/Build/Platform lib/Module/Build lib/Module/Load lib/Module -rmdir lib/Net/FTP lib/Object -rmdir lib/Parse/CPAN lib/Parse -rmdir lib/PerlIO/via lib/PerlIO -rmdir lib/Package lib/Params -rmdir lib/Pod/Perldoc lib/Pod/Simple lib/Pod/Text -rmdir lib/Sys lib/Scalar/Util lib/Scalar -rmdir lib/Term/UI lib/Thread -rmdir lib/Test/Builder/Tester lib/Test/Builder lib/Test -rmdir lib/Unicode/Collate -rmdir lib/XS/APItest lib/XS -rmdir lib/inc/latest lib/inc -rmdir lib/autodie/exception lib/autodie lib/encoding lib/threads -rm -f lib/ExtUtils/CBuilder/t/libcompilet.dll.a -rm -f lib/ExtUtils/ParseXS/t/libXSTest.dll.a _realcleaner: @$(LDLIBPTH) $(MAKE) _cleaner1 CLEAN=distclean @$(LDLIBPTH) $(MAKE) _cleaner2 _verycleaner: @$(LDLIBPTH) $(MAKE) _cleaner1 CLEAN=veryclean @$(LDLIBPTH) $(MAKE) _cleaner2 -rm -f *~ *.orig */*~ */*.orig */*/*~ */*/*.orig .PHONY: lint lint: $(c) rm -f *.ln lint $(lintflags) -DPERL_CORE -D_REENTRANT -DDEBUGGING -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 $(c) .PHONY: splint splint: $(c) splint $(splintflags) -DPERL_CORE -D_REENTRANT -DDEBUGGING -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 $(splintfiles) # Need to unset during recursion to go out of loop. # The README below ensures that the dependency list is never empty and # that when MAKEDEPEND is empty $(FIRSTMAKEFILE) doesn't need rebuilding. MAKEDEPEND = Makefile makedepend $(FIRSTMAKEFILE): README $(MAKEDEPEND) $(MAKE) depend MAKEDEPEND= config.h: config_h.SH config.sh $(SHELL) config_h.SH # When done, touch perlmain.c so that it doesn't get remade each time. .PHONY: depend depend: makedepend sh ./makedepend MAKE=$(MAKE) - test -s perlmain.c && touch perlmain.c cd x2p; $(MAKE) depend # Cannot postpone this until $firstmakefile is ready ;-) makedepend: makedepend.SH config.sh sh ./makedepend.SH runtests: runtests.SH config.sh sh ./runtests.SH .PHONY: test check test_prep test_prep_nodll test_prep_pre \ test_prep_reonly test_tty test-tty test_notty test-notty \ utest ucheck test.utf8 check.utf8 test.torture torturetest \ test.utf16 check.utf16 utest.utf16 ucheck.utf16 \ test.third check.third utest.third ucheck.third test_notty.third \ test.deparse test_notty.deparse test_harness test_harness_notty \ minitest coretest test.taintwarn test-reonly _test _test: echo >&2 The _test target is deprecated. Please upgrade your smoker PERL=./perl $(RUN_TESTS) choose # Cannot delegate rebuilding of t/perl to make # to allow interlaced test and minitest # Architecture-neutral stuff: test_prep_pre: preplibrary utilities $(nonxs_ext) test_prep: test_prep_pre $(MINIPERL_EXE) $(unidatafiles) $(PERL_EXE) $(dynamic_ext) $(TEST_PERL_DLL) runtests cd t && (rm -f $(PERL_EXE); $(LNS) ../$(PERL_EXE) $(PERL_EXE)) test_prep_reonly: $(MINIPERL_EXE) $(PERL_EXE) $(dynamic_ext_re) $(TEST_PERL_DLL) $(MINIPERL) make_ext.pl $(dynamic_ext_re) MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) LINKTYPE=dynamic cd t && (rm -f $(PERL_EXE); $(LNS) ../$(PERL_EXE) $(PERL_EXE)) test check: test_prep $(RUN_TESTS) choose test_tty: test_prep $(RUN_TESTS) tty test_notty: test_prep $(RUN_TESTS) no-tty utest ucheck test.utf8 check.utf8: test_prep TEST_ARGS=-utf8 $(RUN_TESTS) choose coretest: test_prep TEST_ARGS=-core $(RUN_TESTS) choose test-prep: test_prep test-tty: test_tty test-notty: test_notty # Torture testing test.torture torturetest: test_prep TEST_ARGS=-torture $(RUN_TESTS) choose # Targets for UTF16 testing: minitest.utf16: minitest.prep - cd t && (rm -f $(PERL_EXE); $(LNS) ../$(MINIPERL_EXE) $(PERL_EXE)) \ && $(RUN_PERL) TEST -minitest -utf16 base/*.t comp/*.t cmd/*.t run/*.t io/*.t op/*.t uni/*.t .clist hlist: $(h) echo $(h) | tr ' ' $(TRNL) >.hlist shlist: $(sh) echo $(sh) | tr ' ' $(TRNL) >.shlist pllist: $(pl) echo $(pl) | tr ' ' $(TRNL) >.pllist Makefile: Makefile.SH ./config.sh $(SHELL) Makefile.SH .PHONY: distcheck distcheck: FORCE perl '-MExtUtils::Manifest=&fullcheck' -e 'fullcheck()' .PHONY: elc elc: emacs/cperl-mode.elc emacs/cperl-mode.elc: emacs/cperl-mode.el -cd emacs; emacs -batch -q -no-site-file -f batch-byte-compile cperl-mode.el .PHONY: etags ctags tags etags: TAGS TAGS: emacs/cperl-mode.elc sh emacs/ptags # Let's hope make will not go into an infinite loop on case-unsensitive systems # This may also fail if . is in the head of the path, since perl will # require -Ilib tags: TAGS perl emacs/e2ctags.pl TAGS > tags ctags: ctags -f Tags -N --totals --languages=c --langmap=c:+.h --exclude=opmini.c --exclude=perlmini.c *.c *.h # AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE # If this runs make out of memory, delete /usr/include lines. !NO!SUBS! $eunicefix Makefile case `pwd` in *SH) $rm -f ../Makefile $ln Makefile ../Makefile ;; esac $rm -f $firstmakefile # Now do any special processing required before building. case "$ebcdic" in define) xxx='' echo "This is an EBCDIC system, checking if any parser files need regenerating." >&2 case "$osname" in os390|posix-bc) if cd x2p then rm -f y.tab.c y.tab.h case "$osname" in posix-bc) # we are using two different yaccs in BS2000 Posix! byacc a2p.y >/dev/null 2>&1 ;; *) # e.g. os390 yacc a2p.y >/dev/null 2>&1 ;; esac if cmp -s y.tab.c a2p.c then rm -f y.tab.c else echo "a2p.y -> a2p.c" >&2 mv -f y.tab.c a2p.c chmod u+w a2p.c sed -e 's/fprintf *( *stderr *,/PerlIO_printf(Perl_debug_log,/g' \ -e 's|^static void __YY_YACC_MAIN.*BS2000.*|/*static main deleted*/|' \ -e 's/y\.tab/a2p/g' a2p.c >a2p.tmp && mv a2p.tmp a2p.c xxx="$xxx a2p.c" fi # In case somebody yacc -d:ed the a2p.y. if test -f y.tab.h then if cmp -s y.tab.h a2p.h then rm -f y.tab.h else echo "a2p.h -> a2p.h" >&2 mv -f y.tab.h a2p.h xxx="$xxx a2p.h" fi fi cd .. fi ;; vmesa) # Do nothing in VM/ESA. ;; *) echo "'$osname' is an EBCDIC system I don't know that well." >&4 ;; esac case "$xxx" in '') echo "No parser files were regenerated. That's okay." >&2 ;; esac ;; esac # ex: set ts=8 sts=4 sw=4 noet: perl-5.12.0-RC0/av.h0000444000175000017500000000560011325127001012675 0ustar jessejesse/* av.h * * Copyright (C) 1991, 1992, 1993, 1995, 1996, 1997, 1998, 1999, 2000, * 2001, 2002, 2005, 2006, 2007, 2008, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ struct xpvav { union _xnvu xnv_u; SSize_t xav_fill; /* Index of last element present */ SSize_t xav_max; /* max index for which array has space */ _XPVMG_HEAD; }; /* SV** xav_alloc; */ #define xav_alloc xiv_u.xivu_p1 /* SV* xav_arylen; */ /* SVpav_REAL is set for all AVs whose xav_array contents are refcounted. * Some things like "@_" and the scratchpad list do not set this, to * indicate that they are cheating (for efficiency) by not refcounting * the AV's contents. * * SVpav_REIFY is only meaningful on such "fake" AVs (i.e. where SVpav_REAL * is not set). It indicates that the fake AV is capable of becoming * real if the array needs to be modified in some way. Functions that * modify fake AVs check both flags to call av_reify() as appropriate. * * Note that the Perl stack and @DB::args have neither flag set. (Thus, * items that go on the stack are never refcounted.) * * These internal details are subject to change any time. AV * manipulations external to perl should not care about any of this. * GSAR 1999-09-10 */ /* =head1 Handy Values =for apidoc AmU||Nullav Null AV pointer. (deprecated - use C<(AV *)NULL> instead) =head1 Array Manipulation Functions =for apidoc Am|int|AvFILL|AV* av Same as C. Deprecated, use C instead. =cut */ #ifndef PERL_CORE # define Nullav Null(AV*) #endif #define AvARRAY(av) ((av)->sv_u.svu_array) #define AvALLOC(av) (*((SV***)&((XPVAV*) SvANY(av))->xav_alloc)) #define AvMAX(av) ((XPVAV*) SvANY(av))->xav_max #define AvFILLp(av) ((XPVAV*) SvANY(av))->xav_fill #define AvARYLEN(av) (*Perl_av_arylen_p(aTHX_ MUTABLE_AV(av))) #define AvREAL(av) (SvFLAGS(av) & SVpav_REAL) #define AvREAL_on(av) (SvFLAGS(av) |= SVpav_REAL) #define AvREAL_off(av) (SvFLAGS(av) &= ~SVpav_REAL) #define AvREAL_only(av) (AvREIFY_off(av), SvFLAGS(av) |= SVpav_REAL) #define AvREIFY(av) (SvFLAGS(av) & SVpav_REIFY) #define AvREIFY_on(av) (SvFLAGS(av) |= SVpav_REIFY) #define AvREIFY_off(av) (SvFLAGS(av) &= ~SVpav_REIFY) #define AvREIFY_only(av) (AvREAL_off(av), SvFLAGS(av) |= SVpav_REIFY) #define AvREALISH(av) (SvFLAGS(av) & (SVpav_REAL|SVpav_REIFY)) #define AvFILL(av) ((SvRMAGICAL((const SV *) (av))) \ ? mg_size(MUTABLE_SV(av)) : AvFILLp(av)) #define NEGATIVE_INDICES_VAR "NEGATIVE_INDICES" /* =for apidoc newAV Creates a new AV. The reference count is set to 1. =cut */ #define newAV() MUTABLE_AV(newSV_type(SVt_PVAV)) /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */ perl-5.12.0-RC0/vmesa/0000755000175000017500000000000011351321567013246 5ustar jessejesseperl-5.12.0-RC0/vmesa/vmesaish.h0000444000175000017500000000035411143650501015226 0ustar jessejesse#ifndef _VMESA_INCLUDED # define _VMESA_INCLUDED 1 # include # include # include void * dlopen(const char *); void * dlsym(void *, const char *); void * dlerror(void); # define OLD_PTHREADS_API #endif perl-5.12.0-RC0/vmesa/vmesa.c0000444000175000017500000005077211325125742014534 0ustar jessejesse/************************************************************/ /* */ /* Module ID - vmesa.c */ /* */ /* Function - Provide operating system dependent process- */ /* ing for perl under VM/ESA. */ /* */ /* Parameters - See individual entry points. */ /* */ /* Called By - N/A - see individual entry points. */ /* */ /* Calling To - N/A - see individual entry points. */ /* */ /* Notes - (1) ....................................... */ /* */ /* (2) ....................................... */ /* */ /* Name - Neale Ferguson. */ /* */ /* Date - August, 1998. */ /* */ /* */ /* Associated - (1) Refer To ........................... */ /* Documentation */ /* (2) Refer To ........................... */ /* */ /************************************************************/ /************************************************************/ /* */ /* MODULE MAINTENANCE HISTORY */ /* -------------------------- */ /* */ static char REQ_REL_WHO [13] = /*-------------- -------------------------------------*/ "9999_99 NAF "; /* Original module */ /* */ /*============ End of Module Maintenance History ===========*/ /************************************************************/ /* */ /* DEFINES */ /* ------- */ /* */ /************************************************************/ #define FAIL 65280 /*=============== END OF DEFINES ===========================*/ /************************************************************/ /* */ /* INCLUDE STATEMENTS */ /* ------------------ */ /* */ /************************************************************/ #include #include #include #include #include #include #include #include "EXTERN.h" #include "perl.h" #pragma map(truncate, "@@TRUNC") /*================== End of Include Statements =============*/ /************************************************************/ /* */ /* Global Variables */ /* ---------------- */ /* */ /************************************************************/ static int Perl_stdin_fd = STDIN_FILENO, Perl_stdout_fd = STDOUT_FILENO; static long dl_retcode = 0; /*================== End of Global Variables ===============*/ /************************************************************/ /* */ /* FUNCTION PROTOTYPES */ /* ------------------- */ /* */ /************************************************************/ int do_aspawn(SV *, SV **, SV **); int do_spawn(char *, int); static int spawnit(char *); static pid_t spawn_cmd(char *, int, int); struct perl_thread * getTHR(void); /*================== End of Prototypes =====================*/ /************************************************************/ /* */ /* D O _ A S P A W N */ /* ----------------- */ /* */ /************************************************************/ int do_aspawn(SV* really, SV **mark, SV **sp) { char **a, *tmps; struct inheritance inherit; pid_t pid; int status, fd, nFd, fdMap[3]; SV *sv, **p_sv; STRLEN n_a; status = FAIL; if (sp > mark) { Newx(PL_Argv, sp - mark + 1, char*); a = PL_Argv; while (++mark <= sp) { if (*mark) *a++ = SvPVx(*mark, n_a); else *a++ = ""; } inherit.flags = SPAWN_SETGROUP; inherit.pgroup = SPAWN_NEWPGROUP; fdMap[STDIN_FILENO] = Perl_stdin_fd; fdMap[STDOUT_FILENO] = Perl_stdout_fd; fdMap[STDERR_FILENO] = STDERR_FILENO; nFd = 3; *a = NULL; /*-----------------------------------------------------*/ /* Will execvp() use PATH? */ /*-----------------------------------------------------*/ if (*PL_Argv[0] != '/') TAINT_ENV(); if (really && *(tmps = SvPV(really, n_a))) pid = spawnp(tmps, nFd, fdMap, &inherit, (const char **) PL_Argv, (const char **) environ); else pid = spawnp(PL_Argv[0], nFd, fdMap, &inherit, (const char **) PL_Argv, (const char **) environ); if (pid < 0) { status = FAIL; if (ckWARN(WARN_EXEC)) warner(WARN_EXEC,"Can't exec \"%s\": %s", PL_Argv[0], Strerror(errno)); } else { /*------------------------------------------------*/ /* If the file descriptors have been remapped then*/ /* we've been called following a my_popen request */ /* therefore we don't want to wait for spawnned */ /* program to complete. We need to set the fdpid */ /* value to the value of the spawnned process' pid*/ /*------------------------------------------------*/ fd = 0; if (Perl_stdin_fd != STDIN_FILENO) fd = Perl_stdin_fd; else if (Perl_stdout_fd != STDOUT_FILENO) fd = Perl_stdout_fd; if (fd != 0) { /*---------------------------------------------*/ /* Get the fd of the other end of the pipe, */ /* use this to reference the fdpid which will */ /* be used by my_pclose */ /*---------------------------------------------*/ close(fd); MUTEX_LOCK(&PL_fdpid_mutex); p_sv = av_fetch(PL_fdpid,fd,TRUE); fd = (int) SvIVX(*p_sv); SvREFCNT_dec(*p_sv); *p_sv = &PL_sv_undef; sv = *av_fetch(PL_fdpid,fd,TRUE); MUTEX_UNLOCK(&PL_fdpid_mutex); (void) SvUPGRADE(sv, SVt_IV); SvIVX(sv) = pid; status = 0; } else wait4pid(pid, &status, 0); } do_execfree(); } return (status); } /*===================== End of do_aspawn ===================*/ /************************************************************/ /* */ /* D O _ S P A W N */ /* --------------- */ /* */ /************************************************************/ int do_spawn(char *cmd, int execf) { char **a, *s, flags[10]; int status, nFd, fdMap[3]; struct inheritance inherit; pid_t pid; while (*cmd && isSPACE(*cmd)) cmd++; /*------------------------------------------------------*/ /* See if there are shell metacharacters in it */ /*------------------------------------------------------*/ if (*cmd == '.' && isSPACE(cmd[1])) return (spawnit(cmd)); else { if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4])) return (spawnit(cmd)); else { /*------------------------------------------------*/ /* Catch VAR=val gizmo */ /*------------------------------------------------*/ for (s = cmd; *s && isALPHA(*s); s++); if (*s != '=') { for (s = cmd; *s; s++) { if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) { if (*s == '\n' && !s[1]) { *s = '\0'; break; } return(spawnit(cmd)); } } } } } Newx(PL_Argv, (s - cmd) / 2 + 2, char*); PL_Cmd = savepvn(cmd, s-cmd); a = PL_Argv; for (s = PL_Cmd; *s;) { while (*s && isSPACE(*s)) s++; if (*s) *(a++) = s; while (*s && !isSPACE(*s)) s++; if (*s) *s++ = '\0'; } *a = NULL; fdMap[STDIN_FILENO] = Perl_stdin_fd; fdMap[STDOUT_FILENO] = Perl_stdout_fd; fdMap[STDERR_FILENO] = STDERR_FILENO; nFd = 3; inherit.flags = 0; if (PL_Argv[0]) { pid = spawnp(PL_Argv[0], nFd, fdMap, &inherit, (const char **) PL_Argv, (const char **) environ); if (pid < 0) { status = FAIL; if (ckWARN(WARN_EXEC)) warner(WARN_EXEC,"Can't exec \"%s\": %s", PL_Argv[0], Strerror(errno)); } else wait4pid(pid, &status, 0); } do_execfree(); return (status); } /*===================== End of do_spawn ====================*/ /************************************************************/ /* */ /* Name - spawnit. */ /* */ /* Function - Spawn command and return status. */ /* */ /* On Entry - cmd - command to be spawned. */ /* */ /* On Exit - status returned. */ /* */ /************************************************************/ int spawnit(char *cmd) { pid_t pid; int status; pid = spawn_cmd(cmd, STDIN_FILENO, STDOUT_FILENO); if (pid < 0) status = FAIL; else wait4pid(pid, &status, 0); return (status); } /*===================== End of spawnit =====================*/ /************************************************************/ /* */ /* Name - spawn_cmd. */ /* */ /* Function - Spawn command and return pid. */ /* */ /* On Entry - cmd - command to be spawned. */ /* */ /* On Exit - pid returned. */ /* */ /************************************************************/ pid_t spawn_cmd(char *cmd, int inFd, int outFd) { struct inheritance inherit; pid_t pid; const char *argV[4] = {"/bin/sh","-c",NULL,NULL}; int nFd, fdMap[3]; argV[2] = cmd; fdMap[STDIN_FILENO] = inFd; fdMap[STDOUT_FILENO] = outFd; fdMap[STDERR_FILENO] = STDERR_FILENO; nFd = 3; inherit.flags = SPAWN_SETGROUP; inherit.pgroup = SPAWN_NEWPGROUP; pid = spawn(argV[0], nFd, fdMap, &inherit, argV, (const char **) environ); return (pid); } /*===================== End of spawnit =====================*/ /************************************************************/ /* */ /* Name - my_popen. */ /* */ /* Function - Use popen to execute a command return a */ /* file descriptor. */ /* */ /* On Entry - cmd - command to be executed. */ /* */ /* On Exit - FILE * returned. */ /* */ /************************************************************/ #include PerlIO * my_popen(char *cmd, char *mode) { FILE *fd; int pFd[2], this, that, pid; SV *sv; if (PerlProc_pipe(pFd) >= 0) { this = (*mode == 'w'); that = !this; /*-------------------------------------------------*/ /* If this is a read mode pipe */ /* - map the write end of the pipe to STDOUT */ /* - return the *FILE for the read end of the pipe */ /*-------------------------------------------------*/ if (!this) Perl_stdout_fd = pFd[that]; /*-------------------------------------------------*/ /* Else */ /* - map the read end of the pipe to STDIN */ /* - return the *FILE for the write end of the pipe*/ /*-------------------------------------------------*/ else Perl_stdin_fd = pFd[that]; if (strNE(cmd,"-")) { PERL_FLUSHALL_FOR_CHILD; pid = spawn_cmd(cmd, Perl_stdin_fd, Perl_stdout_fd); if (pid >= 0) { MUTEX_LOCK(&PL_fdpid_mutex); sv = *av_fetch(PL_fdpid,pFd[this],TRUE); MUTEX_UNLOCK(&PL_fdpid_mutex); (void) SvUPGRADE(sv, SVt_IV); SvIVX(sv) = pid; fd = PerlIO_fdopen(pFd[this], mode); close(pFd[that]); } else fd = NULL; } else { MUTEX_LOCK(&PL_fdpid_mutex); sv = *av_fetch(PL_fdpid,pFd[that],TRUE); MUTEX_UNLOCK(&PL_fdpid_mutex); (void) SvUPGRADE(sv, SVt_IV); SvIVX(sv) = pFd[this]; fd = PerlIO_fdopen(pFd[this], mode); } } else fd = NULL; return (fd); } /*===================== End of my_popen ====================*/ /************************************************************/ /* */ /* Name - my_pclose. */ /* */ /* Function - Use pclose to terminate a piped command */ /* file stream. */ /* */ /* On Entry - fd - FILE pointer. */ /* */ /* On Exit - Status returned. */ /* */ /************************************************************/ long my_pclose(FILE *fp) { int pid, saveErrno, status; long rc, wRc; SV **sv; FILE *other; MUTEX_LOCK(&PL_fdpid_mutex); sv = av_fetch(PL_fdpid,PerlIO_fileno(fp),TRUE); MUTEX_UNLOCK(&PL_fdpid_mutex); pid = (int) SvIVX(*sv); SvREFCNT_dec(*sv); *sv = &PL_sv_undef; rc = PerlIO_close(fp); saveErrno = errno; do { wRc = waitpid(pid, &status, 0); } while ((wRc == -1) && (errno == EINTR)); Perl_stdin_fd = STDIN_FILENO; Perl_stdout_fd = STDOUT_FILENO; errno = saveErrno; if (rc != 0) SETERRNO(errno, garbage); return (rc); } /************************************************************/ /* */ /* Name - dlopen. */ /* */ /* Function - Load a DLL. */ /* */ /* On Exit - */ /* */ /************************************************************/ void * dlopen(const char *path) { dllhandle *handle; fprintf(stderr,"Loading %s\n",path); handle = dllload(path); dl_retcode = errno; fprintf(stderr,"Handle %08X %s\n",handle,strerror(errno)); return ((void *) handle); } /*===================== End of dlopen ======================*/ /************************************************************/ /* */ /* Name - dlsym. */ /* */ /* Function - Locate a DLL symbol. */ /* */ /* On Exit - */ /* */ /************************************************************/ void * dlsym(void *handle, const char *symbol) { void *symLoc; fprintf(stderr,"Finding %s\n",symbol); symLoc = dllqueryvar((dllhandle *) handle, (char *) symbol); if (symLoc == NULL) symLoc = (void *) dllqueryfn((dllhandle *) handle, (char *) symbol); dl_retcode = errno; return(symLoc); } /*===================== End of dlsym =======================*/ /************************************************************/ /* */ /* Name - dlerror. */ /* */ /* Function - Return the last errno pertaining to a DLL */ /* operation. */ /* */ /* On Exit - */ /* */ /************************************************************/ void * dlerror(void) { char * dlEmsg; dlEmsg = strerror(dl_retcode); dl_retcode = 0; return(dlEmsg); } /*===================== End of dlerror =====================*/ /************************************************************/ /* */ /* Name - TRUNCATE. */ /* */ /* Function - Truncate a file identified by 'path' to */ /* a given length. */ /* */ /* On Entry - path - Path of file to be truncated. */ /* length - length of truncated file. */ /* */ /* On Exit - retC - return code. */ /* */ /************************************************************/ int truncate(const unsigned char *path, off_t length) { int fd, retC; fd = open((const char *) path, O_RDWR); if (fd > 0) { retC = ftruncate(fd, length); close(fd); } else retC = fd; return(retC); } /*===================== End of trunc =======================*/ perl-5.12.0-RC0/vmesa/Makefile0000444000175000017500000000027511143650501014700 0ustar jessejesseCCCMD=`sh $(shellflags) ../cflags $@` all : vm perl depend : cd .. && $(MAKE) depend vm : vmesa.o cp vmesa.o ../vmesa.o perl : cd .. && $(MAKE) vmesa.o : vmesa.c $(CCCMD) vmesa.c perl-5.12.0-RC0/README.openbsd0000444000175000017500000000226711143650473014451 0ustar jessejesseIf you read this file _as_is_, just ignore the funny characters you see. It is written in the POD format (see pod/perlpod.pod) which is specifically designed to be readable as is. =head1 NAME README.openbsd - Perl version 5 on OpenBSD systems =head1 DESCRIPTION This document describes various features of OpenBSD that will affect how Perl version 5 (hereafter just Perl) is compiled and/or runs. =head2 OpenBSD core dumps from getprotobyname_r and getservbyname_r with ithreads When Perl is configured to use ithreads, it will use re-entrant library calls in preference to non-re-entrant versions. There is an incompatability in OpenBSD's C and C function in versions 3.7 and later that will cause a SEGV when called without doing a C on their return structs prior to calling these functions. Current Perl's should handle this problem correctly. Older threaded Perls (5.8.6 or earlier) will run into this problem. If you want to run a threaded Perl on OpenBSD 3.7 or higher, you will need to upgrade to at least Perl 5.8.7. =head1 AUTHOR Steve Peters Please report any errors, updates, or suggestions to F. perl-5.12.0-RC0/t/0000755000175000017500000000000011351321566012375 5ustar jessejesseperl-5.12.0-RC0/t/comp/0000755000175000017500000000000011351321566013333 5ustar jessejesseperl-5.12.0-RC0/t/comp/hints.t0000555000175000017500000001050511344764022014647 0ustar jessejesse#!./perl # Tests the scoping of $^H and %^H BEGIN { @INC = qw(. ../lib); } BEGIN { print "1..24\n"; } BEGIN { print "not " if exists $^H{foo}; print "ok 1 - \$^H{foo} doesn't exist initially\n"; if (${^OPEN}) { print "not " unless $^H & 0x00020000; print "ok 2 - \$^H contains HINT_LOCALIZE_HH initially with ${^OPEN}\n"; } else { print "not " if $^H & 0x00020000; print "ok 2 - \$^H doesn't contain HINT_LOCALIZE_HH initially\n"; } } { # simulate a pragma -- don't forget HINT_LOCALIZE_HH BEGIN { $^H |= 0x04020000; $^H{foo} = "a"; } BEGIN { print "not " if $^H{foo} ne "a"; print "ok 3 - \$^H{foo} is now 'a'\n"; print "not " unless $^H & 0x00020000; print "ok 4 - \$^H contains HINT_LOCALIZE_HH while compiling\n"; } { BEGIN { $^H |= 0x00020000; $^H{foo} = "b"; } BEGIN { print "not " if $^H{foo} ne "b"; print "ok 5 - \$^H{foo} is now 'b'\n"; } } BEGIN { print "not " if $^H{foo} ne "a"; print "ok 6 - \$^H{foo} restored to 'a'\n"; } # The pragma settings disappear after compilation # (test at CHECK-time and at run-time) CHECK { print "not " if exists $^H{foo}; print "ok 9 - \$^H{foo} doesn't exist when compilation complete\n"; if (${^OPEN}) { print "not " unless $^H & 0x00020000; print "ok 10 - \$^H contains HINT_LOCALIZE_HH when compilation complete with ${^OPEN}\n"; } else { print "not " if $^H & 0x00020000; print "ok 10 - \$^H doesn't contain HINT_LOCALIZE_HH when compilation complete\n"; } } print "not " if exists $^H{foo}; print "ok 11 - \$^H{foo} doesn't exist at runtime\n"; if (${^OPEN}) { print "not " unless $^H & 0x00020000; print "ok 12 - \$^H contains HINT_LOCALIZE_HH at run-time with ${^OPEN}\n"; } else { print "not " if $^H & 0x00020000; print "ok 12 - \$^H doesn't contain HINT_LOCALIZE_HH at run-time\n"; } # op_entereval should keep the pragmas it was compiled with eval q* print "not " if $^H{foo} ne "a"; print "ok 13 - \$^H{foo} is 'a' at eval-\"\" time\n"; print "not " unless $^H & 0x00020000; print "ok 14 - \$^H contains HINT_LOCALIZE_HH at eval\"\"-time\n"; *; } BEGIN { print "not " if exists $^H{foo}; print "ok 7 - \$^H{foo} doesn't exist while finishing compilation\n"; if (${^OPEN}) { print "not " unless $^H & 0x00020000; print "ok 8 - \$^H contains HINT_LOCALIZE_HH while finishing compilation with ${^OPEN}\n"; } else { print "not " if $^H & 0x00020000; print "ok 8 - \$^H doesn't contain HINT_LOCALIZE_HH while finishing compilation\n"; } } { BEGIN{$^H{x}=1}; for my $tno (15..16) { eval q( print $^H{x}==1 && !$^H{y} ? "ok $tno\n" : "not ok $tno\n"; $^H{y} = 1; ); if ($@) { (my $str = $@)=~s/^/# /gm; print "not ok $tno\n$str\n"; } } } { BEGIN { $^H |= 0x04000000; $^H{foo} = "z"; } our($ri0, $rf0); BEGIN { $ri0 = $^H; $rf0 = $^H{foo}; } print +($ri0 & 0x04000000 ? "" : "not "), "ok 17 - \$^H correct before require\n"; print +($rf0 eq "z" ? "" : "not "), "ok 18 - \$^H{foo} correct before require\n"; our($ra1, $ri1, $rf1, $rfe1); BEGIN { require "comp/hints.aux"; } print +(!($ri1 & 0x04000000) ? "" : "not "), "ok 19 - \$^H cleared for require\n"; print +(!defined($rf1) && !$rfe1 ? "" : "not "), "ok 20 - \$^H{foo} cleared for require\n"; our($ri2, $rf2); BEGIN { $ri2 = $^H; $rf2 = $^H{foo}; } print +($ri2 & 0x04000000 ? "" : "not "), "ok 21 - \$^H correct after require\n"; print +($rf2 eq "z" ? "" : "not "), "ok 22 - \$^H{foo} correct after require\n"; } # [perl #73174] { my $res; BEGIN { $^H{73174} = "foo" } BEGIN { $res = ($^H{73174} // "") } "" =~ /\x{100}/i; # forces loading of utf8.pm, which used to reset %^H BEGIN { $res .= '-' . ($^H{73174} // "")} $res .= '-' . ($^H{73174} // ""); print $res eq "foo-foo-" ? "" : "not ", "ok 23 - \$^H{foo} correct after /unicode/i (res=$res)\n"; } # Add new tests above this require, in case it fails. require './test.pl'; # bug #27040: hints hash was being double-freed my $result = runperl( prog => '$^H |= 0x20000; eval q{BEGIN { $^H |= 0x20000 }}', stderr => 1 ); print "not " if length $result; print "ok 24 - double-freeing hints hash\n"; print "# got: $result\n" if length $result; __END__ # Add new tests above require 'test.pl' perl-5.12.0-RC0/t/comp/use.t0000555000175000017500000001402011325127001014277 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = ('../lib', 'lib'); $INC{"feature.pm"} = 1; # so we don't attempt to load feature.pm } print "1..73\n"; # Can't require test.pl, as we're testing the use/require mechanism here. my $test = 1; sub _ok { my ($type, $got, $expected, $name) = @_; my $result; if ($type eq 'is') { $result = $got eq $expected; } elsif ($type eq 'isnt') { $result = $got ne $expected; } elsif ($type eq 'like') { $result = $got =~ $expected; } else { die "Unexpected type '$type'$name"; } if ($result) { if ($name) { print "ok $test - $name\n"; } else { print "ok $test\n"; } } else { if ($name) { print "not ok $test - $name\n"; } else { print "not ok $test\n"; } my @caller = caller(1); print "# Failed test at $caller[1] line $caller[2]\n"; print "# Got '$got'\n"; if ($type eq 'is') { print "# Expected '$expected'\n"; } elsif ($type eq 'isnt') { print "# Expected not '$expected'\n"; } elsif ($type eq 'like') { print "# Expected $expected\n"; } } $test = $test + 1; $result; } sub like ($$;$) { _ok ('like', @_); } sub is ($$;$) { _ok ('is', @_); } sub isnt ($$;$) { _ok ('isnt', @_); } eval "use 5"; # implicit semicolon is ($@, ''); eval "use 5;"; is ($@, ''); eval "{use 5}"; # [perl #70884] is ($@, ''); eval "{use 5 }"; # [perl #70884] is ($@, ''); # new style version numbers eval q{ use v5.5.630; }; is ($@, ''); eval q{ use 10.0.2; }; like ($@, qr/^Perl v10\.0\.2 required/); eval "use 5.000"; # implicit semicolon is ($@, ''); eval "use 5.000;"; is ($@, ''); eval "use 6.000;"; like ($@, qr/Perl v6\.0\.0 required--this is only \Q$^V\E, stopped/); eval "no 6.000;"; is ($@, ''); eval "no 5.000;"; like ($@, qr/Perls since v5\.0\.0 too modern--this is \Q$^V\E, stopped/); eval "use 5.6;"; like ($@, qr/Perl v5\.600\.0 required \(did you mean v5\.6\.0\?\)--this is only \Q$^V\E, stopped/); eval "use 5.8;"; like ($@, qr/Perl v5\.800\.0 required \(did you mean v5\.8\.0\?\)--this is only \Q$^V\E, stopped/); eval "use 5.9;"; like ($@, qr/Perl v5\.900\.0 required \(did you mean v5\.9\.0\?\)--this is only \Q$^V\E, stopped/); eval "use 5.10;"; like ($@, qr/Perl v5\.100\.0 required \(did you mean v5\.10\.0\?\)--this is only \Q$^V\E, stopped/); eval "use 5.11;"; like ($@, qr/Perl v5\.110\.0 required \(did you mean v5\.11\.0\?\)--this is only \Q$^V\E, stopped/); eval sprintf "use %.6f;", $]; is ($@, ''); eval sprintf "use %.6f;", $] - 0.000001; is ($@, ''); eval sprintf("use %.6f;", $] + 1); like ($@, qr/Perl v6.\d+.\d+ required--this is only \Q$^V\E, stopped/); eval sprintf "use %.6f;", $] + 0.00001; like ($@, qr/Perl v5.\d+.\d+ required--this is only \Q$^V\E, stopped/); # check that "use 5.11.0" (and higher) loads strictures eval 'use 5.11.0; ${"foo"} = "bar";'; like ($@, qr/Can't use string \("foo"\) as a SCALAR ref while "strict refs" in use/); # but that they can be disabled eval 'use 5.11.0; no strict "refs"; ${"foo"} = "bar";'; is ($@, ""); # and they are properly scoped eval '{use 5.11.0;} ${"foo"} = "bar";'; is ($@, ""); { use test_use } # check that subparse saves pending tokens local $test_use::VERSION = 1.0; eval "use test_use 0.9"; is ($@, ''); eval "use test_use 1.0"; is ($@, ''); eval "use test_use 1.01"; isnt ($@, ''); eval "use test_use 0.9 qw(fred)"; is ($@, ''); is("@test_use::got", "fred"); eval "use test_use 1.0 qw(joe)"; is ($@, ''); is("@test_use::got", "joe"); eval "use test_use 1.01 qw(freda)"; isnt($@, ''); is("@test_use::got", "joe"); { local $test_use::VERSION = 35.36; eval "use test_use v33.55"; is ($@, ''); eval "use test_use v100.105"; like ($@, qr/test_use version v100.105.0 required--this is only version v35\.360\.0/); eval "use test_use 33.55"; is ($@, ''); eval "use test_use 100.105"; like ($@, qr/test_use version 100.105 required--this is only version 35.36/); local $test_use::VERSION = '35.36'; eval "use test_use v33.55"; like ($@, ''); eval "use test_use v100.105"; like ($@, qr/test_use version v100.105.0 required--this is only version v35\.360\.0/); eval "use test_use 33.55"; is ($@, ''); eval "use test_use 100.105"; like ($@, qr/test_use version 100.105 required--this is only version 35.36/); local $test_use::VERSION = v35.36; eval "use test_use v33.55"; is ($@, ''); eval "use test_use v100.105"; like ($@, qr/test_use version v100.105.0 required--this is only version v35\.36\.0/); eval "use test_use 33.55"; is ($@, ''); eval "use test_use 100.105"; like ($@, qr/test_use version 100.105 required--this is only version v35.36/); } { # Regression test for patch 14937: # Check that a .pm file with no package or VERSION doesn't core. # (git commit 2658f4d9934aba5f8b23afcc078dc12b3a40223) eval "use test_use_14937 3"; like ($@, qr/^test_use_14937 defines neither package nor VERSION--version check failed at/); } my @ver = split /\./, sprintf "%vd", $^V; foreach my $index (-3..+3) { foreach my $v (0, 1) { my @parts = @ver; if ($index) { if ($index < 0) { # Jiggle one of the parts down --$parts[-$index - 1]; if ($parts[-$index - 1] < 0) { # perl's version number ends with '.0' $parts[-$index - 1] = 0; $parts[-$index - 2] -= 2; } } else { # Jiggle one of the parts up ++$parts[$index - 1]; } } my $v_version = sprintf "v%d.%d.%d", @parts; my $version; if ($v) { $version = $v_version; } else { $version = $parts[0] + $parts[1] / 1000 + $parts[2] / 1000000; } eval "use $version"; if ($index > 0) { # The future like ($@, qr/Perl $v_version required--this is only \Q$^V\E, stopped/, "use $version"); } else { # The present or past is ($@, '', "use $version"); } eval "no $version"; if ($index <= 0) { # The present or past like ($@, qr/Perls since $v_version too modern--this is \Q$^V\E, stopped/, "no $version"); } else { # future is ($@, '', "no $version"); } } } perl-5.12.0-RC0/t/comp/bproto.t0000555000175000017500000000126111325125742015025 0ustar jessejesse#!./perl # # check if builtins behave as prototyped # BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } print "1..10\n"; my $i = 1; sub foo {} my $bar = "bar"; sub test_too_many { eval $_[0]; print "not " unless $@ =~ /^Too many arguments/; printf "ok %d\n",$i++; } sub test_no_error { eval $_[0]; print "not " if $@; printf "ok %d\n",$i++; } test_too_many($_) for split /\n/, q[ defined(&foo, $bar); undef(&foo, $bar); uc($bar,$bar); ]; test_no_error($_) for split /\n/, q[ scalar(&foo,$bar); defined &foo, &foo, &foo; undef &foo, $bar; uc $bar,$bar; grep(not($bar), $bar); grep(not($bar, $bar), $bar); grep((not $bar, $bar, $bar), $bar); ]; perl-5.12.0-RC0/t/comp/line_debug_0.aux0000444000175000017500000000037511325127001016356 0ustar jessejesse$z = 'line one'; $z = 'multiline statement'; $z = 'line five'; $z = ' multiline string '; $z = 'line ten'; $z = <$f") or die "Can't write '$f': $!"; binmode REQ; print REQ @_; close REQ or die "Could not close $f: $!"; } eval {require 5.005}; print "# $@\nnot " if $@; print "ok ",$i++,"\n"; eval { require 5.005 }; print "# $@\nnot " if $@; print "ok ",$i++,"\n"; eval { require 5.005; }; print "# $@\nnot " if $@; print "ok ",$i++,"\n"; eval { require 5.005 }; print "# $@\nnot " if $@; print "ok ",$i++,"\n"; # new style version numbers eval { require v5.5.630; }; print "# $@\nnot " if $@; print "ok ",$i++,"\n"; eval { require 10.0.2; }; print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.2 required/; print "ok ",$i++,"\n"; my $ver = 5.005_63; eval { require $ver; }; print "# $@\nnot " if $@; print "ok ",$i++,"\n"; # check inaccurate fp $ver = 10.2; eval { require $ver; }; print "# $@\nnot " unless $@ =~ /^Perl v10\.200.0 required/; print "ok ",$i++,"\n"; $ver = 10.000_02; eval { require $ver; }; print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.20 required/; print "ok ",$i++,"\n"; print "not " unless 5.5.1 gt v5.5; print "ok ",$i++,"\n"; { print "not " unless v5.5.640 eq "\x{5}\x{5}\x{280}"; print "ok ",$i++,"\n"; print "not " unless v7.15 eq "\x{7}\x{f}"; print "ok ",$i++,"\n"; print "not " unless v1.20.300.4000.50000.600000 eq "\x{1}\x{14}\x{12c}\x{fa0}\x{c350}\x{927c0}"; print "ok ",$i++,"\n"; } # "use 5.11.0" (and higher) loads strictures. # check that this doesn't happen with require eval 'require 5.11.0; ${"foo"} = "bar";'; print "# $@\nnot " if $@; print "ok ",$i++,"\n"; # interaction with pod (see the eof) write_file('bleah.pm', "print 'ok $i\n'; 1;\n"); require "bleah.pm"; $i++; # run-time failure in require do_require "0;\n"; print "# $@\nnot " unless $@ =~ /did not return a true/; print "ok ",$i++,"\n"; print "not " if exists $INC{'bleah.pm'}; print "ok ",$i++,"\n"; my $flag_file = 'bleah.flg'; # run-time error in require for my $expected_compile (1,0) { write_file($flag_file, 1); print "not " unless -e $flag_file; print "ok ",$i++,"\n"; write_file('bleah.pm', "unlink '$flag_file' or die; \$a=0; \$b=1/\$a; 1;\n"); print "# $@\nnot " if eval { require 'bleah.pm' }; print "ok ",$i++,"\n"; print "not " unless -e $flag_file xor $expected_compile; print "ok ",$i++,"\n"; print "not " unless exists $INC{'bleah.pm'}; print "ok ",$i++,"\n"; } # compile-time failure in require do_require "1)\n"; # bison says 'parse error' instead of 'syntax error', # various yaccs may or may not capitalize 'syntax'. print "# $@\nnot " unless $@ =~ /(syntax|parse) error/mi; print "ok ",$i++,"\n"; # previous failure cached in %INC print "not " unless exists $INC{'bleah.pm'}; print "ok ",$i++,"\n"; write_file($flag_file, 1); write_file('bleah.pm', "unlink '$flag_file'; 1"); print "# $@\nnot " if eval { require 'bleah.pm' }; print "ok ",$i++,"\n"; print "# $@\nnot " unless $@ =~ /Compilation failed/i; print "ok ",$i++,"\n"; print "not " unless -e $flag_file; print "ok ",$i++,"\n"; print "not " unless exists $INC{'bleah.pm'}; print "ok ",$i++,"\n"; # successful require do_require "1"; print "# $@\nnot " if $@; print "ok ",$i++,"\n"; # do FILE shouldn't see any outside lexicals my $x = "ok $i\n"; write_file("bleah.do", < 'C0U', 'UTF-16BE' => 'n', 'UTF-16LE' => 'v', ); sub bytes_to_utf { my ($enc, $content, $do_bom) = @_; my $template = $templates{$enc}; die "Unsupported encoding $enc" unless $template; return pack "$template*", ($do_bom ? 0xFEFF : ()), unpack "C*", $content; } foreach (sort keys %templates) { $i++; do_require(bytes_to_utf($_, qq(print "ok $i # $_\\n"; 1;\n), 1)); if ($@ =~ /^(Unsupported script encoding \Q$_\E)/) { print "ok $i # skip $1\n"; } } END { foreach my $file (@fjles_to_delete) { 1 while unlink $file; } } # ***interaction with pod (don't put any thing after here)*** =pod perl-5.12.0-RC0/t/comp/package.t0000555000175000017500000000277711325127001015116 0ustar jessejesse#!./perl print "1..14\n"; $blurfl = 123; $foo = 3; package xyz; sub new {bless [];} $bar = 4; { package ABC; $blurfl = 5; $main'a = $'b; } $ABC'dyick = 6; $xyz = 2; $main = join(':', sort(keys %main::)); $xyz = join(':', sort(keys %xyz::)); $ABC = join(':', sort(keys %ABC::)); if ('a' lt 'A') { print $xyz eq 'bar:main:new:xyz:ABC' ? "ok 1\n" : "not ok 1 '$xyz'\n"; } else { print $xyz eq 'ABC:bar:main:new:xyz' ? "ok 1\n" : "not ok 1 '$xyz'\n"; } print $ABC eq 'blurfl:dyick' ? "ok 2\n" : "not ok 2 '$ABC'\n"; print $main'blurfl == 123 ? "ok 3\n" : "not ok 3\n"; package ABC; print $blurfl == 5 ? "ok 4\n" : "not ok 4\n"; eval 'print $blurfl == 5 ? "ok 5\n" : "not ok 5\n";'; eval 'package main; print $blurfl == 123 ? "ok 6\n" : "not ok 6\n";'; print $blurfl == 5 ? "ok 7\n" : "not ok 7\n"; package main; sub c { caller(0) } sub foo { my $s = shift; if ($s) { package PQR; main::c(); } } print((foo(1))[0] eq 'PQR' ? "ok 8\n" : "not ok 8\n"); my $Q = xyz->new(); undef %xyz::; eval { $a = *xyz::new{PACKAGE}; }; print $a eq "__ANON__" ? "ok 9\n" : "not ok 9 # '$a'\n"; eval { $Q->param; }; print $@ =~ /^Can't use anonymous symbol table for method lookup/ ? "ok 10\n" : "not ok 10 # '$@'\n"; print "$Q" =~ /^__ANON__=/ ? "ok 11\n" : "not ok 11 # '$Q'\n"; print ref $Q eq "__ANON__" ? "ok 12\n" : "not ok 12 # '$Q'\n"; package bug32562; print __PACKAGE__ eq 'bug32562' ? "ok 13\n" : "not ok 13\n"; print eval '__PACKAGE__' eq 'bug32562' ? "ok 14\n" : "not ok 14\n"; perl-5.12.0-RC0/t/comp/uproto.t0000555000175000017500000000561511325127001015045 0ustar jessejesse#!perl print "1..39\n"; my $test = 0; sub failed { my ($got, $expected, $name) = @_; print "not ok $test - $name\n"; my @caller = caller(1); print "# Failed test at $caller[1] line $caller[2]\n"; if (defined $got) { print "# Got '$got'\n"; } else { print "# Got undef\n"; } print "# Expected $expected\n"; return; } sub like { my ($got, $pattern) = @_; $test = $test + 1; if (defined $got && $got =~ $pattern) { print "ok $test\n"; # Principle of least surprise - maintain the expected interface, even # though we aren't using it here (yet). return 1; } failed($got, $pattern, $name); } sub is { my ($got, $expect) = @_; $test = $test + 1; if (defined $expect) { if (defined $got && $got eq $expect) { print "ok $test\n"; return 1; } failed($got, "'$expect'", $name); } else { if (!defined $got) { print "ok $test\n"; return 1; } failed($got, 'undef', $name); } } sub f($$_) { my $x = shift; is("@_", $x) } $foo = "FOO"; my $bar = "BAR"; $_ = 42; f("FOO xy", $foo, "xy"); f("BAR zt", $bar, "zt"); f("FOO 42", $foo); f("BAR 42", $bar); f("y 42", substr("xy",1,1)); f("1 42", ("abcdef" =~ /abc/)); f("not undef 42", $undef || "not undef"); f(" 42", -f "no_such_file"); f("FOOBAR 42", ($foo . $bar)); f("FOOBAR 42", ($foo .= $bar)); f("FOOBAR 42", $foo); eval q{ f("foo") }; like( $@, qr/Not enough arguments for main::f at/ ); eval q{ f(1,2,3,4) }; like( $@, qr/Too many arguments for main::f at/ ); { my $_ = "quarante-deux"; $foo = "FOO"; $bar = "BAR"; f("FOO quarante-deux", $foo); f("BAR quarante-deux", $bar); f("y quarante-deux", substr("xy",1,1)); f("1 quarante-deux", ("abcdef" =~ /abc/)); f("not undef quarante-deux", $undef || "not undef"); f(" quarante-deux", -f "no_such_file"); f("FOOBAR quarante-deux", ($foo . $bar)); f("FOOBAR quarante-deux", ($foo .= $bar)); f("FOOBAR quarante-deux", $foo); } &f(""); # no error sub g(_) { is(shift, $expected) } $expected = "foo"; g("foo"); g($expected); $_ = $expected; g(); g; undef $expected; &g; # $_ not passed { $expected = my $_ = "bar"; g() } eval q{ sub wrong1 (_$); wrong1(1,2) }; like( $@, qr/Malformed prototype for main::wrong1/, 'wrong1' ); eval q{ sub wrong2 ($__); wrong2(1,2) }; like( $@, qr/Malformed prototype for main::wrong2/, 'wrong2' ); sub opt ($;_) { is($_[0], "seen"); is($_[1], undef, "; has precedence over _"); } opt("seen"); sub unop (_) { is($_[0], 11, "unary op") } unop 11, 22; # takes only the first parameter into account sub mymkdir (_;$) { is("@_", $expected, "mymkdir") } $expected = $_ = "mydir"; mymkdir(); mymkdir($expected = "foo"); $expected = "foo 493"; mymkdir foo => 0755; # $_ says modifiable, it's not passed by copy sub double(_) { $_[0] *= 2 } $_ = 21; double(); is( $_, 42, '$_ is modifiable' ); { my $_ = 22; double(); is( $_, 44, 'my $_ is modifiable' ); } perl-5.12.0-RC0/t/comp/colon.t0000555000175000017500000000636411344764022014644 0ustar jessejesse#!./perl # # Ensure that syntax using colons (:) is parsed correctly. # The tests are done on the following tokens (by default): # ABC LABEL XYZZY m q qq qw qx s tr y AUTOLOAD and alarm # -- Robin Barker # # Uncomment this for testing, but don't leave it in for "production", as # we've not yet verified that use works. # use strict; $_ = ''; # to avoid undef warning on m// etc. sub ok { my($test,$ok) = @_; print "not " unless $ok; print "ok $test\n"; } $SIG{__WARN__} = sub { 1; }; # avoid some spurious warnings print "1..25\n"; ok 1, (eval "package ABC; sub zyx {1}; 1;" and eval "ABC::zyx" and not eval "ABC:: eq ABC||" and not eval "ABC::: >= 0"); ok 2, (eval "package LABEL; sub zyx {1}; 1;" and eval "LABEL::zyx" and not eval "LABEL:: eq LABEL||" and not eval "LABEL::: >= 0"); ok 3, (eval "package XYZZY; sub zyx {1}; 1;" and eval "XYZZY::zyx" and not eval "XYZZY:: eq XYZZY||" and not eval "XYZZY::: >= 0"); ok 4, (eval "package m; sub zyx {1}; 1;" and not eval "m::zyx" and eval "m:: eq m||" and not eval "m::: >= 0"); ok 5, (eval "package q; sub zyx {1}; 1;" and not eval "q::zyx" and eval "q:: eq q||" and not eval "q::: >= 0"); ok 6, (eval "package qq; sub zyx {1}; 1;" and not eval "qq::zyx" and eval "qq:: eq qq||" and not eval "qq::: >= 0"); ok 7, (eval "package qw; sub zyx {1}; 1;" and not eval "qw::zyx" and eval "qw:: eq qw||" and not eval "qw::: >= 0"); ok 8, (eval "package qx; sub zyx {1}; 1;" and not eval "qx::zyx" and eval "qx:: eq qx||" and not eval "qx::: >= 0"); ok 9, (eval "package s; sub zyx {1}; 1;" and not eval "s::zyx" and not eval "s:: eq s||" and eval "s::: >= 0"); ok 10, (eval "package tr; sub zyx {1}; 1;" and not eval "tr::zyx" and not eval "tr:: eq tr||" and eval "tr::: >= 0"); ok 11, (eval "package y; sub zyx {1}; 1;" and not eval "y::zyx" and not eval "y:: eq y||" and eval "y::: >= 0"); ok 12, (eval "ABC:1" and not eval "ABC:echo: eq ABC|echo|" and not eval "ABC:echo:ohce: >= 0"); ok 13, (eval "LABEL:1" and not eval "LABEL:echo: eq LABEL|echo|" and not eval "LABEL:echo:ohce: >= 0"); ok 14, (eval "XYZZY:1" and not eval "XYZZY:echo: eq XYZZY|echo|" and not eval "XYZZY:echo:ohce: >= 0"); ok 15, (not eval "m:1" and eval "m:echo: eq m|echo|" and not eval "m:echo:ohce: >= 0"); ok 16, (not eval "q:1" and eval "q:echo: eq q|echo|" and not eval "q:echo:ohce: >= 0"); ok 17, (not eval "qq:1" and eval "qq:echo: eq qq|echo|" and not eval "qq:echo:ohce: >= 0"); ok 18, (not eval "qw:1" and eval "qw:echo: eq qw|echo|" and not eval "qw:echo:ohce: >= 0"); ok 19, (not eval "qx:1" and eval "qx:echo 1: eq qx|echo 1|" and # echo without args may warn not eval "qx:echo:ohce: >= 0"); ok 20, (not eval "s:1" and not eval "s:echo: eq s|echo|" and eval "s:echo:ohce: >= 0"); ok 21, (not eval "tr:1" and not eval "tr:echo: eq tr|echo|" and eval "tr:echo:ohce: >= 0"); ok 22, (not eval "y:1" and not eval "y:echo: eq y|echo|" and eval "y:echo:ohce: >= 0"); ok 23, (eval "AUTOLOAD:1" and not eval "AUTOLOAD:echo: eq AUTOLOAD|echo|" and not eval "AUTOLOAD:echo:ohce: >= 0"); ok 24, (eval "and:1" and not eval "and:echo: eq and|echo|" and not eval "and:echo:ohce: >= 0"); ok 25, (eval "alarm:1" and not eval "alarm:echo: eq alarm|echo|" and not eval "alarm:echo:ohce: >= 0"); perl-5.12.0-RC0/t/comp/cmdopt.t0000555000175000017500000000621711325125742015014 0ustar jessejesse#!./perl print "1..44\n"; # test the optimization of constants if (1) { print "ok 1\n";} else { print "not ok 1\n";} unless (0) { print "ok 2\n";} else { print "not ok 2\n";} if (0) { print "not ok 3\n";} else { print "ok 3\n";} unless (1) { print "not ok 4\n";} else { print "ok 4\n";} unless (!1) { print "ok 5\n";} else { print "not ok 5\n";} if (!0) { print "ok 6\n";} else { print "not ok 6\n";} unless (!0) { print "not ok 7\n";} else { print "ok 7\n";} if (!1) { print "not ok 8\n";} else { print "ok 8\n";} $x = 1; if (1 && $x) { print "ok 9\n";} else { print "not ok 9\n";} if (0 && $x) { print "not ok 10\n";} else { print "ok 10\n";} $x = ''; if (1 && $x) { print "not ok 11\n";} else { print "ok 11\n";} if (0 && $x) { print "not ok 12\n";} else { print "ok 12\n";} $x = 1; if (1 || $x) { print "ok 13\n";} else { print "not ok 13\n";} if (0 || $x) { print "ok 14\n";} else { print "not ok 14\n";} $x = ''; if (1 || $x) { print "ok 15\n";} else { print "not ok 15\n";} if (0 || $x) { print "not ok 16\n";} else { print "ok 16\n";} # test the optimization of variables $x = 1; if ($x) { print "ok 17\n";} else { print "not ok 17\n";} unless ($x) { print "not ok 18\n";} else { print "ok 18\n";} $x = ''; if ($x) { print "not ok 19\n";} else { print "ok 19\n";} unless ($x) { print "ok 20\n";} else { print "not ok 20\n";} # test optimization of string operations $a = 'a'; if ($a eq 'a') { print "ok 21\n";} else { print "not ok 21\n";} if ($a ne 'a') { print "not ok 22\n";} else { print "ok 22\n";} if ($a =~ /a/) { print "ok 23\n";} else { print "not ok 23\n";} if ($a !~ /a/) { print "not ok 24\n";} else { print "ok 24\n";} # test interaction of logicals and other operations $a = 'a'; $x = 1; if ($a eq 'a' and $x) { print "ok 25\n";} else { print "not ok 25\n";} if ($a ne 'a' and $x) { print "not ok 26\n";} else { print "ok 26\n";} $x = ''; if ($a eq 'a' and $x) { print "not ok 27\n";} else { print "ok 27\n";} if ($a ne 'a' and $x) { print "not ok 28\n";} else { print "ok 28\n";} $x = 1; if ($a eq 'a' or $x) { print "ok 29\n";} else { print "not ok 29\n";} if ($a ne 'a' or $x) { print "ok 30\n";} else { print "not ok 30\n";} $x = ''; if ($a eq 'a' or $x) { print "ok 31\n";} else { print "not ok 31\n";} if ($a ne 'a' or $x) { print "not ok 32\n";} else { print "ok 32\n";} $x = 1; if ($a =~ /a/ && $x) { print "ok 33\n";} else { print "not ok 33\n";} if ($a !~ /a/ && $x) { print "not ok 34\n";} else { print "ok 34\n";} $x = ''; if ($a =~ /a/ && $x) { print "not ok 35\n";} else { print "ok 35\n";} if ($a !~ /a/ && $x) { print "not ok 36\n";} else { print "ok 36\n";} $x = 1; if ($a =~ /a/ || $x) { print "ok 37\n";} else { print "not ok 37\n";} if ($a !~ /a/ || $x) { print "ok 38\n";} else { print "not ok 38\n";} $x = ''; if ($a =~ /a/ || $x) { print "ok 39\n";} else { print "not ok 39\n";} if ($a !~ /a/ || $x) { print "not ok 40\n";} else { print "ok 40\n";} $x = 1; if ($a eq 'a' xor $x) { print "not ok 41\n";} else { print "ok 41\n";} if ($a ne 'a' xor $x) { print "ok 42\n";} else { print "not ok 42\n";} $x = ''; if ($a eq 'a' xor $x) { print "ok 43\n";} else { print "not ok 43\n";} if ($a ne 'a' xor $x) { print "not ok 44\n";} else { print "ok 44\n";} perl-5.12.0-RC0/t/comp/parser.t0000555000175000017500000003046011337307030015012 0ustar jessejesse#!./perl # Checks if the parser behaves correctly in edge cases # (including weird syntax errors) print "1..122\n"; sub failed { my ($got, $expected, $name) = @_; print "not ok $test - $name\n"; my @caller = caller(1); print "# Failed test at $caller[1] line $caller[2]\n"; if (defined $got) { print "# Got '$got'\n"; } else { print "# Got undef\n"; } print "# Expected $expected\n"; return; } sub like { my ($got, $pattern, $name) = @_; $test = $test + 1; if (defined $got && $got =~ $pattern) { print "ok $test - $name\n"; # Principle of least surprise - maintain the expected interface, even # though we aren't using it here (yet). return 1; } failed($got, $pattern, $name); } sub is { my ($got, $expect, $name) = @_; $test = $test + 1; if (defined $expect) { if (defined $got && $got eq $expect) { print "ok $test - $name\n"; return 1; } failed($got, "'$expect'", $name); } else { if (!defined $got) { print "ok $test - $name\n"; return 1; } failed($got, 'undef', $name); } } eval '%@x=0;'; like( $@, qr/^Can't modify hash dereference in repeat \(x\)/, '%@x=0' ); # Bug 20010422.005 eval q{{s//${}/; //}}; like( $@, qr/syntax error/, 'syntax error, used to dump core' ); # Bug 20010528.007 eval q/"\x{"/; like( $@, qr/^Missing right brace on \\x/, 'syntax error in string, used to dump core' ); eval q/"\N{"/; like( $@, qr/^Missing right brace on \\N/, 'syntax error in string with incomplete \N' ); eval q/"\Nfoo"/; like( $@, qr/^Missing braces on \\N/, 'syntax error in string with incomplete \N' ); eval "a.b.c.d.e.f;sub"; like( $@, qr/^Illegal declaration of anonymous subroutine/, 'found by Markov chain stress testing' ); # Bug 20010831.001 eval '($a, b) = (1, 2);'; like( $@, qr/^Can't modify constant item in list assignment/, 'bareword in list assignment' ); eval 'tie FOO, "Foo";'; like( $@, qr/^Can't modify constant item in tie /, 'tying a bareword causes a segfault in 5.6.1' ); eval 'undef foo'; like( $@, qr/^Can't modify constant item in undef operator /, 'undefing constant causes a segfault in 5.6.1 [ID 20010906.019]' ); eval 'read($bla, FILE, 1);'; like( $@, qr/^Can't modify constant item in read /, 'read($var, FILE, 1) segfaults on 5.6.1 [ID 20011025.054]' ); # This used to dump core (bug #17920) eval q{ sub { sub { f1(f2();); my($a,$b,$c) } } }; like( $@, qr/error/, 'lexical block discarded by yacc' ); # bug #18573, used to corrupt memory eval q{ "\c" }; like( $@, qr/^Missing control char name in \\c/, q("\c" string) ); eval q{ qq(foo$) }; like( $@, qr/Final \$ should be \\\$ or \$name/, q($ at end of "" string) ); # two tests for memory corruption problems in the said variables # (used to dump core or produce strange results) is( "\Q\Q\Q\Q\Q\Q\Q\Q\Q\Q\Q\Q\Qa", "a", "PL_lex_casestack" ); eval { {{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{ {{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{ {{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{ }}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}} }}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}} }}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}} }; is( $@, '', 'PL_lex_brackstack' ); { # tests for bug #20716 undef $a; undef @b; my $a="A"; is("${a}{", "A{", "interpolation, qq//"); is("${a}[", "A[", "interpolation, qq//"); my @b=("B"); is("@{b}{", "B{", "interpolation, qq//"); is(qr/${a}{/, '(?-xism:A{)', "interpolation, qr//"); my $c = "A{"; $c =~ /${a}{/; is($&, 'A{', "interpolation, m//"); $c =~ s/${a}{/foo/; is($c, 'foo', "interpolation, s/...//"); $c =~ s/foo/${a}{/; is($c, 'A{', "interpolation, s//.../"); is(<<"${a}{", "A{ A[ B{\n", "interpolation, here doc"); ${a}{ ${a}[ @{b}{ ${a}{ } eval q{ sub a(;; &) { } a { } }; is($@, '', "';&' sub prototype confuses the lexer"); # Bug #21575 # ensure that the second print statement works, by playing a bit # with the test output. my %data = ( foo => "\n" ); print "#"; print( $data{foo}); $test = $test + 1; print "ok $test\n"; # Bug #21875 # { q.* => ... } should be interpreted as hash, not block foreach my $line (split /\n/, <<'EOF') 1 { foo => 'bar' } 1 { qoo => 'bar' } 1 { q => 'bar' } 1 { qq => 'bar' } 0 { q,'bar', } 0 { q=bar= } 0 { qq=bar= } 1 { q=bar= => 'bar' } EOF { my ($expect, $eval) = split / /, $line, 2; my $result = eval $eval; is($@, '', "eval $eval"); is(ref $result, $expect ? 'HASH' : '', $eval); } # Bug #24212 { local $SIG{__WARN__} = sub { }; # silence mandatory warning eval q{ my $x = -F 1; }; like( $@, qr/(?i:syntax|parse) error .* near "F 1"/, "unknown filetest operators" ); is( eval q{ sub F { 42 } -F 1 }, '-42', '-F calls the F function' ); } # Bug #24762 { eval q{ *foo{CODE} ? 1 : 0 }; is( $@, '', "glob subscript in conditional" ); } # Bug #25824 { eval q{ sub f { @a=@b=@c; {use} } }; like( $@, qr/syntax error/, "use without body" ); } # [perl #2738] perl segfautls on input { eval q{ sub _ <> {} }; like($@, qr/Illegal declaration of subroutine main::_/, "readline operator as prototype"); eval q{ $s = sub <> {} }; like($@, qr/Illegal declaration of anonymous subroutine/, "readline operator as prototype"); eval q{ sub _ __FILE__ {} }; like($@, qr/Illegal declaration of subroutine main::_/, "__FILE__ as prototype"); } # tests for "Bad name" eval q{ foo::$bar }; like( $@, qr/Bad name after foo::/, 'Bad name after foo::' ); eval q{ foo''bar }; like( $@, qr/Bad name after foo'/, 'Bad name after foo\'' ); # test for ?: context error eval q{($a ? $x : ($y)) = 5}; like( $@, qr/Assignment to both a list and a scalar/, 'Assignment to both a list and a scalar' ); eval q{ s/x/#/e }; is( $@, '', 'comments in s///e' ); # these five used to coredump because the op cleanup on parse error could # be to the wrong pad eval q[ sub { our $a= 1;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a; sub { my $z ]; like($@, qr/Missing right curly/, 'nested sub syntax error' ); eval q[ sub { my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$r); sub { my $z ]; like($@, qr/Missing right curly/, 'nested sub syntax error 2' ); eval q[ sub { our $a= 1;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a; use DieDieDie; ]; like($@, qr/Can't locate DieDieDie.pm/, 'croak cleanup' ); eval q[ sub { my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$r); use DieDieDie; ]; like($@, qr/Can't locate DieDieDie.pm/, 'croak cleanup 2' ); eval q[ my @a; my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$r); @a =~ s/a/b/; # compile-time error use DieDieDie; ]; like($@, qr/Can't modify/, 'croak cleanup 3' ); # these might leak, or have duplicate frees, depending on the bugginess of # the parser stack 'fail in reduce' cleanup code. They're here mainly as # something to be run under valgrind, with PERL_DESTRUCT_LEVEL=1. eval q[ BEGIN { } ] for 1..10; is($@, "", 'BEGIN 1' ); eval q[ BEGIN { my $x; $x = 1 } ] for 1..10; is($@, "", 'BEGIN 2' ); eval q[ BEGIN { \&foo1 } ] for 1..10; is($@, "", 'BEGIN 3' ); eval q[ sub foo2 { } ] for 1..10; is($@, "", 'BEGIN 4' ); eval q[ sub foo3 { my $x; $x=1 } ] for 1..10; is($@, "", 'BEGIN 5' ); eval q[ BEGIN { die } ] for 1..10; like($@, qr/BEGIN failed--compilation aborted/, 'BEGIN 6' ); eval q[ BEGIN {\&foo4; die } ] for 1..10; like($@, qr/BEGIN failed--compilation aborted/, 'BEGIN 7' ); { # RT #70934 # check both the specific case in the ticket, and a few other paths into # S_scan_ident() # simplify long ids my $x100 = "x" x 256; my $xFE = "x" x 254; my $xFD = "x" x 253; my $xFC = "x" x 252; my $xFB = "x" x 251; eval qq[ \$#$xFB ]; is($@, "", "251 character \$# sigil ident ok"); eval qq[ \$#$xFC ]; like($@, qr/Identifier too long/, "too long id in \$# sigil ctx"); eval qq[ \$$xFB ]; is($@, "", "251 character \$ sigil ident ok"); eval qq[ \$$xFC ]; like($@, qr/Identifier too long/, "too long id in \$ sigil ctx"); eval qq[ %$xFB ]; is($@, "", "251 character % sigil ident ok"); eval qq[ %$xFC ]; like($@, qr/Identifier too long/, "too long id in % sigil ctx"); eval qq[ \\&$xFC ]; # take a ref since I don't want to call it is($@, "", "252 character & sigil ident ok"); eval qq[ \\&$xFD ]; like($@, qr/Identifier too long/, "too long id in & sigil ctx"); eval qq[ *$xFC ]; is($@, "", "252 character glob ident ok"); eval qq[ *$xFD ]; like($@, qr/Identifier too long/, "too long id in glob ctx"); eval qq[ for $xFD ]; like($@, qr/Missing \$ on loop variable/, "253 char id ok, but a different error"); eval qq[ for $xFE; ]; like($@, qr/Identifier too long/, "too long id in for ctx"); # the specific case from the ticket my $x = "x" x 257; eval qq[ for $x ]; like($@, qr/Identifier too long/, "too long id ticket case"); } { is(exists &zlonk, '', 'sub not present'); eval qq[ {sub zlonk} ]; is($@, '', 'sub declaration followed by a closing curly'); is(exists &zlonk, 1, 'sub now stubbed'); is(defined &zlonk, '', 'but no body defined'); } # bug #71748 eval q{ $_ = ""; s/(.)/ { # }->{$1}; /e; 1; }; is($@, "", "multiline whitespace inside substitute expression"); # Add new tests HERE: # More awkward tests for #line. Keep these at the end, as they will screw # with sane line reporting for any other test failures sub check ($$$) { my ($file, $line, $name) = @_; my (undef, $got_file, $got_line) = caller; like ($got_file, $file, "file of $name"); is ($got_line, $line, "line of $name"); } my $this_file = qr/parser\.t(?:\.[bl]eb?)?$/; #line 3 check($this_file, 3, "bare line"); # line 5 check($this_file, 5, "bare line with leading space"); #line 7 check($this_file, 7, "trailing space still valid"); # line 11 check($this_file, 11, "leading and trailing"); # line 13 check($this_file, 13, "leading tab"); #line 17 check($this_file, 17, "middle tab"); #line 19 check($this_file, 19, "loadsaspaces"); #line 23 KASHPRITZA check(qr/^KASHPRITZA$/, 23, "bare filename"); #line 29 "KAHEEEE" check(qr/^KAHEEEE$/, 29, "filename in quotes"); #line 31 "CLINK CLOINK BZZT" check(qr/^CLINK CLOINK BZZT$/, 31, "filename with spaces in quotes"); #line 37 "THOOM THOOM" check(qr/^THOOM THOOM$/, 37, "filename with tabs in quotes"); #line 41 "GLINK PLINK GLUNK DINK" check(qr/^GLINK PLINK GLUNK DINK$/, 41, "a space after the quotes"); #line 43 "BBFRPRAFPGHPP check(qr/^"BBFRPRAFPGHPP$/, 43, "actually missing a quote is still valid"); #line 47 bang eth check(qr/^"BBFRPRAFPGHPP$/, 46, "but spaces aren't allowed without quotes"); #line 77sevenseven check(qr/^"BBFRPRAFPGHPP$/, 49, "need a space after the line number"); eval <<'EOSTANZA'; die $@ if $@; #line 51 "With wonderful deathless ditties|We build up the world's great cities,|And out of a fabulous story|We fashion an empire's glory:|One man with a dream, at pleasure,|Shall go forth and conquer a crown;|And three with a new song's measure|Can trample a kingdom down." check(qr/^With.*down\.$/, 51, "Overflow the second small buffer check"); EOSTANZA # And now, turn on the debugger flag for long names $^P = 0x100; #line 53 "For we are afar with the dawning|And the suns that are not yet high,|And out of the infinite morning|Intrepid you hear us cry-|How, spite of your human scorning,|Once more God's future draws nigh,|And already goes forth the warning|That ye of the past must die." check(qr/^For we.*must die\.$/, 53, "Our long line is set up"); eval <<'EOT'; die $@ if $@; #line 59 " " check(qr/^ $/, 59, "Overflow the first small buffer check only"); EOT eval <<'EOSTANZA'; die $@ if $@; #line 61 "Great hail! we cry to the comers|From the dazzling unknown shore;|Bring us hither your sun and your summers;|And renew our world as of yore;|You shall teach us your song's new numbers,|And things that we dreamed not before:|Yea, in spite of a dreamer who slumbers,|And a singer who sings no more." check(qr/^Great hail!.*no more\.$/, 61, "Overflow both small buffer checks"); EOSTANZA { my @x = 'string'; is(eval q{ "$x[0]->strung" }, 'string->strung', 'literal -> after an array subscript within ""'); @x = ['string']; # this used to give "string" like("$x[0]-> [0]", qr/^ARRAY\([^)]*\)-> \[0]\z/, 'literal -> [0] after an array subscript within ""'); } __END__ # Don't add new tests HERE. See note above perl-5.12.0-RC0/t/comp/opsubs.t0000555000175000017500000001326211325127001015025 0ustar jessejesse#!./perl -Tw # Uncomment this for testing, but don't leave it in for "production", as # we've not yet verified that use works. # use strict; $|++; print "1..36\n"; my $test = 0; sub failed { my ($got, $expected, $name) = @_; if ($::TODO) { print "not ok $test - $name # TODO: $::TODO\n"; } else { print "not ok $test - $name\n"; } my @caller = caller(1); print "# Failed test at $caller[1] line $caller[2]\n"; if (defined $got) { print "# Got '$got'\n"; } else { print "# Got undef\n"; } print "# Expected $expected\n"; return; } sub like { my ($got, $pattern, $name) = @_; $test = $test + 1; if (defined $got && $got =~ $pattern) { if ($::TODO) { print "ok $test - $name # TODO: $::TODO\n"; } else { print "ok $test - $name\n"; } # Principle of least surprise - maintain the expected interface, even # though we aren't using it here (yet). return 1; } failed($got, $pattern, $name); } sub is { my ($got, $expect, $name) = @_; $test = $test + 1; if (defined $got && $got eq $expect) { if ($::TODO) { print "ok $test - $name # TODO: $::TODO\n"; } else { print "ok $test - $name\n"; } return 1; } failed($got, "'$expect'", $name); } sub isnt { my ($got, $expect, $name) = @_; $test = $test + 1; if (defined $got && $got ne $expect) { if ($::TODO) { print "ok $test - $name # TODO: $::TODO\n"; } else { print "ok $test - $name\n"; } return 1; } failed($got, "not '$expect'", $name); } sub can_ok { my ($class, $method) = @_; $test = $test + 1; if (eval { $class->can($method) }) { if ($::TODO) { print "ok $test - $class->can('$method') # TODO: $::TODO\n"; } else { print "ok $test - $class->can('$method')\n"; } return 1; } my @caller = caller; print "# Failed test at $caller[1] line $caller[2]\n"; print "# $class cannot $method\n"; return; } =pod Even if you have a C, calling C will be parsed as the C operator. Calling C<&q()> or C gets you the function. This test verifies this behavior for nine different operators. =cut sub m { return "m-".shift } sub q { return "q-".shift } sub qq { return "qq-".shift } sub qr { return "qr-".shift } sub qw { return "qw-".shift } sub qx { return "qx-".shift } sub s { return "s-".shift } sub tr { return "tr-".shift } sub y { return "y-".shift } # m operator can_ok( 'main', "m" ); SILENCE_WARNING: { # Complains because $_ is undef local $^W; isnt( m('unqualified'), "m-unqualified", "m('unqualified') is oper" ); } is( main::m('main'), "m-main", "main::m() is func" ); is( &m('amper'), "m-amper", "&m() is func" ); # q operator can_ok( 'main', "q" ); isnt( q('unqualified'), "q-unqualified", "q('unqualified') is oper" ); is( main::q('main'), "q-main", "main::q() is func" ); is( &q('amper'), "q-amper", "&q() is func" ); # qq operator can_ok( 'main', "qq" ); isnt( qq('unqualified'), "qq-unqualified", "qq('unqualified') is oper" ); is( main::qq('main'), "qq-main", "main::qq() is func" ); is( &qq('amper'), "qq-amper", "&qq() is func" ); # qr operator can_ok( 'main', "qr" ); isnt( qr('unqualified'), "qr-unqualified", "qr('unqualified') is oper" ); is( main::qr('main'), "qr-main", "main::qr() is func" ); is( &qr('amper'), "qr-amper", "&qr() is func" ); # qw operator can_ok( 'main', "qw" ); isnt( qw('unqualified'), "qw-unqualified", "qw('unqualified') is oper" ); is( main::qw('main'), "qw-main", "main::qw() is func" ); is( &qw('amper'), "qw-amper", "&qw() is func" ); # qx operator can_ok( 'main', "qx" ); eval "qx('unqualified'". ($^O eq 'MSWin32' ? " 2>&1)" : ")"); TODO: { local $::TODO = $^O eq 'MSWin32' ? "Tainting of PATH not working of Windows" : $::TODO; like( $@, qr/^Insecure/, "qx('unqualified') doesn't work" ); } is( main::qx('main'), "qx-main", "main::qx() is func" ); is( &qx('amper'), "qx-amper", "&qx() is func" ); # s operator can_ok( 'main', "s" ); eval "s('unqualified')"; like( $@, qr/^Substitution replacement not terminated/, "s('unqualified') doesn't work" ); is( main::s('main'), "s-main", "main::s() is func" ); is( &s('amper'), "s-amper", "&s() is func" ); # tr operator can_ok( 'main', "tr" ); eval "tr('unqualified')"; like( $@, qr/^Transliteration replacement not terminated/, "tr('unqualified') doesn't work" ); is( main::tr('main'), "tr-main", "main::tr() is func" ); is( &tr('amper'), "tr-amper", "&tr() is func" ); # y operator can_ok( 'main', "y" ); eval "y('unqualified')"; like( $@, qr/^Transliteration replacement not terminated/, "y('unqualified') doesn't work" ); is( main::y('main'), "y-main", "main::y() is func" ); is( &y('amper'), "y-amper", "&y() is func" ); =pod from irc://irc.perl.org/p5p 2004/08/12 bug or feature? You decide!!!! [kane@coke ~]$ perlc -le'sub y{1};y(1)' Transliteration replacement not terminated at -e line 1. bug I think i'll perlbug feature smiles at rgs done will be closed at not a bug, like the previous reports of this one feature being first class and second class keywords? you have similar ones with q, qq, qr, qx, tr, s and m one could say 1st class keywords, yes and I forgot qw hmm silly... it's acutally operators, isn't it? as in you can't call a subroutine with the same name as an operator unless you have the & ? or fqpn (fully qualified package name) main::y() works just fine as does &y; but not y() If that's a feature, then let's write a test that it continues to work like that. =cut perl-5.12.0-RC0/t/comp/hints.aux0000444000175000017500000000013511325127001015161 0ustar jessejesseour($ri1, $rf1, $rfe1); BEGIN { $ri1 = $^H; $rf1 = $^H{foo}; $rfe1 = exists($^H{foo}); } 1; perl-5.12.0-RC0/t/comp/utf.t0000555000175000017500000000620711325127001014311 0ustar jessejesse#!./perl -w print "1..4016\n"; my $test = 0; my %templates = ( 'UTF-8' => 'C0U', 'UTF-16BE' => 'n', 'UTF-16LE' => 'v', ); sub bytes_to_utf { my ($enc, $content, $do_bom) = @_; my $template = $templates{$enc}; die "Unsupported encoding $enc" unless $template; my @chars = unpack "U*", $content; if ($enc ne 'UTF-8') { # Make surrogate pairs my @remember_that_utf_16_is_variable_length; foreach my $ord (@chars) { if ($ord < 0x10000) { push @remember_that_utf_16_is_variable_length, $ord; } else { $ord -= 0x10000; push @remember_that_utf_16_is_variable_length, (0xD800 | ($ord >> 10)), (0xDC00 | ($ord & 0x3FF)); } } @chars = @remember_that_utf_16_is_variable_length; } return pack "$template*", ($do_bom ? 0xFEFF : ()), @chars; } sub test { my ($enc, $write, $expect, $bom, $nl, $name) = @_; open my $fh, ">", "utf$$.pl" or die "utf.pl: $!"; binmode $fh; print $fh bytes_to_utf($enc, $write . ($nl ? "\n" : ''), $bom); close $fh or die $!; my $got = do "./utf$$.pl"; $test = $test + 1; if (!defined $got) { if ($@ =~ /^(Unsupported script encoding \Q$enc\E)/) { print "ok $test # skip $1\n"; } else { print "not ok $test # $enc $bom $nl $name; got undef\n"; } } elsif ($got ne $expect) { print "not ok $test # $enc $bom $nl $name; got '$got'\n"; } else { print "ok $test # $enc $bom $nl $name\n"; } } for my $bom (0, 1) { for my $enc (qw(UTF-16LE UTF-16BE UTF-8)) { for my $nl (1, 0) { for my $value (123, 1234, 12345) { test($enc, $value, $value, $bom, $nl, $value); # This has the unfortunate side effect of causing an infinite # loop without the bug fix it corresponds to: test($enc, "($value)", $value, $bom, $nl, "($value)"); } next if $enc eq 'UTF-8'; # Arguably a bug that currently string literals from UTF-8 file # handles are not implicitly "use utf8", but don't FIXME that # right now, as here we're testing the input filter itself. for my $expect ("N", "\xFF", "\x{100}", "\x{010a}", "\x{0a23}", "\x{10000}", "\x{64321}", "\x{10FFFD}", "\x{1000a}", # 0xD800 0xDC0A "\x{12800}", # 0xD80A 0xDC00 ) { # A space so that the UTF-16 heuristic triggers - " '" gives two # characters of ASCII. my $write = " '$expect'"; my $name = 'chrs ' . join ', ', map {ord $_} split '', $expect; test($enc, $write, $expect, $bom, $nl, $name); } # This is designed to try to trip over the end of the buffer, # with similar results to U-1000A and U-12800 above. for my $pad (2 .. 162) { for my $chr ("\x{10000}", "\x{1000a}", "\x{12800}") { my $padding = ' ' x $pad; # Need 4 octets that were from 2 ASCII characters to trigger # the heuristic that detects UTF-16 without a BOM. For # UTF-16BE, one space and the newline will do, as the # newline's high octet comes first. But for UTF-16LE, a # newline is "\n\0", so it doesn't trigger it. test($enc, " \n$padding'$chr'", $chr, $bom, $nl, sprintf "'\\x{%x}' with $pad spaces before it", ord $chr); } } } } } END { 1 while unlink "utf$$.pl"; } perl-5.12.0-RC0/t/comp/our.t0000555000175000017500000000300211325127001014306 0ustar jessejesse#!./perl print "1..7\n"; my $test = 0; sub is { my ($got, $expect, $name) = @_; $test = $test + 1; if (defined $got && $got eq $expect) { print "ok $test - $name\n"; return 1; } print "not ok $test - $name\n"; my @caller = caller(0); print "# Failed test at $caller[1] line $caller[2]\n"; if (defined $got) { print "# Got '$got'\n"; } else { print "# Got undef\n"; } print "# Expected $expect\n"; return; } { package TieAll; # tie, track, and report what calls are made my @calls; sub AUTOLOAD { for ($AUTOLOAD =~ /TieAll::(.*)/) { if (/TIE/) { return bless {} } elsif (/calls/) { return join ',', splice @calls } else { push @calls, $_; # FETCHSIZE doesn't like undef # if FIRSTKEY, see if NEXTKEY is also called return 1 if /FETCHSIZE|FIRSTKEY/; return; } } } } tie $x, 'TieAll'; tie @x, 'TieAll'; tie %x, 'TieAll'; {our $x;} is(TieAll->calls, '', 'our $x has no runtime effect'); {our ($x);} is(TieAll->calls, '', 'our ($x) has no runtime effect'); {our %x;} is(TieAll->calls, '', 'our %x has no runtime effect'); {our (%x);} is(TieAll->calls, '', 'our (%x) has no runtime effect'); {our @x;} is(TieAll->calls, '', 'our @x has no runtime effect'); {our (@x);} is(TieAll->calls, '', 'our (@x) has no runtime effect'); $y = 1; { my $y = 2; { our $y = $y; is($y, 2, 'our shouldnt be visible until introduced') } } perl-5.12.0-RC0/t/comp/redef.t0000555000175000017500000000402011325125742014601 0ustar jessejesse#!./perl -w # # Contributed by Graham Barr BEGIN { $warn = ""; $SIG{__WARN__} = sub { $warn .= join("",@_) } } sub ok ($$) { print $_[1] ? "ok " : "not ok ", $_[0], "\n"; } print "1..20\n"; my $NEWPROTO = 'Prototype mismatch:'; sub sub0 { 1 } sub sub0 { 2 } ok 1, $warn =~ s/Subroutine sub0 redefined[^\n]+\n//s; sub sub1 { 1 } sub sub1 () { 2 } ok 2, $warn =~ s/$NEWPROTO \Qsub main::sub1: none vs ()\E[^\n]+\n//s; ok 3, $warn =~ s/Subroutine sub1 redefined[^\n]+\n//s; sub sub2 { 1 } sub sub2 ($) { 2 } ok 4, $warn =~ s/$NEWPROTO \Qsub main::sub2: none vs ($)\E[^\n]+\n//s; ok 5, $warn =~ s/Subroutine sub2 redefined[^\n]+\n//s; sub sub3 () { 1 } sub sub3 { 2 } ok 6, $warn =~ s/$NEWPROTO \Qsub main::sub3 () vs none\E[^\n]+\n//s; ok 7, $warn =~ s/Constant subroutine sub3 redefined[^\n]+\n//s; sub sub4 () { 1 } sub sub4 () { 2 } ok 8, $warn =~ s/Constant subroutine sub4 redefined[^\n]+\n//s; sub sub5 () { 1 } sub sub5 ($) { 2 } ok 9, $warn =~ s/$NEWPROTO \Qsub main::sub5 () vs ($)\E[^\n]+\n//s; ok 10, $warn =~ s/Constant subroutine sub5 redefined[^\n]+\n//s; sub sub6 ($) { 1 } sub sub6 { 2 } ok 11, $warn =~ s/$NEWPROTO \Qsub main::sub6 ($) vs none\E[^\n]+\n//s; ok 12, $warn =~ s/Subroutine sub6 redefined[^\n]+\n//s; sub sub7 ($) { 1 } sub sub7 () { 2 } ok 13, $warn =~ s/$NEWPROTO \Qsub main::sub7 ($) vs ()\E[^\n]+\n//s; ok 14, $warn =~ s/Subroutine sub7 redefined[^\n]+\n//s; sub sub8 ($) { 1 } sub sub8 ($) { 2 } ok 15, $warn =~ s/Subroutine sub8 redefined[^\n]+\n//s; sub sub9 ($@) { 1 } sub sub9 ($) { 2 } ok 16, $warn =~ s/$NEWPROTO sub main::sub9 \(\$\Q@) vs ($)\E[^\n]+\n//s; ok 17, $warn =~ s/Subroutine sub9 redefined[^\n]+\n//s; BEGIN { local $^W = 0; eval qq(sub sub10 () {1} sub sub10 {1}); } ok 18, $warn =~ s/$NEWPROTO \Qsub main::sub10 () vs none\E[^\n]+\n//s; ok 19, $warn =~ s/Constant subroutine sub10 redefined[^\n]+\n//s; ok 20, $warn eq ''; # If we got any errors that we were not expecting, then print them print $warn if length $warn; perl-5.12.0-RC0/t/comp/decl.t0000555000175000017500000000064511325127001014422 0ustar jessejesse#!./perl # check to see if subroutine declarations work everwhere sub one { print "ok 1\n"; } format one = ok 5 . print "1..7\n"; one(); two(); sub two { print "ok 2\n"; } format two = @<<< $foo . if ($x eq $x) { sub three { print "ok 3\n"; } three(); } four(); $~ = 'one'; write; $~ = 'two'; $foo = "ok 6"; write; $~ = 'three'; write; format three = ok 7 . sub four { print "ok 4\n"; } perl-5.12.0-RC0/t/comp/proto.t0000555000175000017500000003471411325127001014662 0ustar jessejesse#!./perl # # Contributed by Graham Barr # # So far there are tests for the following prototypes. # none, () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@) # # It is impossible to test every prototype that can be specified, but # we should test as many as we can. # BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } # We need this, as in places we're testing the interaction of prototypes with # strict use strict; print "1..153\n"; my $i = 1; sub testing (&$) { my $p = prototype(shift); my $c = shift; my $what = defined $c ? '(' . $p . ')' : 'no prototype'; print '#' x 25,"\n"; print '# Testing ',$what,"\n"; print '#' x 25,"\n"; print "not " if((defined($p) && defined($c) && $p ne $c) || (defined($p) != defined($c))); printf "ok %d\n",$i++; } @_ = qw(a b c d); my @array; my %hash; ## ## ## testing \&no_proto, undef; sub no_proto { print "# \@_ = (",join(",",@_),")\n"; scalar(@_) } print "not " unless 0 == no_proto(); printf "ok %d\n",$i++; print "not " unless 1 == no_proto(5); printf "ok %d\n",$i++; print "not " unless 4 == &no_proto; printf "ok %d\n",$i++; print "not " unless 1 == no_proto +6; printf "ok %d\n",$i++; print "not " unless 4 == no_proto(@_); printf "ok %d\n",$i++; ## ## ## testing \&no_args, ''; sub no_args () { print "# \@_ = (",join(",",@_),")\n"; scalar(@_) } print "not " unless 0 == no_args(); printf "ok %d\n",$i++; print "not " unless 0 == no_args; printf "ok %d\n",$i++; print "not " unless 5 == no_args +5; printf "ok %d\n",$i++; print "not " unless 4 == &no_args; printf "ok %d\n",$i++; print "not " unless 2 == &no_args(1,2); printf "ok %d\n",$i++; eval "no_args(1)"; print "not " unless $@; printf "ok %d\n",$i++; ## ## ## testing \&one_args, '$'; sub one_args ($) { print "# \@_ = (",join(",",@_),")\n"; scalar(@_) } print "not " unless 1 == one_args(1); printf "ok %d\n",$i++; print "not " unless 1 == one_args +5; printf "ok %d\n",$i++; print "not " unless 4 == &one_args; printf "ok %d\n",$i++; print "not " unless 2 == &one_args(1,2); printf "ok %d\n",$i++; eval "one_args(1,2)"; print "not " unless $@; printf "ok %d\n",$i++; eval "one_args()"; print "not " unless $@; printf "ok %d\n",$i++; sub one_a_args ($) { print "# \@_ = (",join(",",@_),")\n"; print "not " unless @_ == 1 && $_[0] == 4; printf "ok %d\n",$i++; } one_a_args(@_); ## ## ## testing \&over_one_args, '$@'; sub over_one_args ($@) { print "# \@_ = (",join(",",@_),")\n"; scalar(@_) } print "not " unless 1 == over_one_args(1); printf "ok %d\n",$i++; print "not " unless 2 == over_one_args(1,2); printf "ok %d\n",$i++; print "not " unless 1 == over_one_args +5; printf "ok %d\n",$i++; print "not " unless 4 == &over_one_args; printf "ok %d\n",$i++; print "not " unless 2 == &over_one_args(1,2); printf "ok %d\n",$i++; print "not " unless 5 == &over_one_args(1,@_); printf "ok %d\n",$i++; eval "over_one_args()"; print "not " unless $@; printf "ok %d\n",$i++; sub over_one_a_args ($@) { print "# \@_ = (",join(",",@_),")\n"; print "not " unless @_ >= 1 && $_[0] == 4; printf "ok %d\n",$i++; } over_one_a_args(@_); over_one_a_args(@_,1); over_one_a_args(@_,1,2); over_one_a_args(@_,@_); ## ## ## testing \&scalar_and_hash, '$%'; sub scalar_and_hash ($%) { print "# \@_ = (",join(",",@_),")\n"; scalar(@_) } print "not " unless 1 == scalar_and_hash(1); printf "ok %d\n",$i++; print "not " unless 3 == scalar_and_hash(1,2,3); printf "ok %d\n",$i++; print "not " unless 1 == scalar_and_hash +5; printf "ok %d\n",$i++; print "not " unless 4 == &scalar_and_hash; printf "ok %d\n",$i++; print "not " unless 2 == &scalar_and_hash(1,2); printf "ok %d\n",$i++; print "not " unless 5 == &scalar_and_hash(1,@_); printf "ok %d\n",$i++; eval "scalar_and_hash()"; print "not " unless $@; printf "ok %d\n",$i++; sub scalar_and_hash_a ($@) { print "# \@_ = (",join(",",@_),")\n"; print "not " unless @_ >= 1 && $_[0] == 4; printf "ok %d\n",$i++; } scalar_and_hash_a(@_); scalar_and_hash_a(@_,1); scalar_and_hash_a(@_,1,2); scalar_and_hash_a(@_,@_); ## ## ## testing \&one_or_two, '$;$'; sub one_or_two ($;$) { print "# \@_ = (",join(",",@_),")\n"; scalar(@_) } print "not " unless 1 == one_or_two(1); printf "ok %d\n",$i++; print "not " unless 2 == one_or_two(1,3); printf "ok %d\n",$i++; print "not " unless 1 == one_or_two +5; printf "ok %d\n",$i++; print "not " unless 4 == &one_or_two; printf "ok %d\n",$i++; print "not " unless 3 == &one_or_two(1,2,3); printf "ok %d\n",$i++; print "not " unless 5 == &one_or_two(1,@_); printf "ok %d\n",$i++; eval "one_or_two()"; print "not " unless $@; printf "ok %d\n",$i++; eval "one_or_two(1,2,3)"; print "not " unless $@; printf "ok %d\n",$i++; sub one_or_two_a ($;$) { print "# \@_ = (",join(",",@_),")\n"; print "not " unless @_ >= 1 && $_[0] == 4; printf "ok %d\n",$i++; } one_or_two_a(@_); one_or_two_a(@_,1); one_or_two_a(@_,@_); ## ## ## testing \&a_sub, '&'; sub a_sub (&) { print "# \@_ = (",join(",",@_),")\n"; &{$_[0]}; } sub tmp_sub_1 { printf "ok %d\n",$i++ } a_sub { printf "ok %d\n",$i++ }; a_sub \&tmp_sub_1; @array = ( \&tmp_sub_1 ); eval 'a_sub @array'; print "not " unless $@; printf "ok %d\n",$i++; ## ## ## testing \&a_subx, '\&'; sub a_subx (\&) { print "# \@_ = (",join(",",@_),")\n"; &{$_[0]}; } sub tmp_sub_2 { printf "ok %d\n",$i++ } a_subx &tmp_sub_2; @array = ( \&tmp_sub_2 ); eval 'a_subx @array'; print "not " unless $@; printf "ok %d\n",$i++; ## ## ## testing \&sub_aref, '&\@'; sub sub_aref (&\@) { print "# \@_ = (",join(",",@_),")\n"; my($sub,$array) = @_; print "not " unless @_ == 2 && @{$array} == 4; print map { &{$sub}($_) } @{$array} } @array = (qw(O K)," ", $i++); sub_aref { lc shift } @array; print "\n"; ## ## ## testing \&sub_array, '&@'; sub sub_array (&@) { print "# \@_ = (",join(",",@_),")\n"; print "not " unless @_ == 5; my $sub = shift; print map { &{$sub}($_) } @_ } @array = (qw(O K)," ", $i++); sub_array { lc shift } @array; sub_array { lc shift } ('O', 'K', ' ', $i++); print "\n"; ## ## ## testing \&a_hash, '%'; sub a_hash (%) { print "# \@_ = (",join(",",@_),")\n"; scalar(@_); } print "not " unless 1 == a_hash 'a'; printf "ok %d\n",$i++; print "not " unless 2 == a_hash 'a','b'; printf "ok %d\n",$i++; ## ## ## testing \&a_hash_ref, '\%'; sub a_hash_ref (\%) { print "# \@_ = (",join(",",@_),")\n"; print "not " unless ref($_[0]) && $_[0]->{'a'}; printf "ok %d\n",$i++; $_[0]->{'b'} = 2; } %hash = ( a => 1); a_hash_ref %hash; print "not " unless $hash{'b'} == 2; printf "ok %d\n",$i++; ## ## ## testing \&array_ref_plus, '\@@'; sub array_ref_plus (\@@) { print "# \@_ = (",join(",",@_),")\n"; print "not " unless @_ == 2 && ref($_[0]) && 1 == @{$_[0]} && $_[1] eq 'x'; printf "ok %d\n",$i++; @{$_[0]} = (qw(ok)," ",$i++,"\n"); } @array = ('a'); { my @more = ('x'); array_ref_plus @array, @more; } print "not " unless @array == 4; print @array; my $p; print "not " if defined prototype('CORE::print'); print "ok ", $i++, "\n"; print "not " if defined prototype('CORE::system'); print "ok ", $i++, "\n"; print "# CORE::open => ($p)\nnot " if ($p = prototype('CORE::open')) ne '*;$@'; print "ok ", $i++, "\n"; print "# CORE:Foo => ($p), \$@ => `$@'\nnot " if defined ($p = eval { prototype('CORE::Foo') or 1 }) or $@ !~ /^Can't find an opnumber/; print "ok ", $i++, "\n"; # correctly note too-short parameter lists that don't end with '$', # a possible regression. sub foo1 ($\@); eval q{ foo1 "s" }; print "not " unless $@ =~ /^Not enough/; print "ok ", $i++, "\n"; sub foo2 ($\%); eval q{ foo2 "s" }; print "not " unless $@ =~ /^Not enough/; print "ok ", $i++, "\n"; sub X::foo3; *X::foo3 = sub {'ok'}; print "# $@not " unless eval {X->foo3} eq 'ok'; print "ok ", $i++, "\n"; sub X::foo4 ($); *X::foo4 = sub ($) {'ok'}; print "not " unless X->foo4 eq 'ok'; print "ok ", $i++, "\n"; # test if the (*) prototype allows barewords, constants, scalar expressions, # globs and globrefs (just as CORE::open() does), all under stricture sub star (*&) { &{$_[1]} } sub star2 (**&) { &{$_[2]} } sub BAR { "quux" } sub Bar::BAZ { "quuz" } my $star = 'FOO'; star FOO, sub { print "not " unless $_[0] eq 'FOO'; print "ok $i - star FOO\n"; }; $i++; star(FOO, sub { print "not " unless $_[0] eq 'FOO'; print "ok $i - star(FOO)\n"; }); $i++; star "FOO", sub { print "not " unless $_[0] eq 'FOO'; print qq/ok $i - star "FOO"\n/; }; $i++; star("FOO", sub { print "not " unless $_[0] eq 'FOO'; print qq/ok $i - star("FOO")\n/; }); $i++; star $star, sub { print "not " unless $_[0] eq 'FOO'; print "ok $i - star \$star\n"; }; $i++; star($star, sub { print "not " unless $_[0] eq 'FOO'; print "ok $i - star(\$star)\n"; }); $i++; star *FOO, sub { print "not " unless $_[0] eq \*FOO; print "ok $i - star *FOO\n"; }; $i++; star(*FOO, sub { print "not " unless $_[0] eq \*FOO; print "ok $i - star(*FOO)\n"; }); $i++; star \*FOO, sub { print "not " unless $_[0] eq \*FOO; print "ok $i - star \\*FOO\n"; }; $i++; star(\*FOO, sub { print "not " unless $_[0] eq \*FOO; print "ok $i - star(\\*FOO)\n"; }); $i++; star2 FOO, BAR, sub { print "not " unless $_[0] eq 'FOO' and $_[1] eq 'BAR'; print "ok $i - star2 FOO, BAR\n"; }; $i++; star2(Bar::BAZ, FOO, sub { print "not " unless $_[0] eq 'Bar::BAZ' and $_[1] eq 'FOO'; print "ok $i - star2(Bar::BAZ, FOO)\n" }); $i++; star2 BAR(), FOO, sub { print "not " unless $_[0] eq 'quux' and $_[1] eq 'FOO'; print "ok $i - star2 BAR(), FOO\n" }; $i++; star2(FOO, BAR(), sub { print "not " unless $_[0] eq 'FOO' and $_[1] eq 'quux'; print "ok $i - star2(FOO, BAR())\n"; }); $i++; star2 "FOO", "BAR", sub { print "not " unless $_[0] eq 'FOO' and $_[1] eq 'BAR'; print qq/ok $i - star2 "FOO", "BAR"\n/; }; $i++; star2("FOO", "BAR", sub { print "not " unless $_[0] eq 'FOO' and $_[1] eq 'BAR'; print qq/ok $i - star2("FOO", "BAR")\n/; }); $i++; star2 $star, $star, sub { print "not " unless $_[0] eq 'FOO' and $_[1] eq 'FOO'; print "ok $i - star2 \$star, \$star\n"; }; $i++; star2($star, $star, sub { print "not " unless $_[0] eq 'FOO' and $_[1] eq 'FOO'; print "ok $i - star2(\$star, \$star)\n"; }); $i++; star2 *FOO, *BAR, sub { print "not " unless $_[0] eq \*FOO and $_[1] eq \*BAR; print "ok $i - star2 *FOO, *BAR\n"; }; $i++; star2(*FOO, *BAR, sub { print "not " unless $_[0] eq \*FOO and $_[1] eq \*BAR; print "ok $i - star2(*FOO, *BAR)\n"; }); $i++; star2 \*FOO, \*BAR, sub { no strict 'refs'; print "not " unless $_[0] eq \*{'FOO'} and $_[1] eq \*{'BAR'}; print "ok $i - star2 \*FOO, \*BAR\n"; }; $i++; star2(\*FOO, \*BAR, sub { no strict 'refs'; print "not " unless $_[0] eq \*{'FOO'} and $_[1] eq \*{'BAR'}; print "ok $i - star2(\*FOO, \*BAR)\n"; }); $i++; # test scalarref prototype sub sreftest (\$$) { print "not " unless ref $_[0]; print "ok $_[1] - sreftest\n"; } { no strict 'vars'; sreftest my $sref, $i++; sreftest($helem{$i}, $i++); sreftest $aelem[0], $i++; } # test prototypes when they are evaled and there is a syntax error # Byacc generates the string "syntax error". Bison gives the # string "parse error". # for my $p ( "", qw{ () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@) } ) { my $warn = ""; local $SIG{__WARN__} = sub { my $thiswarn = join("",@_); return if $thiswarn =~ /^Prototype mismatch: sub main::evaled_subroutine/; $warn .= $thiswarn; }; my $eval = "sub evaled_subroutine $p { &void *; }"; eval $eval; print "# eval[$eval]\nnot " unless $@ && $@ =~ /(parse|syntax) error/i; print "ok ", $i++, "\n"; if ($warn eq '') { print "ok ", $i++, "\n"; } else { print "not ok ", $i++, "# $warn \n"; } } # Not $$;$;$ print "not " unless prototype "CORE::substr" eq '$$;$$'; print "ok ", $i++, "\n"; # recv takes a scalar reference for its second argument print "not " unless prototype "CORE::recv" eq '*\\$$$'; print "ok ", $i++, "\n"; { my $myvar; my @myarray; my %myhash; sub mysub { print "not calling mysub I hope\n" } local *myglob; sub myref (\[$@%&*]) { print "# $_[0]\n"; return "$_[0]" } print "not " unless myref($myvar) =~ /^SCALAR\(/; print "ok ", $i++, "\n"; print "not " unless myref(@myarray) =~ /^ARRAY\(/; print "ok ", $i++, "\n"; print "not " unless myref(%myhash) =~ /^HASH\(/; print "ok ", $i++, "\n"; print "not " unless myref(&mysub) =~ /^CODE\(/; print "ok ", $i++, "\n"; print "not " unless myref(*myglob) =~ /^GLOB\(/; print "ok ", $i++, "\n"; eval q/sub multi1 (\[%@]) { 1 } multi1 $myvar;/; print "not " unless $@ =~ /Type of arg 1 to main::multi1 must be one of \[%\@\] /; print "ok ", $i++, "\n"; eval q/sub multi2 (\[$*&]) { 1 } multi2 @myarray;/; print "not " unless $@ =~ /Type of arg 1 to main::multi2 must be one of \[\$\*&\] /; print "ok ", $i++, "\n"; eval q/sub multi3 (\[$@]) { 1 } multi3 %myhash;/; print "not " unless $@ =~ /Type of arg 1 to main::multi3 must be one of \[\$\@\] /; print "ok ", $i++, "\n"; eval q/sub multi4 ($\[%]) { 1 } multi4 1, &mysub;/; print "not " unless $@ =~ /Type of arg 2 to main::multi4 must be one of \[%\] /; print "ok ", $i++, "\n"; eval q/sub multi5 (\[$@]$) { 1 } multi5 *myglob;/; print "not " unless $@ =~ /Type of arg 1 to main::multi5 must be one of \[\$\@\] / && $@ =~ /Not enough arguments/; print "ok ", $i++, "\n"; } # check that obviously bad prototypes are getting warnings { local $^W = 1; my $warn = ""; local $SIG{__WARN__} = sub { $warn .= join("",@_) }; eval 'sub badproto (@bar) { 1; }'; print "not " unless $warn =~ /Illegal character in prototype for main::badproto : \@bar/; print "ok ", $i++, "\n"; eval 'sub badproto2 (bar) { 1; }'; print "not " unless $warn =~ /Illegal character in prototype for main::badproto2 : bar/; print "ok ", $i++, "\n"; eval 'sub badproto3 (&$bar$@) { 1; }'; print "not " unless $warn =~ /Illegal character in prototype for main::badproto3 : &\$bar\$\@/; print "ok ", $i++, "\n"; eval 'sub badproto4 (@ $b ar) { 1; }'; print "not " unless $warn =~ /Illegal character in prototype for main::badproto4 : \@\$bar/; print "ok ", $i++, "\n"; } # make sure whitespace in prototypes works eval "sub good (\$\t\$\n\$) { 1; }"; print "not " if $@; print "ok ", $i++, "\n"; # Ought to fail, doesn't in 5.8.1. eval 'sub bug (\[%@]) { } my $array = [0 .. 1]; bug %$array;'; print "not " unless $@ =~ /Not a HASH reference/; print "ok ", $i++, "\n"; perl-5.12.0-RC0/t/comp/fold.t0000555000175000017500000000441311325127001014434 0ustar jessejesse#!./perl -w # Uncomment this for testing, but don't leave it in for "production", as # we've not yet verified that use works. # use strict; print "1..13\n"; my $test = 0; # Historically constant folding was performed by evaluating the ops, and if # they threw an exception compilation failed. This was seen as buggy, because # even illegal constants in unreachable code would cause failure. So now # illegal expressions are reported at runtime, if the expression is reached, # making constant folding consistent with many other languages, and purely an # optimisation rather than a behaviour change. sub failed { my ($got, $expected, $name) = @_; print "not ok $test - $name\n"; my @caller = caller(1); print "# Failed test at $caller[1] line $caller[2]\n"; if (defined $got) { print "# Got '$got'\n"; } else { print "# Got undef\n"; } print "# Expected $expected\n"; return; } sub like { my ($got, $pattern, $name) = @_; $test = $test + 1; if (defined $got && $got =~ $pattern) { print "ok $test - $name\n"; # Principle of least surprise - maintain the expected interface, even # though we aren't using it here (yet). return 1; } failed($got, $pattern, $name); } sub is { my ($got, $expect, $name) = @_; $test = $test + 1; if (defined $got && $got eq $expect) { print "ok $test - $name\n"; return 1; } failed($got, "'$expect'", $name); } my $a; $a = eval '$b = 0/0 if 0; 3'; is ($a, 3, 'constants in conditionals don\'t affect constant folding'); is ($@, '', 'no error'); my $b = 0; $a = eval 'if ($b) {return sqrt -3} 3'; is ($a, 3, 'variables in conditionals don\'t affect constant folding'); is ($@, '', 'no error'); $a = eval q{ $b = eval q{if ($b) {return log 0} 4}; is ($b, 4, 'inner eval folds constant'); is ($@, '', 'no error'); 5; }; is ($a, 5, 'outer eval folds constant'); is ($@, '', 'no error'); # warn and die hooks should be disabled during constant folding { my $c = 0; local $SIG{__WARN__} = sub { $c++ }; local $SIG{__DIE__} = sub { $c+= 2 }; eval q{ is($c, 0, "premature warn/die: $c"); my $x = "a"+5; is($c, 1, "missing warn hook"); is($x, 5, "a+5"); $c = 0; $x = 1/0; }; like ($@, qr/division/, "eval caught division"); is($c, 2, "missing die hook"); } perl-5.12.0-RC0/t/comp/term.t0000555000175000017500000000445511325125742014477 0ustar jessejesse#!./perl # tests that aren't important enough for base.term print "1..23\n"; $x = "\\n"; print "#1\t:$x: eq " . ':\n:' . "\n"; if ($x eq '\n') {print "ok 1\n";} else {print "not ok 1\n";} $x = "#2\t:$x: eq :\\n:\n"; print $x; unless (index($x,'\\\\')>0) {print "ok 2\n";} else {print "not ok 2\n";} if (length('\\\\') == 2) {print "ok 3\n";} else {print "not ok 3\n";} $one = 'a'; if (length("\\n") == 2) {print "ok 4\n";} else {print "not ok 4\n";} if (length("\\\n") == 2) {print "ok 5\n";} else {print "not ok 5\n";} if (length("$one\\n") == 3) {print "ok 6\n";} else {print "not ok 6\n";} if (length("$one\\\n") == 3) {print "ok 7\n";} else {print "not ok 7\n";} if (length("\\n$one") == 3) {print "ok 8\n";} else {print "not ok 8\n";} if (length("\\\n$one") == 3) {print "ok 9\n";} else {print "not ok 9\n";} if (length("\\${one}") == 2) {print "ok 10\n";} else {print "not ok 10\n";} if ("${one}b" eq "ab") { print "ok 11\n";} else {print "not ok 11\n";} @foo = (1,2,3); if ("$foo[1]b" eq "2b") { print "ok 12\n";} else {print "not ok 12\n";} if ("@foo[0..1]b" eq "1 2b") { print "ok 13\n";} else {print "not ok 13\n";} $" = '::'; if ("@foo[0..1]b" eq "1::2b") { print "ok 14\n";} else {print "not ok 14\n";} # test if C distinguishes between blocks and hashrefs $a = "{ '\\'' , 'foo' }"; $a = eval $a; if (ref($a) eq 'HASH') {print "ok 15\n";} else {print "not ok 15\n";} $a = "{ '\\\\\\'abc' => 'foo' }"; $a = eval $a; if (ref($a) eq 'HASH') {print "ok 16\n";} else {print "not ok 16\n";} $a = "{'a\\\n\\'b','foo'}"; $a = eval $a; if (ref($a) eq 'HASH') {print "ok 17\n";} else {print "not ok 17\n";} $a = "{'\\\\\\'\\\\'=>'foo'}"; $a = eval $a; if (ref($a) eq 'HASH') {print "ok 18\n";} else {print "not ok 18\n";} $a = "{q,a'b,,'foo'}"; $a = eval $a; if (ref($a) eq 'HASH') {print "ok 19\n";} else {print "not ok 19\n";} $a = "{q[[']]=>'foo'}"; $a = eval $a; if (ref($a) eq 'HASH') {print "ok 20\n";} else {print "not ok 20\n";} # needs disambiguation if first term is a variable $a = "+{ \$a , 'foo'}"; $a = eval $a; if (ref($a) eq 'HASH') {print "ok 21\n";} else {print "not ok 21\n";} $a = "+{ \$a=>'foo'}"; $a = eval $a; if (ref($a) eq 'HASH') {print "ok 22\n";} else {print "not ok 22\n";} $a = "{ 0x01 => 'foo'}->{0x01}"; $a = eval $a; if ($a eq 'foo') {print "ok 23\n";} else {print "not ok 23\n";} perl-5.12.0-RC0/t/comp/retainedlines.t0000555000175000017500000000546311325127001016344 0ustar jessejesse#!./perl -w # Check that lines from eval are correctly retained by the debugger # Uncomment this for testing, but don't leave it in for "production", as # we've not yet verified that use works. # use strict; print "1..65\n"; my $test = 0; sub failed { my ($got, $expected, $name) = @_; print "not ok $test - $name\n"; my @caller = caller(1); print "# Failed test at $caller[1] line $caller[2]\n"; if (defined $got) { print "# Got '$got'\n"; } else { print "# Got undef\n"; } print "# Expected $expected\n"; return; } sub is { my ($got, $expect, $name) = @_; $test = $test + 1; if (defined $expect) { if (defined $got && $got eq $expect) { print "ok $test - $name\n"; return 1; } failed($got, "'$expect'", $name); } else { if (!defined $got) { print "ok $test - $name\n"; return 1; } failed($got, 'undef', $name); } } $^P = 0xA; my @before = grep { /eval/ } keys %::; is ((scalar @before), 0, "No evals"); my %seen; sub check_retained_lines { my ($prog, $name) = @_; # Is there a more efficient way to write this? my @expect_lines = (undef, map ({"$_\n"} split "\n", $prog), "\n", ';'); my @keys = grep {!$seen{$_}} grep { /eval/ } keys %::; is ((scalar @keys), 1, "1 new eval"); my @got_lines = @{$::{$keys[0]}}; is ((scalar @got_lines), (scalar @expect_lines), "Right number of lines for $name"); for (0..$#expect_lines) { is ($got_lines[$_], $expect_lines[$_], "Line $_ is correct"); } $seen{$keys[0]}++; } my $name = 'foo'; for my $sep (' ', "\0") { my $prog = "sub $name { 'Perl${sep}Rules' }; 1; "; eval $prog or die; check_retained_lines($prog, ord $sep); $name++; } { # This contains a syntax error my $prog = "sub $name { 'This is $name' } 1 + "; eval $prog and die; is (eval "$name()", "This is $name", "Subroutine was compiled, despite error") or print STDERR "# $@\n"; check_retained_lines($prog, 'eval that defines subroutine but has syntax error'); $name++; } foreach my $flags (0x0, 0x800, 0x1000, 0x1800) { local $^P = $^P | $flags; # This is easier if we accept that the guts eval will add a trailing \n # for us my $prog = "1 + 1 + 1\n"; my $fail = "1 + \n"; is (eval $prog, 3, 'String eval works'); if ($flags & 0x800) { check_retained_lines($prog, sprintf "%#X", $^P); } else { my @after = grep { /eval/ } keys %::; is (scalar @after, 0 + keys %seen, "evals that don't define subroutines are correctly cleaned up"); } is (eval $fail, undef, 'Failed string eval fails'); if ($flags & 0x1000) { check_retained_lines($fail, sprintf "%#X", $^P); } else { my @after = grep { /eval/ } keys %::; is (scalar @after, 0 + keys %seen, "evals that fail are correctly cleaned up"); } } perl-5.12.0-RC0/t/comp/multiline.t0000555000175000017500000000332111325127001015507 0ustar jessejesse#!./perl print "1..6\n"; my $test = 0; sub failed { my ($got, $expected, $name) = @_; print "not ok $test - $name\n"; my @caller = caller(1); print "# Failed test at $caller[1] line $caller[2]\n"; if (defined $got) { print "# Got '$got'\n"; } else { print "# Got undef\n"; } print "# Expected $expected\n"; return; } sub like { my ($got, $pattern, $name) = @_; $test = $test + 1; if (defined $got && $got =~ $pattern) { print "ok $test - $name\n"; # Principle of least surprise - maintain the expected interface, even # though we aren't using it here (yet). return 1; } failed($got, $pattern, $name); } sub is { my ($got, $expect, $name) = @_; $test = $test + 1; if (defined $got && $got eq $expect) { print "ok $test - $name\n"; return 1; } failed($got, "'$expect'", $name); } my $filename = "multiline$$"; END { 1 while unlink $filename; } open(TRY,'>',$filename) || (die "Can't open $filename: $!"); $x = 'now is the time for all good men to come to. ! '; $y = 'now is the time' . "\n" . 'for all good men' . "\n" . 'to come to.' . "\n\n\n!\n\n"; is($x, $y, 'test data is sane'); print TRY $x; close TRY or die "Could not close: $!"; open(TRY,$filename) || (die "Can't reopen $filename: $!"); $count = 0; $z = ''; while () { $z .= $_; $count = $count + 1; } is($z, $y, 'basic multiline reading'); is($count, 7, ' line count'); is($., 7, ' $.' ); $out = (($^O eq 'MSWin32') || $^O eq 'NetWare') ? `type $filename` : ($^O eq 'VMS') ? `type $filename.;0` # otherwise .LIS is assumed : `cat $filename`; like($out, qr/.*\n.*\n.*\n$/); close(TRY) || (die "Can't close $filename: $!"); is($out, $y); perl-5.12.0-RC0/t/comp/line_debug.t0000555000175000017500000000123611325127001015605 0ustar jessejesse#!./perl chdir 't' if -d 't'; sub ok { my($test,$ok) = @_; print "not " unless $ok; print "ok $test\n"; } # The auxiliary file contains a bunch of code that systematically exercises # every place that can call lex_next_chunk() (except for the one that's not # used by the main Perl parser). open AUX, "<", "comp/line_debug_0.aux" or die $!; my @lines = ; close AUX; my $nlines = @lines; print "1..", 2+$nlines, "\n"; $^P = 0x2; do "comp/line_debug_0.aux"; ok 1, scalar(@{"_{_NUM_ERRORS}) if(!$opts || ($opts->{-severity} && $opts->{-severity} eq 'ERROR')); ++($self->{_NUM_WARNINGS}) if(!$opts || ($opts->{-severity} && $opts->{-severity} eq 'WARNING')); push @errors, $opts; }; } use strict; use File::Spec; s{^\.\./lib$}{lib} for @INC; chdir '..'; my @files; my $manifest = 'MANIFEST'; open my $m, '<', $manifest or die "Can't open '$manifest': $!"; while (<$m>) { chomp; next unless /\s/; # Ignore lines without whitespace (i.e., filename only) my ($file, $separator) = /^(\S+)(\s+)/; next if $file =~ /^cpan\//; next unless ($file =~ /\.(?:pm|pod|pl)$/); push @files, $file; }; @files = sort @files; # so we get consistent results sub pod_ok { my ($filename) = @_; local @My::Pod::Checker::errors; my $checker = My::Pod::Checker->new(-quiet => 1); $checker->parse_from_file($filename, undef); my $error_count = $checker->num_errors(); if(! ok($error_count <= 0, "POD of $filename")) { diag( "'$filename' contains POD errors" ); diag(sprintf "%s %s: %s at line %s", $_->{-severity}, $_->{-file}, $_->{-msg}, $_->{-line}) for @My::Pod::Checker::errors; }; }; plan (tests => scalar @files); pod_ok $_ for @files; __DATA__ lib/ ext/ pod/ AUTHORS Changes INSTALL README* *.pod perl-5.12.0-RC0/t/porting/maintainers.t0000555000175000017500000000144411325127002016550 0ustar jessejesse#!./perl -w # Test that there are no missing Maintainers in Maintainers.PL BEGIN { # This test script uses a slightly atypical invocation of the 'standard' # core testing setup stanza. # The existing porting tools which manage the Maintainers file all # expect to be run from the root # XXX that should be fixed chdir '..' unless -d 't'; @INC = qw(lib Porting); } use strict; use warnings; use Maintainers qw(show_results process_options finish_tap_output); if ($^O eq 'VMS') { print "1..0 # Skip: home-grown glob doesn't handle fancy patterns\n"; exit 0; } { local @ARGV = qw|--tap-output --checkmani|; show_results(process_options()); } { local @ARGV = qw|--tap-output --checkmani lib/ ext/|; show_results(process_options()); } finish_tap_output(); # EOF perl-5.12.0-RC0/t/porting/checkcase.t0000555000175000017500000000130211325127002016140 0ustar jessejesse#!/usr/bin/perl # Finds the files that have the same name, case insensitively, # in the current directory and its subdirectories use warnings; use strict; use File::Find; my %files; my $test_count = 0; find(sub { my $name = $File::Find::name; # Assumes that the path separator is exactly one character. $name =~ s/^\.\..//; # Special exemption for Makefile, makefile return if $name =~ m!\A(?:x2p/)?[Mm]akefile\z!; push @{$files{lc $name}}, $name; }, '..'); foreach (values %files) { if (@$_ > 1) { print "not ok ".++$test_count. " - ". join(", ", @$_), "\n"; } else { print "ok ".++$test_count. " - ". join(", ", @$_), "\n"; } } print "1..".$test_count."\n"; perl-5.12.0-RC0/t/porting/args_assert.t0000555000175000017500000000222411325127002016550 0ustar jessejesse#!perl use strict; use warnings; require './test.pl'; plan('no_plan'); # Fail for every PERL_ARGS_ASSERT* macro that was declared but not used. my %declared; my %used; my $prefix = ''; unless (-d 't' && -f 'MANIFEST') { # we'll assume that we are in t then. # All files are interal to perl, so Unix-style is sufficiently portable. $prefix = '../'; } { my $proto = $prefix . 'proto.h'; open my $fh, '<', $proto or die "Can't open $proto: $!"; while (<$fh>) { $declared{$1}++ if /^#define\s+(PERL_ARGS_ASSERT[A-Za-z_]+)\s+/; } } cmp_ok(scalar keys %declared, '>', 0, 'Some macros were declared'); if (!@ARGV) { my $manifest = $prefix . 'MANIFEST'; open my $fh, '<', $manifest or die "Can't open $manifest: $!"; while (<$fh>) { # *.c or */*.c push @ARGV, $prefix . $1 if m!^((?:[^/]+/)?[^/]+\.c)\t!; } } while (<>) { $used{$1}++ if /^\s+(PERL_ARGS_ASSERT_[A-Za-z_]+);$/; } my %unused; foreach (keys %declared) { $unused{$_}++ unless $used{$_}; } if (keys %unused) { fail("$_ is declared but not used") foreach sort keys %unused; } else { pass('Every PERL_ARGS_ASSERT* macro declared is used'); } perl-5.12.0-RC0/t/porting/manifest.t0000555000175000017500000000256111325127002016045 0ustar jessejesse#!./perl -w # Test the well-formed-ness of the MANIFEST file. BEGIN { chdir 't'; @INC = '../lib'; } use strict; use File::Spec; require './test.pl'; plan('no_plan'); my $manifest = File::Spec->catfile(File::Spec->updir(), 'MANIFEST'); open my $m, '<', $manifest or die "Can't open '$manifest': $!"; # Test that MANIFEST uses tabs - not spaces - after the name of the file. while (<$m>) { chomp; next unless /\s/; # Ignore lines without whitespace (i.e., filename only) my ($file, $separator) = /^(\S+)(\s+)/; isnt($file, undef, "Line $. doesn't start with a blank") or next; # Remember, we're running from t/ ok(-f "../$file", "File $file exists"); if ($separator !~ tr/\t//c) { # It's all tabs next; } elsif ($separator !~ tr/ //c) { # It's all spaces fail("Spaces in entry for $file"); } elsif ($separator =~ tr/\t//) { fail("Mixed tabs and spaces in entry for $file"); } else { fail("Odd whitespace in entry for $file"); } } close $m or die $!; # Test that MANIFEST is properly sorted SKIP: { skip("'Porting/manisort' not found", 1) if (! -f '../Porting/manisort'); my $result = runperl('progfile' => '../Porting/manisort', 'args' => [ '-c', '../MANIFEST' ], 'stderr' => 1); like($result, qr/is sorted properly/, 'MANIFEST sorted properly'); } # EOF perl-5.12.0-RC0/t/porting/diag.t0000555000175000017500000003153111325127002015142 0ustar jessejesse#!/usr/bin/perl use warnings; use strict; require './test.pl'; plan('no_plan'); $|=1; my $make_exceptions_list = ($ARGV[0]||'') eq '--make-exceptions-list'; chdir '..' or die "Can't chdir ..: $!"; BEGIN { defined $ENV{PERL_UNICODE} and push @INC, "lib"; } open my $diagfh, "<", "pod/perldiag.pod" or die "Can't open pod/perldiag.pod: $!"; my %entries; while () { chomp; $entries{$_}{todo}=1; } my $cur_entry; while (<$diagfh>) { if (m/^=item (.*)/) { $cur_entry = $1; } elsif (m/^\((.)(?: ([a-z]+?))?\)/ and !$entries{$cur_entry}{severity}) { # Make sure to init this here, so an actual entry in perldiag overwrites # one in DATA. $entries{$cur_entry}{todo} = 0; $entries{$cur_entry}{severity} = $1; $entries{$cur_entry}{category} = $2; } } my @todo = <*>; while (@todo) { my $todo = shift @todo; next if $todo ~~ ['t', 'lib', 'ext', 'dist', 'cpan']; # opmini.c is just a copy of op.c, so there's no need to check again. next if $todo eq 'opmini.c'; if (-d $todo) { push @todo, glob "$todo/*"; } elsif ($todo =~ m/\.[ch]$/) { check_file($todo); } } sub check_file { my ($codefn) = @_; print "# $codefn\n"; open my $codefh, "<", $codefn or die "Can't open $codefn: $!"; my $listed_as; my $listed_as_line; my $sub = 'top of file'; while (<$codefh>) { chomp; # Getting too much here isn't a problem; we only use this to skip # errors inside of XS modules, which should get documented in the # docs for the module. if (m<^([^#\s].*)> and $1 !~ m/^[{}]*$/) { $sub = $1; } next if $sub =~ m/^XS/; if (m) { $listed_as = $1; $listed_as_line = $.+1; } next if /^#/; next if /^ * /; while (m/\bDIE\b|Perl_(croak|die|warn(er)?)/ and not m/\);$/) { my $nextline = <$codefh>; # Means we fell off the end of the file. Not terribly surprising; # this code tries to merge a lot of things that aren't regular C # code (preprocessor stuff, long comments). That's OK; we don't # need those anyway. last if not defined $nextline; chomp $nextline; $nextline =~ s/^\s+//; # Note that we only want to do this where *both* are true. $_ =~ s/\\$//; if ($_ =~ m/"$/ and $nextline =~ m/^"/) { $_ =~ s/"$//; $nextline =~ s/^"//; } $_ = "$_$nextline"; } # This should happen *after* unwrapping, or we don't reformat the things # in later lines. # List from perlguts.pod "Formatted Printing of IVs, UVs, and NVs" my %specialformats = (IVdf => 'd', UVuf => 'd', UVof => 'o', UVxf => 'x', UVXf => 'X', NVef => 'f', NVff => 'f', NVgf => 'f', SVf => 's'); for my $from (keys %specialformats) { s/%"\s*$from\s*"/\%$specialformats{$from}/g; s/%"\s*$from/\%$specialformats{$from}"/g; } # The %"foo" thing needs to happen *before* this regex. if (m/(?:DIE|Perl_(croak|die|warn|warner))(?:_nocontext)? \s* \(aTHX_ \s* (?:packWARN\d*\((.*?)\),)? \s* "((?:\\"|[^"])*?)"/x) { # diag($_); # DIE is just return Perl_die my $severity = {croak => [qw/P F/], die => [qw/P F/], warn => [qw/W D S/], }->{$1||'die'}; my @categories; if ($2) { @categories = map {s/^WARN_//; lc $_} split /\s*[|,]\s*/, $2; } my $name; if ($listed_as and $listed_as_line == $.) { $name = $listed_as; } else { $name = $3; # The form listed in perldiag ignores most sorts of fancy printf formatting, # or makes it more perlish. $name =~ s/%%/\\%/g; $name =~ s/%l[ud]/%d/g; $name =~ s/%\.(\d+|\*)s/\%s/g; $name =~ s/\\"/"/g; $name =~ s/\\t/\t/g; $name =~ s/\\n/ /g; $name =~ s/\s+$//; } # Extra explanatory info on an already-listed error, doesn't # need it's own listing. next if $name =~ m/^\t/; # Happens fairly often with PL_no_modify. next if $name eq '%s'; # Special syntax for magic comment, allows ignoring the fact # that it isn't listed. Only use in very special circumstances, # like this script failing to notice that the Perl_croak call is # inside an #if 0 block. next if $name eq 'SKIPME'; if (exists $entries{$name}) { if ($entries{$name}{todo}) { TODO: { no warnings 'once'; local $::TODO = 'in DATA'; fail("Presence of '$name' from $codefn line $."); } } else { ok("Presence of '$name' from $codefn line $."); } # Later, should start checking that the severity is correct, too. } elsif ($name =~ m/^panic: /) { # Just too many panic:s, they are hard to diagnose, and there # is a generic "panic: %s" entry. Leave these for another # pass. ok("Presence of '$name' from $codefn line $., covered by panic: %s entry"); } else { if ($make_exceptions_list) { print STDERR "$name\n"; } else { fail("Presence of '$name' from $codefn line $."); } } die if $name =~ /%$/; } } } # Lists all missing things as of the inaguration of this script, so we # don't have to go from "meh" to perfect all at once. __DATA__ Ambiguous call resolved as CORE::%s(), %s Ambiguous use of %c resolved as operator %c Ambiguous use of %c{%s} resolved to %c%s Ambiguous use of %c{%s%s} resolved to %c%s%s Ambiguous use of -%s resolved as -&%s() Argument "%s" isn't numeric Argument "%s" isn't numeric in %s Attempt to clear deleted array Attempt to free non-arena SV: 0x%x Attempt to free non-existent shared string '%s'%s Attempt to free temp prematurely: SV 0x%x Attempt to free unreferenced scalar: SV 0x%x Attempt to reload %s aborted. Compilation failed in require av_reify called on tied array Bad name after %s%s Bad symbol for %s bad top format reference Bizarre copy of %s Bizarre SvTYPE [%d] Cannot copy to %s Can't call method "%s" %s Can't coerce readonly %s to string Can't coerce readonly %s to string in %s Can't fix broken locale name "%s" Can't get short module name from a handle Can't goto subroutine from an eval-block Can't goto subroutine from an eval-string Can't locate object method "%s" via package "%s" (perhaps you forgot to load "%s"?) Can't modify non-existent substring Can't open Can't open perl script "%s": %s Can't open %s Can't reset \%ENV on this system Can't return array to lvalue scalar context Can't return a %s from lvalue subroutine Can't return hash to lvalue scalar context Can't spawn "%s": %s Can't %s script `%s' with ARGV[0] being `%s' Can't %s "%s": %s Can't %s %s%s%s Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found) Can't take %s of %f Can't use '%c' after -mname Can't use string ("%s"%s) as a subroutine ref while "strict refs" in use Can't use \\%c to mean $%c in expression Can't use when() outside a topicalizer \\%c better written as $%c Character(s) in '%c' format wrapped in %s $%c is no longer supported Cloning substitution context is unimplemented Code missing after '/' in pack Code missing after '/' in unpack Compilation failed in require Corrupted regexp opcode %d > %d '%c' outside of string in pack Debug leaking scalars child failed%s%s with errno %d: %s Deep recursion on anonymous subroutine defined(\%hash) is deprecated Don't know how to handle magic of type \\%o -Dp not implemented on this platform entering effective gid failed entering effective uid failed Error reading "%s": %s Exiting %s via %s Filehandle opened only for %sput Filehandle %s opened only for %sput Filehandle STD%s reopened as %s only for input YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET! FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP! Format STDOUT redefined Free to wrong pool %p not %p get %s %p %p %p glob failed (can't start child: %s) glob failed (child exited with status %d%s) Goto undefined subroutine Goto undefined subroutine &%s Hash \%%s missing the \% in argument %d of %s() Illegal character \\%03o (carriage return) Illegal character %sin prototype for %s : %s Integer overflow in decimal number Integer overflow in version %d internal \%p might conflict with future printf extensions invalid control request: '\\%03o' Invalid module name %s with -%c option: contains single ':' invalid option -D%c, use -D'' to see choices Invalid range "%c-%c" in transliteration operator Invalid separator character %c%c%c in PerlIO layer specification %s Invalid TOKEN object ignored Invalid type '%c' in pack Invalid type '%c' in %s Invalid type '%c' in unpack Invalid type ',' in %s Invalid strict version format (0 before decimal required) Invalid strict version format (no leading zeros) Invalid strict version format (no underscores) Invalid strict version format (v1.2.3 required) Invalid strict version format (version required) Invalid strict version format (1.[0-9] required) Invalid version format (alpha without decimal) Invalid version format (misplaced _ in number) Invalid version object 'j' not supported on this platform 'J' not supported on this platform Layer does not match this perl leaving effective gid failed leaving effective uid failed List form of piped open not implemented Lost precision when decrementing %f by 1 Lost precision when incrementing %f by 1 %lx Malformed UTF-16 surrogate Malformed UTF-8 character (fatal) '\%' may not be used in pack Missing (suid) fd script name More than one argument to open More than one argument to open(,':%s') mprotect for %p %d failed with %d mprotect RW for %p %d failed with %d No code specified for -%c No directory specified for -I No such class field "%s" Not an XSUB reference Not %s reference Offset outside string Opening dirhandle %s also as a file Opening filehandle %s also as a directory Operator or semicolon missing before %c%s PERL_SIGNALS illegal: "%s" Perl %s required (did you mean %s?)--this is only %s, stopped Perl %s required--this is only %s, stopped Perls since %s too modern--this is %s, stopped Possible unintended interpolation of $\\ in regex ptr wrong %p != %p fl=%08 Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?) Recursive call to Perl_load_module in PerlIO_find_layer refcnt_dec: fd %d < 0 refcnt_dec: fd %d: %d <= 0 refcnt_dec: fd %d >= refcnt_size %d refcnt_inc: fd %d < 0 refcnt_inc: fd %d: %d <= 0 Reversed %c= operator Runaway prototype %s(%.0f) failed %s(%.0f) too large Scalar value %s better written as $%s %sCompilation failed in regexp %sCompilation failed in require set %s %p %p %p %s free() ignored (RMAGIC, PERL_CORE) %s has too many errors. SIG%s handler "%s" not defined. %s: illegal mapping '%s' %s in %s Size magic not implemented %s limit (%d) exceeded %s method "%s" overloading "%s" in package "%s" %s number > %s non-portable %s object version %s does not match %s%s%s%s %s %srealloc() %signored %s returned from lvalue subroutine in scalar context %s%s has too many errors. %s%s on %s %s %s%s on %s %s %s Starting Full Screen process with flag=%d, mytype=%d Starting PM process with flag=%d, mytype=%d strxfrm() gets absurd SWASHNEW didn't return an HV ref -T and -B not implemented on filehandles The flock() function is not implemented on NetWare The rewinddir() function is not implemented on NetWare The seekdir() function is not implemented on NetWare The stat preceding lstat() wasn't an lstat The telldir() function is not implemented on NetWare Too deeply nested ()-groups in %s Too late to run CHECK block Too late to run INIT block Too many args on %s line of "%s" U0 mode on a byte string Unbalanced string table refcount: (%d) for "%s" Undefined top format called Unexpected constant lvalue entersub entry via type/targ %d:%d Unicode non-character 0x%04 Unknown PerlIO layer "scalar" Unknown Unicode option letter '%c' unrecognised control character '%c' Unstable directory path, current directory changed unexpectedly Unsupported script encoding UTF-16BE Unsupported script encoding UTF-16LE Unsupported script encoding UTF-32BE Unsupported script encoding UTF-32LE Unterminated compressed integer in unpack Usage: CODE(0x%x)(%s) Usage: %s(%s) Usage: %s::%s(%s) Usage: VMS::Filespec::unixrealpath(spec) Usage: VMS::Filespec::vmsrealpath(spec) Use of inherited AUTOLOAD for non-method %s::%s() is deprecated UTF-16 surrogate 0x%04 utf8 "\\x%02X" does not map to Unicode Value of logical "%s" too long. Truncating to %i bytes value of node is %d in Offset macro Value of %s%s can be "0"; test with defined() Variable "%c%s" is not imported vector argument not supported with alpha versions Wide character Wide character in $/ Wide character in print Wide character in %s Within []-length '%c' not allowed in %s Wrong syntax (suid) fd script name "%s" 'X' outside of string in unpack perl-5.12.0-RC0/t/porting/test_bootstrap.t0000555000175000017500000000273411325127002017315 0ustar jessejesse#!/perl -w use strict; # See "Writing a test" in perlhack.pod for the instructions about the order that # testing directories run, and which constructions should be avoided in the # early tests. # This regression tests ensures that the rules aren't accidentally overlooked. require './test.pl'; plan('no_plan'); open my $fh, '<', '../MANIFEST' or die "Can't open MANIFEST: $!"; # Three tests in t/comp need to use require or use to get their job done: my %exceptions = (hints => "require './test.pl'", parser => 'use DieDieDie', proto => 'use strict', ); while (my $file = <$fh>) { next unless $file =~ s!^t/!!; chomp $file; $file =~ s/\s+.*//; next unless $file =~ m!\.t$!; local $/; open my $t, '<', $file or die "Can't open $file: $!"; my $contents = <$t>; # Make sure that we don't match ourselves unlike($contents, qr/use\s+Test::More/, "$file doesn't use Test::\QMore"); next unless $file =~ m!^base/! or $file =~ m!^comp!; # Remove only the excepted constructions for the specific files. if ($file =~ m!comp/(.*)\.t! && $exceptions{$1}) { my $allowed = $exceptions{$1}; $contents =~ s/\Q$allowed//gs; } # All uses of use are allowed in t/comp/use.t unlike($contents, qr/^\s*use\s+/m, "$file doesn't use use") unless $file eq 'comp/use.t'; # All uses of require are allowed in t/comp/require.t unlike($contents, qr/^\s*require\s+/m, "$file doesn't use require") unless $file eq 'comp/require.t' } perl-5.12.0-RC0/t/thread_it.pl0000444000175000017500000000160511325125742014674 0ustar jessejesse#!perl use strict; use warnings; use Config; if (!$Config{useithreads}) { print "1..0 # Skip: no ithreads\n"; exit 0; } if ($ENV{PERL_CORE_MINITEST}) { print "1..0 # Skip: no dynamic loading on miniperl, no threads\n"; exit 0; } require threads; sub thread_it { # Generate things like './op/regexp.t', './t/op/regexp.t', ':op:regexp.t' my @paths = (join ('/', '.', @_), join ('/', '.', 't', @_), join (':', @_)); for my $file (@paths) { if (-r $file) { print "# found tests in $file\n"; $::running_as_thread = "running tests in a new thread"; do $file or die $@; print "# running tests in a new thread\n"; my $curr = threads->create(sub { run_tests(); return defined &curr_test ? curr_test() : () })->join(); curr_test($curr) if defined $curr; exit; } } die "Cannot find " . join (" or ", @paths) . "\n"; } 1; perl-5.12.0-RC0/t/base/0000755000175000017500000000000011351321566013307 5ustar jessejesseperl-5.12.0-RC0/t/base/cond.t0000555000175000017500000000051711325125742014422 0ustar jessejesse#!./perl # make sure conditional operators work print "1..4\n"; $x = '0'; $x eq $x && (print "ok 1\n"); $x ne $x && (print "not ok 1\n"); $x eq $x || (print "not ok 2\n"); $x ne $x || (print "ok 2\n"); $x == $x && (print "ok 3\n"); $x != $x && (print "not ok 3\n"); $x == $x || (print "not ok 4\n"); $x != $x || (print "ok 4\n"); perl-5.12.0-RC0/t/base/num.t0000555000175000017500000001333711325125742014302 0ustar jessejesse#!./perl print "1..50\n"; # First test whether the number stringification works okay. # (Testing with == would exercize the IV/NV part, not the PV.) $a = 1; "$a"; print $a eq "1" ? "ok 1\n" : "not ok 1 # $a\n"; $a = -1; "$a"; print $a eq "-1" ? "ok 2\n" : "not ok 2 # $a\n"; $a = 1.; "$a"; print $a eq "1" ? "ok 3\n" : "not ok 3 # $a\n"; $a = -1.; "$a"; print $a eq "-1" ? "ok 4\n" : "not ok 4 # $a\n"; $a = 0.1; "$a"; print $a eq "0.1" ? "ok 5\n" : "not ok 5 # $a\n"; $a = -0.1; "$a"; print $a eq "-0.1" ? "ok 6\n" : "not ok 6 # $a\n"; $a = .1; "$a"; print $a eq "0.1" ? "ok 7\n" : "not ok 7 # $a\n"; $a = -.1; "$a"; print $a eq "-0.1" ? "ok 8\n" : "not ok 8 # $a\n"; $a = 10.01; "$a"; print $a eq "10.01" ? "ok 9\n" : "not ok 9 # $a\n"; $a = 1e3; "$a"; print $a eq "1000" ? "ok 10\n" : "not ok 10 # $a\n"; $a = 10.01e3; "$a"; print $a eq "10010" ? "ok 11\n" : "not ok 11 # $a\n"; $a = 0b100; "$a"; print $a eq "4" ? "ok 12\n" : "not ok 12 # $a\n"; $a = 0100; "$a"; print $a eq "64" ? "ok 13\n" : "not ok 13 # $a\n"; $a = 0x100; "$a"; print $a eq "256" ? "ok 14\n" : "not ok 14 # $a\n"; $a = 1000; "$a"; print $a eq "1000" ? "ok 15\n" : "not ok 15 # $a\n"; # Okay, now test the numerics. # We may be assuming too much, given the painfully well-known floating # point sloppiness, but the following are still quite reasonable # assumptions which if not working would confuse people quite badly. $a = 1; "$a"; # Keep the stringification as a potential troublemaker. print $a + 1 == 2 ? "ok 16\n" : "not ok 16 #" . $a + 1 . "\n"; # Don't know how useful printing the stringification of $a + 1 really is. $a = -1; "$a"; print $a + 1 == 0 ? "ok 17\n" : "not ok 17 #" . $a + 1 . "\n"; $a = 1.; "$a"; print $a + 1 == 2 ? "ok 18\n" : "not ok 18 #" . $a + 1 . "\n"; $a = -1.; "$a"; print $a + 1 == 0 ? "ok 19\n" : "not ok 19 #" . $a + 1 . "\n"; sub ok { # Can't assume too much of floating point numbers. my ($a, $b, $c) = @_; abs($a - $b) <= $c; } $a = 0.1; "$a"; print ok($a + 1, 1.1, 0.05) ? "ok 20\n" : "not ok 20 #" . $a + 1 . "\n"; $a = -0.1; "$a"; print ok($a + 1, 0.9, 0.05) ? "ok 21\n" : "not ok 21 #" . $a + 1 . "\n"; $a = .1; "$a"; print ok($a + 1, 1.1, 0.005) ? "ok 22\n" : "not ok 22 #" . $a + 1 . "\n"; $a = -.1; "$a"; print ok($a + 1, 0.9, 0.05) ? "ok 23\n" : "not ok 23 #" . $a + 1 . "\n"; $a = 10.01; "$a"; print ok($a + 1, 11.01, 0.005) ? "ok 24\n" : "not ok 24 #" . $a + 1 . "\n"; $a = 1e3; "$a"; print $a + 1 == 1001 ? "ok 25\n" : "not ok 25 #" . $a + 1 . "\n"; $a = 10.01e3; "$a"; print $a + 1 == 10011 ? "ok 26\n" : "not ok 26 #" . $a + 1 . "\n"; $a = 0b100; "$a"; print $a + 1 == 0b101 ? "ok 27\n" : "not ok 27 #" . $a + 1 . "\n"; $a = 0100; "$a"; print $a + 1 == 0101 ? "ok 28\n" : "not ok 28 #" . $a + 1 . "\n"; $a = 0x100; "$a"; print $a + 1 == 0x101 ? "ok 29\n" : "not ok 29 #" . $a + 1 . "\n"; $a = 1000; "$a"; print $a + 1 == 1001 ? "ok 30\n" : "not ok 30 #" . $a + 1 . "\n"; # back to some basic stringify tests # we expect NV stringification to work according to C sprintf %.*g rules if ($^O eq 'os2') { # In the long run, fix this. For 5.8.0, deal. $a = 0.01; "$a"; print $a eq "0.01" || $a eq '1e-02' ? "ok 31\n" : "not ok 31 # $a\n"; $a = 0.001; "$a"; print $a eq "0.001" || $a eq '1e-03' ? "ok 32\n" : "not ok 32 # $a\n"; $a = 0.0001; "$a"; print $a eq "0.0001" || $a eq '1e-04' ? "ok 33\n" : "not ok 33 # $a\n"; } else { $a = 0.01; "$a"; print $a eq "0.01" ? "ok 31\n" : "not ok 31 # $a\n"; $a = 0.001; "$a"; print $a eq "0.001" ? "ok 32\n" : "not ok 32 # $a\n"; $a = 0.0001; "$a"; print $a eq "0.0001" ? "ok 33\n" : "not ok 33 # $a\n"; } $a = 0.00009; "$a"; print $a eq "9e-05" || $a eq "9e-005" ? "ok 34\n" : "not ok 34 # $a\n"; $a = 1.1; "$a"; print $a eq "1.1" ? "ok 35\n" : "not ok 35 # $a\n"; $a = 1.01; "$a"; print $a eq "1.01" ? "ok 36\n" : "not ok 36 # $a\n"; $a = 1.001; "$a"; print $a eq "1.001" ? "ok 37\n" : "not ok 37 # $a\n"; $a = 1.0001; "$a"; print $a eq "1.0001" ? "ok 38\n" : "not ok 38 # $a\n"; $a = 1.00001; "$a"; print $a eq "1.00001" ? "ok 39\n" : "not ok 39 # $a\n"; $a = 1.000001; "$a"; print $a eq "1.000001" ? "ok 40\n" : "not ok 40 # $a\n"; $a = 0.; "$a"; print $a eq "0" ? "ok 41\n" : "not ok 41 # $a\n"; $a = 100000.; "$a"; print $a eq "100000" ? "ok 42\n" : "not ok 42 # $a\n"; $a = -100000.; "$a"; print $a eq "-100000" ? "ok 43\n" : "not ok 43 # $a\n"; $a = 123.456; "$a"; print $a eq "123.456" ? "ok 44\n" : "not ok 44 # $a\n"; $a = 1e34; "$a"; unless ($^O eq 'posix-bc') { print $a eq "1e+34" || $a eq "1e+034" ? "ok 45\n" : "not ok 45 # $a\n"; } else { print "ok 45 # skipped on $^O\n"; } # see bug #15073 $a = 0.00049999999999999999999999999999999999999; $b = 0.0005000000000000000104; print $a <= $b ? "ok 46\n" : "not ok 46\n"; if ($^O eq 'ultrix' || $^O eq 'VMS') { # Ultrix enters looong nirvana over this. VMS blows up when configured with # D_FLOAT (but with G_FLOAT or IEEE works fine). The test should probably # make the number of 0's a function of NV_DIG, but that's not in Config and # we probably don't want to suck Config into a base test anyway. print "ok 47\n"; } else { $a = 0.00000000000000000000000000000000000000000000000000000000000000000001; print $a > 0 ? "ok 47\n" : "not ok 47\n"; } $a = 80000.0000000000000000000000000; print $a == 80000.0 ? "ok 48\n" : "not ok 48\n"; $a = 1.0000000000000000000000000000000000000000000000000000000000000000000e1; print $a == 10.0 ? "ok 49\n" : "not ok 49\n"; # From Math/Trig - number has to be long enough to exceed at least DBL_DIG $a = 57.295779513082320876798154814169; print ok($a*10,572.95779513082320876798154814169,1e-10) ? "ok 50\n" : "not ok 50 # $a\n"; perl-5.12.0-RC0/t/base/lex.t0000555000175000017500000001407311325127001014257 0ustar jessejesse#!./perl print "1..57\n"; $x = 'x'; print "#1 :$x: eq :x:\n"; if ($x eq 'x') {print "ok 1\n";} else {print "not ok 1\n";} $x = $#[0]; if ($x eq '') {print "ok 2\n";} else {print "not ok 2\n";} $x = $#x; if ($x eq '-1') {print "ok 3\n";} else {print "not ok 3\n";} $x = '\\'; # '; if (length($x) == 1) {print "ok 4\n";} else {print "not ok 4\n";} eval 'while (0) { print "foo\n"; } /^/ && (print "ok 5\n"); '; eval '$foo{1} / 1;'; if (!$@) {print "ok 6\n";} else {print "not ok 6 $@\n";} eval '$foo = 123+123.4+123e4+123.4E5+123.4e+5+.12;'; $foo = int($foo * 100 + .5); if ($foo eq 2591024652) {print "ok 7\n";} else {print "not ok 7 :$foo:\n";} print <<'EOF'; ok 8 EOF $foo = 'ok 9'; print <; print "ok 18 - was the test for the deprecated use of bare << to mean <<\"\"\n"; #print <<; # Yow! #ok 18 # ## previous line intentionally left blank. print < -1; print "ok 37\n"; # print "($@)\n" if $@; eval 'my $ {^XYZ};'; print "not " unless index ($@, 'Can\'t use global $^XYZ in "my"') > -1; print "ok 38\n"; # print "($@)\n" if $@; # Now let's make sure that caret variables are all forced into the main package. package Someother; $^Q = 'Someother'; $ {^Quixote} = 'Someother 2'; $ {^M} = 'Someother 3'; package main; print "not " unless $^Q eq 'Someother'; print "ok 39\n"; print "not " unless $ {^Quixote} eq 'Someother 2'; print "ok 40\n"; print "not " unless $ {^M} eq 'Someother 3'; print "ok 41\n"; } # see if eval '', s///e, and heredocs mix sub T { my ($where, $num) = @_; my ($p,$f,$l) = caller; print "# $p:$f:$l vs /$where/\nnot " unless "$p:$f:$l" =~ /$where/; print "ok $num\n"; } my $test = 42; { # line 42 "plink" local $_ = "not ok "; eval q{ s/^not /<@nosuch<" eq "><")) || print "# $@", "not "; print "ok $test\n"; ++$test; # Look at this! This is going to be a common error in the future: eval(q("fred@example.com" eq "fred.com")) || print "# $@", "not "; print "ok $test\n"; ++$test; # Let's make sure that normal array interpolation still works right # For some reason, this appears not to be tested anywhere else. my @a = (1,2,3); print +((">@a<" eq ">1 2 3<") ? '' : 'not '), "ok $test\n"; ++$test; # Ditto. eval(q{@nosuch = ('a', 'b', 'c'); ">@nosuch<" eq ">a b c<"}) || print "# $@", "not "; print "ok $test\n"; ++$test; # This isn't actually a lex test, but it's testing the same feature sub makearray { my @array = ('fish', 'dog', 'carrot'); *R::crackers = \@array; } eval(q{makearray(); ">@R::crackers<" eq ">fish dog carrot<"}) || print "# $@", "not "; print "ok $test\n"; ++$test; } # Tests 52-54 # => should only quote foo::bar if it isn't a real sub. AMS, 20010621 sub xyz::foo { "bar" } my %str = ( foo => 1, xyz::foo => 1, xyz::bar => 1, ); my $test = 52; print ((exists $str{foo} ? "" : "not ")."ok $test\n"); ++$test; print ((exists $str{bar} ? "" : "not ")."ok $test\n"); ++$test; print ((exists $str{xyz::bar} ? "" : "not ")."ok $test\n"); ++$test; sub foo::::::bar { print "ok $test\n"; $test++ } foo::::::bar; eval "\$x =\xE2foo"; if ($@ =~ /Unrecognized character \\xE2; marked by <-- HERE after \$x =<-- HERE near column 5/) { print "ok $test\n"; } else { print "not ok $test\n"; } $test++; # Is "[~" scanned correctly? @a = (1,2,3); print "not " unless($a[~~2] == 3); print "ok 57\n"; perl-5.12.0-RC0/t/base/if.t0000555000175000017500000000032211325125742014067 0ustar jessejesse#!./perl print "1..2\n"; # first test to see if we can run the tests. $x = 'test'; if ($x eq $x) { print "ok 1\n"; } else { print "not ok 1\n";} if ($x ne $x) { print "not ok 2\n"; } else { print "ok 2\n";} perl-5.12.0-RC0/t/base/rs.t0000555000175000017500000001377011325125742014130 0ustar jessejesse#!./perl # Test $! print "1..28\n"; $test_count = 1; $teststring = "1\n12\n123\n1234\n1234\n12345\n\n123456\n1234567\n"; $teststring2 = "1234567890123456789012345678901234567890"; # Create our test datafile 1 while unlink 'foo'; # in case junk left around rmdir 'foo'; open TESTFILE, ">./foo" or die "error $! $^E opening"; binmode TESTFILE; print TESTFILE $teststring; close TESTFILE or die "error $! $^E closing"; $test_count_start = $test_count; # Needed to know how many tests to skip open TESTFILE, "<./foo"; binmode TESTFILE; test_string(*TESTFILE); close TESTFILE; unlink "./foo"; # try the record reading tests. New file so we don't have to worry about # the size of \n. open TESTFILE, ">./foo"; print TESTFILE $teststring2; binmode TESTFILE; close TESTFILE; open TESTFILE, "<./foo"; binmode TESTFILE; test_record(*TESTFILE); close TESTFILE; $test_count_end = $test_count; # Needed to know how many tests to skip # Now for the tricky bit--full record reading if ($^O eq 'VMS') { # Create a temp file. We jump through these hoops 'cause CREATE really # doesn't like our methods for some reason. open FDLFILE, "> ./foo.fdl"; print FDLFILE "RECORD\n FORMAT VARIABLE\n"; close FDLFILE; open CREATEFILE, "> ./foo.com"; print CREATEFILE '$ DEFINE/USER SYS$INPUT NL:', "\n"; print CREATEFILE '$ DEFINE/USER SYS$OUTPUT NL:', "\n"; print CREATEFILE '$ OPEN YOW []FOO.BAR/WRITE', "\n"; print CREATEFILE '$ CLOSE YOW', "\n"; print CREATEFILE "\$EXIT\n"; close CREATEFILE; $throwaway = `\@\[\]foo`, "\n"; open(TEMPFILE, ">./foo.bar") or print "# open failed $! $^E\n"; print TEMPFILE "foo\nfoobar\nbaz\n"; close TEMPFILE; open TESTFILE, "<./foo.bar"; $/ = \10; $bar = ; if ($bar eq "foo\n") {print "ok $test_count\n";} else {print "not ok $test_count\n";} $test_count++; $bar = ; if ($bar eq "foobar\n") {print "ok $test_count\n";} else {print "not ok $test_count\n";} $test_count++; # can we do a short read? $/ = \2; $bar = ; if ($bar eq "ba") {print "ok $test_count\n";} else {print "not ok $test_count\n";} $test_count++; # do we get the rest of the record? $bar = ; if ($bar eq "z\n") {print "ok $test_count\n";} else {print "not ok $test_count\n";} $test_count++; close TESTFILE; 1 while unlink qw(foo.bar foo.com foo.fdl); } else { # Nobody else does this at the moment (well, maybe OS/390, but they can # put their own tests in) so we just punt foreach $test ($test_count..$test_count + 3) { print "ok $test # skipped on non-VMS system\n"; $test_count++; } } $/ = "\n"; # see if open/readline/close work on our and my variables { if (open our $T, "./foo") { my $line = <$T>; print "# $line\n"; length($line) == 40 or print "not "; close $T or print "not "; } else { print "not "; } print "ok $test_count # open/readline/close on our variable\n"; $test_count++; } { if (open my $T, "./foo") { my $line = <$T>; print "# $line\n"; length($line) == 40 or print "not "; close $T or print "not "; } else { print "not "; } print "ok $test_count # open/readline/close on my variable\n"; $test_count++; } if (not eval q/use PerlIO::scalar; use PerlIO::via::scalar; 1/) { # In-memory files necessitate PerlIO::via::scalar, thus a perl with # perlio and dynaloading enabled. miniperl won't be able to run this # test, so skip it # PerlIO::via::scalar has to be tested as well. # use PerlIO::scalar succeeds with ./TEST and with ./perl harness but not with ./perl for $test ($test_count .. $test_count + ($test_count_end - $test_count_start - 1)) { print "ok $test # skipped - Can't test in memory file with miniperl/without PerlIO::Scalar\n"; $test_count++; } } else { # Test if a file in memory behaves the same as a real file (= re-run the test with a file in memory) open TESTFILE, "<", \$teststring; test_string(*TESTFILE); close TESTFILE; open TESTFILE, "<", \$teststring2; test_record(*TESTFILE); close TESTFILE; } # Get rid of the temp file END { unlink "./foo"; } sub test_string { *FH = shift; # Check the default $/ $bar = ; if ($bar ne "1\n") {print "not ";} print "ok $test_count # default \$/\n"; $test_count++; # explicitly set to \n $/ = "\n"; $bar = ; if ($bar ne "12\n") {print "not ";} print "ok $test_count # \$/ = \"\\n\"\n"; $test_count++; # Try a non line terminator $/ = 3; $bar = ; if ($bar ne "123") {print "not ";} print "ok $test_count # \$/ = 3\n"; $test_count++; # Eat the line terminator $/ = "\n"; $bar = ; # How about a larger terminator $/ = "34"; $bar = ; if ($bar ne "1234") {print "not ";} print "ok $test_count # \$/ = \"34\"\n"; $test_count++; # Eat the line terminator $/ = "\n"; $bar = ; # Does paragraph mode work? $/ = ''; $bar = ; if ($bar ne "1234\n12345\n\n") {print "not ";} print "ok $test_count # \$/ = ''\n"; $test_count++; # Try slurping the rest of the file $/ = undef; $bar = ; if ($bar ne "123456\n1234567\n") {print "not ";} print "ok $test_count # \$/ = undef\n"; $test_count++; } sub test_record { *FH = shift; # Test straight number $/ = \2; $bar = ; if ($bar ne "12") {print "not ";} print "ok $test_count # \$/ = \\2\n"; $test_count++; # Test stringified number $/ = \"2"; $bar = ; if ($bar ne "34") {print "not ";} print "ok $test_count # \$/ = \"2\"\n"; $test_count++; # Integer variable $foo = 2; $/ = \$foo; $bar = ; if ($bar ne "56") {print "not ";} print "ok $test_count # \$/ = \\\$foo (\$foo = 2)\n"; $test_count++; # String variable $foo = "2"; $/ = \$foo; $bar = ; if ($bar ne "78") {print "not ";} print "ok $test_count # \$/ = \\\$foo (\$foo = \"2\")\n"; $test_count++; # Naughty straight number - should get the rest of the file $/ = \0; $bar = ; if ($bar ne "90123456789012345678901234567890") {print "not ";} print "ok $test_count # \$/ = \\0\n"; $test_count++; } perl-5.12.0-RC0/t/base/term.t0000555000175000017500000000217511325127001014436 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; } print "1..7\n"; # check "" interpretation $x = "\n"; # 10 is ASCII/Iso Latin, 13 is Mac OS, 21 is EBCDIC. if ($x eq chr(10)) { print "ok 1\n";} elsif ($x eq chr(13)) { print "ok 1 # Mac OS\n"; } elsif ($x eq chr(21)) { print "ok 1 # EBCDIC\n"; } else {print "not ok 1\n";} # check `` processing $x = `$^X -le "print 'hi there'"`; if ($x eq "hi there\n") {print "ok 2\n";} else {print "not ok 2\n";} # check $#array $x[0] = 'foo'; $x[1] = 'foo'; $tmp = $#x; print "#3\t:$tmp: == :1:\n"; if ($#x == '1') {print "ok 3\n";} else {print "not ok 3\n";} # check numeric literal $x = 1; if ($x == '1') {print "ok 4\n";} else {print "not ok 4\n";} $x = '1E2'; if (($x | 1) == 101) {print "ok 5\n";} else {print "not ok 5\n";} # check <> pseudoliteral open(try, "/dev/null") || open(try,"nla0:") || (die "Can't open /dev/null."); if ( eq '') { print "ok 6\n"; } else { print "not ok 6\n"; die "/dev/null IS NOT A CHARACTER SPECIAL FILE!!!!\n" unless -c '/dev/null'; } open(try, "harness") || (die "Can't open harness."); if ( ne '') {print "ok 7\n";} else {print "not ok 7\n";} perl-5.12.0-RC0/t/base/pat.t0000555000175000017500000000031711325125742014261 0ustar jessejesse#!./perl print "1..2\n"; # first test to see if we can run the tests. $_ = 'test'; if (/^test/) { print "ok 1\n"; } else { print "not ok 1\n";} if (/^foo/) { print "not ok 2\n"; } else { print "ok 2\n";} perl-5.12.0-RC0/t/win32/0000755000175000017500000000000011351321567013340 5ustar jessejesseperl-5.12.0-RC0/t/win32/system_tests0000444000175000017500000000423311143650501016021 0ustar jessejesse#!perl use Config; use Cwd; use strict; $| = 1; my $cwdb = my $cwd = cwd(); $cwd =~ s,\\,/,g; $cwdb =~ s,/,\\,g; my $testdir = "t e s t"; my $exename = "showav"; my $plxname = "showargv"; my $exe = "$testdir/$exename"; my $exex = $exe . ".exe"; (my $exeb = $exe) =~ s,/,\\,g; my $exebx = $exeb . ".exe"; my $bat = "$testdir/$plxname"; my $batx = $bat . ".bat"; (my $batb = $bat) =~ s,/,\\,g; my $batbx = $batb . ".bat"; my $cmdx = $bat . ".cmd"; my $cmdb = $batb; my $cmdbx = $cmdb . ".cmd"; my @commands = ( $exe, $exex, $exeb, $exebx, "./$exe", "./$exex", ".\\$exeb", ".\\$exebx", "$cwd/$exe", "$cwd/$exex", "$cwdb\\$exeb", "$cwdb\\$exebx", $bat, $batx, $batb, $batbx, "./$bat", "./$batx", ".\\$batb", ".\\$batbx", "$cwd/$bat", "$cwd/$batx", "$cwdb\\$batb", "$cwdb\\$batbx", $cmdx, $cmdbx, "./$cmdx", ".\\$cmdbx", "$cwd/$cmdx", "$cwdb\\$cmdbx", [$^X, $batx], [$^X, $batbx], [$^X, "./$batx"], [$^X, ".\\$batbx"], [$^X, "$cwd/$batx"], [$^X, "$cwdb\\$batbx"], ); my @av = ( undef, "", " ", "abc", "a b\tc", "\tabc", "abc\t", " abc\t", "\ta b c ", ["\ta b c ", ""], ["\ta b c ", " "], ["", "\ta b c ", "abc"], [" ", "\ta b c ", "abc"], ['" "', 'a" "b" "c', "abc"], ); print "1.." . (@commands * @av * 2) . "\n"; for my $cmds (@commands) { for my $args (@av) { my @all_args; my @cmds = defined($cmds) ? (ref($cmds) ? @$cmds : $cmds) : (); my @args = defined($args) ? (ref($args) ? @$args : $args) : (); print "######## [@cmds]\n"; print "<", join('><', $cmds[$#cmds], map { my $x = $_; $x =~ s/"//g; $x } @args), ">\n"; if (system(@cmds,@args) != 0) { print "Failed, status($?)\n"; if ($Config{ccflags} =~ /\bDDEBUGGING\b/) { print "Running again in debug mode\n"; $^D = 1; # -Dp system(@cmds,@args); } } $^D = 0; my $cmdstr = join " ", map { /\s|^$/ && !/\"/ ? qq["$_"] : $_ } @cmds, @args; print "######## '$cmdstr'\n"; if (system($cmdstr) != 0) { print "Failed, status($?)\n"; if ($Config{ccflags} =~ /\bDDEBUGGING\b/) { print "Running again in debug mode\n"; $^D = 1; # -Dp system($cmdstr); } } $^D = 0; } } perl-5.12.0-RC0/t/win32/system.t0000555000175000017500000000704111325127002015041 0ustar jessejesse#!perl BEGIN { chdir 't' if -d 't'; # We need '../../lib' as well as '../lib' because parts of Config are # delay-loaded, after we've chdir()'ed into $testdir. @INC = ('../lib', '../../lib'); # XXX this could be further munged to enable some parts on other # platforms unless ($^O =~ /^MSWin/) { print "1..0 # skipped: windows specific test\n"; exit 0; } } use File::Path; use File::Copy; use Config; use Cwd; use strict; $| = 1; my $cwd = cwd(); my $testdir = "t e s t"; my $exename = "showav"; my $plxname = "showargv"; rmtree($testdir); mkdir($testdir); die "Could not create '$testdir':$!" unless -d $testdir; open(my $F, ">$testdir/$exename.c") or die "Can't create $testdir/$exename.c: $!"; print $F <<'EOT'; #include #ifdef __BORLANDC__ #include #endif int main(int ac, char **av) { int i; #ifdef __BORLANDC__ char *s = GetCommandLine(); int j=0; av[0] = s; if (s[0]=='"') { for(;s[++j]!='"';) ; av[0]++; } else { for(;s[++j]!=' ';) ; } s[j]=0; #endif for (i = 0; i < ac; i++) printf("[%s]", av[i]); printf("\n"); return 0; } EOT open($F, ">$testdir/$plxname.bat") or die "Can't create $testdir/$plxname.bat: $!"; print $F <<'EOT'; @rem = '--*-Perl-*-- @echo off if "%OS%" == "Windows_NT" goto WinNT EOT print $F <nul goto endofperl @rem '; #!perl #line 15 print "[$_]" for ($0, @ARGV); print "\n"; __END__ :endofperl EOT close $F; # build the executable chdir($testdir); END { chdir($cwd) && rmtree("$cwd/$testdir") if -d "$cwd/$testdir"; } if (open(my $EIN, "$cwd/win32/${exename}_exe.uu")) { print "# Unpacking $exename.exe\n"; my $e; { local $/; $e = unpack "u", <$EIN>; close $EIN; } open my $EOUT, ">$exename.exe" or die "Can't write $exename.exe: $!"; binmode $EOUT; print $EOUT $e; close $EOUT; } else { my $minus_o = ''; if ($Config{cc} =~ /\bgcc/i) { $minus_o = "-o $exename.exe"; } print "# Compiling $exename.c\n# $Config{cc} $Config{ccflags} $exename.c\n"; if (system("$Config{cc} $Config{ccflags} $minus_o $exename.c >log 2>&1") != 0) { print "# Could not compile $exename.c, status $?\n" ."# Where is your C compiler?\n" ."1..0 # skipped: can't build test executable\n"; exit(0); } unless (-f "$exename.exe") { if (open(LOG,') { print "# ",$_; } } else { warn "Cannot open log (in $testdir):$!"; } } } copy("$plxname.bat","$plxname.cmd"); chdir($cwd); unless (-x "$testdir/$exename.exe") { print "# Could not build $exename.exe\n" ."1..0 # skipped: can't build test executable\n"; exit(0); } open my $T, "$^X -I../lib -w win32/system_tests |" or die "Can't spawn win32/system_tests: $!"; my $expect; my $comment = ""; my $test = 0; while (<$T>) { chomp; if (/^1\.\./) { print "$_\n"; } elsif (/^#+\s(.*)$/) { $comment = $1; } elsif (/^/[]/; $expect =~ s/\Q$plxname\E]/$plxname.bat]/; } else { if ($expect ne $_) { print "# $comment\n" if $comment; print "# want: $expect\n"; print "# got : $_\n"; print "not "; } ++$test; print "ok $test\n"; } } close $T; perl-5.12.0-RC0/t/README0000444000175000017500000000267611325125742013265 0ustar jessejesseThis is the perl test library. To run the test suite, just type './TEST' or 'make test' from the build directory above t/. See also the section "Special Make Test Targets" in pod/perlhack.pod to learn about other specific test commands. To add new tests, just look at the current tests and do likewise. The library t/test.pl provides some utility functions that you can use in most tests, except in the most basic ones. If a test fails, run it by itself to see if it prints any informative diagnostics. If not, modify the test to print informative diagnostics. If you put out extra lines with a '#' character on the front, you don't have to worry about removing the extra print statements later since TEST ignores lines beginning with '#'. If you know that Perl is basically working but expect that some tests will fail, you may want to use Test::Harness thusly: cd t ./perl harness This method pinpoints failed tests automatically. If you come up with new tests, please send them to perlbug@perl.org. Tests in the t/base/ directory ought to be runnable with plain miniperl. That is, they should not require Config.pm nor should they require any extensions to have been built. TEST will abort if any tests in the t/base/ directory fail. Tests in the t/comp/, t/cmd/, t/run/, t/io/, t/op/ and t/uni/ directories should also be runnable by miniperl and not require Config.pm, but failures to comply will not cause TEST to abort like for t/base/. perl-5.12.0-RC0/t/TEST0000555000175000017500000005237111325127001013075 0ustar jessejesse#!./perl # This is written in a peculiar style, since we're trying to avoid # most of the constructs we'll be testing for. (This comment is # probably obsolete on the avoidance side, though still currrent # on the peculiarity side.) # t/TEST and t/harness need to share code. The logical way to do this would be # to have the common code in a file both require or use. However, t/TEST needs # to still work, to generate test results, even if require isn't working, so # we cannot do that. t/harness has no such restriction, so it is quite # acceptable to have it require t/TEST. # In which case, we need to stop t/TEST actually running tests, as all # t/harness needs are its subroutines. # directories with special sets of test switches my %dir_to_switch = (base => '', comp => '', run => '', '../ext/File-Glob/t' => '-I.. -MTestInit', # FIXME - tests assume t/ ); # "not absolute" is the the default, as it saves some fakery within TestInit # which can peturb tests, and takes CPU. Working with the upstream author of # any of these, to figure out how to remove them from this list, considered # "a good thing". my %abs = ( '../cpan/Archive-Extract' => 1, '../cpan/Archive-Tar' => 1, '../cpan/AutoLoader' => 1, '../cpan/CPAN' => 1, '../cpan/Class-ISA' => 1, '../cpan/Cwd' => 1, '../cpan/Devel-PPPort' => 1, '../cpan/Encode' => 1, '../cpan/ExtUtils-Command' => 1, '../cpan/ExtUtils-Constant' => 1, '../cpan/ExtUtils-MakeMaker' => 1, '../cpan/ExtUtils-Manifest' => 1, '../cpan/ExtUtils-ParseXS' => 1, '../cpan/File-Fetch' => 1, '../cpan/IPC-Cmd' => 1, '../cpan/IPC-SysV' => 1, '../cpan/Locale-Codes' => 1, '../cpan/Log-Message' => 1, '../cpan/Math-BigInt' => 1, '../cpan/Math-BigRat' => 1, '../cpan/Math-Complex' => 1, '../cpan/Module-Build' => 1, '../cpan/Module-Load' => 1, '../cpan/Module-Load-Conditional' => 1, '../cpan/Object-Accessor' => 1, '../cpan/Package-Constants' => 1, '../cpan/Parse-CPAN-Meta' => 1, '../cpan/Pod-Simple' => 1, '../cpan/Term-UI' => 1, '../cpan/Test-Simple' => 1, '../cpan/Tie-File' => 1, '../cpan/bignum' => 1, '../cpan/podlators' => 1, '../dist/ExtUtils-Install' => 1, ); my %temp_no_core = ('../cpan/B-Debug' => 1, '../cpan/Compress-Raw-Bzip2' => 1, '../cpan/Compress-Raw-Zlib' => 1, '../cpan/Devel-PPPort' => 1, '../cpan/Getopt-Long' => 1, '../cpan/IO-Compress' => 1, '../cpan/Math-BigInt' => 1, '../cpan/Math-BigRat' => 1, '../cpan/MIME-Base64' => 1, '../cpan/NEXT' => 1, '../cpan/parent' => 1, '../cpan/Parse-CPAN-Meta' => 1, '../cpan/Pod-Simple' => 1, '../cpan/podlators' => 1, '../cpan/Test-Simple' => 1, '../cpan/Tie-RefHash' => 1, '../cpan/Time-HiRes' => 1, '../cpan/Unicode-Collate' => 1, '../cpan/Unicode-Normalize' => 1, ); if ($::do_nothing) { return 1; } # Location to put the Valgrind log. my $Valgrind_Log = 'current.valgrind'; $| = 1; # for testing TEST only #BEGIN { require '../lib/strict.pm'; "strict"->import() }; #BEGIN { require '../lib/warnings.pm'; "warnings"->import() }; # delete env vars that may influence the results # but allow override via *_TEST env var if wanted # (e.g. PERL5OPT_TEST=-d:NYTProf) for my $envname (qw(PERL5LIB PERLLIB PERL5OPT)) { my $override = $ENV{"${envname}_TEST"}; if (defined $override) { warn "$0: $envname=$override\n"; $ENV{$envname} = $override; } else { delete $ENV{$envname}; } } # remove empty elements due to insertion of empty symbols via "''p1'" syntax @ARGV = grep($_,@ARGV) if $^O eq 'VMS'; our $show_elapsed_time = $ENV{HARNESS_TIMER} || 0; # Cheesy version of Getopt::Std. We can't replace it with that, because we # can't rely on require working. { my @argv = (); foreach my $idx (0..$#ARGV) { push( @argv, $ARGV[$idx] ), next unless $ARGV[$idx] =~ /^-(\S+)$/; $::benchmark = 1 if $1 eq 'benchmark'; $::core = 1 if $1 eq 'core'; $::verbose = 1 if $1 eq 'v'; $::torture = 1 if $1 eq 'torture'; $::with_utf8 = 1 if $1 eq 'utf8'; $::with_utf16 = 1 if $1 eq 'utf16'; $::taintwarn = 1 if $1 eq 'taintwarn'; $ENV{PERL_CORE_MINITEST} = 1 if $1 eq 'minitest'; if ($1 =~ /^deparse(,.+)?$/) { $::deparse = 1; $::deparse_opts = $1; } } @ARGV = @argv; } chdir 't' if -f 't/TEST'; if (-f 'TEST' && -f 'harness' && -d '../lib') { @INC = '../lib'; } die "You need to run \"make test\" first to set things up.\n" unless -e 'perl' or -e 'perl.exe' or -e 'perl.pm'; if ($ENV{PERL_3LOG}) { # Tru64 third(1) tool, see perlhack unless (-x 'perl.third') { unless (-x '../perl.third') { die "You need to run \"make perl.third first.\n"; } else { print "Symlinking ../perl.third as perl.third...\n"; die "Failed to symlink: $!\n" unless symlink("../perl.third", "perl.third"); die "Symlinked but no executable perl.third: $!\n" unless -x 'perl.third'; } } } # check leakage for embedders $ENV{PERL_DESTRUCT_LEVEL} = 2 unless exists $ENV{PERL_DESTRUCT_LEVEL}; $ENV{EMXSHELL} = 'sh'; # For OS/2 if ($show_elapsed_time) { require Time::HiRes } my %skip = ( '.' => 1, '..' => 1, 'CVS' => 1, 'RCS' => 1, 'SCCS' => 1, '.svn' => 1, ); # Roll your own File::Find! sub _find_tests { my($dir) = @_; opendir DIR, $dir or die "Trouble opening $dir: $!"; foreach my $f (sort { $a cmp $b } readdir DIR) { next if $skip{$f}; my $fullpath = "$dir/$f"; if (-d $fullpath) { _find_tests($fullpath); } elsif ($f =~ /\.t$/) { push @ARGV, $fullpath; } } } # Scan the text of the test program to find switches and special options # we might need to apply. sub _scan_test { my($test, $type) = @_; open(my $script, "<", $test) or die "Can't read $test.\n"; my $first_line = <$script>; $first_line =~ tr/\0//d if $::with_utf16; my $switch = ""; if ($first_line =~ /#!.*\bperl.*\s-\w*([tT])/) { $switch = "-$1"; } else { if ($::taintwarn) { # not all tests are expected to pass with this option $switch = '-t'; } else { $switch = ''; } } my $file_opts = ""; if ($type eq 'deparse') { # Look for #line directives which change the filename while (<$script>) { $file_opts = $file_opts . ",-f$3$4" if /^#\s*line\s+(\d+)\s+((\w+)|"([^"]+)")/; } } close $script; my $perl = './perl'; my $lib = '../lib'; my $run_dir; my $return_dir; $test =~ /^(.+)\/[^\/]+/; my $dir = $1; my $testswitch = $dir_to_switch{$dir}; if (!defined $testswitch) { if ($test =~ s!^(\.\./(cpan|dist|ext)/[^/]+)/t!t!) { $run_dir = $1; $return_dir = '../../t'; $lib = '../../lib'; $perl = '../../t/perl'; $testswitch = "-I../.. -MTestInit=U2T"; if ($2 eq 'cpan' || $2 eq 'dist') { if($abs{$run_dir}) { $testswitch = $testswitch . ',A'; } if ($temp_no_core{$run_dir}) { $testswitch = $testswitch . ',NC'; } } } else { $testswitch = '-I.. -MTestInit'; # -T will remove . from @INC } } my $utf8 = ($::with_utf8 || $::with_utf16) ? "-I$lib -Mutf8" : ''; my %options = ( perl => $perl, lib => $lib, test => $test, run_dir => $run_dir, return_dir => $return_dir, testswitch => $testswitch, utf8 => $utf8, file => $file_opts, switch => $switch, ); return \%options; } sub _cmd { my($options, $type) = @_; my $test = $options->{test}; my $cmd; if ($type eq 'deparse') { my $perl = "$options->{perl} $options->{testswitch}"; my $lib = $options->{lib}; $cmd = ( "$perl $options->{switch} -I$lib -MO=-qq,Deparse,-sv1.,". "-l$::deparse_opts$options->{file} ". "$test > $test.dp ". "&& $perl $options->{switch} -I$lib $test.dp" ); } elsif ($type eq 'perl') { my $perl = $options->{perl}; my $redir = $^O eq 'VMS' ? '2>&1' : ''; if ($ENV{PERL_VALGRIND}) { my $valgrind = $ENV{VALGRIND} // 'valgrind'; my $vg_opts = $ENV{VG_OPTS} // "--suppressions=perl.supp --leak-check=yes " . "--leak-resolution=high --show-reachable=yes " . "--num-callers=50"; $perl = "$valgrind --log-fd=3 $vg_opts $perl"; $redir = "3>$Valgrind_Log"; } my $args = "$options->{testswitch} $options->{switch} $options->{utf8}"; $cmd = $perl . _quote_args($args) . " $test $redir"; } return $cmd; } sub _before_fork { my ($options) = @_; if ($options->{run_dir}) { my $run_dir = $options->{run_dir}; chdir $run_dir or die "Can't chdir to '$run_dir': $!"; } return; } sub _after_fork { my ($options) = @_; if ($options->{return_dir}) { my $return_dir = $options->{return_dir}; chdir $return_dir or die "Can't chdir from '$options->{run_dir}' to '$return_dir': $!"; } return; } sub _run_test { my ($test, $type) = @_; my $options = _scan_test($test, $type); # $test might have changed if we're in ext/Foo, so don't use it anymore # from now on. Use $options->{test} instead. _before_fork($options); my $cmd = _cmd($options, $type); open(my $results, "$cmd |") or print "can't run '$cmd': $!.\n"; _after_fork($options); # Our environment may force us to use UTF-8, but we can't be sure that # anything we're reading from will be generating (well formed) UTF-8 # This may not be the best way - possibly we should unset ${^OPEN} up # top? binmode $results; return $results; } sub _quote_args { my ($args) = @_; my $argstring = ''; foreach (split(/\s+/,$args)) { # In VMS protect with doublequotes because otherwise # DCL will lowercase -- unless already doublequoted. $_ = q(").$_.q(") if ($^O eq 'VMS') && !/^\"/ && length($_) > 0; $argstring = $argstring . ' ' . $_; } return $argstring; } sub _populate_hash { return unless defined $_[0]; return map {$_, 1} split /\s+/, $_[0]; } sub _tests_from_manifest { my ($extensions, $known_extensions) = @_; my %skip; my %extensions = _populate_hash($extensions); my %known_extensions = _populate_hash($known_extensions); foreach (keys %known_extensions) { $skip{$_} = 1 unless $extensions{$_}; } my @results; my $mani = '../MANIFEST'; if (open(MANI, $mani)) { while () { if (m!^((?:cpan|dist|ext)/(\S+)/+(?:[^/\s]+\.t|test\.pl)|lib/\S+?(?:\.t|test\.pl))\s!) { my $t = $1; my $extension = $2; if (!$::core || $t =~ m!^lib/[a-z]!) { if (defined $extension) { $extension =~ s!/t$!!; # XXX Do I want to warn that I'm skipping these? next if $skip{$extension}; my $flat_extension = $extension; $flat_extension =~ s!-!/!g; next if $skip{$flat_extension}; # Foo/Bar may live in Foo-Bar } my $path = "../$t"; push @results, $path; $::path_to_name{$path} = $t; } } } close MANI; } else { warn "$0: cannot open $mani: $!\n"; } return @results; } unless (@ARGV) { # base first, as TEST bails out if that can't run # then comp, to validate that require works # then run, to validate that -M works # then we know we can -MTestInit for everything else, making life simpler foreach my $dir (qw(base comp run cmd io re op uni mro)) { _find_tests($dir); } _find_tests("lib") unless $::core; # Config.pm may be broken for make minitest. And this is only a refinement # for skipping tests on non-default builds, so it is allowed to fail. # What we want to to is make a list of extensions which we did not build. my $configsh = '../config.sh'; my ($extensions, $known_extensions); if (-f $configsh) { open FH, $configsh or die "Can't open $configsh: $!"; while () { if (/^extensions=['"](.*)['"]$/) { $extensions = $1; } elsif (/^known_extensions=['"](.*)['"]$/) { $known_extensions = $1; } } if (!defined $known_extensions) { warn "No known_extensions line found in $configsh"; } if (!defined $extensions) { warn "No extensions line found in $configsh"; } } # The "complex" constructions of list return from a subroutine, and push of # a list, might fail if perl is really hosed, but they aren't needed for # make minitest, and the building of extensions will likely also fail if # something is that badly wrong. push @ARGV, _tests_from_manifest($extensions, $known_extensions); unless ($::core) { _find_tests('x2p'); _find_tests('porting'); _find_tests('japh') if $::torture; _find_tests('t/benchmark') if $::benchmark or $ENV{PERL_BENCHMARK}; } } if ($::deparse) { _testprogs('deparse', '', @ARGV); } elsif ($::with_utf16) { for my $e (0, 1) { for my $b (0, 1) { print STDERR "# ENDIAN $e BOM $b\n"; my @UARGV; for my $a (@ARGV) { my $u = $a . "." . ($e ? "l" : "b") . "e" . ($b ? "b" : ""); my $f = $e ? "v" : "n"; push @UARGV, $u; unlink($u); if (open(A, $a)) { if (open(U, ">$u")) { print U pack("$f", 0xFEFF) if $b; while () { print U pack("$f*", unpack("C*", $_)); } close(U); } close(A); } } _testprogs('perl', '', @UARGV); unlink(@UARGV); } } } else { _testprogs('perl', '', @ARGV); } sub _testprogs { my ($type, $args, @tests) = @_; print <<'EOT' if ($type eq 'deparse'); ------------------------------------------------------------------------------ TESTING DEPARSER ------------------------------------------------------------------------------ EOT $::bad_files = 0; foreach my $t (@tests) { unless (exists $::path_to_name{$t}) { my $tname = "t/$t"; $::path_to_name{$t} = $tname; } } my $maxlen = 0; foreach (@::path_to_name{@tests}) { s/\.\w+\z/./; my $len = length ; $maxlen = $len if $len > $maxlen; } # + 3 : we want three dots between the test name and the "ok" my $dotdotdot = $maxlen + 3 ; my $valgrind = 0; my $total_files = @tests; my $good_files = 0; my $tested_files = 0; my $totmax = 0; my %failed_tests; while (my $test = shift @tests) { my $test_start_time = $show_elapsed_time ? Time::HiRes::time() : 0; if ($test =~ /^$/) { next; } if ($type eq 'deparse') { if ($test eq "comp/redef.t") { # Redefinition happens at compile time next; } elsif ($test =~ m{lib/Switch/t/}) { # B::Deparse doesn't support source filtering next; } } my $te = $::path_to_name{$test} . '.' x ($dotdotdot - length($::path_to_name{$test})); if ($^O ne 'VMS') { # defer printing on VMS due to piping bug print $te; $te = ''; } my $results = _run_test($test, $type); my $failure; my $next = 0; my $seen_leader = 0; my $seen_ok = 0; my $trailing_leader = 0; my $max; my %todo; while (<$results>) { next if /^\s*$/; # skip blank lines if (/^1..$/ && ($^O eq 'VMS')) { # VMS pipe bug inserts blank lines. my $l2 = ; if ($l2 =~ /^\s*$/) { $l2 = ; } $_ = '1..' . $l2; } if ($::verbose) { print $_; } unless (/^\#/) { if ($trailing_leader) { # shouldn't be anything following a postfix 1..n $failure = 'FAILED--extra output after trailing 1..n'; last; } if (/^1\.\.([0-9]+)( todo ([\d ]+))?/) { if ($seen_leader) { $failure = 'FAILED--seen duplicate leader'; last; } $max = $1; %todo = map { $_ => 1 } split / /, $3 if $3; $totmax = $totmax + $max; $tested_files = $tested_files + 1; if ($seen_ok) { # 1..n appears at end of file $trailing_leader = 1; if ($next != $max) { $failure = "FAILED--expected $max tests, saw $next"; last; } } else { $next = 0; } $seen_leader = 1; } else { if (/^(not )?ok(?: (\d+))?[^\#]*(\s*\#.*)?/) { unless ($seen_leader) { unless ($seen_ok) { $next = 0; } } $seen_ok = 1; $next = $next + 1; my($not, $num, $extra, $istodo) = ($1, $2, $3, 0); $num = $next unless $num; if ($num == $next) { # SKIP is essentially the same as TODO for t/TEST # this still conforms to TAP: # http://search.cpan.org/dist/TAP/TAP.pm $extra and $istodo = $extra =~ /#\s*(?:TODO|SKIP)\b/; $istodo = 1 if $todo{$num}; if( $not && !$istodo ) { $failure = "FAILED at test $num"; last; } } else { $failure ="FAILED--expected test $next, saw test $num"; last; } } elsif (/^Bail out!\s*(.*)/i) { # magic words die "FAILED--Further testing stopped" . ($1 ? ": $1\n" : ".\n"); } else { # module tests are allowed extra output, # because Test::Harness allows it next if $test =~ /^\W*(cpan|dist|ext|lib)\b/; $failure = "FAILED--unexpected output at test $next"; last; } } } } close $results; if (not defined $failure) { $failure = 'FAILED--no leader found' unless $seen_leader; } if ($ENV{PERL_VALGRIND}) { my @valgrind; if (-e $Valgrind_Log) { if (open(V, $Valgrind_Log)) { @valgrind = ; close V; } else { warn "$0: Failed to open '$Valgrind_Log': $!\n"; } } if ($ENV{VG_OPTS} =~ /cachegrind/) { if (rename $Valgrind_Log, "$test.valgrind") { $valgrind = $valgrind + 1; } else { warn "$0: Failed to create '$test.valgrind': $!\n"; } } elsif (@valgrind) { my $leaks = 0; my $errors = 0; for my $i (0..$#valgrind) { local $_ = $valgrind[$i]; if (/^==\d+== ERROR SUMMARY: (\d+) errors? /) { $errors = $errors + $1; # there may be multiple error summaries } elsif (/^==\d+== LEAK SUMMARY:/) { for my $off (1 .. 4) { if ($valgrind[$i+$off] =~ /(?:lost|reachable):\s+\d+ bytes in (\d+) blocks/) { $leaks = $leaks + $1; } } } } if ($errors or $leaks) { if (rename $Valgrind_Log, "$test.valgrind") { $valgrind = $valgrind + 1; } else { warn "$0: Failed to create '$test.valgrind': $!\n"; } } } else { warn "No valgrind output?\n"; } if (-e $Valgrind_Log) { unlink $Valgrind_Log or warn "$0: Failed to unlink '$Valgrind_Log': $!\n"; } } if ($type eq 'deparse') { unlink "./$test.dp"; } if ($ENV{PERL_3LOG}) { my $tpp = $test; $tpp =~ s:^\.\./::; $tpp =~ s:/:_:g; $tpp =~ s:\.t$:.3log:; rename("perl.3log", $tpp) || die "rename: perl3.log to $tpp: $!\n"; } if (not defined $failure and $next != $max) { $failure="FAILED--expected $max tests, saw $next"; } if( !defined $failure # don't mask a test failure and $? ) { $failure = "FAILED--non-zero wait status: $?"; } if (defined $failure) { print "${te}$failure\n"; $::bad_files = $::bad_files + 1; if ($test =~ /^base/) { die "Failed a basic test ($test) -- cannot continue.\n"; } $failed_tests{$test} = 1; } else { if ($max) { my $elapsed; if ( $show_elapsed_time ) { $elapsed = sprintf( " %8.0f ms", (Time::HiRes::time() - $test_start_time) * 1000 ); } else { $elapsed = ""; } print "${te}ok$elapsed\n"; $good_files = $good_files + 1; } else { print "${te}skipped\n"; $tested_files = $tested_files - 1; } } } # while tests if ($::bad_files == 0) { if ($good_files) { print "All tests successful.\n"; # XXX add mention of 'perlbug -ok' ? } else { die "FAILED--no tests were run for some reason.\n"; } } else { my $pct = $tested_files ? sprintf("%.2f", ($tested_files - $::bad_files) / $tested_files * 100) : "0.00"; my $s = $::bad_files == 1 ? "" : "s"; warn "Failed $::bad_files test$s out of $tested_files, $pct% okay.\n"; for my $test ( sort keys %failed_tests ) { print "\t$test\n"; } warn <<'SHRDLU_1'; ### Since not all tests were successful, you may want to run some of ### them individually and examine any diagnostic messages they produce. ### See the INSTALL document's section on "make test". SHRDLU_1 warn <<'SHRDLU_2' if $good_files / $total_files > 0.8; ### You have a good chance to get more information by running ### ./perl harness ### in the 't' directory since most (>=80%) of the tests succeeded. SHRDLU_2 if (eval {require Config; import Config; 1}) { if ($::Config{usedl} && (my $p = $::Config{ldlibpthname})) { warn < 78; my $STDOUT = tempfile(); my $STDERR = tempfile(); my $PERL = $ENV{PERL} || './perl'; my $FAILURE_CODE = 119; delete $ENV{PERLLIB}; delete $ENV{PERL5LIB}; delete $ENV{PERL5OPT}; sub runperl_and_capture { local *F; my ($env, $args) = @_; unshift @$args, '-I../lib'; local %ENV = %ENV; delete $ENV{PERLLIB}; delete $ENV{PERL5LIB}; delete $ENV{PERL5OPT}; my $pid = fork; return (0, "Couldn't fork: $!") unless defined $pid; # failure if ($pid) { # parent my ($actual_stdout, $actual_stderr); wait; return (0, "Failure in child.\n") if ($?>>8) == $FAILURE_CODE; open F, "< $STDOUT" or return (0, "Couldn't read $STDOUT file"); { local $/; $actual_stdout = } open F, "< $STDERR" or return (0, "Couldn't read $STDERR file"); { local $/; $actual_stderr = } return ($actual_stdout, $actual_stderr); } else { # child for my $k (keys %$env) { $ENV{$k} = $env->{$k}; } open STDOUT, "> $STDOUT" or exit $FAILURE_CODE; open STDERR, "> $STDERR" or it_didnt_work(); { exec $PERL, @$args } it_didnt_work(); } } # Run perl with specified environment and arguments returns a list. # First element is true if Perl's stdout and stderr match the # supplied $stdout and $stderr argument strings exactly. # second element is an explanation of the failure sub runperl { local *F; my ($env, $args, $stdout, $stderr) = @_; my ($actual_stdout, $actual_stderr) = runperl_and_capture($env, $args); if ($actual_stdout ne $stdout) { return (0, "Stdout mismatch: expected [$stdout], saw [$actual_stdout]"); } elsif ($actual_stderr ne $stderr) { return (0, "Stderr mismatch: expected [$stderr], saw [$actual_stderr]"); } else { return 1; # success } } sub it_didnt_work { print STDOUT "IWHCWJIHCI\cNHJWCJQWKJQJWCQW\n"; exit $FAILURE_CODE; } sub try { my ($success, $reason) = runperl(@_); $reason =~ s/\n/\\n/g if defined $reason; local $::Level = $::Level + 1; ok( $success, $reason ); } # PERL5OPT Command-line options (switches). Switches in # this variable are taken as if they were on # every Perl command line. Only the -[DIMUdmtw] # switches are allowed. When running taint # checks (because the program was running setuid # or setgid, or the -T switch was used), this # variable is ignored. If PERL5OPT begins with # -T, tainting will be enabled, and any # subsequent options ignored. try({PERL5OPT => '-w'}, ['-e', 'print $::x'], "", qq{Name "main::x" used only once: possible typo at -e line 1.\nUse of uninitialized value \$x in print at -e line 1.\n}); try({PERL5OPT => '-Mstrict'}, ['-e', 'print $::x'], "", ""); try({PERL5OPT => '-Mstrict'}, ['-e', 'print $x'], "", qq{Global symbol "\$x" requires explicit package name at -e line 1.\nExecution of -e aborted due to compilation errors.\n}); # Fails in 5.6.0 try({PERL5OPT => '-Mstrict -w'}, ['-e', 'print $x'], "", qq{Global symbol "\$x" requires explicit package name at -e line 1.\nExecution of -e aborted due to compilation errors.\n}); # Fails in 5.6.0 try({PERL5OPT => '-w -Mstrict'}, ['-e', 'print $::x'], "", < '-w -Mstrict'}, ['-e', 'print $::x'], "", < '-MExporter'}, ['-e0'], "", ""); # Fails in 5.6.0 try({PERL5OPT => '-MExporter -MExporter'}, ['-e0'], "", ""); try({PERL5OPT => '-Mstrict -Mwarnings'}, ['-e', 'print "ok" if $INC{"strict.pm"} and $INC{"warnings.pm"}'], "ok", ""); open F, ">", "Oooof.pm" or die "Can't write Oooof.pm: $!"; print F "package Oooof; 1;\n"; close F; END { 1 while unlink "Oooof.pm" } try({PERL5OPT => '-I. -MOooof'}, ['-e', 'print "ok" if $INC{"Oooof.pm"} eq "Oooof.pm"'], "ok", ""); try({PERL5OPT => '-I./ -MOooof'}, ['-e', 'print "ok" if $INC{"Oooof.pm"} eq "Oooof.pm"'], "ok", ""); try({PERL5OPT => '-w -w'}, ['-e', 'print $ENV{PERL5OPT}'], '-w -w', ''); try({PERL5OPT => '-t'}, ['-e', 'print ${^TAINT}'], '-1', ''); try({PERL5OPT => '-W'}, ['-e', 'local $^W = 0; no warnings; print $x'], '', < "foobar$Config{path_sep}42"}, ['-e', 'print grep { $_ eq "foobar" } @INC'], 'foobar', ''); try({PERLLIB => "foobar$Config{path_sep}42"}, ['-e', 'print grep { $_ eq "42" } @INC'], '42', ''); try({PERL5LIB => "foobar$Config{path_sep}42"}, ['-e', 'print grep { $_ eq "foobar" } @INC'], 'foobar', ''); try({PERL5LIB => "foobar$Config{path_sep}42"}, ['-e', 'print grep { $_ eq "42" } @INC'], '42', ''); try({PERL5LIB => "foo", PERLLIB => "bar"}, ['-e', 'print grep { $_ eq "foo" } @INC'], 'foo', ''); try({PERL5LIB => "foo", PERLLIB => "bar"}, ['-e', 'print grep { $_ eq "bar" } @INC'], '', ''); # Tests for S_incpush_use_sep(): my @dump_inc = ('-e', 'print "$_\n" foreach @INC'); my ($out, $err) = runperl_and_capture({}, [@dump_inc]); is ($err, '', 'No errors when determining @INC'); my @default_inc = split /\n/, $out; is (shift @default_inc, '../lib', 'Our -I../lib is at the front'); my $sep = $Config{path_sep}; foreach (['nothing', ''], ['something', 'zwapp', 'zwapp'], ['two things', "zwapp${sep}bam", 'zwapp', 'bam'], ['two things, ::', "zwapp${sep}${sep}bam", 'zwapp', 'bam'], [': at start', "${sep}zwapp", 'zwapp'], [': at end', "zwapp${sep}", 'zwapp'], [':: sandwich ::', "${sep}${sep}zwapp${sep}${sep}", 'zwapp'], [':', "${sep}"], ['::', "${sep}${sep}"], [':::', "${sep}${sep}${sep}"], ['two things and :', "zwapp${sep}bam${sep}", 'zwapp', 'bam'], [': and two things', "${sep}zwapp${sep}bam", 'zwapp', 'bam'], [': two things :', "${sep}zwapp${sep}bam${sep}", 'zwapp', 'bam'], ['three things', "zwapp${sep}bam${sep}${sep}owww", 'zwapp', 'bam', 'owww'], ) { my ($name, $lib, @expect) = @$_; push @expect, @default_inc; ($out, $err) = runperl_and_capture({PERL5LIB => $lib}, [@dump_inc]); is ($err, '', "No errors when determining \@INC for $name"); my @inc = split /\n/, $out; is (shift @inc, '../lib', 'Our -I../lib is at the front for $name'); is (scalar @inc, scalar @expect, "expected number of elements in \@INC for $name"); is ("@inc", "@expect", "expected elements in \@INC for $name"); } # PERL5LIB tests with included arch directories still missing END { 1 while unlink $STDOUT; 1 while unlink $STDERR; } perl-5.12.0-RC0/t/run/switchx2.aux0000444000175000017500000000070311325125742015470 0ustar jessejesseFrom: foo@bar.xx Date: Jan 1, 2037 12:34 PM Subject: Ignore mail header To: perl@perl.xx #perl Not perl #! Still not perl #!/something/else Still not perl #!/usr/bin/bash # Ignore shell commands if [[ -z $FOO ]]; then echo 'not ok 1'; fi #!/some/path/that/leads/to/perl -l # These lines get executed my $test = $ARGV[0]; if (-f 'switchx.t') { print("ok $test"); } $test++; print "ok $test"; __END__ # This is ignored print "not ok $test"; perl-5.12.0-RC0/t/run/cloexec.t0000555000175000017500000001367311325127002015011 0ustar jessejesse#!./perl # # Test inheriting file descriptors across exec (close-on-exec). # # perlvar describes $^F aka $SYSTEM_FD_MAX as follows: # # The maximum system file descriptor, ordinarily 2. System file # descriptors are passed to exec()ed processes, while higher file # descriptors are not. Also, during an open(), system file descriptors # are preserved even if the open() fails. (Ordinary file descriptors # are closed before the open() is attempted.) The close-on-exec # status of a file descriptor will be decided according to the value of # C<$^F> when the corresponding file, pipe, or socket was opened, not # the time of the exec(). # # This documented close-on-exec behaviour is typically implemented in # various places (e.g. pp_sys.c) with code something like: # # #if defined(HAS_FCNTL) && defined(F_SETFD) # fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */ # #endif # # This behaviour, therefore, is only currently implemented for platforms # where: # # a) HAS_FCNTL and F_SETFD are both defined # b) Integer fds are native OS handles # # ... which is typically just the Unix-like platforms. # # Notice that though integer fds are supported by the C runtime library # on Windows, they are not native OS handles, and so are not inherited # across an exec (though native Windows file handles are). BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require Config; if (!$Config::Config{'d_fcntl'}) { print("1..0 # Skip: fcntl() is not available\n"); exit(0); } require './test.pl'; } use strict; $|=1; my $Is_VMS = $^O eq 'VMS'; my $Is_Win32 = $^O eq 'MSWin32'; # When in doubt, skip. skip_all("VMS") if $Is_VMS; skip_all("Win32") if $Is_Win32; sub make_tmp_file { my ($fname, $fcontents) = @_; local *FHTMP; open FHTMP, ">$fname" or die "open '$fname': $!"; print FHTMP $fcontents or die "print '$fname': $!"; close FHTMP or die "close '$fname': $!"; } my $Perl = which_perl(); my $quote = $Is_VMS || $Is_Win32 ? '"' : "'"; my $tmperr = tempfile(); my $tmpfile1 = tempfile(); my $tmpfile2 = tempfile(); my $tmpfile1_contents = "tmpfile1 line 1\ntmpfile1 line 2\n"; my $tmpfile2_contents = "tmpfile2 line 1\ntmpfile2 line 2\n"; make_tmp_file($tmpfile1, $tmpfile1_contents); make_tmp_file($tmpfile2, $tmpfile2_contents); # $Child_prog is the program run by the child that inherits the fd. # Note: avoid using ' or " in $Child_prog since it is run with -e my $Child_prog = <<'CHILD_PROG'; my $fd = shift; print qq{childfd=$fd\n}; open INHERIT, qq{<&=$fd} or die qq{open $fd: $!}; my $line = ; close INHERIT or die qq{close $fd: $!}; print $line CHILD_PROG $Child_prog =~ tr/\n//d; plan(tests => 22); sub test_not_inherited { my $expected_fd = shift; ok( -f $tmpfile2, "tmpfile '$tmpfile2' exists" ); my $cmd = qq{$Perl -e $quote$Child_prog$quote $expected_fd}; # Expect 'Bad file descriptor' or similar to be written to STDERR. local *SAVERR; open SAVERR, ">&STDERR"; # save original STDERR open STDERR, ">$tmperr" or die "open '$tmperr': $!"; my $out = `$cmd`; my $rc = $? >> 8; open STDERR, ">&SAVERR" or die "error: restore STDERR: $!"; close SAVERR or die "error: close SAVERR: $!"; # XXX: it seems one cannot rely on a non-zero return code, # at least not on Tru64. # cmp_ok( $rc, '!=', 0, # "child return code=$rc (non-zero means cannot inherit fd=$expected_fd)" ); cmp_ok( $out =~ tr/\n//, '==', 1, "child stdout: has 1 newline (rc=$rc, should be non-zero)" ); is( $out, "childfd=$expected_fd\n", 'child stdout: fd' ); } sub test_inherited { my $expected_fd = shift; ok( -f $tmpfile1, "tmpfile '$tmpfile1' exists" ); my $cmd = qq{$Perl -e $quote$Child_prog$quote $expected_fd}; my $out = `$cmd`; my $rc = $? >> 8; cmp_ok( $rc, '==', 0, "child return code=$rc (zero means inherited fd=$expected_fd ok)" ); my @lines = split(/^/, $out); cmp_ok( $out =~ tr/\n//, '==', 2, 'child stdout: has 2 newlines' ); cmp_ok( scalar(@lines), '==', 2, 'child stdout: split into 2 lines' ); is( $lines[0], "childfd=$expected_fd\n", 'child stdout: fd' ); is( $lines[1], "tmpfile1 line 1\n", 'child stdout: line 1' ); } $^F == 2 or print STDERR "# warning: \$^F is $^F (not 2)\n"; # Should not be able to inherit > $^F in the default case. open FHPARENT2, "<$tmpfile2" or die "open '$tmpfile2': $!"; my $parentfd2 = fileno FHPARENT2; defined $parentfd2 or die "fileno: $!"; cmp_ok( $parentfd2, '>', $^F, "parent open fd=$parentfd2 (\$^F=$^F)" ); test_not_inherited($parentfd2); close FHPARENT2 or die "close '$tmpfile2': $!"; # Should be able to inherit $^F after setting to $parentfd2 # Need to set $^F before open because close-on-exec set at time of open. $^F = $parentfd2; open FHPARENT1, "<$tmpfile1" or die "open '$tmpfile1': $!"; my $parentfd1 = fileno FHPARENT1; defined $parentfd1 or die "fileno: $!"; cmp_ok( $parentfd1, '<=', $^F, "parent open fd=$parentfd1 (\$^F=$^F)" ); test_inherited($parentfd1); close FHPARENT1 or die "close '$tmpfile1': $!"; # ... and test that you cannot inherit fd = $^F+n. open FHPARENT1, "<$tmpfile1" or die "open '$tmpfile1': $!"; open FHPARENT2, "<$tmpfile2" or die "open '$tmpfile2': $!"; $parentfd2 = fileno FHPARENT2; defined $parentfd2 or die "fileno: $!"; cmp_ok( $parentfd2, '>', $^F, "parent open fd=$parentfd2 (\$^F=$^F)" ); test_not_inherited($parentfd2); close FHPARENT2 or die "close '$tmpfile2': $!"; close FHPARENT1 or die "close '$tmpfile1': $!"; # ... and now you can inherit after incrementing. $^F = $parentfd2; open FHPARENT2, "<$tmpfile2" or die "open '$tmpfile2': $!"; open FHPARENT1, "<$tmpfile1" or die "open '$tmpfile1': $!"; $parentfd1 = fileno FHPARENT1; defined $parentfd1 or die "fileno: $!"; cmp_ok( $parentfd1, '<=', $^F, "parent open fd=$parentfd1 (\$^F=$^F)" ); test_inherited($parentfd1); close FHPARENT1 or die "close '$tmpfile1': $!"; close FHPARENT2 or die "close '$tmpfile2': $!"; perl-5.12.0-RC0/t/run/switcha.t0000555000175000017500000000017711143650501015027 0ustar jessejesse#!./perl -na BEGIN { print "1..2\n"; *ARGV = *DATA; $i = 0; } print "$F[1] ",++$i,"\n"; __DATA__ not ok not ok 3 perl-5.12.0-RC0/t/run/fresh_perl.t0000555000175000017500000004276011325127002015517 0ustar jessejesse#!./perl # ** DO NOT ADD ANY MORE TESTS HERE ** # Instead, put the test in the appropriate test file and use the # fresh_perl_is()/fresh_perl_like() functions in t/test.pl. # This is for tests that used to abnormally cause segfaults, and other nasty # errors that might kill the interpreter and for some reason you can't # use an eval(). BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; # for which_perl() etc } use strict; my $Perl = which_perl(); $|=1; my @prgs = (); while() { if(m/^#{8,}\s*(.*)/) { push @prgs, ['', $1]; } else { $prgs[-1][0] .= $_; } } plan tests => scalar @prgs; foreach my $prog (@prgs) { my($raw_prog, $name) = @$prog; my $switch; if ($raw_prog =~ s/^\s*(-\w.*)\n//){ $switch = $1; } my($prog,$expected) = split(/\nEXPECT\n/, $raw_prog); $prog .= "\n"; $expected = '' unless defined $expected; if ($prog =~ /^\# SKIP: (.+)/m) { if (eval $1) { ok(1, "Skip: $1"); next; } } $expected =~ s/\n+$//; fresh_perl_is($prog, $expected, { switches => [$switch || ''] }, $name); } __END__ ######## $a = ":="; @_ = split /($a)/o, "a:=b:=c"; print "@_" EXPECT a := b := c ######## $cusp = ~0 ^ (~0 >> 1); use integer; $, = " "; print +($cusp - 1) % 8, $cusp % 8, -$cusp % 8, 8 | (($cusp + 1) % 8 + 7), "!\n"; EXPECT 7 0 0 8 ! ######## $foo=undef; $foo->go; EXPECT Can't call method "go" on an undefined value at - line 1. ######## BEGIN { "foo"; } ######## $array[128]=1 ######## $x=0x0eabcd; print $x->ref; EXPECT Can't call method "ref" without a package or object reference at - line 1. ######## chop ($str .= ); ######## close ($banana); ######## $x=2;$y=3;$x<$y ? $x : $y += 23;print $x; EXPECT 25 ######## eval 'sub bar {print "In bar"}'; ######## system './perl -ne "print if eof" /dev/null' ######## chop($file = ); ######## package N; sub new {my ($obj,$n)=@_; bless \$n} $aa=new N 1; $aa=12345; print $aa; EXPECT 12345 ######## $_="foo"; printf(STDOUT "%s\n", $_); EXPECT foo ######## push(@a, 1, 2, 3,) ######## quotemeta "" ######## for ("ABCDE") { ⊂ s/./&sub($&)/eg; print;} sub sub {local($_) = @_; $_ x 4;} EXPECT Modification of a read-only value attempted at - line 3. ######## package FOO;sub new {bless {FOO => BAR}}; package main; use strict vars; my $self = new FOO; print $$self{FOO}; EXPECT BAR ######## $_="foo"; s/.{1}//s; print; EXPECT oo ######## print scalar ("foo","bar") EXPECT bar ######## sub by_number { $a <=> $b; };# inline function for sort below $as_ary{0}="a0"; @ordered_array=sort by_number keys(%as_ary); ######## sub NewShell { local($Host) = @_; my($m2) = $#Shells++; $Shells[$m2]{HOST} = $Host; return $m2; } sub ShowShell { local($i) = @_; } &ShowShell(&NewShell(beach,Work,"+0+0")); &ShowShell(&NewShell(beach,Work,"+0+0")); &ShowShell(&NewShell(beach,Work,"+0+0")); ######## { package FAKEARRAY; sub TIEARRAY { print "TIEARRAY @_\n"; die "bomb out\n" unless $count ++ ; bless ['foo'] } sub FETCH { print "fetch @_\n"; $_[0]->[$_[1]] } sub STORE { print "store @_\n"; $_[0]->[$_[1]] = $_[2] } sub DESTROY { print "DESTROY \n"; undef @{$_[0]}; } } eval 'tie @h, FAKEARRAY, fred' ; tie @h, FAKEARRAY, fred ; EXPECT TIEARRAY FAKEARRAY fred TIEARRAY FAKEARRAY fred DESTROY ######## BEGIN { die "phooey\n" } EXPECT phooey BEGIN failed--compilation aborted at - line 1. ######## BEGIN { 1/$zero } EXPECT Illegal division by zero at - line 1. BEGIN failed--compilation aborted at - line 1. ######## BEGIN { undef = 0 } EXPECT Modification of a read-only value attempted at - line 1. BEGIN failed--compilation aborted at - line 1. ######## { package foo; sub PRINT { shift; print join(' ', reverse @_)."\n"; } sub PRINTF { shift; my $fmt = shift; print sprintf($fmt, @_)."\n"; } sub TIEHANDLE { bless {}, shift; } sub READLINE { "Out of inspiration"; } sub DESTROY { print "and destroyed as well\n"; } sub READ { shift; print STDOUT "foo->can(READ)(@_)\n"; return 100; } sub GETC { shift; print STDOUT "Don't GETC, Get Perl\n"; return "a"; } } { local(*FOO); tie(*FOO,'foo'); print FOO "sentence.", "reversed", "a", "is", "This"; print "-- ", , " --\n"; my($buf,$len,$offset); $buf = "string"; $len = 10; $offset = 1; read(FOO, $buf, $len, $offset) == 100 or die "foo->READ failed"; getc(FOO) eq "a" or die "foo->GETC failed"; printf "%s is number %d\n", "Perl", 1; } EXPECT This is a reversed sentence. -- Out of inspiration -- foo->can(READ)(string 10 1) Don't GETC, Get Perl Perl is number 1 and destroyed as well ######## my @a; $a[2] = 1; for (@a) { $_ = 2 } print "@a\n" EXPECT 2 2 2 ######## # used to attach defelem magic to all immortal values, # which made restore of local $_ fail. foo(2>1); sub foo { bar() for @_; } sub bar { local $_; } print "ok\n"; EXPECT ok ######## @a = ($a, $b, $c, $d) = (5, 6); print "ok\n" if ($a[0] == 5 and $a[1] == 6 and !defined $a[2] and !defined $a[3]); EXPECT ok ######## print "ok\n" if (1E2<<1 == 200 and 3E4<<3 == 240000); EXPECT ok ######## print "ok\n" if ("\0" lt "\xFF"); EXPECT ok ######## open(H,'run/fresh_perl.t'); # must be in the 't' directory stat(H); print "ok\n" if (-e _ and -f _ and -r _); EXPECT ok ######## sub thing { 0 || return qw(now is the time) } print thing(), "\n"; EXPECT nowisthetime ######## $ren = 'joy'; $stimpy = 'happy'; { local $main::{ren} = *stimpy; print $ren, ' ' } print $ren, "\n"; EXPECT happy joy ######## $stimpy = 'happy'; { local $main::{ren} = *stimpy; print ${'ren'}, ' ' } print +(defined(${'ren'}) ? 'oops' : 'joy'), "\n"; EXPECT happy joy ######## package p; sub func { print 'really ' unless wantarray; 'p' } sub groovy { 'groovy' } package main; print p::func()->groovy(), "\n" EXPECT really groovy ######## @list = ([ 'one', 1 ], [ 'two', 2 ]); sub func { $num = shift; (grep $_->[1] == $num, @list)[0] } print scalar(map &func($_), 1 .. 3), " ", scalar(map scalar &func($_), 1 .. 3), "\n"; EXPECT 2 3 ######## ($k, $s) = qw(x 0); @{$h{$k}} = qw(1 2 4); for (@{$h{$k}}) { $s += $_; delete $h{$k} if ($_ == 2) } print "bogus\n" unless $s == 7; ######## my $a = 'outer'; eval q[ my $a = 'inner'; eval q[ print "$a " ] ]; eval { my $x = 'peace'; eval q[ print "$x\n" ] } EXPECT inner peace ######## -w $| = 1; sub foo { print "In foo1\n"; eval 'sub foo { print "In foo2\n" }'; print "Exiting foo1\n"; } foo; foo; EXPECT In foo1 Subroutine foo redefined at (eval 1) line 1. Exiting foo1 In foo2 ######## $s = 0; map {#this newline here tickles the bug $s += $_} (1,2,4); print "eat flaming death\n" unless ($s == 7); ######## sub foo { local $_ = shift; @_ = split; @_ } @x = foo(' x y z '); print "you die joe!\n" unless "@x" eq 'x y z'; ######## /(?{"{"})/ # Check it outside of eval too EXPECT Sequence (?{...}) not terminated or not {}-balanced in regex; marked by <-- HERE in m/(?{ <-- HERE "{"})/ at - line 1. ######## /(?{"{"}})/ # Check it outside of eval too EXPECT Unmatched right curly bracket at (re_eval 1) line 1, at end of line syntax error at (re_eval 1) line 1, near ""{"}" Compilation failed in regexp at - line 1. ######## BEGIN { @ARGV = qw(a b c d e) } BEGIN { print "argv <@ARGV>\nbegin <",shift,">\n" } END { print "end <",shift,">\nargv <@ARGV>\n" } INIT { print "init <",shift,">\n" } CHECK { print "check <",shift,">\n" } EXPECT argv begin check init end argv ######## -l # fdopen from a system descriptor to a system descriptor used to close # the former. open STDERR, '>&=STDOUT' or die $!; select STDOUT; $| = 1; print fileno STDOUT or die $!; select STDERR; $| = 1; print fileno STDERR or die $!; EXPECT 1 2 ######## -w sub testme { my $a = "test"; { local $a = "new test"; print $a }} EXPECT Can't localize lexical variable $a at - line 1. ######## package X; sub ascalar { my $r; bless \$r } sub DESTROY { print "destroyed\n" }; package main; *s = ascalar X; EXPECT destroyed ######## package X; sub anarray { bless [] } sub DESTROY { print "destroyed\n" }; package main; *a = anarray X; EXPECT destroyed ######## package X; sub ahash { bless {} } sub DESTROY { print "destroyed\n" }; package main; *h = ahash X; EXPECT destroyed ######## package X; sub aclosure { my $x; bless sub { ++$x } } sub DESTROY { print "destroyed\n" }; package main; *c = aclosure X; EXPECT destroyed ######## package X; sub any { bless {} } my $f = "FH000"; # just to thwart any future optimisations sub afh { select select ++$f; my $r = *{$f}{IO}; delete $X::{$f}; bless $r } sub DESTROY { print "destroyed\n" } package main; $x = any X; # to bump sv_objcount. IO objs aren't counted?? *f = afh X; EXPECT destroyed destroyed ######## BEGIN { $| = 1; $SIG{__WARN__} = sub { eval { print $_[0] }; die "bar\n"; }; warn "foo\n"; } EXPECT foo bar BEGIN failed--compilation aborted at - line 8. ######## package X; @ISA='Y'; sub new { my $class = shift; my $self = { }; bless $self, $class; my $init = shift; $self->foo($init); print "new", $init; return $self; } sub DESTROY { my $self = shift; print "DESTROY", $self->foo; } package Y; sub attribute { my $self = shift; my $var = shift; if (@_ == 0) { return $self->{$var}; } elsif (@_ == 1) { $self->{$var} = shift; } } sub AUTOLOAD { $AUTOLOAD =~ /::([^:]+)$/; my $method = $1; splice @_, 1, 0, $method; goto &attribute; } package main; my $x = X->new(1); for (2..3) { my $y = X->new($_); print $y->foo; } print $x->foo; EXPECT new1new22DESTROY2new33DESTROY31DESTROY1 ######## re(); sub re { my $re = join '', eval 'qr/(??{ $obj->method })/'; $re; } EXPECT ######## use strict; my $foo = "ZZZ\n"; END { print $foo } EXPECT ZZZ ######## eval ' use strict; my $foo = "ZZZ\n"; END { print $foo } '; EXPECT ZZZ ######## -w if (@ARGV) { print "" } else { if ($x == 0) { print "" } else { print $x } } EXPECT Use of uninitialized value $x in numeric eq (==) at - line 3. ######## $x = sub {}; foo(); sub foo { eval { return }; } print "ok\n"; EXPECT ok ######## # moved to op/lc.t EXPECT ######## sub f { my $a = 1; my $b = 2; my $c = 3; my $d = 4; next } my $x = "foo"; { f } continue { print $x, "\n" } EXPECT foo ######## sub C () { 1 } sub M { $_[0] = 2; } eval "C"; M(C); EXPECT Modification of a read-only value attempted at - line 2. ######## print qw(ab a\b a\\b); EXPECT aba\ba\b ######## # lexicals declared after the myeval() definition should not be visible # within it sub myeval { eval $_[0] } my $foo = "ok 2\n"; myeval('sub foo { local $foo = "ok 1\n"; print $foo; }'); die $@ if $@; foo(); print $foo; EXPECT ok 1 ok 2 ######## # lexicals outside an eval"" should be visible inside subroutine definitions # within it eval <<'EOT'; die $@ if $@; { my $X = "ok\n"; eval 'sub Y { print $X }'; die $@ if $@; Y(); } EOT EXPECT ok ######## # This test is here instead of lib/locale.t because # the bug depends on in the internal state of the locale # settings and pragma/locale messes up that state pretty badly. # We need a "fresh run". BEGIN { eval { require POSIX }; if ($@) { exit(0); # running minitest? } } use Config; my $have_setlocale = $Config{d_setlocale} eq 'define'; $have_setlocale = 0 if $@; # Visual C's CRT goes silly on strings of the form "en_US.ISO8859-1" # and mingw32 uses said silly CRT $have_setlocale = 0 if (($^O eq 'MSWin32' || $^O eq 'NetWare') && $Config{cc} =~ /^(cl|gcc)/i); exit(0) unless $have_setlocale; my @locales; if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a 2>/dev/null|")) { while() { chomp; push(@locales, $_); } close(LOCALES); } exit(0) unless @locales; for (@locales) { use POSIX qw(locale_h); use locale; setlocale(LC_NUMERIC, $_) or next; my $s = sprintf "%g %g", 3.1, 3.1; next if $s eq '3.1 3.1' || $s =~ /^(3.+1) \1$/; print "$_ $s\n"; } EXPECT ######## # [ID 20001202.002] and change #8066 added 'at -e line 1'; # reversed again as a result of [perl #17763] die qr(x) EXPECT (?-xism:x) ######## # 20001210.003 mjd@plover.com format REMITOUT_TOP = FOO . format REMITOUT = BAR . # This loop causes a segv in 5.6.0 for $lineno (1..61) { write REMITOUT; } print "It's OK!"; EXPECT It's OK! ######## # Inaba Hiroto reset; if (0) { if ("" =~ //) { } } ######## # Nicholas Clark $ENV{TERM} = 0; reset; // if 0; ######## # Vadim Konovalov use strict; sub new_pmop($) { my $pm = shift; return eval "sub {shift=~/$pm/}"; } new_pmop "abcdef"; reset; new_pmop "abcdef"; reset; new_pmop "abcdef"; reset; new_pmop "abcdef"; reset; ######## # David Dyck # coredump in 5.7.1 close STDERR; die; EXPECT ######## # core dump in 20000716.007 -w "x" =~ /(\G?x)?/; ######## # Bug 20010515.004 my @h = 1 .. 10; bad(@h); sub bad { undef @h; print "O"; print for @_; print "K"; } EXPECT OK ######## # Bug 20010506.041 "abcd\x{1234}" =~ /(a)(b[c])(d+)?/i and print "ok\n"; EXPECT ok ######## my $foo = Bar->new(); my @dst; END { ($_ = "@dst") =~ s/\(0x.+?\)/(0x...)/; print $_, "\n"; } package Bar; sub new { my Bar $self = bless [], Bar; eval '$self'; return $self; } sub DESTROY { push @dst, "$_[0]"; } EXPECT Bar=ARRAY(0x...) ######## (?{...}) compilation bounces on PL_rs -0 { /(?{ $x })/; # { } BEGIN { print "ok\n" } EXPECT ok ######## scalar ref to file test operator segfaults on 5.6.1 [ID 20011127.155] # This only happens if the filename is 11 characters or less. $foo = \-f "blah"; print "ok" if ref $foo && !$$foo; EXPECT ok ######## [ID 20011128.159] 'X' =~ /\X/ segfault in 5.6.1 print "ok" if 'X' =~ /\X/; EXPECT ok ######## segfault in 5.6.1 within peep() @a = (1..9); @b = sort { @c = sort { @d = sort { 0 } @a; @d; } @a; } @a; print join '', @a, "\n"; EXPECT 123456789 ######## example from Camel 5, ch. 15, pp.406 (with my) # SKIP: ord "A" == 193 # EBCDIC use strict; use utf8; my $人 = 2; # 0xe4 0xba 0xba: U+4eba, "human" in CJK ideograph $人++; # a child is born print $人, "\n"; EXPECT 3 ######## example from Camel 5, ch. 15, pp.406 (with our) # SKIP: ord "A" == 193 # EBCDIC use strict; use utf8; our $人 = 2; # 0xe4 0xba 0xba: U+4eba, "human" in CJK ideograph $人++; # a child is born print $人, "\n"; EXPECT 3 ######## example from Camel 5, ch. 15, pp.406 (with package vars) # SKIP: ord "A" == 193 # EBCDIC use utf8; $人 = 2; # 0xe4 0xba 0xba: U+4eba, "human" in CJK ideograph $人++; # a child is born print $人, "\n"; EXPECT 3 ######## example from Camel 5, ch. 15, pp.406 (with use vars) # SKIP: ord "A" == 193 # EBCDIC use strict; use utf8; use vars qw($人); $人 = 2; # 0xe4 0xba 0xba: U+4eba, "human" in CJK ideograph $人++; # a child is born print $人, "\n"; EXPECT 3 ######## # test that closures generated by eval"" hold on to the CV of the eval"" # for their entire lifetime $code = eval q[ sub { eval '$x = "ok 1\n"'; } ]; &{$code}(); print $x; EXPECT ok 1 ######## [ID 20020623.009] nested eval/sub segfaults $eval = eval 'sub { eval "sub { %S }" }'; $eval->({}); ######## [perl #17951] Strange UTF error -W # From: "John Kodis" # Newsgroups: comp.lang.perl.moderated # Subject: Strange UTF error # Date: Fri, 11 Oct 2002 16:19:58 -0400 # Message-ID: $_ = "foobar\n"; utf8::upgrade($_); # the original code used a UTF-8 locale (affects STDIN) # matching is actually irrelevant: avoiding several dozen of these # Illegal hexadecimal digit ' ' ignored at /usr/lib/perl5/5.8.0/utf8_heavy.pl line 152 # is what matters. /^([[:digit:]]+)/; EXPECT ######## [perl #20667] unicode regex vs non-unicode regex $toto = 'Hello'; $toto =~ /\w/; # this line provokes the problem! $name = 'A B'; # utf8::upgrade($name) if @ARGV; if ($name =~ /(\p{IsUpper}) (\p{IsUpper})/){ print "It's good! >$1< >$2<\n"; } else { print "It's not good...\n"; } EXPECT It's good! >A< >B< ######## [perl #8760] strangness with utf8 and warn $_="foo";utf8::upgrade($_);/bar/i,warn$_; EXPECT foo at - line 1. ######## glob() bug Mon, 01 Sep 2003 02:25:41 -0700 <200309010925.h819Pf0X011457@smtp3.ActiveState.com> -lw BEGIN { if ($^O eq 'os390') { require File::Glob; import File::Glob ':glob'; } } BEGIN { eval 'require Fcntl'; if ($@) { print qq[./"TEST"\n./"TEST"\n]; exit 0 } # running minitest? } if ($^O eq 'VMS') { # VMS is not *that* kind of a glob. print qq[./"TEST"\n./"TEST"\n]; } else { print glob(q(./"TEST")); use File::Glob; print glob(q(./"TEST")); } EXPECT ./"TEST" ./"TEST" ######## glob() bug Mon, 01 Sep 2003 02:25:41 -0700 <200309010925.h819Pf0X011457@smtp3.ActiveState.com> -lw BEGIN { if ($^O eq 'os390') { require File::Glob; import File::Glob ':glob'; } } BEGIN { eval 'require Fcntl'; if ($@) { print qq[./"TEST"\n./"TEST"\n]; exit 0 } # running minitest? } if ($^O eq 'VMS') { # VMS is not *that* kind of a glob. print qq[./"TEST"\n./"TEST"\n]; } else { use File::Glob; print glob(q(./"TEST")); use File::Glob; print glob(q(./"TEST")); } EXPECT ./"TEST" ./"TEST" ######## "Segfault using HTML::Entities", Richard Jolly , in perl-unicode@perl.org -lw # SKIP: use Config; $ENV{PERL_CORE_MINITEST} or " $Config::Config{'extensions'} " !~ m[ Encode ] # Perl configured without Encode module BEGIN { eval 'require Encode'; if ($@) { exit 0 } # running minitest? } # Test case cut down by jhi $SIG{__WARN__} = sub { $@ = shift }; use Encode; my $t = ord('A') == 193 ? "\xEA" : "\xE9"; Encode::_utf8_on($t); $t =~ s/([^a])//ge; $@ =~ s/ at .*/ at/; print $@ EXPECT Malformed UTF-8 character (unexpected end of string) in substitution (s///) at perl-5.12.0-RC0/t/run/switchx.t0000555000175000017500000000064711325125742015066 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } require './test.pl'; use File::Spec::Functions; # Test '-x' print runperl( switches => ['-x'], progfile => catfile(curdir(), 'run', 'switchx.aux') ); # Test '-xdir' print runperl( switches => ['-x' . catfile(curdir(), 'run')], progfile => catfile(curdir(), 'run', 'switchx2.aux'), args => [ 3 ] ); # EOF perl-5.12.0-RC0/t/run/switchC.t0000555000175000017500000000463311325127002014767 0ustar jessejesse#!./perl -w # Tests for the command-line switches BEGIN { chdir 't' if -d 't'; @INC = '../lib'; unless (find PerlIO::Layer 'perlio') { print "1..0 # Skip: not perlio\n"; exit 0; } if ($ENV{PERL_CORE_MINITEST}) { print "1..0 # Skip : -C and \$ENV{PERL_UNICODE} are disabled on miniperl\n"; exit 0; } } BEGIN { require "./test.pl"; } plan(tests => 9); my $r; my $tmpfile = tempfile(); my $b = pack("C*", unpack("U0C*", pack("U",256))); $r = runperl( switches => [ '-CO', '-w' ], prog => 'print chr(256)', stderr => 1 ); like( $r, qr/^$b(?:\r?\n)?$/s, '-CO: no warning on UTF-8 output' ); SKIP: { if (exists $ENV{PERL_UNICODE} && ($ENV{PERL_UNICODE} eq "" || $ENV{PERL_UNICODE} =~ /[SO]/)) { skip(qq[cannot test with PERL_UNICODE locale "" or /[SO]/], 1); } $r = runperl( switches => [ '-CI', '-w' ], prog => 'print ord()', stderr => 1, stdin => $b ); like( $r, qr/^256(?:\r?\n)?$/s, '-CI: read in UTF-8 input' ); } $r = runperl( switches => [ '-CE', '-w' ], prog => 'warn chr(256), qq(\n)', stderr => 1 ); like( $r, qr/^$b(?:\r?\n)?$/s, '-CE: UTF-8 stderr' ); $r = runperl( switches => [ '-Co', '-w' ], prog => "open(F, q(>$tmpfile)); print F chr(256); close F", stderr => 1 ); like( $r, qr/^$/s, '-Co: auto-UTF-8 open for output' ); $r = runperl( switches => [ '-Ci', '-w' ], prog => "open(F, q(<$tmpfile)); print ord(); close F", stderr => 1 ); like( $r, qr/^256(?:\r?\n)?$/s, '-Ci: auto-UTF-8 open for input' ); $r = runperl( switches => [ '-CA', '-w' ], prog => 'print ord shift', stderr => 1, args => [ chr(256) ] ); like( $r, qr/^256(?:\r?\n)?$/s, '-CA: @ARGV' ); $r = runperl( switches => [ '-CS', '-w' ], progs => [ '#!perl -CS', 'print chr(256)'], stderr => 1, ); like( $r, qr/^$b(?:\r?\n)?$/s, '#!perl -C' ); $r = runperl( switches => [ '-CA', '-w' ], progs => [ '#!perl -CS', 'print chr(256)' ], stderr => 1, ); like( $r, qr/^Too late for "-CS" option at -e line 1\.$/s, '#!perl -C with different -C on command line' ); $r = runperl( switches => [ '-w' ], progs => [ '#!perl -CS', 'print chr(256)' ], stderr => 1, ); like( $r, qr/^Too late for "-CS" option at -e line 1\.$/s, '#!perl -C but not command line' ); perl-5.12.0-RC0/t/run/switchF1.t0000555000175000017500000000100711325125742015054 0ustar jessejesse#!perl -w print "1..5\n"; my $file = "Run_switchF1.pl"; open F, ">$file" or die "Open $file: $!"; my $prog = <<'EOT'; #!./perl -anF[~#QQ\\xq'] BEGIN { *ARGV = *DATA; } print "@F"; __DATA__ okx1 okq2 ok\3 ok'4 EOT # 2 of the characters toke.c used to use to quote the split parameter: $prog =~ s/QQ/\x01\x80/; # These 2 plus ~ # and ' were enough to make perl choke print F $prog; close F or die "Close $file: $!"; print system ($^X, $file) ? "not ok 5\n" : "ok 5\n"; unlink $file or die "Unlink $file: $!"; perl-5.12.0-RC0/t/run/noswitch.t0000555000175000017500000000023011143650501015211 0ustar jessejesse#!./perl BEGIN { print "1..3\n"; *ARGV = *DATA; } print "ok 1\n"; print <>; print "ok 3\n"; __DATA__ ok 2 - read from aliased DATA filehandle perl-5.12.0-RC0/t/run/exit.t0000555000175000017500000001375411325127002014340 0ustar jessejesse#!./perl # # Tests for perl exit codes, playing with $?, etc... BEGIN { chdir 't' if -d 't'; @INC = qw(. ../lib); } # Run some code, return its wait status. sub run { my($code) = shift; $code = "\"" . $code . "\"" if $^O eq 'VMS'; #VMS needs quotes for this. return system($^X, "-e", $code); } BEGIN { $numtests = ($^O eq 'VMS') ? 16 : 17; } my $vms_exit_mode = 0; if ($^O eq 'VMS') { if (eval 'require VMS::Feature') { $vms_exit_mode = !(VMS::Feature::current("posix_exit")); } else { my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; my $env_posix_ex = $ENV{'PERL_VMS_POSIX_EXIT'} || ''; my $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; my $posix_ex = $env_posix_ex =~ /^[ET1]/i; if (($unix_rpt || $posix_ex) ) { $vms_exit_mode = 0; } else { $vms_exit_mode = 1; } } $numtests = 29 unless $vms_exit_mode; } require "test.pl"; plan(tests => $numtests); my $native_success = 0; $native_success = 1 if $^O eq 'VMS'; my $exit, $exit_arg; $exit = run('exit'); is( $exit >> 8, 0, 'Normal exit' ); is( $exit, $?, 'Normal exit $?' ); is( ${^CHILD_ERROR_NATIVE}, $native_success, 'Normal exit ${^CHILD_ERROR_NATIVE}' ); if (!$vms_exit_mode) { my $posix_ok = eval { require POSIX; }; my $wait_macros_ok = defined &POSIX::WIFEXITED; eval { POSIX::WIFEXITED(${^CHILD_ERROR_NATIVE}) }; $wait_macros_ok = 0 if $@; $exit = run('exit 42'); is( $exit >> 8, 42, 'Non-zero exit' ); is( $exit, $?, 'Non-zero exit $?' ); isnt( !${^CHILD_ERROR_NATIVE}, 0, 'Non-zero exit ${^CHILD_ERROR_NATIVE}' ); SKIP: { skip("No POSIX", 3) unless $posix_ok; skip("No POSIX wait macros", 3) unless $wait_macros_ok; ok(POSIX::WIFEXITED(${^CHILD_ERROR_NATIVE}), "WIFEXITED"); ok(!POSIX::WIFSIGNALED(${^CHILD_ERROR_NATIVE}), "WIFSIGNALED"); is(POSIX::WEXITSTATUS(${^CHILD_ERROR_NATIVE}), 42, "WEXITSTATUS"); } SKIP: { skip("Skip signals and core dump tests on Win32 and VMS", 7) if ($^O eq 'MSWin32' || $^O eq 'VMS'); #TODO VMS will backtrace on this test and exits with code of 0 #instead of 15. $exit = run('kill 15, $$; sleep(1);'); is( $exit & 127, 15, 'Term by signal' ); ok( !($exit & 128), 'No core dump' ); is( $? & 127, 15, 'Term by signal $?' ); isnt( ${^CHILD_ERROR_NATIVE}, 0, 'Term by signal ${^CHILD_ERROR_NATIVE}' ); SKIP: { skip("No POSIX", 3) unless $posix_ok; skip("No POSIX wait macros", 3) unless $wait_macros_ok; ok(!POSIX::WIFEXITED(${^CHILD_ERROR_NATIVE}), "WIFEXITED"); ok(POSIX::WIFSIGNALED(${^CHILD_ERROR_NATIVE}), "WIFSIGNALED"); is(POSIX::WTERMSIG(${^CHILD_ERROR_NATIVE}), 15, "WTERMSIG"); } } } if ($^O eq 'VMS') { # On VMS, successful returns from system() are reported 0, VMS errors that # can not be translated to UNIX are reported as EVMSERR, which has a value # of 65535. Codes from 2 through 7 are assumed to be from non-compliant # VMS systems and passed through. Programs written to use _POSIX_EXIT() # codes like GNV will pass the numbers 2 through 255 encoded in the # C facility by multiplying the number by 8 and adding %x35A000 to it. # Perl will decode that number from children back to it's internal status. # # For native VMS status codes, success codes are odd numbered, error codes # are even numbered. The 3 LSBs of the code indicate if the success is # an informational message or the severity of the failure. # # Because the failure codes for the tests of the CLI facility status codes can # not be translated to UNIX error codes, they will be reported as EVMSERR, # even though Perl will exit with them having the VMS status codes. # # Note that this is testing the perl exit() routine, and not the VMS # DCL EXIT statement. # # The value %x1000000 has been added to the exit code to prevent the # status message from being sent to the STDOUT and STDERR stream. # # Double quotes are needed to pass these commands through DCL to PERL $exit = run("exit 268632065"); # %CLI-S-NORMAL is( $exit >> 8, 0, 'PERL success exit' ); is( ${^CHILD_ERROR_NATIVE} & 7, 1, 'VMS success exit' ); $exit = run("exit 268632067"); # %CLI-I-NORMAL is( $exit >> 8, 0, 'PERL informational exit' ); is( ${^CHILD_ERROR_NATIVE} & 7, 3, 'VMS informational exit' ); $exit = run("exit 268632064"); # %CLI-W-NORMAL is( $exit >> 8, 1, 'Perl warning exit' ); is( ${^CHILD_ERROR_NATIVE} & 7, 0, 'VMS warning exit' ); $exit = run("exit 268632066"); # %CLI-E-NORMAL is( $exit >> 8, 2, 'Perl error exit' ); is( ${^CHILD_ERROR_NATIVE} & 7, 2, 'VMS error exit' ); $exit = run("exit 268632068"); # %CLI-F-NORMAL is( $exit >> 8, 4, 'Perl fatal error exit' ); is( ${^CHILD_ERROR_NATIVE} & 7, 4, 'VMS fatal exit' ); $exit = run("exit 02015320012"); # POSIX exit code 1 is( $exit >> 8, 1, 'Posix exit code 1' ); $exit = run("exit 02015323771"); # POSIX exit code 255 is( $exit >> 8 , 255, 'Posix exit code 255' ); } $exit_arg = 42; $exit = run("END { \$? = $exit_arg }"); # On VMS, in the child process the actual exit status will be SS$_ABORT, # or 44, which is what you get from any non-zero value of $? except for # 65535 that has been dePOSIXified by STATUS_UNIX_SET. If $? is set to # 65535 internally when there is a VMS status code that is valid, and # when Perl exits, it will set that status code. # # In this test on VMS, the child process exit with a SS$_ABORT, which # the parent stores in ${^CHILD_ERROR_NATIVE}. The SS$_ABORT code is # then translated to the UNIX code EINTR which has the value of 4 on VMS. # # This is complex because Perl translates internally generated UNIX # status codes to SS$_ABORT on exit, but passes through unmodified UNIX # status codes that exit() is called with by scripts. $exit_arg = (44 & 7) if $vms_exit_mode; is( $exit >> 8, $exit_arg, 'Changing $? in END block' ); perl-5.12.0-RC0/t/run/switchx.aux0000444000175000017500000000054411325125742015411 0ustar jessejesseSome stuff that's not Perl This CPP directive should not be read. #define BARMAR 1 #perl Still not perl. #! still not perl #!/something/else still not perl #!/some/path/that/leads/to/perl -l print "1..4"; if (-f 'run/switchx.aux') { print "ok 1"; } print "ok 2"; # other tests are in switchx2.aux __END__ # This is ignored print "not ok 2"; perl-5.12.0-RC0/t/run/switches.t0000555000175000017500000002327411325127002015216 0ustar jessejesse#!./perl -w # Tests for the command-line switches: # -0, -c, -l, -s, -m, -M, -V, -v, -h, -i, -E and all unknown # Some switches have their own tests, see MANIFEST. BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } BEGIN { require "./test.pl"; } plan(tests => 71); use Config; # due to a bug in VMS's piping which makes it impossible for runperl() # to emulate echo -n (ie. stdin always winds up with a newline), these # tests almost totally fail. $TODO = "runperl() unable to emulate echo -n due to pipe bug" if $^O eq 'VMS'; my $r; my @tmpfiles = (); END { unlink @tmpfiles } # Tests for -0 $r = runperl( switches => [ '-0', ], stdin => 'foo\0bar\0baz\0', prog => 'print qq(<$_>) while <>', ); is( $r, "", "-0" ); $r = runperl( switches => [ '-l', '-0', '-p' ], stdin => 'foo\0bar\0baz\0', prog => '1', ); is( $r, "foo\nbar\nbaz\n", "-0 after a -l" ); $r = runperl( switches => [ '-0', '-l', '-p' ], stdin => 'foo\0bar\0baz\0', prog => '1', ); is( $r, "foo\0bar\0baz\0", "-0 before a -l" ); $r = runperl( switches => [ sprintf("-0%o", ord 'x') ], stdin => 'fooxbarxbazx', prog => 'print qq(<$_>) while <>', ); is( $r, "", "-0 with octal number" ); $r = runperl( switches => [ '-00', '-p' ], stdin => 'abc\ndef\n\nghi\njkl\nmno\n\npq\n', prog => 's/\n/-/g;$_.=q(/)', ); is( $r, 'abc-def--/ghi-jkl-mno--/pq-/', '-00 (paragraph mode)' ); $r = runperl( switches => [ '-0777', '-p' ], stdin => 'abc\ndef\n\nghi\njkl\nmno\n\npq\n', prog => 's/\n/-/g;$_.=q(/)', ); is( $r, 'abc-def--ghi-jkl-mno--pq-/', '-0777 (slurp mode)' ); $r = runperl( switches => [ '-066' ], prog => 'BEGIN { print qq{($/)} } print qq{[$/]}', ); is( $r, "(\066)[\066]", '$/ set at compile-time' ); # Tests for -c my $filename = tempfile(); SKIP: { local $TODO = ''; # this one works on VMS open my $f, ">$filename" or skip( "Can't write temp file $filename: $!" ); print $f <<'SWTEST'; BEGIN { print "block 1\n"; } CHECK { print "block 2\n"; } INIT { print "block 3\n"; } print "block 4\n"; END { print "block 5\n"; } SWTEST close $f or die "Could not close: $!"; $r = runperl( switches => [ '-c' ], progfile => $filename, stderr => 1, ); # Because of the stderr redirection, we can't tell reliably the order # in which the output is given ok( $r =~ /$filename syntax OK/ && $r =~ /\bblock 1\b/ && $r =~ /\bblock 2\b/ && $r !~ /\bblock 3\b/ && $r !~ /\bblock 4\b/ && $r !~ /\bblock 5\b/, '-c' ); } # Tests for -l $r = runperl( switches => [ sprintf("-l%o", ord 'x') ], prog => 'print for qw/foo bar/' ); is( $r, 'fooxbarx', '-l with octal number' ); # Tests for -s $r = runperl( switches => [ '-s' ], prog => 'for (qw/abc def ghi/) {print defined $$_ ? $$_ : q(-)}', args => [ '--', '-abc=2', '-def', ], ); is( $r, '21-', '-s switch parsing' ); $filename = tempfile(); SKIP: { open my $f, ">$filename" or skip( "Can't write temp file $filename: $!" ); print $f <<'SWTEST'; #!perl -s BEGIN { print $x,$y; exit } SWTEST close $f or die "Could not close: $!"; $r = runperl( progfile => $filename, args => [ '-x=foo -y' ], ); is( $r, 'foo1', '-s on the shebang line' ); } # Bug ID 20011106.084 $filename = tempfile(); SKIP: { open my $f, ">$filename" or skip( "Can't write temp file $filename: $!" ); print $f <<'SWTEST'; #!perl -sn BEGIN { print $x; exit } SWTEST close $f or die "Could not close: $!"; $r = runperl( progfile => $filename, args => [ '-x=foo' ], ); is( $r, 'foo', '-sn on the shebang line' ); } # Tests for -m and -M my $package = tempfile(); $filename = "$package.pm"; SKIP: { open my $f, ">$filename" or skip( "Can't write temp file $filename: $!",4 ); print $f <<"SWTESTPM"; package $package; sub import { print map "<\$_>", \@_ } 1; SWTESTPM close $f or die "Could not close: $!"; $r = runperl( switches => [ "-M$package" ], prog => '1', ); is( $r, "<$package>", '-M' ); $r = runperl( switches => [ "-M$package=foo" ], prog => '1', ); is( $r, "<$package>", '-M with import parameter' ); $r = runperl( switches => [ "-m$package" ], prog => '1', ); { local $TODO = ''; # this one works on VMS is( $r, '', '-m' ); } $r = runperl( switches => [ "-m$package=foo,bar" ], prog => '1', ); is( $r, "<$package>", '-m with import parameters' ); push @tmpfiles, $filename; { local $TODO = ''; # these work on VMS is( runperl( switches => [ '-MTie::Hash' ], stderr => 1, prog => 1 ), '', "-MFoo::Bar allowed" ); like( runperl( switches => [ "-M:$package" ], stderr => 1, prog => 'die "oops"' ), qr/Invalid module name [\w:]+ with -M option\b/, "-M:Foo not allowed" ); like( runperl( switches => [ '-mA:B:C' ], stderr => 1, prog => 'die "oops"' ), qr/Invalid module name [\w:]+ with -m option\b/, "-mFoo:Bar not allowed" ); like( runperl( switches => [ '-m-A:B:C' ], stderr => 1, prog => 'die "oops"' ), qr/Invalid module name [\w:]+ with -m option\b/, "-m-Foo:Bar not allowed" ); like( runperl( switches => [ '-m-' ], stderr => 1, prog => 'die "oops"' ), qr/Module name required with -m option\b/, "-m- not allowed" ); like( runperl( switches => [ '-M-=' ], stderr => 1, prog => 'die "oops"' ), qr/Module name required with -M option\b/, "-M- not allowed" ); } # disable TODO on VMS } # Tests for -V { local $TODO = ''; # these ones should work on VMS # basic perl -V should generate significant output. # we don't test actual format too much since it could change like( runperl( switches => ['-V'] ), qr/(\n.*){20}/, '-V generates 20+ lines' ); like( runperl( switches => ['-V'] ), qr/\ASummary of my perl5 .*configuration:/, '-V looks okay' ); # lookup a known config var chomp( $r=runperl( switches => ['-V:osname'] ) ); is( $r, "osname='$^O';", 'perl -V:osname'); # lookup a nonexistent var chomp( $r=runperl( switches => ['-V:this_var_makes_switches_test_fail'] ) ); is( $r, "this_var_makes_switches_test_fail='UNKNOWN';", 'perl -V:unknown var'); # regexp lookup # platforms that don't like this quoting can either skip this test # or fix test.pl _quote_args $r = runperl( switches => ['"-V:i\D+size"'] ); # should be unlike( $r, qr/^$|not found|UNKNOWN/ ); like( $r, qr/^(?!.*(not found|UNKNOWN))./, 'perl -V:re got a result' ); # make sure each line we got matches the re ok( !( grep !/^i\D+size=/, split /^/, $r ), '-V:re correct' ); } # Tests for -v { local $TODO = ''; # these ones should work on VMS # there are definitely known build configs where this test will fail # DG/UX comes to mind. Maybe we should remove these special cases? my $v = sprintf "%vd", $^V; my $ver = $Config{PERL_VERSION}; my $rel = $Config{PERL_SUBVERSION}; like( runperl( switches => ['-v'] ), qr/This is perl 5, version \Q$ver\E, subversion \Q$rel\E \(v\Q$v\E(?:[-*\w]+| \([^)]+\))?\) built for \Q$Config{archname}\E.+Copyright.+Larry Wall.+Artistic License.+GNU General Public License/s, '-v looks okay' ); } # Tests for -h { local $TODO = ''; # these ones should work on VMS like( runperl( switches => ['-h'] ), qr/Usage: .+(?i:perl(?:$Config{_exe})?).+switches.+programfile.+arguments/, '-h looks okay' ); } # Tests for switches which do not exist foreach my $switch (split //, "ABbGgHJjKkLNOoPQqRrYyZz123456789_") { local $TODO = ''; # these ones should work on VMS like( runperl( switches => ["-$switch"], stderr => 1, prog => 'die "oops"' ), qr/\QUnrecognized switch: -$switch (-h will show valid options)./, "-$switch correctly unknown" ); } # Tests for -i { local $TODO = ''; # these ones should work on VMS sub do_i_unlink { 1 while unlink("file", "file.bak") } open(FILE, ">file") or die "$0: Failed to create 'file': $!"; print FILE <<__EOF__; foo yada dada bada foo bing king kong foo __EOF__ close FILE; END { do_i_unlink() } runperl( switches => ['-pi.bak'], prog => 's/foo/bar/', args => ['file'] ); open(FILE, "file") or die "$0: Failed to open 'file': $!"; chomp(my @file = ); close FILE; open(BAK, "file.bak") or die "$0: Failed to open 'file': $!"; chomp(my @bak = ); close BAK; is(join(":", @file), "bar yada dada:bada bar bing:king kong bar", "-i new file"); is(join(":", @bak), "foo yada dada:bada foo bing:king kong foo", "-i backup file"); } # Tests for -E $TODO = ''; # the -E tests work on VMS $r = runperl( switches => [ '-E', '"say q(Hello, world!)"'] ); is( $r, "Hello, world!\n", "-E say" ); $r = runperl( switches => [ '-E', '"undef ~~ undef and say q(Hello, world!)"'] ); is( $r, "Hello, world!\n", "-E ~~" ); $r = runperl( switches => [ '-E', '"given(undef) {when(undef) { say q(Hello, world!)"}}'] ); is( $r, "Hello, world!\n", "-E given" ); $r = runperl( switches => [ '-nE', q("} END { say q/affe/") ], stdin => 'zomtek', ); is( $r, "affe\n", '-E works outside of the block created by -n' ); $r = runperl( switches => [ '-E', q("*{'bar'} = sub{}; print 'Hello, world!',qq|\n|;")] ); is( $r, "Hello, world!\n", "-E does not enable strictures" ); # RT #30660 $filename = tempfile(); SKIP: { open my $f, ">$filename" or skip( "Can't write temp file $filename: $!" ); print $f <<'SWTEST'; #!perl -w -iok print "$^I\n"; SWTEST close $f or die "Could not close: $!"; $r = runperl( progfile => $filename, ); like( $r, qr/ok/, 'Spaces on the #! line (#30660)' ); } perl-5.12.0-RC0/t/run/switchI.t0000555000175000017500000000135111325127002014767 0ustar jessejesse#!./perl -IFoo::Bar -IBla BEGIN { chdir 't' if -d 't'; unshift @INC, '../lib'; require './test.pl'; # for which_perl() etc } BEGIN { plan(4); } my $Is_VMS = $^O eq 'VMS'; my $lib; $lib = 'Bla'; ok(grep { $_ eq $lib } @INC[0..($#INC-1)]); SKIP: { skip 'Double colons not allowed in dir spec', 1 if $Is_VMS; $lib = 'Foo::Bar'; ok(grep { $_ eq $lib } @INC[0..($#INC-1)]); } $lib = 'Bla2'; fresh_perl_is("print grep { \$_ eq '$lib' } \@INC[0..(\$#INC-1)]", $lib, { switches => ['-IBla2'] }, '-I'); SKIP: { skip 'Double colons not allowed in dir spec', 1 if $Is_VMS; $lib = 'Foo::Bar2'; fresh_perl_is("print grep { \$_ eq '$lib' } \@INC", $lib, { switches => ['-IFoo::Bar2'] }, '-I with colons'); } perl-5.12.0-RC0/t/run/script.t0000555000175000017500000000112011325127002014653 0ustar jessejesse#!./perl BEGIN { chdir 't'; @INC = '../lib'; require './test.pl'; # for which_perl() etc } my $Perl = which_perl(); my $filename = tempfile(); print "1..3\n"; $x = `$Perl -le "print 'ok';"`; if ($x eq "ok\n") {print "ok 1\n";} else {print "not ok 1\n";} open(try,">$filename") || (die "Can't open temp file."); print try 'print "ok\n";'; print try "\n"; close try or die "Could not close: $!"; $x = `$Perl $filename`; if ($x eq "ok\n") {print "ok 2\n";} else {print "not ok 2\n";} $x = `$Perl <$filename`; if ($x eq "ok\n") {print "ok 3\n";} else {print "not ok 3\n";} perl-5.12.0-RC0/t/run/switch0.t0000555000175000017500000000011111143650501014732 0ustar jessejesse#!./perl -0 print "1..1\n"; print ord $/ == 0 ? "ok 1\n" : "not ok 1\n"; perl-5.12.0-RC0/t/run/switchd.t0000555000175000017500000000261711325125742015041 0ustar jessejesse#!./perl -w BEGIN { chdir 't' if -d 't'; @INC = qw(../lib lib); } BEGIN { require "./test.pl"; } # This test depends on t/lib/Devel/switchd.pm. plan(tests => 2); my $r; my $filename = tempfile(); SKIP: { open my $f, ">$filename" or skip( "Can't write temp file $filename: $!" ); print $f <<'__SWDTEST__'; package Bar; sub bar { $_[0] * $_[0] } package Foo; sub foo { my $s; $s += Bar::bar($_) for 1..$_[0]; } package main; Foo::foo(3); __SWDTEST__ close $f; $| = 1; # Unbufferize. $r = runperl( switches => [ '-Ilib', '-f', '-d:switchd' ], progfile => $filename, args => ['3'], ); like($r, qr/^sub;import;DB;sub;DB;DB;DB;sub;DB;sub;DB;sub;DB;$/); $r = runperl( switches => [ '-Ilib', '-f', '-d:switchd=a,42' ], progfile => $filename, args => ['4'], ); like($r, qr/^sub;import;DB;sub;DB;DB;DB;sub;DB;sub;DB;sub;DB;$/); } perl-5.12.0-RC0/t/run/switcht.t0000555000175000017500000000316211325125742015055 0ustar jessejesse#!./perl -t BEGIN { chdir 't'; @INC = '../lib'; require './test.pl'; } plan tests => 13; my $Perl = which_perl(); my $warning; local $SIG{__WARN__} = sub { $warning = join "\n", @_; }; my $Tmsg = 'while running with -t switch'; is( ${^TAINT}, -1, '${^TAINT} == -1' ); my $out = `$Perl -le "print q(Hello)"`; is( $out, "Hello\n", '`` worked' ); like( $warning, qr/^Insecure .* $Tmsg/, ' taint warn' ); { no warnings 'taint'; $warning = ''; my $out = `$Perl -le "print q(Hello)"`; is( $out, "Hello\n", '`` worked' ); is( $warning, '', ' no warnings "taint"' ); } # Get ourselves a tainted variable. my $filename = tempfile(); $file = $0; $file =~ s/.*/$filename/; ok( open(FILE, ">$file"), 'open >' ) or DIE $!; print FILE "Stuff\n"; close FILE; like( $warning, qr/^Insecure dependency in open $Tmsg/, 'open > taint warn' ); ok( -e $file, ' file written' ); unlink($file); like( $warning, qr/^Insecure dependency in unlink $Tmsg/, 'unlink() taint warn' ); ok( !-e $file, 'unlink worked' ); ok( !$^W, "-t doesn't enable regular warnings" ); mkdir('ttdir'); open(FH,'>','ttdir/ttest.pl')or DIE $!; print FH 'return 42'; close FH or DIE $!; SKIP: { ($^O eq 'MSWin32') || skip('skip tainted do test with \ separator'); my $test = 0; $test = do '.\ttdir/ttest.pl'; is($test, 42, 'Could "do" .\ttdir/ttest.pl'); } { my $test = 0; $test = do './ttdir/ttest.pl'; is($test, 42, 'Could "do" ./ttdir/ttest.pl'); } unlink ('./ttdir/ttest.pl'); rmdir ('ttdir'); perl-5.12.0-RC0/t/uni/0000755000175000017500000000000011351321567013171 5ustar jessejesseperl-5.12.0-RC0/t/uni/latin2.t0000555000175000017500000001315111325125742014547 0ustar jessejesseBEGIN { if ($ENV{'PERL_CORE'}){ chdir 't'; @INC = '../lib'; } require Config; import Config; if ($Config{'extensions'} !~ /\bEncode\b/) { print "1..0 # Skip: Encode was not built\n"; exit 0; } if (ord("A") == 193) { print "1..0 # Skip: EBCDIC\n"; exit 0; } unless (PerlIO::Layer->find('perlio')){ print "1..0 # Skip: PerlIO required\n"; exit 0; } if ($ENV{PERL_CORE_MINITEST}) { print "1..0 # Skip: no dynamic loading on miniperl, no Encode\n"; exit 0; } $| = 1; require './test.pl'; } plan tests => 94; use encoding "latin2"; # iso 8859-2 # U+00C1, \xC1, \301, LATIN CAPITAL LETTER A WITH ACUTE # U+0102, \xC3, \402, LATIN CAPITAL LETTER A WITH BREVE # U+00E1, \xE1, \303, LATIN SMALL LETTER A WITH ACUTE # U+0103, \xE3, \403, LATIN SMALL LETTER A WITH BREVE ok("\xC1" =~ /\xC1/, '\xC1 to /\xC1/'); ok("\x{C1}" =~ /\x{C1}/, '\x{C1} to /\x{C1}/'); ok("\xC3" =~ /\xC3/, '\xC3 to /\xC3/'); ok("\x{102}" =~ /\xC3/, '\x{102} to /\xC3/'); ok("\xC3" =~ /\x{C3}/, '\xC3 to /\x{C3}/'); ok("\x{102}" =~ /\x{C3}/, '\x{102} to /\x{C3}/'); ok("\xC3" =~ /\x{102}/, '\xC3 to /\x{102}/'); ok("\x{102}" =~ /\x{102}/, '\x{102} to /\x{102}/'); ok("\xC1" =~ /\xC1/i, '\xC1 to /\xC1/i'); ok("\xE1" =~ /\xC1/i, '\xE1 to /\xC1/i'); ok("\xC1" =~ /\xE1/i, '\xC1 to /\xE1/i'); ok("\xE1" =~ /\xE1/i, '\xE1 to /\xE1/i'); ok("\x{102}" =~ /\xC3/i, '\x{102} to /\xC3/i'); ok("\x{103}" =~ /\xC3/i, '\x{103} to /\xC3/i'); ok("\x{102}" =~ /\xE3/i, '\x{102} to /\xE3/i'); ok("\x{103}" =~ /\xE3/i, '\x{103} to /\xE3/i'); ok("\xC1" =~ /[\xC1]/, '\xC1 to /[\xC1]/'); ok("\x{C1}" =~ /[\x{C1}]/, '\x{C1} to /[\x{C1}]/'); ok("\xC3" =~ /[\xC3]/, '\xC3 to /[\xC3]/'); ok("\x{102}" =~ /[\xC3]/, '\x{102} to /[\xC3]/'); ok("\xC3" =~ /[\x{C3}]/, '\xC3 to /[\x{C3}]/'); ok("\x{102}" =~ /[\x{C3}]/, '\x{102} to /[\x{C3}]/'); ok("\xC3" =~ /[\x{102}]/, '\xC3 to /[\x{102}]/'); ok("\x{102}" =~ /[\x{102}]/, '\x{102} to /[\x{102}]/'); ok("\xC1" =~ /[\xC1]/i, '\xC1 to /[\xC1]/i'); ok("\xE1" =~ /[\xC1]/i, '\xE1 to /[\xC1]/i'); ok("\xC1" =~ /[\xE1]/i, '\xC1 to /[\xE1]/i'); ok("\xE1" =~ /[\xE1]/i, '\xE1 to /[\xE1]/i'); ok("\x{102}" =~ /[\xC3]/i, '\x{102} to /[\xC3]/i'); ok("\x{103}" =~ /[\xC3]/i, '\x{103} to /[\xC3]/i'); ok("\x{102}" =~ /[\xE3]/i, '\x{102} to /[\xE3]/i'); ok("\x{103}" =~ /[\xE3]/i, '\x{103} to /[\xE3]/i'); ok("\xC1" =~ '\xC1', '\xC1 to \'\xC1\''); ok("\xC1" =~ '\x{C1}', '\xC1 to \'\x{C1}\''); ok("\xC3" =~ '\303', '\xC3 to \'\303\''); ok("\xC3" =~ '\x{102}', '\xC3 to \'\x{102}\''); ok("\xC1" =~ '[\xC1]', '\xC1 to \'[\xC1]\''); ok("\xC1" =~ '[\x{C1}]', '\xC1 to \'[\x{C1}]\''); ok("\xC3" =~ '[\303]', '\xC3 to \'[\303]\''); ok("\xC3" =~ '[\x{102}]', '\xC3 to \'[\x{102}]\''); ok("\xC1" =~ /Á/, '\xC1 to //'); ok("\xE1" !~ /Á/, '\xE1 to //'); ok("\xC1" =~ /Á/i, '\xC1 to //i'); ok("\xE1" =~ /Á/i, '\xE1 to //i'); ok("\xC1" =~ /[Á]/, '\xC1 to /[]/'); ok("\xE1" !~ /[Á]/, '\xE1 to /[]/'); ok("\xC1" =~ /[Á]/i, '\xC1 to /[]/i'); ok("\xE1" =~ /[Á]/i, '\xE1 to /[]/i'); ok("\xC1\xC1" =~ /Á\xC1/, '\xC1\xC1 to /\xC1/'); ok("\xC1\xC1" =~ /\xC1Á/, '\xC1\xC1 to /\xC1/'); ok("\xC1\xC1" =~ /Á\xC1/i, '\xC1\xC1 to /\xC1/i'); ok("\xC1\xC1" =~ /\xC1Á/i, '\xC1\xC1 to /\xC1/i'); ok("\xC1\xE1" =~ /Á\xC1/i, '\xC1\xE1 to /\xC1/i'); ok("\xC1\xE1" =~ /\xC1Á/i, '\xC1\xE1 to /\xC1/i'); ok("\xE1\xE1" =~ /Á\xC1/i, '\xE1\xE1 to /\xC1/i'); ok("\xE1\xE1" =~ /\xC1Á/i, '\xE1\xE1 to /\xC1/i'); # \xDF is LATIN SMALL LETTER SHARP S ok("\xDF" =~ /\xDF/, '\xDF to /\xDF/'); ok("\xDF" =~ /\xDF/i, '\xDF to /\xDF/i'); ok("\xDF" =~ /[\xDF]/, '\xDF to /[\xDF]/'); ok("\xDF" =~ /[\xDF]/i, '\xDF to /[\xDF]/i'); ok("\xDF" =~ /ß/, '\xDF to //'); ok("\xDF" =~ /ß/i, '\xDF to //i'); ok("\xDF" =~ /[ß]/, '\xDF to /[]/'); ok("\xDF" =~ /[ß]/i, '\xDF to /[]/i'); ok("SS" =~ /\xDF/i, 'SS to /\xDF/i'); ok("Ss" =~ /\xDF/i, 'Ss to /\xDF/i'); ok("sS" =~ /\xDF/i, 'sS to /\xDF/i'); ok("ss" =~ /\xDF/i, 'ss to /\xDF/i'); ok("SS" =~ /ß/i, 'SS to //i'); ok("Ss" =~ /ß/i, 'Ss to //i'); ok("sS" =~ /ß/i, 'sS to //i'); ok("ss" =~ /ß/i, 'ss to //i'); ok("\xC3" =~ /\303/, '\xC1 to /\303/'); ok("\303" =~ /\303/, '\303 to /\303/'); ok("\xC3" =~ /\303/i, '\xC1 to /\303/i'); ok("\xE3" =~ /\303/i, '\xC1 to /\303/i'); ok("\xC3" =~ /[\303]/, '\xC1 to /[\303]/'); ok("\303" =~ /[\303]/, '\303 to /[\303]/'); ok("\xC3" =~ /[\303]/i, '\xC1 to /[\303]/i'); ok("\xE3" =~ /[\303]/i, '\xC1 to /[\303]/i'); ok("\xC3" =~ /\402/, '\xC1 to /\402/'); ok("\402" =~ /\402/, '\402 to /\402/'); ok("\xC3" =~ /\402/i, '\xC1 to /\402/i'); ok("\xE3" =~ /\402/i, '\xC1 to /\402/i'); ok("\xC3" =~ /[\402]/, '\xC1 to /[\402]/'); ok("\402" =~ /[\402]/, '\402 to /[\402]/'); ok("\xC3" =~ /[\402]/i, '\xC1 to /[\402]/i'); ok("\xE3" =~ /[\402]/i, '\xC1 to /[\402]/i'); { my $re = '(?i:\xC1)'; ok("\xC1" =~ $re, '\xC1 to (?i:\xC1)'); ok("\xE1" =~ $re, '\xE1 to (?i:\xC1)'); utf8::downgrade($re); ok("\xC1" =~ $re, '\xC1 to (?i:\xC1) down'); ok("\xE1" =~ $re, '\xE1 to (?i:\xC1) down'); utf8::upgrade($re); ok("\xC1" =~ $re, '\xC1 to (?i:\xC1) up'); ok("\xE1" =~ $re, '\xE1 to (?i:\xC1) up'); } perl-5.12.0-RC0/t/uni/overload.t0000555000175000017500000001630711325127002015166 0ustar jessejesse#!perl -w BEGIN { chdir 't'; @INC = '../lib'; require './test.pl'; } plan(tests => 215); package UTF8Toggle; use strict; use overload '""' => 'stringify', fallback => 1; sub new { my $class = shift; my $value = shift; my $state = shift||0; return bless [$value, $state], $class; } sub stringify { my $self = shift; $self->[1] = ! $self->[1]; if ($self->[1]) { utf8::downgrade($self->[0]); } else { utf8::upgrade($self->[0]); } $self->[0]; } package main; # These tests are based on characters 128-255 not having latin1, and hence # Unicode, semantics # no feature "unicode_strings"; # Bug 34297 foreach my $t ("ASCII", "B\366se") { my $length = length $t; my $u = UTF8Toggle->new($t); is (length $u, $length, "length of '$t'"); is (length $u, $length, "length of '$t'"); is (length $u, $length, "length of '$t'"); is (length $u, $length, "length of '$t'"); } my $u = UTF8Toggle->new("\311"); my $lc = lc $u; is (length $lc, 1); is ($lc, "\311", "E acute -> e acute"); $lc = lc $u; is (length $lc, 1); is ($lc, "\351", "E acute -> e acute"); $lc = lc $u; is (length $lc, 1); is ($lc, "\311", "E acute -> e acute"); $u = UTF8Toggle->new("\351"); my $uc = uc $u; is (length $uc, 1); is ($uc, "\351", "e acute -> E acute"); $uc = uc $u; is (length $uc, 1); is ($uc, "\311", "e acute -> E acute"); $uc = uc $u; is (length $uc, 1); is ($uc, "\351", "e acute -> E acute"); $u = UTF8Toggle->new("\311"); $lc = lcfirst $u; is (length $lc, 1); is ($lc, "\311", "E acute -> e acute"); $lc = lcfirst $u; is (length $lc, 1); is ($lc, "\351", "E acute -> e acute"); $lc = lcfirst $u; is (length $lc, 1); is ($lc, "\311", "E acute -> e acute"); $u = UTF8Toggle->new("\351"); $uc = ucfirst $u; is (length $uc, 1); is ($uc, "\351", "e acute -> E acute"); $uc = ucfirst $u; is (length $uc, 1); is ($uc, "\311", "e acute -> E acute"); $uc = ucfirst $u; is (length $uc, 1); is ($uc, "\351", "e acute -> E acute"); my $have_setlocale = 0; eval { require POSIX; import POSIX ':locale_h'; $have_setlocale++; }; SKIP: { if (!$have_setlocale) { skip "No setlocale", 24; } elsif (!setlocale(&POSIX::LC_ALL, "en_GB.ISO8859-1")) { skip "Could not setlocale to en_GB.ISO8859-1", 24; } elsif ($^O eq 'dec_osf' || $^O eq 'VMS') { skip "$^O has broken en_GB.ISO8859-1 locale", 24; } else { use locale; my $u = UTF8Toggle->new("\311"); my $lc = lc $u; is (length $lc, 1); is ($lc, "\351", "E acute -> e acute"); $lc = lc $u; is (length $lc, 1); is ($lc, "\351", "E acute -> e acute"); $lc = lc $u; is (length $lc, 1); is ($lc, "\351", "E acute -> e acute"); $u = UTF8Toggle->new("\351"); my $uc = uc $u; is (length $uc, 1); is ($uc, "\311", "e acute -> E acute"); $uc = uc $u; is (length $uc, 1); is ($uc, "\311", "e acute -> E acute"); $uc = uc $u; is (length $uc, 1); is ($uc, "\311", "e acute -> E acute"); $u = UTF8Toggle->new("\311"); $lc = lcfirst $u; is (length $lc, 1); is ($lc, "\351", "E acute -> e acute"); $lc = lcfirst $u; is (length $lc, 1); is ($lc, "\351", "E acute -> e acute"); $lc = lcfirst $u; is (length $lc, 1); is ($lc, "\351", "E acute -> e acute"); $u = UTF8Toggle->new("\351"); $uc = ucfirst $u; is (length $uc, 1); is ($uc, "\311", "e acute -> E acute"); $uc = ucfirst $u; is (length $uc, 1); is ($uc, "\311", "e acute -> E acute"); $uc = ucfirst $u; is (length $uc, 1); is ($uc, "\311", "e acute -> E acute"); } } my $tmpfile = tempfile(); foreach my $operator ('print', 'syswrite', 'syswrite len', 'syswrite off', 'syswrite len off') { foreach my $layer ('', ':utf8') { open my $fh, "+>$layer", $tmpfile or die $!; my $pad = $operator =~ /\boff\b/ ? "\243" : ""; my $trail = $operator =~ /\blen\b/ ? "!" : ""; my $u = UTF8Toggle->new("$pad\311\n$trail"); my $l = UTF8Toggle->new("$pad\351\n$trail", 1); if ($operator eq 'print') { no warnings 'utf8'; print $fh $u; print $fh $u; print $fh $u; print $fh $l; print $fh $l; print $fh $l; } elsif ($operator eq 'syswrite') { syswrite $fh, $u; syswrite $fh, $u; syswrite $fh, $u; syswrite $fh, $l; syswrite $fh, $l; syswrite $fh, $l; } elsif ($operator eq 'syswrite len') { syswrite $fh, $u, 2; syswrite $fh, $u, 2; syswrite $fh, $u, 2; syswrite $fh, $l, 2; syswrite $fh, $l, 2; syswrite $fh, $l, 2; } elsif ($operator eq 'syswrite off' || $operator eq 'syswrite len off') { syswrite $fh, $u, 2, 1; syswrite $fh, $u, 2, 1; syswrite $fh, $u, 2, 1; syswrite $fh, $l, 2, 1; syswrite $fh, $l, 2, 1; syswrite $fh, $l, 2, 1; } else { die $operator; } seek $fh, 0, 0 or die $!; my $line; chomp ($line = <$fh>); is ($line, "\311", "$operator $layer"); chomp ($line = <$fh>); is ($line, "\311", "$operator $layer"); chomp ($line = <$fh>); is ($line, "\311", "$operator $layer"); chomp ($line = <$fh>); is ($line, "\351", "$operator $layer"); chomp ($line = <$fh>); is ($line, "\351", "$operator $layer"); chomp ($line = <$fh>); is ($line, "\351", "$operator $layer"); close $fh or die $!; } } my $little = "\243\243"; my $big = " \243 $little ! $little ! $little \243 "; my $right = rindex $big, $little; my $right1 = rindex $big, $little, 11; my $left = index $big, $little; my $left1 = index $big, $little, 4; cmp_ok ($right, ">", $right1, "Sanity check our rindex tests"); cmp_ok ($left, "<", $left1, "Sanity check our index tests"); foreach my $b ($big, UTF8Toggle->new($big)) { foreach my $l ($little, UTF8Toggle->new($little), UTF8Toggle->new($little, 1)) { is (rindex ($b, $l), $right, "rindex"); is (rindex ($b, $l), $right, "rindex"); is (rindex ($b, $l), $right, "rindex"); is (rindex ($b, $l, 11), $right1, "rindex 11"); is (rindex ($b, $l, 11), $right1, "rindex 11"); is (rindex ($b, $l, 11), $right1, "rindex 11"); is (index ($b, $l), $left, "index"); is (index ($b, $l), $left, "index"); is (index ($b, $l), $left, "index"); is (index ($b, $l, 4), $left1, "index 4"); is (index ($b, $l, 4), $left1, "index 4"); is (index ($b, $l, 4), $left1, "index 4"); } } my $bits = "\311"; foreach my $pieces ($bits, UTF8Toggle->new($bits)) { like ($bits ^ $pieces, qr/\A\0+\z/, "something xor itself is zeros"); like ($bits ^ $pieces, qr/\A\0+\z/, "something xor itself is zeros"); like ($bits ^ $pieces, qr/\A\0+\z/, "something xor itself is zeros"); like ($pieces ^ $bits, qr/\A\0+\z/, "something xor itself is zeros"); like ($pieces ^ $bits, qr/\A\0+\z/, "something xor itself is zeros"); like ($pieces ^ $bits, qr/\A\0+\z/, "something xor itself is zeros"); } foreach my $value ("\243", UTF8Toggle->new("\243")) { is (pack ("A/A", $value), pack ("A/A", "\243"), "pack copes with overloading"); is (pack ("A/A", $value), pack ("A/A", "\243")); is (pack ("A/A", $value), pack ("A/A", "\243")); } foreach my $value ("\243", UTF8Toggle->new("\243")) { my $v; $v = substr $value, 0, 1; is ($v, "\243"); $v = substr $value, 0, 1; is ($v, "\243"); $v = substr $value, 0, 1; is ($v, "\243"); } { package RT69422; use overload '""' => sub { $_[0]->{data} } } { my $text = bless { data => "\x{3075}" }, 'RT69422'; my $p = substr $text, 0, 1; is ($p, "\x{3075}"); } perl-5.12.0-RC0/t/uni/chr.t0000555000175000017500000000136211325127002014122 0ustar jessejesse#!./perl -w BEGIN { require Config; import Config; if ($Config{'extensions'} !~ /\bEncode\b/) { print "1..0 # Skip: Encode was not built\n"; exit 0; } if (ord("A") == 193) { print "1..0 # Skip: EBCDIC\n"; exit 0; } unless (PerlIO::Layer->find('perlio')){ print "1..0 # Skip: PerlIO required\n"; exit 0; } if ($ENV{PERL_CORE_MINITEST}) { print "1..0 # Skip: no dynamic loading on miniperl, no Encode\n"; exit 0; } $| = 1; require './test.pl'; } use strict; plan (tests => 6); use encoding 'johab'; ok(chr(0x7f) eq "\x7f"); ok(chr(0x80) eq "\x80"); ok(chr(0xff) eq "\xff"); for my $i (127, 128, 255) { ok(chr($i) eq pack('C', $i)); } __END__ perl-5.12.0-RC0/t/uni/cache.t0000555000175000017500000000067611325127002014420 0ustar jessejesseBEGIN { chdir 't' if -d 't'; @INC = qw(../lib .); require "test.pl"; } plan tests => 1; my $count = 0; unshift @INC, sub { # XXX Kludge requires exact path, which might change $count++ if $_[1] eq 'unicore/lib/Sc/Hira.pl'; }; my $s = 'foo'; $s =~ m/[\p{Hiragana}]/; $s =~ m/[\p{Hiragana}]/; $s =~ m/[\p{Hiragana}]/; $s =~ m/[\p{Hiragana}]/; is($count, 1, "Swatch hash caching kept us from reloading swatch hash."); perl-5.12.0-RC0/t/uni/tr_eucjp.t0000555000175000017500000000307411325127002015163 0ustar jessejesse#! perl -w # # $Id$ # # This script is written intentionally in EUC-JP # -- dankogai BEGIN { require Config; import Config; if ($Config{'extensions'} !~ /\bEncode\b/) { print "1..0 # Skip: Encode was not built\n"; exit 0; } if (ord("A") == 193) { print "1..0 # Skip: EBCDIC\n"; exit 0; } unless (PerlIO::Layer->find('perlio')){ print "1..0 # Skip: PerlIO required\n"; exit 0; } if ($ENV{PERL_CORE_MINITEST}) { print "1..0 # Skip: no dynamic loading on miniperl, no Encode\n"; exit 0; } $| = 1; require './test.pl'; } use strict; plan(tests => 6); use encoding 'euc-jp'; my @hiragana = map {chr} ord("¤¡")..ord("¤ó"); my @katakana = map {chr} ord("¥¡")..ord("¥ó"); my $hiragana = join('' => @hiragana); my $katakana = join('' => @katakana); my %h2k; @h2k{@hiragana} = @katakana; my %k2h; @k2h{@katakana} = @hiragana; # print @hiragana, "\n"; my $str; $str = $hiragana; $str =~ tr/¤¡-¤ó/¥¡-¥ó/; is($str, $katakana, "tr// # hiragana -> katakana"); $str = $katakana; $str =~ tr/¥¡-¥ó/¤¡-¤ó/; is($str, $hiragana, "tr// # hiragana -> katakana"); $str = $hiragana; eval qq(\$str =~ tr/¤¡-¤ó/¥¡-¥ó/); is($str, $katakana, "eval qq(tr//) # hiragana -> katakana"); $str = $katakana; eval qq(\$str =~ tr/¥¡-¥ó/¤¡-¤ó/); is($str, $hiragana, "eval qq(tr//) # hiragana -> katakana"); $str = $hiragana; $str =~ s/([¤¡-¤ó])/$h2k{$1}/go; is($str, $katakana, "s/// # hiragana -> katakana"); $str = $katakana; $str =~ s/([¥¡-¥ó])/$k2h{$1}/go; is($str, $hiragana, "s/// # hiragana -> katakana"); __END__ perl-5.12.0-RC0/t/uni/lower.t0000555000175000017500000000037411325125742014511 0ustar jessejesseBEGIN { chdir 't' if -d 't'; @INC = qw(../lib uni .); require "case.pl"; } casetest("Lower", \%utf8::ToSpecLower, sub { lc $_[0] }, sub { my $a = ""; lc ($_[0] . $a) }, sub { lcfirst $_[0] }, sub { my $a = ""; lcfirst ($_[0] . $a) }); perl-5.12.0-RC0/t/uni/tie.t0000555000175000017500000000140611325127002014126 0ustar jessejesse#!perl -w BEGIN { require './test.pl'; } plan (tests => 9); use strict; { package UTF8Toggle; sub TIESCALAR { my $class = shift; my $value = shift; my $state = shift||0; return bless [$value, $state], $class; } sub FETCH { my $self = shift; $self->[1] = ! $self->[1]; if ($self->[1]) { utf8::downgrade($self->[0]); } else { utf8::upgrade($self->[0]); } $self->[0]; } } foreach my $t ("ASCII", "B\366se") { my $length = length $t; my $u; tie $u, 'UTF8Toggle', $t; is (length $u, $length, "length of '$t'"); is (length $u, $length, "length of '$t'"); is (length $u, $length, "length of '$t'"); is (length $u, $length, "length of '$t'"); } { local $::TODO = "Need more tests!"; fail(); } perl-5.12.0-RC0/t/uni/tr_sjis.t0000555000175000017500000000310011325127002015013 0ustar jessejesse#!perl -w # # $Id$ # # This script is written intentionally in Shift JIS # -- dankogai BEGIN { require Config; import Config; if ($Config{'extensions'} !~ /\bEncode\b/) { print "1..0 # Skip: Encode was not built\n"; exit 0; } if (ord("A") == 193) { print "1..0 # Skip: EBCDIC\n"; exit 0; } unless (PerlIO::Layer->find('perlio')){ print "1..0 # Skip: PerlIO required\n"; exit 0; } if ($ENV{PERL_CORE_MINITEST}) { print "1..0 # Skip: no dynamic loading on miniperl, no Encode\n"; exit 0; } $| = 1; require './test.pl'; } use strict; plan(tests => 6); use encoding 'shiftjis'; my @hiragana = map {chr} ord("‚Ÿ")..ord("‚ñ"); my @katakana = map {chr} ord("ƒ@")..ord("ƒ“"); my $hiragana = join('' => @hiragana); my $katakana = join('' => @katakana); my %h2k; @h2k{@hiragana} = @katakana; my %k2h; @k2h{@katakana} = @hiragana; # print @hiragana, "\n"; my $str; $str = $hiragana; $str =~ tr/‚Ÿ-‚ñ/ƒ@-ƒ“/; is($str, $katakana, "tr// # hiragana -> katakana"); $str = $katakana; $str =~ tr/ƒ@-ƒ“/‚Ÿ-‚ñ/; is($str, $hiragana, "tr// # hiragana -> katakana"); $str = $hiragana; eval qq(\$str =~ tr/‚Ÿ-‚ñ/ƒ@-ƒ“/); is($str, $katakana, "eval qq(tr//) # hiragana -> katakana"); $str = $katakana; eval qq(\$str =~ tr/ƒ@-ƒ“/‚Ÿ-‚ñ/); is($str, $hiragana, "eval qq(tr//) # hiragana -> katakana"); $str = $hiragana; $str =~ s/([‚Ÿ-‚ñ])/$h2k{$1}/go; is($str, $katakana, "s/// # hiragana -> katakana"); $str = $katakana; $str =~ s/([ƒ@-ƒ“])/$k2h{$1}/go; is($str, $hiragana, "s/// # hiragana -> katakana"); __END__ perl-5.12.0-RC0/t/uni/case.pl0000444000175000017500000001010611325125742014433 0ustar jessejesseuse File::Spec; require "test.pl"; sub unidump { join " ", map { sprintf "%04X", $_ } unpack "U*", $_[0]; } sub casetest { my ($base, $spec, @funcs) = @_; # For each provided function run it, and run a version with some extra # characters afterwards. Use a recycling symbol, as it doesn't change case. my $ballast = chr (0x2672) x 3; @funcs = map {my $f = $_; ($f, sub {my $r = $f->($_[0] . $ballast); # Add it before $r =~ s/$ballast\z//so # Remove it afterwards or die "'$_[0]' to '$r' mangled"; $r; # Result with $ballast removed. }, )} @funcs; my $file = File::Spec->catfile(File::Spec->catdir(File::Spec->updir, "lib", "unicore", "To"), "$base.pl"); my $simple = do $file or die $@; my %simple; for my $i (split(/\n/, $simple)) { my ($k, $v) = split(' ', $i); $simple{$k} = $v; } my %seen; for my $i (sort keys %simple) { $seen{$i}++; } print "# ", scalar keys %simple, " simple mappings\n"; my $both; for my $i (sort keys %$spec) { if (++$seen{$i} == 2) { warn sprintf "$base: $i seen twice\n"; $both++; } } print "# ", scalar keys %$spec, " special mappings\n"; exit(1) if $both; my %none; for my $i (map { ord } split //, "\e !\"#\$%&'()+,-./0123456789:;<=>?\@[\\]^_{|}~\b") { next if pack("U0U", $i) =~ /\w/; $none{$i}++ unless $seen{$i}; } print "# ", scalar keys %none, " noncase mappings\n"; my $tests = ((scalar keys %simple) + (scalar keys %$spec) + (scalar keys %none)) * @funcs; print "1..$tests\n"; my $test = 1; for my $i (sort keys %simple) { my $w = $simple{$i}; my $c = pack "U0U", hex $i; foreach my $func (@funcs) { my $d = $func->($c); my $e = unidump($d); print $d eq pack("U0U", hex $simple{$i}) ? "ok $test # $i -> $w\n" : "not ok $test # $i -> $e ($w)\n"; $test++; } } for my $i (sort keys %$spec) { my $w = unidump($spec->{$i}); if (ord('A') == 193 && $i eq "\x8A\x73") { $w = '0178'; # It's a Latin small Y with diaeresis and not a Latin small letter sharp 's'. } my $u = unpack "C0U", $i; my $h = sprintf "%04X", $u; my $c = chr($u); $c .= chr(0x100); chop $c; foreach my $func (@funcs) { my $d = $func->($c); my $e = unidump($d); if (ord "A" == 193) { # EBCDIC # We need to a little bit of remapping. # # For example, in titlecase (ucfirst) mapping # of U+0149 the Unicode mapping is U+02BC U+004E. # The 4E is N, which in EBCDIC is 2B-- # and the ucfirst() does that right. # The problem is that our reference # data is in Unicode code points. # # The Right Way here would be to use, say, # Encode, to remap the less-than 0x100 code points, # but let's try to be Encode-independent here. # # These are the titlecase exceptions: # # Unicode Unicode+EBCDIC # # 0149 -> 02BC 004E (02BC 002B) # 01F0 -> 004A 030C (00A2 030C) # 1E96 -> 0048 0331 (00E7 0331) # 1E97 -> 0054 0308 (00E8 0308) # 1E98 -> 0057 030A (00EF 030A) # 1E99 -> 0059 030A (00DF 030A) # 1E9A -> 0041 02BE (00A0 02BE) # # The uppercase exceptions are identical. # # The lowercase has one more: # # Unicode Unicode+EBCDIC # # 0130 -> 0069 0307 (00D1 0307) # if ($h =~ /^(0130|0149|01F0|1E96|1E97|1E98|1E99|1E9A)$/) { $e =~ s/004E/002B/; # N $e =~ s/004A/00A2/; # J $e =~ s/0048/00E7/; # H $e =~ s/0054/00E8/; # T $e =~ s/0057/00EF/; # W $e =~ s/0059/00DF/; # Y $e =~ s/0041/00A0/; # A $e =~ s/0069/00D1/; # i } # We have to map the output, not the input, because # pack/unpack U has been EBCDICified, too, it would # just undo our remapping. } print $w eq $e ? "ok $test # $i -> $w\n" : "not ok $test # $h -> $e ($w)\n"; $test++; } } for my $i (sort { $a <=> $b } keys %none) { my $w = $i = sprintf "%04X", $i; my $c = pack "U0U", hex $i; foreach my $func (@funcs) { my $d = $func->($c); my $e = unidump($d); print $d eq $c ? "ok $test # $i -> $w\n" : "not ok $test # $i -> $e ($w)\n"; $test++; } } } 1; perl-5.12.0-RC0/t/uni/lex_utf8.t0000555000175000017500000000325711325127002015111 0ustar jessejesse#!./perl -w # # This script is written intentionally in UTF-8 BEGIN { if (ord("A") == 193) { print "1..0 # Skip: EBCDIC\n"; exit 0; } $| = 1; require './test.pl'; } use strict; plan (tests => 10); use charnames ':full'; use utf8; my $A_with_ogonek = "Ä„"; my $micro_sign = "µ"; my $hex_first = "a\x{A2}Ä„"; my $hex_last = "aÄ„\x{A2}"; my $name_first = "b\N{MICRO SIGN}Æ"; my $name_last = "bÆ\N{MICRO SIGN}"; my $uname_first = "b\N{U+00B5}Æ"; my $uname_last = "bÆ\N{U+00B5}"; my $octal_first = "c\377Ć"; my $octal_last = "cĆ\377"; do { use bytes; is((join "", unpack("C*", $A_with_ogonek)), "196" . "132", 'single char above 0x100'); is((join "", unpack("C*", $micro_sign)), "194" . "181", 'single char in 0x80 .. 0xFF'); is((join "", unpack("C*", $hex_first)), "97" . "194" . "162" . "196" . "132", 'a . \x{A2} . char above 0x100'); is((join "", unpack("C*", $hex_last)), "97" . "196" . "132" . "194" . "162", 'a . char above 0x100 . \x{A2}'); is((join "", unpack("C*", $name_first)), "98" . "194" . "181" . "198" . "129", 'b . \N{MICRO SIGN} . char above 0x100'); is((join "", unpack("C*", $name_last)), "98" . "198" . "129" . "194" . "181", 'b . char above 0x100 . \N{MICRO SIGN}'); is((join "", unpack("C*", $uname_first)), "98" . "194" . "181" . "198" . "129", 'b . \N{U+00B5} . char above 0x100'); is((join "", unpack("C*", $uname_last)), "98" . "198" . "129" . "194" . "181", 'b . char above 0x100 . \N{U+00B5}'); is((join "", unpack("C*", $octal_first)), "99" . "195" . "191" . "196" . "134", 'c . \377 . char above 0x100'); is((join "", unpack("C*", $octal_last)), "99" . "196" . "134" . "195" . "191", 'c . char above 0x100 . \377'); } __END__ perl-5.12.0-RC0/t/uni/tr_7jis.t0000555000175000017500000000337711325127002014737 0ustar jessejesse#! perl -w # # $Id$ # # This script is written intentionally in ISO-2022-JP # requires Encode 1.83 or better to work # -- dankogai BEGIN { require Config; import Config; if ($Config{'extensions'} !~ /\bEncode\b/) { print "1..0 # Skip: Encode was not built\n"; exit 0; } if (ord("A") == 193) { print "1..0 # Skip: EBCDIC\n"; exit 0; } unless (PerlIO::Layer->find('perlio')){ print "1..0 # Skip: PerlIO required\n"; exit 0; } if ($ENV{PERL_CORE_MINITEST}) { print "1..0 # Skip: no dynamic loading on miniperl, no Encode\n"; exit 0; } $| = 1; require './test.pl'; } use strict; plan(tests => 6); use encoding 'iso-2022-jp'; my @hiragana = map {chr} ord("$B$!(B")..ord("$B$s(B"); my @katakana = map {chr} ord("$B%!(B")..ord("$B%s(B"); my $hiragana = join('' => @hiragana); my $katakana = join('' => @katakana); my %h2k; @h2k{@hiragana} = @katakana; my %k2h; @k2h{@katakana} = @hiragana; # print @hiragana, "\n"; my $str; $str = $hiragana; $str =~ tr/$B$!(B-$B$s(B/$B%!(B-$B%s(B/; is($str, $katakana, "tr// # hiragana -> katakana"); $str = $katakana; $str =~ tr/$B%!(B-$B%s(B/$B$!(B-$B$s(B/; is($str, $hiragana, "tr// # hiragana -> katakana"); $str = $hiragana; eval qq(\$str =~ tr/$B$!(B-$B$s(B/$B%!(B-$B%s(B/); is($str, $katakana, "eval qq(tr//) # hiragana -> katakana"); $str = $katakana; eval qq(\$str =~ tr/$B%!(B-$B%s(B/$B$!(B-$B$s(B/); is($str, $hiragana, "eval qq(tr//) # hiragana -> katakana"); $str = $hiragana; $str =~ s/([$B$!(B-$B$s(B])/$h2k{$1}/go; is($str, $katakana, "s/// # hiragana -> katakana"); $str = $katakana; $str =~ s/([$B%!(B-$B%s(B])/$k2h{$1}/go; is($str, $hiragana, "s/// # hiragana -> katakana"); __END__ perl-5.12.0-RC0/t/uni/greek.t0000555000175000017500000001107711325125742014460 0ustar jessejesseBEGIN { if ($ENV{'PERL_CORE'}){ chdir 't'; @INC = '../lib'; } require Config; import Config; if ($Config{'extensions'} !~ /\bEncode\b/) { print "1..0 # Skip: Encode was not built\n"; exit 0; } if (ord("A") == 193) { print "1..0 # Skip: EBCDIC\n"; exit 0; } unless (PerlIO::Layer->find('perlio')){ print "1..0 # Skip: PerlIO required\n"; exit 0; } if ($ENV{PERL_CORE_MINITEST}) { print "1..0 # Skip: no dynamic loading on miniperl, no Encode\n"; exit 0; } $| = 1; require './test.pl'; } plan tests => 72; use encoding "greek"; # iso 8859-7 # U+0391, \xC1, \301, GREEK CAPITAL LETTER ALPHA # U+03B1, \xE1, \341, GREEK SMALL LETTER ALPHA ok("\xC1" =~ /\xC1/, '\xC1 to /\xC1/'); ok("\x{391}" =~ /\xC1/, '\x{391} to /\xC1/'); ok("\xC1" =~ /\x{C1}/, '\xC1 to /\x{C1}/'); ok("\x{391}" =~ /\x{C1}/, '\x{391} to /\x{C1}/'); ok("\xC1" =~ /\301/, '\xC1 to /\301/'); ok("\x{391}" =~ /\301/, '\x{391} to /\301/'); ok("\xC1" =~ /\x{391}/, '\xC1 to /\x{391}/'); ok("\x{391}" =~ /\x{391}/, '\x{391} to /\x{391}/'); ok("\xC1" =~ /\xC1/i, '\xC1 to /\xC1/i'); ok("\xE1" =~ /\xC1/i, '\xE1 to /\xC1/i'); ok("\xC1" =~ /\xE1/i, '\xC1 to /\xE1/i'); ok("\xE1" =~ /\xE1/i, '\xE1 to /\xE1/i'); ok("\xC1" =~ /\x{391}/i, '\xC1 to /\x{391}/i'); ok("\xE1" =~ /\x{391}/i, '\xE1 to /\x{391}/i'); ok("\xC1" =~ /\x{3B1}/i, '\xC1 to /\x{3B1}/i'); ok("\xE1" =~ /\x{3B1}/i, '\xE1 to /\x{3B1}/i'); ok("\xC1" =~ /[\xC1]/, '\xC1 to /[\xC1]/'); ok("\x{391}" =~ /[\xC1]/, '\x{391} to /[\xC1]/'); ok("\xC1" =~ /[\x{C1}]/, '\xC1 to /[\x{C1}]/'); ok("\x{391}" =~ /[\x{C1}]/, '\x{391} to /[\x{C1}]/'); ok("\xC1" =~ /[\301]/, '\xC1 to /[\301]/'); ok("\x{391}" =~ /[\301]/, '\x{391} to /[\301]/'); ok("\xC1" =~ /[\x{391}]/, '\xC1 to /[\x{391}]/'); ok("\x{391}" =~ /[\x{391}]/, '\x{391} to /[\x{391}]/'); ok("\xC1" =~ /[\xC1]/i, '\xC1 to /[\xC1]/i'); ok("\xE1" =~ /[\xC1]/i, '\xE1 to /[\xC1]/i'); ok("\xC1" =~ /[\xE1]/i, '\xC1 to /[\xE1]/i'); ok("\xE1" =~ /[\xE1]/i, '\xE1 to /[\xE1]/i'); ok("\xC1" =~ /[\x{391}]/i, '\xC1 to /[\x{391}]/i'); ok("\xE1" =~ /[\x{391}]/i, '\xE1 to /[\x{391}]/i'); ok("\xC1" =~ /[\x{3B1}]/i, '\xC1 to /[\x{3B1}]/i'); ok("\xE1" =~ /[\x{3B1}]/i, '\xE1 to /[\x{3B1}]/i'); ok("\xC1" =~ '\xC1', '\xC1 to \'\xC1\''); ok("\xC1" =~ '\x{C1}', '\xC1 to \'\x{C1}\''); ok("\xC1" =~ '\301', '\xC1 to \'\301\''); ok("\xC1" =~ '\x{391}', '\xC1 to \'\x{391}\''); ok("\xC1" =~ '[\xC1]', '\xC1 to \'[\xC1]\''); ok("\xC1" =~ '[\x{C1}]', '\xC1 to \'[\x{C1}]\''); ok("\xC1" =~ '[\301]', '\xC1 to \'[\301]\''); ok("\xC1" =~ '[\x{391}]', '\xC1 to \'[\x{391}]\''); ok("\xC1" =~ /Á/, '\xC1 to //'); ok("\xE1" !~ /Á/, '\xE1 to //'); ok("\xC1" =~ /Á/i, '\xC1 to //i'); ok("\xE1" =~ /Á/i, '\xE1 to //i'); ok("\xC1" =~ /[Á]/, '\xC1 to /[]/'); ok("\xE1" !~ /[Á]/, '\xE1 to /[]/'); ok("\xC1" =~ /[Á]/i, '\xC1 to /[]/i'); ok("\xE1" =~ /[Á]/i, '\xE1 to /[]/i'); ok("\xC1\xC1" =~ /Á\xC1/, '\xC1\xC1 to /\xC1/'); ok("\xC1\xC1" =~ /\xC1Á/, '\xC1\xC1 to /\xC1/'); ok("\xC1\xC1" =~ /Á\xC1/i, '\xC1\xC1 to /\xC1/i'); ok("\xC1\xC1" =~ /\xC1Á/i, '\xC1\xC1 to /\xC1/i'); ok("\xC1\xE1" =~ /Á\xC1/i, '\xC1\xE1 to /\xC1/i'); ok("\xC1\xE1" =~ /\xC1Á/i, '\xC1\xE1 to /\xC1/i'); ok("\xE1\xE1" =~ /Á\xC1/i, '\xE1\xE1 to /\xC1/i'); ok("\xE1\xE1" =~ /\xC1Á/i, '\xE1\xE1 to /\xC1/i'); # U+038A, \xBA, GREEK CAPITAL LETTER IOTA WITH TONOS # U+03AF, \xDF, GREEK SMALL LETTER IOTA WITH TONOS ok("\x{38A}" =~ /\xBA/, '\x{38A} to /\xBA/'); ok("\x{38A}" !~ /\xDF/, '\x{38A} to /\xDF/'); ok("\x{38A}" =~ /\xBA/i, '\x{38A} to /\xBA/i'); ok("\x{38A}" =~ /\xDF/i, '\x{38A} to /\xDF/i'); ok("\x{38A}" =~ /[\xBA]/, '\x{38A} to /[\xBA]/'); ok("\x{38A}" !~ /[\xDF]/, '\x{38A} to /[\xDF]/'); ok("\x{38A}" =~ /[\xBA]/i, '\x{38A} to /[\xBA]/i'); ok("\x{38A}" =~ /[\xDF]/i, '\x{38A} to /[\xDF]/i'); # \xDF is not LATIN SMALL LETTER SHARP S ok("SS" !~ /\xDF/i, 'SS to /\xDF/i'); ok("Ss" !~ /\xDF/i, 'Ss to /\xDF/i'); ok("sS" !~ /\xDF/i, 'sS to /\xDF/i'); ok("ss" !~ /\xDF/i, 'ss to /\xDF/i'); ok("SS" !~ /ß/i, 'SS to //i'); ok("Ss" !~ /ß/i, 'Ss to //i'); ok("sS" !~ /ß/i, 'sS to //i'); ok("ss" !~ /ß/i, 'ss to //i'); perl-5.12.0-RC0/t/uni/upper.t0000555000175000017500000000027111325125742014510 0ustar jessejesseBEGIN { chdir 't' if -d 't'; @INC = qw(../lib uni .); require "case.pl"; } casetest("Upper", \%utf8::ToSpecUpper, sub { uc $_[0] }, sub { my $a = ""; uc ($_[0] . $a) }); perl-5.12.0-RC0/t/uni/fold.t0000555000175000017500000000275011325125742014305 0ustar jessejesseBEGIN { chdir 't' if -d 't'; @INC = '../lib'; } use File::Spec; my $CF = File::Spec->catfile(File::Spec->catdir(File::Spec->updir, "lib", "unicore"), "CaseFolding.txt"); use constant EBCDIC => ord 'A' == 193; if (open(CF, $CF)) { my @CF; while () { # Skip S since we are going for 'F'ull case folding. I is obsolete starting # with Unicode 3.2, but leaving it in does no harm, and allows backward # compatibility if (/^([0-9A-F]+); ([CFI]); ((?:[0-9A-F]+)(?: [0-9A-F]+)*); \# (.+)/) { next if EBCDIC && hex $1 < 0x100; push @CF, [$1, $2, $3, $4]; } } close(CF); die qq[$0: failed to find casefoldings from "$CF"\n] unless @CF; print "1..", scalar @CF, "\n"; my $i = 0; for my $cf (@CF) { my ($code, $status, $mapping, $name) = @$cf; $i++; my $a = pack("U0U*", hex $code); my $b = pack("U0U*", map { hex } split " ", $mapping); my $t0 = ":$a:" =~ /:$a:/ ? 1 : 0; my $t1 = ":$a:" =~ /:$a:/i ? 1 : 0; my $t2 = ":$a:" =~ /:[$a]:/ ? 1 : 0; my $t3 = ":$a:" =~ /:[$a]:/i ? 1 : 0; my $t4 = ":$a:" =~ /:$b:/i ? 1 : 0; my $t5 = ":$a:" =~ /:[$b]:/i ? 1 : 0; my $t6 = ":$b:" =~ /:$a:/i ? 1 : 0; my $t7 = ":$b:" =~ /:[$a]:/i ? 1 : 0; print $t0 && $t1 && $t2 && $t3 && $t4 && $t5 && $t6 && $t7 ? "ok $i \# - $code - $name - $mapping - $status\n" : "not ok $i \# - $code - $name - $mapping - $status - $t0 $t1 $t2 $t3 $t4 $t5 $t6 $t7\n"; } } else { die qq[$0: failed to open "$CF": $!\n]; } perl-5.12.0-RC0/t/uni/class.t0000555000175000017500000000430311325127002014451 0ustar jessejesseBEGIN { chdir 't' if -d 't'; @INC = qw(../lib .); require "test.pl"; } plan tests => 10; sub MyUniClass { <?@ABCDEFGHIJKLMNO'); # make sure it finds class in other package is(($str =~ /(\p{Other::Class}+)/)[0], '@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_'); # make sure it finds class in other OTHER package is(($str =~ /(\p{A::B::Intersection}+)/)[0], '@ABCDEFGHIJKLMNO'); # lib/unicore/Bc/AL.pl $str = "\x{070D}\x{070E}\x{070F}\x{0710}\x{0711}"; is(($str =~ /(\P{BidiClass: ArabicLetter}+)/)[0], "\x{070F}"); is(($str =~ /(\P{BidiClass: AL}+)/)[0], "\x{070F}"); is(($str =~ /(\P{BC :ArabicLetter}+)/)[0], "\x{070F}"); is(($str =~ /(\P{bc=AL}+)/)[0], "\x{070F}"); # make sure InGreek works $str = "[\x{038B}\x{038C}\x{038D}]"; is(($str =~ /(\p{InGreek}+)/)[0], "\x{038B}\x{038C}\x{038D}"); # The other tests that are based on looking at the generated files are now # in t/re/uniprops.t perl-5.12.0-RC0/t/uni/title.t0000555000175000017500000000030311325125742014472 0ustar jessejesseBEGIN { chdir 't' if -d 't'; @INC = qw(../lib uni .); require "case.pl"; } casetest("Title", \%utf8::ToSpecTitle, sub { ucfirst $_[0] }, sub { my $a = ""; ucfirst ($_[0] . $a) }); perl-5.12.0-RC0/t/uni/tr_utf8.t0000555000175000017500000000422111325127002014736 0ustar jessejesse#!perl -w # # $Id$ # # This script is written intentionally in UTF-8 # Requires Encode 1.83 or better # -- dankogai BEGIN { if ($ENV{'PERL_CORE'}){ chdir 't'; @INC = '../lib'; } require Config; import Config; if ($Config{'extensions'} !~ /\bEncode\b/) { print "1..0 # Skip: Encode was not built\n"; exit 0; } if (ord("A") == 193) { print "1..0 # Skip: EBCDIC\n"; exit 0; } unless (PerlIO::Layer->find('perlio')){ print "1..0 # Skip: PerlIO required\n"; exit 0; } if ($ENV{PERL_CORE_MINITEST}) { print "1..0 # Skip: no dynamic loading on miniperl, no Encode\n"; exit 0; } $| = 1; require './test.pl'; } use strict; plan(tests => 8); use encoding 'utf8'; my @hiragana = map {chr} ord("ã")..ord("ã‚“"); my @katakana = map {chr} ord("ã‚¡")..ord("ン"); my $hiragana = join('' => @hiragana); my $katakana = join('' => @katakana); my %h2k; @h2k{@hiragana} = @katakana; my %k2h; @k2h{@katakana} = @hiragana; # print @hiragana, "\n"; my $str; $str = $hiragana; $str =~ tr/ã-ã‚“/ã‚¡-ン/; is($str, $katakana, "tr// # hiragana -> katakana"); $str = $katakana; $str =~ tr/ã‚¡-ン/ã-ã‚“/; is($str, $hiragana, "tr// # hiragana -> katakana"); $str = $hiragana; eval qq(\$str =~ tr/ã-ã‚“/ã‚¡-ン/); is($str, $katakana, "eval qq(tr//) # hiragana -> katakana"); $str = $katakana; eval qq(\$str =~ tr/ã‚¡-ン/ã-ã‚“/); is($str, $hiragana, "eval qq(tr//) # hiragana -> katakana"); $str = $hiragana; $str =~ s/([ã-ã‚“])/$h2k{$1}/go; is($str, $katakana, "s/// # hiragana -> katakana"); $str = $katakana; $str =~ s/([ã‚¡-ン])/$k2h{$1}/go; is($str, $hiragana, "s/// # hiragana -> katakana"); { # [perl 16843] my $line = 'abcdefghijklmnopqrstuvwxyz$0123456789'; $line =~ tr/bcdeghijklmnprstvwxyz$02578/בצדעגהיײקלמנפּרסטװשכיזשױתײח×/; is($line, "aבצדעfגהיײקלמנoפqּרסuטװשכיזש1×±34ת6ײח9", "[perl #16843]"); } { # [perl #40641] my $str = qq/Gebääääääääääääääääääääude/; my $reg = qr/Gebääääääääääääääääääääude/; ok($str =~ /$reg/, "[perl #40641]"); } __END__ perl-5.12.0-RC0/t/uni/write.t0000555000175000017500000000407111143650501014503 0ustar jessejesse#!./perl -w use strict; BEGIN { chdir 't' if -d 't'; @INC = qw(../lib .); require "test.pl"; unless (PerlIO::Layer->find('perlio')){ print "1..0 # Skip: PerlIO required\n"; exit 0; } if (ord("A") == 193) { print "1..0 # Skip: EBCDIC porting needed\n"; exit 0; } } plan tests => 6; # Some tests for UTF8 and format/write our ($bitem1, $uitem1) = ("\x{ff}", "\x{100}"); our ($bitem2, $uitem2) = ("\x{fe}", "\x{101}"); our ($blite1, $ulite1) = ("\x{fd}", "\x{102}"); our ($blite2, $ulite2) = ("\x{fc}", "\x{103}"); our ($bmulti, $umulti) = ("\x{fb}\n\x{fa}\n\x{f9}\n", "\x{104}\n\x{105}\n\x{106}\n"); sub fmwrtest { no strict 'refs'; my ($out, $format, $expect, $name) = @_; eval "format $out =\n$format.\n"; die $@ if $@; open $out, '>:utf8', 'Uni_write.tmp' or die "Can't create Uni_write.tmp"; write $out; close $out or die "Could not close $out: $!"; open UIN, '<:utf8', 'Uni_write.tmp' or die "Can't open Uni_write.tmp";; my $result = do { local $/; ; }; close UIN; is($result, $expect, $name); } fmwrtest OUT1 => < < < < < < 52; $a = "B\x{fc}f"; $b = "G\x{100}r"; $c = 0x200; { my $s = sprintf "%s", $a; is($s, $a, "%s a"); } { my $s = sprintf "%s", $b; is($s, $b, "%s b"); } { my $s = sprintf "%s%s", $a, $b; is($s, $a.$b, "%s%s a b"); } { my $s = sprintf "%s%s", $b, $a; is($s, $b.$a, "%s%s b a"); } { my $s = sprintf "%s%s", $b, $b; is($s, $b.$b, "%s%s b b"); } { my $s = sprintf "%s$b", $a; is($s, $a.$b, "%sb a"); } { my $s = sprintf "$b%s", $a; is($s, $b.$a, "b%s a"); } { my $s = sprintf "%s$a", $b; is($s, $b.$a, "%sa b"); } { my $s = sprintf "$a%s", $b; is($s, $a.$b, "a%s b"); } { my $s = sprintf "$a%s", $a; is($s, $a.$a, "a%s a"); } { my $s = sprintf "$b%s", $b; is($s, $b.$b, "a%s b"); } { my $s = sprintf "%c", $c; is($s, chr($c), "%c c"); } { my $s = sprintf "%s%c", $a, $c; is($s, $a.chr($c), "%s%c a c"); } { my $s = sprintf "%c%s", $c, $a; is($s, chr($c).$a, "%c%s c a"); } { my $s = sprintf "%c$b", $c; is($s, chr($c).$b, "%cb c"); } { my $s = sprintf "%s%c$b", $a, $c; is($s, $a.chr($c).$b, "%s%cb a c"); } { my $s = sprintf "%c%s$b", $c, $a; is($s, chr($c).$a.$b, "%c%sb c a"); } { my $s = sprintf "$b%c", $c; is($s, $b.chr($c), "b%c c"); } { my $s = sprintf "$b%s%c", $a, $c; is($s, $b.$a.chr($c), "b%s%c a c"); } { my $s = sprintf "$b%c%s", $c, $a; is($s, $b.chr($c).$a, "b%c%s c a"); } { # 20010407.008 sprintf removes utf8-ness $a = sprintf "\x{1234}"; is((sprintf "%x %d", unpack("U*", $a), length($a)), "1234 1", '\x{1234}'); $a = sprintf "%s", "\x{5678}"; is((sprintf "%x %d", unpack("U*", $a), length($a)), "5678 1", '%s \x{5678}'); $a = sprintf "\x{1234}%s", "\x{5678}"; is((sprintf "%x %x %d", unpack("U*", $a), length($a)), "1234 5678 2", '\x{1234}%s \x{5678}'); } { # check that utf8ness doesn't "accumulate" my $w = "w\x{fc}"; my $sprintf; $sprintf = sprintf "%s%s", $w, "$w\x{100}"; is(substr($sprintf,0,2), $w, "utf8 echo"); $sprintf = sprintf "%s%s", $w, "$w\x{100}"; is(substr($sprintf,0,2), $w, "utf8 echo echo"); } my @values =(chr 110, chr 255, chr 256); foreach my $prefix (@values) { foreach my $vector (map {$_ . $_} @values) { my $format = "$prefix%*vd"; foreach my $dot (@values) { my $result = sprintf $format, $dot, $vector; is (length $result, 8) or print "# ", join (',', map {ord $_} $prefix, $dot, $vector), "\n"; } } } perl-5.12.0-RC0/t/uni/chomp.t0000555000175000017500000000441711325127002014460 0ustar jessejesse#!./perl -w BEGIN { require Config; import Config; if ($Config{'extensions'} !~ /\bEncode\b/) { print "1..0 # Skip: Encode was not built\n"; exit 0; } if (ord("A") == 193) { print "1..0 # Skip: EBCDIC\n"; exit 0; } unless (PerlIO::Layer->find('perlio')){ print "1..0 # Skip: PerlIO required\n"; exit 0; } if ($ENV{PERL_CORE_MINITEST}) { print "1..0 # Skip: no dynamic loading on miniperl, no Encode\n"; exit 0; } require './test.pl'; } use strict; use Encode; # %mbchars = (encoding => { bytes => utf8, ... }, ...); # * pack('C*') is expected to return bytes even if ${^ENCODING} is true. our %mbchars = ( 'big-5' => { pack('C*', 0x40) => pack('U*', 0x40), # COMMERCIAL AT pack('C*', 0xA4, 0x40) => "\x{4E00}", # CJK-4E00 }, 'euc-jp' => { pack('C*', 0xB0, 0xA1) => "\x{4E9C}", # CJK-4E9C pack('C*', 0x8F, 0xB0, 0xA1) => "\x{4E02}", # CJK-4E02 }, 'shift-jis' => { pack('C*', 0xA9) => "\x{FF69}", # halfwidth katakana small U pack('C*', 0x82, 0xA9) => "\x{304B}", # hiragana KA }, ); # 4 == @char; paired tests inside 3 nested loops, # plus extra pair of tests in a loop, plus extra pair of tests. plan tests => 2 * (4 ** 3 + 4 + 1) * (keys %mbchars); for my $enc (sort keys %mbchars) { local ${^ENCODING} = find_encoding($enc); my @char = (sort(keys %{ $mbchars{$enc} }), sort(values %{ $mbchars{$enc} })); for my $rs (@char) { local $/ = $rs; for my $start (@char) { for my $end (@char) { my $string = $start.$end; my ($expect, $return); if ($end eq $rs) { $expect = $start; # The answer will always be a length in utf8, even if the # scalar was encoded with a different length $return = length ($end . "\x{100}") - 1; } else { $expect = $string; $return = 0; } is (chomp ($string), $return); is ($string, $expect); # "$enc \$/=$rs $start $end" } } # chomp should not stringify references unless it decides to modify # them $_ = []; my $got = chomp(); is ($got, 0); is (ref($_), "ARRAY", "chomp ref (no modify)"); } $/ = ")"; # the last char of something like "ARRAY(0x80ff6e4)" my $got = chomp(); is ($got, 1); ok (!ref($_), "chomp ref (modify)"); } perl-5.12.0-RC0/t/test.pl0000555000175000017500000006316511344764022013725 0ustar jessejesse# # t/test.pl - most of Test::More functionality without the fuss # NOTE: # # Increment ($x++) has a certain amount of cleverness for things like # # $x = 'zz'; # $x++; # $x eq 'aaa'; # # stands more chance of breaking than just a simple # # $x = $x + 1 # # In this file, we use the latter "Baby Perl" approach, and increment # will be worked over by t/op/inc.t $Level = 1; my $test = 1; my $planned; my $noplan; my $Perl; # Safer version of $^X set by which_perl() $TODO = 0; $NO_ENDING = 0; # Use this instead of print to avoid interference while testing globals. sub _print { local($\, $", $,) = (undef, ' ', ''); print STDOUT @_; } sub _print_stderr { local($\, $", $,) = (undef, ' ', ''); print STDERR @_; } sub plan { my $n; if (@_ == 1) { $n = shift; if ($n eq 'no_plan') { undef $n; $noplan = 1; } } else { my %plan = @_; $n = $plan{tests}; } _print "1..$n\n" unless $noplan; $planned = $n; } END { my $ran = $test - 1; if (!$NO_ENDING) { if (defined $planned && $planned != $ran) { _print_stderr "# Looks like you planned $planned tests but ran $ran.\n"; } elsif ($noplan) { _print "1..$ran\n"; } } } # Use this instead of "print STDERR" when outputing failure diagnostic # messages sub _diag { return unless @_; my @mess = map { /^#/ ? "$_\n" : "# $_\n" } map { split /\n/ } @_; $TODO ? _print(@mess) : _print_stderr(@mess); } sub diag { _diag(@_); } sub skip_all { if (@_) { _print "1..0 # Skip @_\n"; } else { _print "1..0\n"; } exit(0); } sub _ok { my ($pass, $where, $name, @mess) = @_; # Do not try to microoptimize by factoring out the "not ". # VMS will avenge. my $out; if ($name) { # escape out '#' or it will interfere with '# skip' and such $name =~ s/#/\\#/g; $out = $pass ? "ok $test - $name" : "not ok $test - $name"; } else { $out = $pass ? "ok $test" : "not ok $test"; } $out = $out . " # TODO $TODO" if $TODO; _print "$out\n"; unless ($pass) { _diag "# Failed $where\n"; } # Ensure that the message is properly escaped. _diag @mess; $test = $test + 1; # don't use ++ return $pass; } sub _where { my @caller = caller($Level); return "at $caller[1] line $caller[2]"; } # DON'T use this for matches. Use like() instead. sub ok ($@) { my ($pass, $name, @mess) = @_; _ok($pass, _where(), $name, @mess); } sub _q { my $x = shift; return 'undef' unless defined $x; my $q = $x; $q =~ s/\\/\\\\/g; $q =~ s/'/\\'/g; return "'$q'"; } sub _qq { my $x = shift; return defined $x ? '"' . display ($x) . '"' : 'undef'; }; # keys are the codes \n etc map to, values are 2 char strings such as \n my %backslash_escape; foreach my $x (split //, 'nrtfa\\\'"') { $backslash_escape{ord eval "\"\\$x\""} = "\\$x"; } # A way to display scalars containing control characters and Unicode. # Trying to avoid setting $_, or relying on local $_ to work. sub display { my @result; foreach my $x (@_) { if (defined $x and not ref $x) { my $y = ''; foreach my $c (unpack("U*", $x)) { if ($c > 255) { $y = $y . sprintf "\\x{%x}", $c; } elsif ($backslash_escape{$c}) { $y = $y . $backslash_escape{$c}; } else { my $z = chr $c; # Maybe we can get away with a literal... if ($z =~ /[[:^print:]]/) { # Use octal for characters traditionally expressed as # such: the low controls if ($c <= 037) { $z = sprintf "\\%03o", $c; } else { $z = sprintf "\\x{%x}", $c; } } $y = $y . $z; } } $x = $y; } return $x unless wantarray; push @result, $x; } return @result; } sub is ($$@) { my ($got, $expected, $name, @mess) = @_; my $pass; if( !defined $got || !defined $expected ) { # undef only matches undef $pass = !defined $got && !defined $expected; } else { $pass = $got eq $expected; } unless ($pass) { unshift(@mess, "# got "._qq($got)."\n", "# expected "._qq($expected)."\n"); } _ok($pass, _where(), $name, @mess); } sub isnt ($$@) { my ($got, $isnt, $name, @mess) = @_; my $pass; if( !defined $got || !defined $isnt ) { # undef only matches undef $pass = defined $got || defined $isnt; } else { $pass = $got ne $isnt; } unless( $pass ) { unshift(@mess, "# it should not be "._qq($got)."\n", "# but it is.\n"); } _ok($pass, _where(), $name, @mess); } sub cmp_ok ($$$@) { my($got, $type, $expected, $name, @mess) = @_; my $pass; { local $^W = 0; local($@,$!); # don't interfere with $@ # eval() sometimes resets $! $pass = eval "\$got $type \$expected"; } unless ($pass) { # It seems Irix long doubles can have 2147483648 and 2147483648 # that stringify to the same thing but are acutally numerically # different. Display the numbers if $type isn't a string operator, # and the numbers are stringwise the same. # (all string operators have alphabetic names, so tr/a-z// is true) # This will also show numbers for some uneeded cases, but will # definately be helpful for things such as == and <= that fail if ($got eq $expected and $type !~ tr/a-z//) { unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n"; } unshift(@mess, "# got "._qq($got)."\n", "# expected $type "._qq($expected)."\n"); } _ok($pass, _where(), $name, @mess); } # Check that $got is within $range of $expected # if $range is 0, then check it's exact # else if $expected is 0, then $range is an absolute value # otherwise $range is a fractional error. # Here $range must be numeric, >= 0 # Non numeric ranges might be a useful future extension. (eg %) sub within ($$$@) { my ($got, $expected, $range, $name, @mess) = @_; my $pass; if (!defined $got or !defined $expected or !defined $range) { # This is a fail, but doesn't need extra diagnostics } elsif ($got !~ tr/0-9// or $expected !~ tr/0-9// or $range !~ tr/0-9//) { # This is a fail unshift @mess, "# got, expected and range must be numeric\n"; } elsif ($range < 0) { # This is also a fail unshift @mess, "# range must not be negative\n"; } elsif ($range == 0) { # Within 0 is == $pass = $got == $expected; } elsif ($expected == 0) { # If expected is 0, treat range as absolute $pass = ($got <= $range) && ($got >= - $range); } else { my $diff = $got - $expected; $pass = abs ($diff / $expected) < $range; } unless ($pass) { if ($got eq $expected) { unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n"; } unshift@mess, "# got "._qq($got)."\n", "# expected "._qq($expected)." (within "._qq($range).")\n"; } _ok($pass, _where(), $name, @mess); } # Note: this isn't quite as fancy as Test::More::like(). sub like ($$@) { like_yn (0,@_) }; # 0 for - sub unlike ($$@) { like_yn (1,@_) }; # 1 for un- sub like_yn ($$$@) { my ($flip, $got, $expected, $name, @mess) = @_; my $pass; $pass = $got =~ /$expected/ if !$flip; $pass = $got !~ /$expected/ if $flip; unless ($pass) { unshift(@mess, "# got '$got'\n", $flip ? "# expected !~ /$expected/\n" : "# expected /$expected/\n"); } local $Level = $Level + 1; _ok($pass, _where(), $name, @mess); } sub pass { _ok(1, '', @_); } sub fail { _ok(0, _where(), @_); } sub curr_test { $test = shift if @_; return $test; } sub next_test { my $retval = $test; $test = $test + 1; # don't use ++ $retval; } # Note: can't pass multipart messages since we try to # be compatible with Test::More::skip(). sub skip { my $why = shift; my $n = @_ ? shift : 1; for (1..$n) { _print "ok $test # skip $why\n"; $test = $test + 1; } local $^W = 0; last SKIP; } sub todo_skip { my $why = shift; my $n = @_ ? shift : 1; for (1..$n) { _print "not ok $test # TODO & SKIP $why\n"; $test = $test + 1; } local $^W = 0; last TODO; } sub eq_array { my ($ra, $rb) = @_; return 0 unless $#$ra == $#$rb; for my $i (0..$#$ra) { next if !defined $ra->[$i] && !defined $rb->[$i]; return 0 if !defined $ra->[$i]; return 0 if !defined $rb->[$i]; return 0 unless $ra->[$i] eq $rb->[$i]; } return 1; } sub eq_hash { my ($orig, $suspect) = @_; my $fail; while (my ($key, $value) = each %$suspect) { # Force a hash recompute if this perl's internals can cache the hash key. $key = "" . $key; if (exists $orig->{$key}) { if ($orig->{$key} ne $value) { _print "# key ", _qq($key), " was ", _qq($orig->{$key}), " now ", _qq($value), "\n"; $fail = 1; } } else { _print "# key ", _qq($key), " is ", _qq($value), ", not in original.\n"; $fail = 1; } } foreach (keys %$orig) { # Force a hash recompute if this perl's internals can cache the hash key. $_ = "" . $_; next if (exists $suspect->{$_}); _print "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n"; $fail = 1; } !$fail; } sub require_ok ($) { my ($require) = @_; eval < [ command-line switches ] # nolib => 1 # don't use -I../lib (included by default) # prog => one-liner (avoid quotes) # progs => [ multi-liner (avoid quotes) ] # progfile => perl script # stdin => string to feed the stdin # stderr => redirect stderr to stdout # args => [ command-line arguments to the perl program ] # verbose => print the command line my $is_mswin = $^O eq 'MSWin32'; my $is_netware = $^O eq 'NetWare'; my $is_vms = $^O eq 'VMS'; my $is_cygwin = $^O eq 'cygwin'; sub _quote_args { my ($runperl, $args) = @_; foreach (@$args) { # In VMS protect with doublequotes because otherwise # DCL will lowercase -- unless already doublequoted. $_ = q(").$_.q(") if $is_vms && !/^\"/ && length($_) > 0; $runperl = $runperl . ' ' . $_; } return $runperl; } sub _create_runperl { # Create the string to qx in runperl(). my %args = @_; my $runperl = which_perl(); if ($runperl =~ m/\s/) { $runperl = qq{"$runperl"}; } #- this allows, for example, to set PERL_RUNPERL_DEBUG=/usr/bin/valgrind if ($ENV{PERL_RUNPERL_DEBUG}) { $runperl = "$ENV{PERL_RUNPERL_DEBUG} $runperl"; } unless ($args{nolib}) { $runperl = $runperl . ' "-I../lib"'; # doublequotes because of VMS } if ($args{switches}) { local $Level = 2; die "test.pl:runperl(): 'switches' must be an ARRAYREF " . _where() unless ref $args{switches} eq "ARRAY"; $runperl = _quote_args($runperl, $args{switches}); } if (defined $args{prog}) { die "test.pl:runperl(): both 'prog' and 'progs' cannot be used " . _where() if defined $args{progs}; $args{progs} = [$args{prog}] } if (defined $args{progs}) { die "test.pl:runperl(): 'progs' must be an ARRAYREF " . _where() unless ref $args{progs} eq "ARRAY"; foreach my $prog (@{$args{progs}}) { if ($is_mswin || $is_netware || $is_vms) { $runperl = $runperl . qq ( -e "$prog" ); } else { $runperl = $runperl . qq ( -e '$prog' ); } } } elsif (defined $args{progfile}) { $runperl = $runperl . qq( "$args{progfile}"); } else { # You probaby didn't want to be sucking in from the upstream stdin die "test.pl:runperl(): none of prog, progs, progfile, args, " . " switches or stdin specified" unless defined $args{args} or defined $args{switches} or defined $args{stdin}; } if (defined $args{stdin}) { # so we don't try to put literal newlines and crs onto the # command line. $args{stdin} =~ s/\n/\\n/g; $args{stdin} =~ s/\r/\\r/g; if ($is_mswin || $is_netware || $is_vms) { $runperl = qq{$Perl -e "print qq(} . $args{stdin} . q{)" | } . $runperl; } else { $runperl = qq{$Perl -e 'print qq(} . $args{stdin} . q{)' | } . $runperl; } } if (defined $args{args}) { $runperl = _quote_args($runperl, $args{args}); } $runperl = $runperl . ' 2>&1' if $args{stderr}; if ($args{verbose}) { my $runperldisplay = $runperl; $runperldisplay =~ s/\n/\n\#/g; _print_stderr "# $runperldisplay\n"; } return $runperl; } sub runperl { die "test.pl:runperl() does not take a hashref" if ref $_[0] and ref $_[0] eq 'HASH'; my $runperl = &_create_runperl; my $result; my $tainted = ${^TAINT}; my %args = @_; exists $args{switches} && grep m/^-T$/, @{$args{switches}} and $tainted = $tainted + 1; if ($tainted) { # We will assume that if you're running under -T, you really mean to # run a fresh perl, so we'll brute force launder everything for you my $sep; if (! eval 'require Config; 1') { warn "test.pl had problems loading Config: $@"; $sep = ':'; } else { $sep = $Config::Config{path_sep}; } my @keys = grep {exists $ENV{$_}} qw(CDPATH IFS ENV BASH_ENV); local @ENV{@keys} = (); # Untaint, plus take out . and empty string: local $ENV{'DCL$PATH'} = $1 if $is_vms && exists($ENV{'DCL$PATH'}) && ($ENV{'DCL$PATH'} =~ /(.*)/s); $ENV{PATH} =~ /(.*)/s; local $ENV{PATH} = join $sep, grep { $_ ne "" and $_ ne "." and -d $_ and ($is_mswin or $is_vms or !(stat && (stat _)[2]&0022)) } split quotemeta ($sep), $1; $ENV{PATH} = $ENV{PATH} . "$sep/bin" if $is_cygwin; # Must have /bin under Cygwin $runperl =~ /(.*)/s; $runperl = $1; $result = `$runperl`; } else { $result = `$runperl`; } $result =~ s/\n\n/\n/ if $is_vms; # XXX pipes sometimes double these return $result; } *run_perl = \&runperl; # Nice alias. sub DIE { _print_stderr "# @_\n"; exit 1; } # A somewhat safer version of the sometimes wrong $^X. sub which_perl { unless (defined $Perl) { $Perl = $^X; # VMS should have 'perl' aliased properly return $Perl if $^O eq 'VMS'; my $exe; if (! eval 'require Config; 1') { warn "test.pl had problems loading Config: $@"; $exe = ''; } else { $exe = $Config::Config{_exe}; } $exe = '' unless defined $exe; # This doesn't absolutize the path: beware of future chdirs(). # We could do File::Spec->abs2rel() but that does getcwd()s, # which is a bit heavyweight to do here. if ($Perl =~ /^perl\Q$exe\E$/i) { my $perl = "perl$exe"; if (! eval 'require File::Spec; 1') { warn "test.pl had problems loading File::Spec: $@"; $Perl = "./$perl"; } else { $Perl = File::Spec->catfile(File::Spec->curdir(), $perl); } } # Build up the name of the executable file from the name of # the command. if ($Perl !~ /\Q$exe\E$/i) { $Perl = $Perl . $exe; } warn "which_perl: cannot find $Perl from $^X" unless -f $Perl; # For subcommands to use. $ENV{PERLEXE} = $Perl; } return $Perl; } sub unlink_all { foreach my $file (@_) { 1 while unlink $file; _print_stderr "# Couldn't unlink '$file': $!\n" if -f $file; } } my %tmpfiles; END { unlink_all keys %tmpfiles } # A regexp that matches the tempfile names $::tempfile_regexp = 'tmp\d+[A-Z][A-Z]?'; # Avoid ++, avoid ranges, avoid split // my @letters = qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z); sub tempfile { my $count = 0; do { my $temp = $count; my $try = "tmp$$"; do { $try = $try . $letters[$temp % 26]; $temp = int ($temp / 26); } while $temp; # Need to note all the file names we allocated, as a second request may # come before the first is created. if (!-e $try && !$tmpfiles{$try}) { # We have a winner $tmpfiles{$try} = 1; return $try; } $count = $count + 1; } while $count < 26 * 26; die "Can't find temporary file name starting 'tmp$$'"; } # This is the temporary file for _fresh_perl my $tmpfile = tempfile(); # # _fresh_perl # # The $resolve must be a subref that tests the first argument # for success, or returns the definition of success (e.g. the # expected scalar) if given no arguments. # sub _fresh_perl { my($prog, $resolve, $runperl_args, $name) = @_; # Given the choice of the mis-parsable {} # (we want an anon hash, but a borked lexer might think that it's a block) # or relying on taking a reference to a lexical # (\ might be mis-parsed, and the reference counting on the pad may go # awry) # it feels like the least-worse thing is to assume that auto-vivification # works. At least, this is only going to be a run-time failure, so won't # affect tests using this file but not this function. $runperl_args->{progfile} = $tmpfile; $runperl_args->{stderr} = 1; open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!"; # VMS adjustments if( $^O eq 'VMS' ) { $prog =~ s#/dev/null#NL:#; # VMS file locking $prog =~ s{if \(-e _ and -f _ and -r _\)} {if (-e _ and -f _)} } print TEST $prog; close TEST or die "Cannot close $tmpfile: $!"; my $results = runperl(%$runperl_args); my $status = $?; # Clean up the results into something a bit more predictable. $results =~ s/\n+$//; $results =~ s/at\s+$::tempfile_regexp\s+line/at - line/g; $results =~ s/of\s+$::tempfile_regexp\s+aborted/of - aborted/g; # bison says 'parse error' instead of 'syntax error', # various yaccs may or may not capitalize 'syntax'. $results =~ s/^(syntax|parse) error/syntax error/mig; if ($^O eq 'VMS') { # some tests will trigger VMS messages that won't be expected $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//; # pipes double these sometimes $results =~ s/\n\n/\n/g; } my $pass = $resolve->($results); unless ($pass) { _diag "# PROG: \n$prog\n"; _diag "# EXPECTED:\n", $resolve->(), "\n"; _diag "# GOT:\n$results\n"; _diag "# STATUS: $status\n"; } # Use the first line of the program as a name if none was given unless( $name ) { ($first_line, $name) = $prog =~ /^((.{1,50}).*)/; $name = $name . '...' if length $first_line > length $name; } _ok($pass, _where(), "fresh_perl - $name"); } # # fresh_perl_is # # Combination of run_perl() and is(). # sub fresh_perl_is { my($prog, $expected, $runperl_args, $name) = @_; # _fresh_perl() is going to clip the trailing newlines off the result. # This will make it so the test author doesn't have to know that. $expected =~ s/\n+$//; local $Level = 2; _fresh_perl($prog, sub { @_ ? $_[0] eq $expected : $expected }, $runperl_args, $name); } # # fresh_perl_like # # Combination of run_perl() and like(). # sub fresh_perl_like { my($prog, $expected, $runperl_args, $name) = @_; local $Level = 2; _fresh_perl($prog, sub { @_ ? $_[0] =~ $expected : $expected }, $runperl_args, $name); } sub can_ok ($@) { my($proto, @methods) = @_; my $class = ref $proto || $proto; unless( @methods ) { return _ok( 0, _where(), "$class->can(...)" ); } my @nok = (); foreach my $method (@methods) { local($!, $@); # don't interfere with caller's $@ # eval sometimes resets $! eval { $proto->can($method) } || push @nok, $method; } my $name; $name = @methods == 1 ? "$class->can('$methods[0]')" : "$class->can(...)"; _ok( !@nok, _where(), $name ); } sub isa_ok ($$;$) { my($object, $class, $obj_name) = @_; my $diag; $obj_name = 'The object' unless defined $obj_name; my $name = "$obj_name isa $class"; if( !defined $object ) { $diag = "$obj_name isn't defined"; } elsif( !ref $object ) { $diag = "$obj_name isn't a reference"; } else { # We can't use UNIVERSAL::isa because we want to honor isa() overrides local($@, $!); # eval sometimes resets $! my $rslt = eval { $object->isa($class) }; if( $@ ) { if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) { if( !UNIVERSAL::isa($object, $class) ) { my $ref = ref $object; $diag = "$obj_name isn't a '$class' it's a '$ref'"; } } else { die <isa on your object and got some weird error. This should never happen. Please contact the author immediately. Here's the error. $@ WHOA } } elsif( !$rslt ) { my $ref = ref $object; $diag = "$obj_name isn't a '$class' it's a '$ref'"; } } _ok( !$diag, _where(), $name ); } # Set a watchdog to timeout the entire test file # NOTE: If the test file uses 'threads', then call the watchdog() function # _AFTER_ the 'threads' module is loaded. sub watchdog ($) { my $timeout = shift; my $timeout_msg = 'Test process timed out - terminating'; my $pid_to_kill = $$; # PID for this process # Don't use a watchdog process if 'threads' is loaded - # use a watchdog thread instead if (! $threads::threads) { # On Windows and VMS, try launching a watchdog process # using system(1, ...) (see perlport.pod) if (($^O eq 'MSWin32') || ($^O eq 'VMS')) { # On Windows, try to get the 'real' PID if ($^O eq 'MSWin32') { eval { require Win32; }; if (defined(&Win32::GetCurrentProcessId)) { $pid_to_kill = Win32::GetCurrentProcessId(); } } # If we still have a fake PID, we can't use this method at all return if ($pid_to_kill <= 0); # Launch watchdog process my $watchdog; eval { local $SIG{'__WARN__'} = sub { _diag("Watchdog warning: $_[0]"); }; my $sig = $^O eq 'VMS' ? 'TERM' : 'KILL'; my $cmd = _create_runperl( prog => "sleep($timeout);" . "warn qq/# $timeout_msg" . '\n/;' . "kill($sig, $pid_to_kill);"); $watchdog = system(1, $cmd); }; if ($@ || ($watchdog <= 0)) { _diag('Failed to start watchdog'); _diag($@) if $@; undef($watchdog); return; } # Add END block to parent to terminate and # clean up watchdog process eval "END { local \$! = 0; local \$? = 0; wait() if kill('KILL', $watchdog); };"; return; } # Try using fork() to generate a watchdog process my $watchdog; eval { $watchdog = fork() }; if (defined($watchdog)) { if ($watchdog) { # Parent process # Add END block to parent to terminate and # clean up watchdog process eval "END { local \$! = 0; local \$? = 0; wait() if kill('KILL', $watchdog); };"; return; } ### Watchdog process code # Load POSIX if available eval { require POSIX; }; # Execute the timeout sleep($timeout - 2) if ($timeout > 2); # Workaround for perlbug #49073 sleep(2); # Kill test process if still running if (kill(0, $pid_to_kill)) { _diag($timeout_msg); kill('KILL', $pid_to_kill); } # Don't execute END block (added at beginning of this file) $NO_ENDING = 1; # Terminate ourself (i.e., the watchdog) POSIX::_exit(1) if (defined(&POSIX::_exit)); exit(1); } # fork() failed - fall through and try using a thread } # Use a watchdog thread because either 'threads' is loaded, # or fork() failed if (eval 'require threads; 1') { threads->create(sub { # Load POSIX if available eval { require POSIX; }; # Execute the timeout my $time_left = $timeout; do { $time_left = $time_left - sleep($time_left); } while ($time_left > 0); # Kill the parent (and ourself) select(STDERR); $| = 1; _diag($timeout_msg); POSIX::_exit(1) if (defined(&POSIX::_exit)); my $sig = $^O eq 'VMS' ? 'TERM' : 'KILL'; kill($sig, $pid_to_kill); })->detach(); return; } # If everything above fails, then just use an alarm timeout if (eval { alarm($timeout); 1; }) { # Load POSIX if available eval { require POSIX; }; # Alarm handler will do the actual 'killing' $SIG{'ALRM'} = sub { select(STDERR); $| = 1; _diag($timeout_msg); POSIX::_exit(1) if (defined(&POSIX::_exit)); my $sig = $^O eq 'VMS' ? 'TERM' : 'KILL'; kill($sig, $pid_to_kill); }; } } 1; perl-5.12.0-RC0/t/benchmark/0000755000175000017500000000000011351321566014327 5ustar jessejesseperl-5.12.0-RC0/t/benchmark/rt26188-speed-up-keys-on-empty-hash.t0000555000175000017500000000544411325125742022741 0ustar jessejesse#!/usr/bin/perl -w use strict; use Benchmark; require './test.pl'; plan(tests => 6); =head1 NAME rt26188 - benchmark speed for keys() on empty hashes =head1 DESCRIPTION If you have an empty hash, the speed of keys() depends on how many keys the hash previously held. For global hashes, getting the count for previously big hashes was substantially slower than for lexical hashes. This test checks that the speed difference for getting the number or list of keys from an empty hash is about the same (< 25%) for lexical and global hashes, both previously big and small. =head1 REFERENCE This test tests against RT ticket #26188 L =cut use vars qw(%h_big %h_small); my %l_big = (1..50000); my %l_small = (1..10); %h_big = (1..50000); %h_small = (1..10); delete @h_big{keys %h_big}; delete @h_small{keys %h_small}; delete @l_big{keys %l_big}; delete @l_small{keys %l_small}; my $res = timethese shift || -3, { big => '1 for keys %h_big', small => '1 for keys %h_small', scalar_big => '$a = keys %h_big', scalar_small => '$a = keys %h_small', lex_big => '1 for keys %l_big', lex_small => '1 for keys %l_small', lex_scalar_big => '$a = keys %l_big', lex_scalar_small => '$a = keys %l_small', }, 'none'; sub iters_per_second { $_[0]->iters / $_[0]->cpu_p } sub about_as_fast_ok { my ($res, $key1, $key2, $name) = @_; $name ||= "Speed difference between $key1 and $key2 is less than 25%"; my %iters_per_second = map { $_ => iters_per_second( $res->{ $_ }) } ($key1, $key2); my $ratio = abs(1 - $iters_per_second{ $key1 } / ($iters_per_second{ $key2 } || 1 )); if (! cmp_ok( $ratio, '<', 0.25, $name )) { diag( sprintf "%20s: %12.2f/s\n", $key1, $iters_per_second{ $key1 } ); diag( sprintf "%20s: %12.2f/s\n", $key2, $iters_per_second{ $key2 } ); }; }; about_as_fast_ok( $res, 'scalar_big', 'scalar_small',"Checking the count of hash keys in an empty hash (global)"); about_as_fast_ok( $res, 'big', 'small', "Checking the list of hash keys in an empty hash (global)"); about_as_fast_ok( $res, 'lex_scalar_big', 'lex_scalar_small',"Checking the count of hash keys in an empty hash (lexical)"); about_as_fast_ok( $res, 'lex_big', 'lex_small', "Checking the list of hash keys in an empty hash (lexical)"); about_as_fast_ok( $res, 'lex_scalar_big', 'scalar_big',"Checking the count of hash keys in an empty hash, global vs. lexical"); about_as_fast_ok( $res, 'lex_big', 'big', "Checking the list of hash keys in an empty hash, global vs. lexical"); __END__ # code written /* quick bailout if the hash is empty anyway. I don't know if placeholders are included in the KEYS count, so a defensive check */ if (! HvKEYS(hv) && !(flags & HV_ITERNEXT_WANTPLACEHOLDERS) ) return NULL; perl-5.12.0-RC0/t/x2p/0000755000175000017500000000000011351321567013107 5ustar jessejesseperl-5.12.0-RC0/t/x2p/s2p.t0000555000175000017500000002643011325127002013773 0ustar jessejesse#!./perl =head1 NAME s2p.t - test suite for s2p/psed =head1 NOTES The general idea is to (a) run psed with a sed script and input data to obtain some output (b) run s2p with a sed script creating a Perl program and then run the Perl program with the input data, again producing output Both final outputs should be identical to the expected output. A $testcase{} contains entries (after the comment ### ###): - script: the sed script - input: the key of the input data, stored in $input{} - expect: the expected output - datfil: an additional file [ , ] (if required) Temporary files are created in the working directory (embedding $$ in the name), and removed after the test. Except for bin2dec (which indeed converts binary to decimal) none of the sed scripts is doing something useful. Author: Wolfgang Laun. =cut BEGIN { chdir 't' if -d 't'; @INC = ( '../lib' ); } use File::Copy; use File::Spec; require './test.pl'; # BRE extensions $ENV{PSEDEXTBRE} = '<>wW'; our %input = ( bins => <<'[TheEnd]', 0 111 1000 10001 [TheEnd] text => <<'[TheEnd]', line 1 line 2 line 3 line 4 line 5 line 6 line 7 line 8 [TheEnd] adr1 => <<'[TheEnd]', #no autoprint # This script should be run on itself /^#__DATA__$/,${ /^#A$/p s/^# *[0-9]* *// /^#\*$/p /^#\.$/p /^#\(..\)\(..\)\2\1*$/p /^#[abc]\{1,\}[def]\{1,\}$/p } #__DATA__ #A #* #. #abxyxy #abxyxyab #abxyxyabab #ad #abcdef [TheEnd] ); our %testcase = ( ### bin2dec ### 'bin2dec' => { script => <<'[TheEnd]', # binary -> decimal s/^[ ]*\([01]\{1,\}\)[ ]*/\1/ t go i\ is not a binary number d # expand binary to Xs : go s/^0*// s/^1/X/ : expand s/^\(X\{1,\}\)0/\1\1/ s/^\(X\{1,\}\)1/\1\1X/ t expand # count Xs in decimal : count s/^X/1/ s/0X/1/ s/1X/2/ s/2X/3/ s/3X/4/ s/4X/5/ s/5X/6/ s/6X/7/ s/7X/8/ s/8X/9/ s/9X/X0/ t count s/^$/0/ [TheEnd] input => 'bins', expect => <<'[TheEnd]', 0 7 8 17 [TheEnd] }, ### = ### '=' => { script => <<'[TheEnd]', 1= $= [TheEnd] input => 'text', expect => <<'[TheEnd]', 1 line 1 line 2 line 3 line 4 line 5 line 6 line 7 8 line 8 [TheEnd] }, ### D ### 'D' => { script => <<'[TheEnd]', #no autoprint /1/{ N N N D } p /2/D = p [TheEnd] input => 'text', expect => <<'[TheEnd]', line 2 line 3 line 4 line 3 line 4 4 line 3 line 4 line 5 5 line 5 line 6 6 line 6 line 7 7 line 7 line 8 8 line 8 [TheEnd] }, ### H ### 'H' => { script => <<'[TheEnd]', #no autoprint 1,$H $g $= $p [TheEnd] input => 'text', expect => <<'[TheEnd]', 8 line 1 line 2 line 3 line 4 line 5 line 6 line 7 line 8 [TheEnd] }, ### N ### 'N' => { script => <<'[TheEnd]', 3a\ added line 4a\ added line 5a\ added line 3,5N = d [TheEnd] input => 'text', expect => <<'[TheEnd]', 1 2 added line 4 added line 6 7 8 [TheEnd] }, ### P ### 'P' => { script => <<'[TheEnd]', 1N 2N 3N 4= 4P 4,$d [TheEnd] input => 'text', expect => <<'[TheEnd]', 4 line 1 [TheEnd] }, ### a ### 'a' => { script => <<'[TheEnd]', 1a\ added line 1.1\ added line 1.2 3a\ added line 3.1 3a\ added line 3.2 [TheEnd] input => 'text', expect => <<'[TheEnd]', line 1 added line 1.1 added line 1.2 line 2 line 3 added line 3.1 added line 3.2 line 4 line 5 line 6 line 7 line 8 [TheEnd] }, ### b ### 'b' => { script => <<'[TheEnd]', #no autoprint 2 b eos 4 b eos p : eos [TheEnd] input => 'text', expect => <<'[TheEnd]', line 1 line 3 line 5 line 6 line 7 line 8 [TheEnd] }, ### block ### 'block' => { script => "#no autoprint\n1,3{\n=\np\n}", input => 'text', expect => <<'[TheEnd]', 1 line 1 2 line 2 3 line 3 [TheEnd] }, ### c ### 'c' => { script => <<'[TheEnd]', 2= 2,4c\ change 2,4 line 1\ change 2,4 line 2 2= 3,5c\ change 3,5 line 1\ change 3,5 line 2 3= [TheEnd] input => 'text', expect => <<'[TheEnd]', line 1 2 change 2,4 line 1 change 2,4 line 2 line 5 line 6 line 7 line 8 [TheEnd] }, ### c1 ### 'c1' => { script => <<'[TheEnd]', 1c\ replaces line 1 2,3c\ replaces lines 2-3 /5/,/6/c\ replaces lines 3-4 8,10c\ replaces lines 6-10 [TheEnd] input => 'text', expect => <<'[TheEnd]', replaces line 1 replaces lines 2-3 line 4 replaces lines 3-4 line 7 [TheEnd] }, ### c2 ### 'c2' => { script => <<'[TheEnd]', 3!c\ replace all except line 3 [TheEnd] input => 'text', expect => <<'[TheEnd]', replace all except line 3 replace all except line 3 line 3 replace all except line 3 replace all except line 3 replace all except line 3 replace all except line 3 replace all except line 3 [TheEnd] }, ### c3 ### 'c3' => { script => <<'[TheEnd]', 1,4!c\ replace all except 1-4 /5/,/8/!c\ replace all except 5-8 [TheEnd] input => 'text', expect => <<'[TheEnd]', replace all except 5-8 replace all except 5-8 replace all except 5-8 replace all except 5-8 replace all except 1-4 replace all except 1-4 replace all except 1-4 replace all except 1-4 [TheEnd] }, ### d ### 'd' => { script => <<'[TheEnd]', # d delete pattern space, start next cycle 2,4 d 5 d [TheEnd] input => 'text', expect => <<'[TheEnd]', line 1 line 6 line 7 line 8 [TheEnd] }, ### gh ### 'gh' => { script => <<'[TheEnd]', 1h 2g 3h 4g 5q [TheEnd] input => 'text', expect => <<'[TheEnd]', line 1 line 1 line 3 line 3 line 5 [TheEnd] }, ### i ### 'i' => { script => <<'[TheEnd]', 1i\ inserted line 1.1\ inserted line 1.2 3i\ inserted line 3.1 3i\ inserted line 3.2 [TheEnd] input => 'text', expect => <<'[TheEnd]', inserted line 1.1 inserted line 1.2 line 1 line 2 inserted line 3.1 inserted line 3.2 line 3 line 4 line 5 line 6 line 7 line 8 [TheEnd] }, ### n ### 'n' => { script => <<'[TheEnd]', 3a\ added line 4a\ added line 5a\ added line 3,5n = d [TheEnd] input => 'text', expect => <<'[TheEnd]', 1 2 line 3 added line 4 line 5 added line 6 7 8 [TheEnd] }, ### o ### 'o' => { script => <<'[TheEnd]', /abc/,/def/ s//XXX/ // i\ cheers [TheEnd] input => 'text', expect => <<'[TheEnd]', line 1 line 2 line 3 line 4 line 5 line 6 line 7 line 8 [TheEnd] }, ### q ### 'q' => { script => <<'[TheEnd]', 2a\ append to line 2 3a\ append to line 3 - should not appear in output 3q [TheEnd] input => 'text', expect => <<'[TheEnd]', line 1 line 2 append to line 2 line 3 [TheEnd] }, ### r ### 'r' => { datfil => [ 'r.txt', "r.txt line 1\nr.txt line 2\nr.txt line 3\n" ], script => <<'[TheEnd]', 2r%r.txt% 4r %r.txt% [TheEnd] input => 'text', expect => <<'[TheEnd]', line 1 line 2 r.txt line 1 r.txt line 2 r.txt line 3 line 3 line 4 r.txt line 1 r.txt line 2 r.txt line 3 line 5 line 6 line 7 line 8 [TheEnd] }, ### s ### 's' => { script => <<'[TheEnd]', # enclose any `(a)'.. `(c)' in `-' s/([a-z])/-\1-/g s/\([abc]\)/-\1-/g [TheEnd] input => 'text', expect => <<'[TheEnd]', line 1 line 2 line 3 line 4 line 5 line 6 line 7 line 8 [TheEnd] }, ### s1 ### 's1' => { script => <<'[TheEnd]', s/\w/@1/ s/\y/@2/ s/\n/@3/ # this is literal { } s/a{3}/@4/ # proper repetition s/a\{3\}/a rep 3/ [TheEnd] input => 'text', expect => <<'[TheEnd]', @1ine 1 @1ine 2 @1ine 3 @1ine 4 @1ine 5 @1ine 6 @1ine 7 @1ine 8 [TheEnd] }, ### t ### 't' => { script => join( "\n", '#no autoprint', 's/./X/p', 's/foo/bar/p', 't bye', '=', 'p', ':bye' ), input => 'text', expect => <<'[TheEnd]', Xine 1 Xine 2 Xine 3 Xine 4 Xine 5 Xine 6 Xine 7 Xine 8 [TheEnd] }, ### w ### 'w' => { datfil => [ 'w.txt', '' ], script => <<'[TheEnd]', w %w.txt% [TheEnd] input => 'text', expect => <<'[TheEnd]', line 1 line 2 line 3 line 4 line 5 line 6 line 7 line 8 [TheEnd] }, ### x ### 'x' => { script => <<'[TheEnd]', 1h 1d 2x 2,$G [TheEnd] input => 'text', expect => <<'[TheEnd]', line 1 line 2 line 3 line 2 line 4 line 2 line 5 line 2 line 6 line 2 line 7 line 2 line 8 line 2 [TheEnd] }, ### y ### 'y' => { script => <<'[TheEnd]', y/abcdefghijklmnopqrstuvwxyz/ABCDEFGHIJKLMNOPQRSTUVWXYZ/ y/|/\ / [TheEnd] input => 'text', expect => <<'[TheEnd]', LINE 1 LINE 2 LINE 3 LINE 4 LINE 5 LINE 6 LINE 7 LINE 8 [TheEnd] }, ### cnt ### 'cnt' => { script => <<'[TheEnd]', #no autoprint # delete line, append NL to hold space s/.*// H $!b # last line only: get hold g s/./X/g t count : count s/^X/1/ s/0X/1/ s/1X/2/ s/2X/3/ s/3X/4/ s/4X/5/ s/5X/6/ s/6X/7/ s/7X/8/ s/8X/9/ s/9X/X0/ t count p [TheEnd] input => 'text', expect => <<'[TheEnd]', 8 [TheEnd] }, ### adr1 ### 'adr1' => { script => <<'[TheEnd]', #no autoprint # This script should be run on itself /^#__DATA__$/,${ /^#A$/p s/^# *[0-9]* *// /^#\*$/p /^#\.$/p /^#\(..\)\(..\)\2\1*$/p /^#[abc]\{1,\}[def]\{1,\}$/p } #__DATA__ #A #* #. #abxyxy #abxyxyab #abxyxyabab #ad #abcdef [TheEnd] input => 'adr1', expect => <<'[TheEnd]', #A [TheEnd] }, ); my @aux = (); my $ntc = 2 * keys %testcase; plan( $ntc ); # temporary file names my $script = "s2pt$$.sed"; my $stdin = "s2pt$$.in"; my $plsed = "s2pt$$.pl"; # various command lines for my $s2p = File::Spec->catfile( File::Spec->updir(), 'x2p', 's2p' ); my $psed = File::Spec->catfile( File::Spec->curdir(), 'psed' ); if ($^O eq 'VMS') { # default in the .com extenson if it's not already there $s2p = VMS::Filespec::vmsify($s2p); $psed = VMS::Filespec::vmsify($psed); # Converting file specs from Unix format to VMS with the extended # character set active can result in a trailing '.' added for null # extensions. This must be removed if the intent is to default the # extension. $s2p =~ s/\.$//; $psed =~ s/\.$//; $s2p = VMS::Filespec::rmsexpand($s2p, '.com'); $psed = VMS::Filespec::rmsexpand($psed, '.com'); } my $sedcmd = [ $psed, '-f', $script, $stdin ]; my $s2pcmd = [ $s2p, '-f', $script ]; my $plcmd = [ $plsed, $stdin ]; # psed: we create a local copy as linking may not work on some systems. copy( $s2p, $psed ); push( @aux, $psed ); # process all testcases # my $indat = ''; for my $tc ( sort keys %testcase ){ my( $psedres, $s2pres ); # 1st test: run psed # prepare the script open( SED, ">$script" ) || goto FAIL_BOTH; my $script = $testcase{$tc}{script}; # additional files for r, w: patch script, inserting temporary names if( exists( $testcase{$tc}{datfil} ) ){ my( $datnam, $datdat ) = @{$testcase{$tc}{datfil}}; my $datfil = "s2pt$$" . $datnam; push( @aux, $datfil ); open( DAT, ">$datfil" ) || goto FAIL_BOTH; print DAT $datdat; close( DAT ); $script =~ s/\%$datnam\%/$datfil/eg; } print SED $script; close( SED ) || goto FAIL_BOTH; # prepare input # if( $indat ne $testcase{$tc}{input} ){ $indat = $testcase{$tc}{input}; open( IN, ">$stdin" ) || goto FAIL_BOTH; print IN $input{$indat}; close( IN ) || goto FAIL_BOTH; } # on VMS, runperl eats blank lines to work around # spurious newlines in pipes $testcase{$tc}{expect} =~ s/\n\n/\n/ if $^O eq 'VMS'; # run and compare # $psedres = runperl( args => $sedcmd ); is( $psedres, $testcase{$tc}{expect}, "psed $tc" ); # 2nd test: run s2p # translate the sed script to a Perl program my $perlprog = runperl( args => $s2pcmd ); open( PP, ">$plsed" ) || goto FAIL_S2P; print PP $perlprog; close( PP ) || goto FAIL_S2P; # execute generated Perl program, compare $s2pres = runperl( args => $plcmd ); is( $s2pres, $testcase{$tc}{expect}, "s2p $tc" ); next; FAIL_BOTH: fail( "psed $tc" ); FAIL_S2P: fail( "s2p $tc" ); } END { for my $f ( $script, $stdin, $plsed, @aux ){ 1 while unlink( $f ); # hats off to VMS... } } perl-5.12.0-RC0/t/io/0000755000175000017500000000000011351321566013004 5ustar jessejesseperl-5.12.0-RC0/t/io/dup.t0000555000175000017500000000613011325127001013747 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = qw(. ../lib); require "./test.pl"; } use Config; no warnings 'once'; my $test = 1; my $tests_needing_perlio = 17; plan(12 + $tests_needing_perlio); print "ok 1\n"; open(DUPOUT,">&STDOUT"); open(DUPERR,">&STDERR"); my $tempfile = tempfile(); open(STDOUT,">$tempfile") || die "Can't open stdout"; open(STDERR,">&STDOUT") || die "Can't open stderr"; select(STDERR); $| = 1; select(STDOUT); $| = 1; print STDOUT "ok 2\n"; print STDERR "ok 3\n"; # Since some systems don't have echo, we use Perl. $echo = qq{$^X -le "print q(ok %d)"}; $cmd = sprintf $echo, 4; print `$cmd`; $cmd = sprintf "$echo 1>&2", 5; print `$cmd`; system sprintf $echo, 6; system sprintf "$echo 1>&2", 7; close(STDOUT) or die "Could not close: $!"; close(STDERR) or die "Could not close: $!"; open(STDOUT,">&DUPOUT") or die "Could not open: $!"; open(STDERR,">&DUPERR") or die "Could not open: $!"; if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) { print `type $tempfile` } elsif ($^O eq 'VMS') { system "type $tempfile.;" } # TYPE defaults to .LIS when there is no extension else { system "cat $tempfile" } print STDOUT "ok 8\n"; open(F,">&",1) or die "Cannot dup to numeric 1: $!"; print F "ok 9\n"; close(F); open(F,">&",'1') or die "Cannot dup to string '1': $!"; print F "ok 10\n"; close(F); open(F,">&=",1) or die "Cannot dup to numeric 1: $!"; print F "ok 11\n"; close(F); if ($Config{useperlio}) { open(F,">&=",'1') or die "Cannot dup to string '1': $!"; print F "ok 12\n"; close(F); } else { open(F, ">&DUPOUT") or die "Cannot dup stdout back: $!"; print F "ok 12\n"; close(F); } # To get STDOUT back. open(F, ">&DUPOUT") or die "Cannot dup stdout back: $!"; curr_test(13); SKIP: { skip("need perlio", $tests_needing_perlio) unless $Config{useperlio}; ok(open(F, ">&", STDOUT)); isnt(fileno(F), fileno(STDOUT)); close F; ok(open(F, "<&=STDIN")) or _diag $!; is(fileno(F), fileno(STDIN)); close F; ok(open(F, ">&=STDOUT")); is(fileno(F), fileno(STDOUT)); close F; ok(open(F, ">&=STDERR")); is(fileno(F), fileno(STDERR)); close F; open(G, ">$tempfile") or die; my $g = fileno(G); ok(open(F, ">&=$g")); is(fileno(F), $g); close F; ok(open(F, ">&=G")); is(fileno(F), $g); print G "ggg\n"; print F "fff\n"; close G; # flush first close F; # flush second open(G, "<$tempfile") or die; { my $line; $line = ; chomp $line; is($line, "ggg"); $line = ; chomp $line; is($line, "fff"); } close G; open UTFOUT, '>:utf8', $tempfile or die $!; open UTFDUP, '>&UTFOUT' or die $!; # some old greek saying. my $message = "\x{03A0}\x{0391}\x{039D}\x{03A4}\x{0391} \x{03A1}\x{0395}\x{0399}\n"; print UTFOUT $message; print UTFDUP $message; binmode UTFDUP, ':utf8'; print UTFDUP $message; close UTFOUT; close UTFDUP; open(UTFIN, "<:utf8", $tempfile) or die $!; { my $line; $line = ; is($line, $message); $line = ; is($line, $message); $line = ; is($line, $message); } close UTFIN; } perl-5.12.0-RC0/t/io/read.t0000555000175000017500000000101611325125742014102 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } use strict; eval 'use Errno'; die $@ if $@ and !$ENV{PERL_CORE_MINITEST}; plan tests => 2; my $tmpfile = tempfile(); open(A,"+>$tmpfile"); print A "_"; seek(A,0,0); my $b = "abcd"; $b = ""; read(A,$b,1,4); close(A); is($b,"\000\000\000\000_"); # otherwise probably "\000bcd_" SKIP: { skip "no EBADF", 1 if (!exists &Errno::EBADF); $! = 0; no warnings 'unopened'; read(B,$b,1); ok($! == &Errno::EBADF); } perl-5.12.0-RC0/t/io/say.t0000555000175000017500000000171111325125742013765 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } # Just a few very basic tests cribbed from t/io/print.t, # with some minor additions. say is actually compiled to # a print opcode, so it's more or less guaranteed to behave # the same way as print in any case. use strict 'vars'; eval 'use Errno'; die $@ if $@ and !$ENV{PERL_CORE_MINITEST}; use feature "say"; say "1..12"; my $foo = 'STDOUT'; say $foo "ok 1"; say "ok 2\n","ok 3\n","ok 4"; say STDOUT "ok 5"; open(FOO,">-"); say FOO "ok 6"; open(my $bar,">-"); say $bar "ok 7"; say {"STDOUT"} "ok 8"; if (!exists &Errno::EBADF) { print "ok 9 # skipped: no EBADF\n"; } else { $! = 0; no warnings 'unopened'; say NONEXISTENT "foo"; print "not " if ($! != &Errno::EBADF); say "ok 9"; } $_ = "ok 10"; say; $_ = "ok 11"; say STDOUT; { # test that $, doesn't show up before the trailing \n local $, = "\nnot ok 13"; # how to fool Test::Harness say "ok 12"; } perl-5.12.0-RC0/t/io/openpid.t0000555000175000017500000000456111325127001014623 0ustar jessejesse#!./perl ##################################################################### # # Test for process id return value from open # Ronald Schmidt (The Software Path) RonaldWS@software-path.com # ##################################################################### BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } if ($^O eq 'dos') { skip_all("no multitasking"); } plan tests => 10; watchdog(15); use Config; $| = 1; $SIG{PIPE} = 'IGNORE'; $SIG{HUP} = 'IGNORE' if $^O eq 'interix'; my $perl = which_perl(); $perl .= qq[ "-I../lib"]; # # commands run 4 perl programs. Two of these programs write a # short message to STDOUT and exit. Two of these programs # read from STDIN. One reader never exits and must be killed. # the other reader reads one line, waits a few seconds and then # exits to test the waitpid function. # $cmd1 = qq/$perl -e "\$|=1; print qq[first process\\n]; sleep 30;"/; $cmd2 = qq/$perl -e "\$|=1; print qq[second process\\n]; sleep 30;"/; $cmd3 = qq/$perl -e "print <>;"/; # hangs waiting for end of STDIN $cmd4 = qq/$perl -e "print scalar <>;"/; #warn "#$cmd1\n#$cmd2\n#$cmd3\n#$cmd4\n"; # start the processes ok( $pid1 = open(FH1, "$cmd1 |"), 'first process started'); ok( $pid2 = open(FH2, "$cmd2 |"), ' second' ); { no warnings 'once'; ok( $pid3 = open(FH3, "| $cmd3"), ' third' ); } ok( $pid4 = open(FH4, "| $cmd4"), ' fourth' ); print "# pids were $pid1, $pid2, $pid3, $pid4\n"; my $killsig = 'HUP'; $killsig = 1 unless $Config{sig_name} =~ /\bHUP\b/; # get message from first process and kill it chomp($from_pid1 = scalar()); is( $from_pid1, 'first process', 'message from first process' ); $kill_cnt = kill $killsig, $pid1; is( $kill_cnt, 1, 'first process killed' ) || print "# errno == $!\n"; # get message from second process and kill second process and reader process chomp($from_pid2 = scalar()); is( $from_pid2, 'second process', 'message from second process' ); $kill_cnt = kill $killsig, $pid2, $pid3; is( $kill_cnt, 2, 'killing procs 2 & 3' ) || print "# errno == $!\n"; # send one expected line of text to child process and then wait for it select(FH4); $| = 1; select(STDOUT); printf FH4 "ok %d - text sent to fourth process\n", curr_test(); next_test(); print "# waiting for process $pid4 to exit\n"; $reap_pid = waitpid $pid4, 0; is( $reap_pid, $pid4, 'fourth process reaped' ); perl-5.12.0-RC0/t/io/fflush.t0000555000175000017500000000663511325125742014472 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } # Script to test auto flush on fork/exec/system/qx. The idea is to # print "Pe" to a file from a parent process and "rl" to the same file # from a child process. If buffers are flushed appropriately, the # file should contain "Perl". We'll see... use Config; use warnings; use strict; # This attempts to mirror the #ifdef forest found in perl.h so that we # know when to run these tests. If that forest ever changes, change # it here too or expect test gratuitous test failures. my $useperlio = defined $Config{useperlio} ? $Config{useperlio} eq 'define' ? 1 : 0 : 0; my $fflushNULL = defined $Config{fflushNULL} ? $Config{fflushNULL} eq 'define' ? 1 : 0 : 0; my $d_sfio = defined $Config{d_sfio} ? $Config{d_sfio} eq 'define' ? 1 : 0 : 0; my $fflushall = defined $Config{fflushall} ? $Config{fflushall} eq 'define' ? 1 : 0 : 0; my $d_fork = defined $Config{d_fork} ? $Config{d_fork} eq 'define' ? 1 : 0 : 0; if ($useperlio || $fflushNULL || $d_sfio) { print "1..7\n"; } else { if ($fflushall) { print "1..7\n"; } else { print "1..0 # Skip: fflush(NULL) or equivalent not available\n"; exit; } } my $runperl = $^X =~ m/\s/ ? qq{"$^X"} : $^X; $runperl .= qq{ "-I../lib"}; sub file_eq { my $f = shift; my $val = shift; open IN, $f or die "open $f: $!"; chomp(my $line = ); close IN; print "# got $line\n"; print "# expected $val\n"; return $line eq $val; } # This script will be used as the command to execute from # child processes my $ffprog = tempfile(); open PROG, "> $ffprog" or die "open $ffprog: $!"; print PROG <<'EOF'; my $f = shift; my $str = shift; open OUT, ">> $f" or die "open $f: $!"; print OUT $str; close OUT; EOF ; close PROG or die "close $ffprog: $!";; $| = 0; # we want buffered output # Test flush on fork/exec if (!$d_fork) { print "ok 1 # skipped: no fork\n"; } else { my $f = tempfile(); open OUT, "> $f" or die "open $f: $!"; print OUT "Pe"; my $pid = fork; if ($pid) { # Parent wait; close OUT or die "close $f: $!"; } elsif (defined $pid) { # Kid print OUT "r"; my $command = qq{$runperl "$ffprog" "$f" "l"}; print "# $command\n"; exec $command or die $!; exit; } else { # Bang die "fork: $!"; } print file_eq($f, "Perl") ? "ok 1\n" : "not ok 1\n"; } # Test flush on system/qx/pipe open my %subs = ( "system" => sub { my $c = shift; system $c; }, "qx" => sub { my $c = shift; qx{$c}; }, "popen" => sub { my $c = shift; open PIPE, "$c|" or die "$c: $!"; close PIPE; }, ); my $t = 2; for (qw(system qx popen)) { my $code = $subs{$_}; my $f = tempfile(); my $command = qq{$runperl $ffprog "$f" "rl"}; open OUT, "> $f" or die "open $f: $!"; print OUT "Pe"; close OUT or die "close $f: $!";; print "# $command\n"; $code->($command); print file_eq($f, "Perl") ? "ok $t\n" : "not ok $t\n"; ++$t; } my $cmd = _create_runperl( switches => ['-l'], prog => sprintf('print qq[ok $_] for (%d..%d)', $t, $t+2)); print "# cmd = '$cmd'\n"; open my $CMD, "$cmd |" or die "Can't open pipe to '$cmd': $!"; while (<$CMD>) { system("$runperl -e 0"); print; } close $CMD; $t += 3; perl-5.12.0-RC0/t/io/crlf_through.t0000555000175000017500000000023011325125742015652 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } no warnings 'once'; $main::use_crlf = 1; do './io/through.t' or die "no kid script"; perl-5.12.0-RC0/t/io/inplace.t0000555000175000017500000000353711325127001014602 0ustar jessejesse#!./perl use strict; require './test.pl'; $^I = $^O eq 'VMS' ? '_bak' : '.bak'; plan( tests => 6 ); my @tfiles = (tempfile(), tempfile(), tempfile()); my @tfiles_bak = map "$_$^I", @tfiles; END { unlink_all(@tfiles_bak); } for my $file (@tfiles) { runperl( prog => 'print qq(foo\n);', args => ['>', $file] ); } @ARGV = @tfiles; while (<>) { s/foo/bar/; } continue { print; } is ( runperl( prog => 'print<>;', args => \@tfiles ), "bar\nbar\nbar\n", "file contents properly replaced" ); is ( runperl( prog => 'print<>;', args => \@tfiles_bak ), "foo\nfoo\nfoo\n", "backup file contents stay the same" ); SKIP: { # based on code, dosish and epoc systems can't do no-backup inplace # edits $^O =~ /^(MSWin32|cygwin|uwin|dos|epoc|os2)$/ and skip("Can't inplace edit without backups on $^O", 4); our @ifiles = ( tempfile(), tempfile(), tempfile() ); { for my $file (@ifiles) { runperl( prog => 'print qq(bar\n);', args => [ '>', $file ] ); } local $^I = ''; local @ARGV = @ifiles; while (<>) { print "foo$_"; } is(scalar(@ARGV), 0, "consumed ARGV"); # runperl may quote its arguments, so don't expect to be able # to reuse things you send it. my @my_ifiles = @ifiles; is( runperl( prog => 'print<>;', args => \@my_ifiles ), "foobar\nfoobar\nfoobar\n", "normal inplace edit"); } # test * equivalency RT #70802 { for my $file (@ifiles) { runperl( prog => 'print qq(bar\n);', args => [ '>', $file ] ); } local $^I = '*'; local @ARGV = @ifiles; while (<>) { print "foo$_"; } is(scalar(@ARGV), 0, "consumed ARGV"); my @my_ifiles = @ifiles; is( runperl( prog => 'print<>;', args => \@my_ifiles ), "foobar\nfoobar\nfoobar\n", "normal inplace edit"); } END { unlink_all(@ifiles); } } perl-5.12.0-RC0/t/io/print.t0000555000175000017500000000214411325125742014326 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } use strict 'vars'; eval 'use Errno'; die $@ if $@ and !$ENV{PERL_CORE_MINITEST}; print "1..21\n"; my $foo = 'STDOUT'; print $foo "ok 1\n"; print "ok 2\n","ok 3\n","ok 4\n"; print STDOUT "ok 5\n"; open(foo,">-"); print foo "ok 6\n"; printf "ok %d\n",7; printf("ok %d\n",8); my @a = ("ok %d%c",9,ord("\n")); printf @a; $a[1] = 10; printf STDOUT @a; $, = ' '; $\ = "\n"; print "ok","11"; my @x = ("ok","12\nok","13\nok"); my @y = ("15\nok","16"); print @x,"14\nok",@y; { local $\ = "ok 17\n# null =>[\000]\nok 18\n"; print ""; } $\ = ''; if (!exists &Errno::EBADF) { print "ok 19 # skipped: no EBADF\n"; } else { $! = 0; no warnings 'unopened'; print NONEXISTENT "foo"; print "not " if ($! != &Errno::EBADF); print "ok 19\n"; } { # Change 26009: pp_print didn't extend the stack # before pushing its return value # to make sure only that these obfuscated sentences will not crash. map print(reverse), ('')x68; print "ok 20\n"; map print(+()), ('')x68; print "ok 21\n"; } perl-5.12.0-RC0/t/io/crlf.t0000555000175000017500000000410311325125742014115 0ustar jessejesse#!./perl -w BEGIN { chdir 't' if -d 't'; @INC = qw(. ../lib); } use Config; require "test.pl"; my $file = tempfile(); if (find PerlIO::Layer 'perlio') { plan(tests => 16); ok(open(FOO,">:crlf",$file)); ok(print FOO 'a'.((('a' x 14).qq{\n}) x 2000) || close(FOO)); ok(open(FOO,"<:crlf",$file)); my $text; { local $/; $text = } is(count_chars($text, "\015\012"), 0); is(count_chars($text, "\n"), 2000); binmode(FOO); seek(FOO,0,0); { local $/; $text = } is(count_chars($text, "\015\012"), 2000); SKIP: { skip("miniperl can't rely on loading PerlIO::scalar") if $ENV{PERL_CORE_MINITEST}; skip("no PerlIO::scalar") unless $Config{extensions} =~ m!\bPerlIO/scalar\b!; require PerlIO::scalar; my $fcontents = join "", map {"$_\015\012"} "a".."zzz"; open my $fh, "<:crlf", \$fcontents; local $/ = "xxx"; local $_ = <$fh>; my $pos = tell $fh; # pos must be behind "xxx", before "\nxxy\n" seek $fh, $pos, 0; $/ = "\n"; $s = <$fh>.<$fh>; ok($s eq "\nxxy\n"); } ok(close(FOO)); # binmode :crlf should not cumulate. # Try it first once and then twice so that even UNIXy boxes # get to exercise this, for DOSish boxes even once is enough. # Try also pushing :utf8 first so that there are other layers # in between (this should not matter: CRLF layers still should # not accumulate). for my $utf8 ('', ':utf8') { for my $binmode (1..2) { open(FOO, ">$file"); # require PerlIO; print PerlIO::get_layers(FOO), "\n"; binmode(FOO, "$utf8:crlf") for 1..$binmode; # require PerlIO; print PerlIO::get_layers(FOO), "\n"; print FOO "Hello\n"; close FOO; open(FOO, "<$file"); binmode(FOO); my $foo = scalar ; close FOO; print join(" ", "#", map { sprintf("%02x", $_) } unpack("C*", $foo)), "\n"; ok($foo =~ /\x0d\x0a$/); ok($foo !~ /\x0d\x0d/); } } } else { skip_all("No perlio, so no :crlf"); } sub count_chars { my($text, $chars) = @_; my $seen = 0; $seen++ while $text =~ /$chars/g; return $seen; } perl-5.12.0-RC0/t/io/tell.t0000555000175000017500000001000011325127001014106 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } print "1..28\n"; $TST = 'TST'; $Is_Dosish = ($^O eq 'MSWin32' or $^O eq 'NetWare' or $^O eq 'dos' or $^O eq 'os2' or $^O eq 'cygwin' or $^O =~ /^uwin/); open($TST, 'harness') || (die "Can't open harness"); binmode $TST if $Is_Dosish; if (eof(TST)) { print "not ok 1\n"; } else { print "ok 1\n"; } $firstline = <$TST>; $secondpos = tell; $x = 0; while () { if (eof) {$x++;} } if ($x == 1) { print "ok 2\n"; } else { print "not ok 2\n"; } $lastpos = tell; unless (eof) { print "not ok 3\n"; } else { print "ok 3\n"; } if (seek($TST,0,0)) { print "ok 4\n"; } else { print "not ok 4\n"; } if (eof) { print "not ok 5\n"; } else { print "ok 5\n"; } if ($firstline eq ) { print "ok 6\n"; } else { print "not ok 6\n"; } if ($secondpos == tell) { print "ok 7\n"; } else { print "not ok 7\n"; } if (seek(TST,0,1)) { print "ok 8\n"; } else { print "not ok 8\n"; } if (eof($TST)) { print "not ok 9\n"; } else { print "ok 9\n"; } if ($secondpos == tell) { print "ok 10\n"; } else { print "not ok 10\n"; } if (seek(TST,0,2)) { print "ok 11\n"; } else { print "not ok 11\n"; } if ($lastpos == tell) { print "ok 12\n"; } else { print "not ok 12\n"; } unless (eof) { print "not ok 13\n"; } else { print "ok 13\n"; } if ($. == 0) { print "not ok 14\n"; } else { print "ok 14\n"; } $curline = $.; open(OTHER, 'harness') || (die "Can't open harness: $!"); binmode OTHER if (($^O eq 'MSWin32') || ($^O eq 'NetWare')); { local($.); if ($. == 0) { print "not ok 15\n"; } else { print "ok 15\n"; } tell OTHER; if ($. == 0) { print "ok 16\n"; } else { print "not ok 16\n"; } $. = 5; scalar ; if ($. == 6) { print "ok 17\n"; } else { print "not ok 17\n"; } } if ($. == $curline) { print "ok 18\n"; } else { print "not ok 18\n"; } { local($.); scalar ; if ($. == 7) { print "ok 19\n"; } else { print "not ok 19\n"; } } if ($. == $curline) { print "ok 20\n"; } else { print "not ok 20\n"; } { local($.); tell OTHER; if ($. == 7) { print "ok 21\n"; } else { print "not ok 21\n"; } } close(OTHER); { no warnings 'closed'; if (tell(OTHER) == -1) { print "ok 22\n"; } else { print "not ok 22\n"; } } { no warnings 'unopened'; if (tell(ETHER) == -1) { print "ok 23\n"; } else { print "not ok 23\n"; } } # ftell(STDIN) (or any std streams) is undefined, it can return -1 or # something else. ftell() on pipes, fifos, and sockets is defined to # return -1. my $written = tempfile(); close($TST); open($tst,">$written") || die "Cannot open $written:$!"; binmode $tst if $Is_Dosish; if (tell($tst) == 0) { print "ok 24\n"; } else { print "not ok 24\n"; } print $tst "fred\n"; if (tell($tst) == 5) { print "ok 25\n"; } else { print "not ok 25\n"; } print $tst "more\n"; if (tell($tst) == 10) { print "ok 26\n"; } else { print "not ok 26\n"; } close($tst); open($tst,"+>>$written") || die "Cannot open $written:$!"; binmode $tst if $Is_Dosish; if (0) { # :stdio does not pass these so ignore them for now if (tell($tst) == 0) { print "ok 27\n"; } else { print "not ok 27\n"; } $line = <$tst>; if ($line eq "fred\n") { print "ok 29\n"; } else { print "not ok 29\n"; } if (tell($tst) == 5) { print "ok 30\n"; } else { print "not ok 30\n"; } } print $tst "xxxx\n"; if (tell($tst) == 15 || tell($tst) == 5) # unset PERLIO or PERLIO=stdio (e.g. HP-UX, Solaris) { print "ok 27\n"; } else { print "not ok 27\n"; } close($tst); open($tst,">$written") || die "Cannot open $written:$!"; print $tst "foobar"; close $tst; open($tst,">>$written") || die "Cannot open $written:$!"; # This test makes a questionable assumption that the file pointer will # be at eof after opening a file but before seeking, reading, or writing. # Only known failure is on cygwin. my $todo = $^O eq "cygwin" && &PerlIO::get_layers($tst) eq 'stdio' && ' # TODO: file pointer not at eof'; if (tell($tst) == 6) { print "ok 28$todo\n"; } else { print "not ok 28$todo\n"; } close $tst; perl-5.12.0-RC0/t/io/through.t0000555000175000017500000001110211325125742014644 0ustar jessejesse#!./perl BEGIN { if ($^O eq 'VMS') { print "1..0 # Skip on VMS -- too picky about line endings for record-oriented pipes\n"; exit; } chdir 't' if -d 't'; @INC = '../lib'; } use strict; require './test.pl'; my $Perl = which_perl(); my $data = <<'EOD'; x yy z EOD (my $data2 = $data) =~ s/\n/\n\n/g; my $t1 = { data => $data, write_c => [1,2,length $data], read_c => [1,2,3,length $data]}; my $t2 = { data => $data2, write_c => [1,2,length $data2], read_c => [1,2,3,length $data2]}; $_->{write_c} = [1..length($_->{data})], $_->{read_c} = [1..length($_->{data})+1, 0xe000] # Need <0xffff for REx for (); # $t1, $t2; my $c; # len write tests, for each: one _all test, and 3 each len+2 $c += @{$_->{write_c}} * (1 + 3*@{$_->{read_c}}) for $t1, $t2; $c *= 3*2*2; # $how_w, file/pipe, 2 reports $c += 6; # Tests with sleep()... print "1..$c\n"; my $set_out = ''; $set_out = "binmode STDOUT, ':crlf'" if defined $main::use_crlf && $main::use_crlf == 1; sub testread ($$$$$$$) { my ($fh, $str, $read_c, $how_r, $write_c, $how_w, $why) = @_; my $buf = ''; if ($how_r eq 'readline_all') { $buf .= $_ while <$fh>; } elsif ($how_r eq 'readline') { $/ = \$read_c; $buf .= $_ while <$fh>; } elsif ($how_r eq 'read') { my($in, $c); $buf .= $in while $c = read($fh, $in, $read_c); } elsif ($how_r eq 'sysread') { my($in, $c); $buf .= $in while $c = sysread($fh, $in, $read_c); } else { die "Unrecognized read: '$how_r'"; } close $fh or die "close: $!"; # The only contamination allowed is with sysread/prints $buf =~ s/\r\n/\n/g if $how_r eq 'sysread' and $how_w =~ /print/; is(length $buf, length $str, "length with wrc=$write_c, rdc=$read_c, $how_w, $how_r, $why"); is($buf, $str, "content with wrc=$write_c, rdc=$read_c, $how_w, $how_r, $why"); } sub testpipe ($$$$$$) { my ($str, $write_c, $read_c, $how_w, $how_r, $why) = @_; (my $quoted = $str) =~ s/\n/\\n/g;; my $fh; if ($how_w eq 'print') { # AUTOFLUSH??? # Should be shell-neutral: open $fh, '-|', qq[$Perl -we "$set_out;print for grep length, split /(.{1,$write_c})/s, qq($quoted)"] or die "open: $!"; } elsif ($how_w eq 'print/flush') { # shell-neutral and miniperl-enabled autoflush? qq(\x24\x7c) eq '$|' open $fh, '-|', qq[$Perl -we "$set_out;eval qq(\\x24\\x7c = 1) or die;print for grep length, split /(.{1,$write_c})/s, qq($quoted)"] or die "open: $!"; } elsif ($how_w eq 'syswrite') { ### How to protect \$_ open $fh, '-|', qq[$Perl -we "$set_out;eval qq(sub w {syswrite STDOUT, \\x24_} 1) or die; w() for grep length, split /(.{1,$write_c})/s, qq($quoted)"] or die "open: $!"; } else { die "Unrecognized write: '$how_w'"; } binmode $fh, ':crlf' if defined $main::use_crlf && $main::use_crlf == 1; testread($fh, $str, $read_c, $how_r, $write_c, $how_w, "pipe$why"); } sub testfile ($$$$$$) { my ($str, $write_c, $read_c, $how_w, $how_r, $why) = @_; my @data = grep length, split /(.{1,$write_c})/s, $str; my $filename = tempfile(); open my $fh, '>', $filename or die; select $fh; binmode $fh, ':crlf' if defined $main::use_crlf && $main::use_crlf == 1; if ($how_w eq 'print') { # AUTOFLUSH??? $| = 0; print $fh $_ for @data; } elsif ($how_w eq 'print/flush') { $| = 1; print $fh $_ for @data; } elsif ($how_w eq 'syswrite') { syswrite $fh, $_ for @data; } else { die "Unrecognized write: '$how_w'"; } close $fh or die "close: $!"; open $fh, '<', $filename or die; binmode $fh, ':crlf' if defined $main::use_crlf && $main::use_crlf == 1; testread($fh, $str, $read_c, $how_r, $write_c, $how_w, "file$why"); } # shell-neutral and miniperl-enabled autoflush? qq(\x24\x7c) eq '$|' open my $fh, '-|', qq[$Perl -we "eval qq(\\x24\\x7c = 1) or die; binmode STDOUT; sleep 1, print for split //, qq(a\nb\n\nc\n\n\n)"] or die "open: $!"; ok(1, 'open pipe'); binmode $fh, q(:crlf); ok(1, 'binmode'); $c = undef; my @c; push @c, ord $c while $c = getc $fh; ok(1, 'got chars'); is(scalar @c, 9, 'got 9 chars'); is("@c", '97 10 98 10 10 99 10 10 10', 'got expected chars'); ok(close($fh), 'close'); for my $s (1..2) { my $t = ($t1, $t2)[$s-1]; my $str = $t->{data}; my $r = $t->{read_c}; my $w = $t->{write_c}; for my $read_c (@$r) { for my $write_c (@$w) { for my $how_r (qw(readline_all readline read sysread)) { next if $how_r eq 'readline_all' and $read_c != 1; for my $how_w (qw(print print/flush syswrite)) { testfile($str, $write_c, $read_c, $how_w, $how_r, $s); testpipe($str, $write_c, $read_c, $how_w, $how_r, $s); } } } } } 1; perl-5.12.0-RC0/t/io/fs.t0000555000175000017500000002740611325127001013600 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require "./test.pl"; } use Config; use File::Spec::Functions; my $Is_VMSish = ($^O eq 'VMS'); if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) { $wd = `cd`; } elsif ($^O eq 'VMS') { $wd = `show default`; } else { $wd = `pwd`; } chomp($wd); my $has_link = $Config{d_link}; my $accurate_timestamps = !($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'dos' || $^O eq 'os2' || $^O eq 'cygwin' || $^O eq 'amigaos' || $wd =~ m#$Config{afsroot}/# ); if (defined &Win32::IsWinNT && Win32::IsWinNT()) { if (Win32::FsType() eq 'NTFS') { $has_link = 1; $accurate_timestamps = 1; } } my $needs_fh_reopen = $^O eq 'dos' # Not needed on HPFS, but needed on HPFS386 ?! || $^O eq 'os2'; $needs_fh_reopen = 1 if (defined &Win32::IsWin95 && Win32::IsWin95()); my $skip_mode_checks = $^O eq 'cygwin' && $ENV{CYGWIN} !~ /ntsec/; plan tests => 51; my $tmpdir = tempfile(); my $tmpdir1 = tempfile(); if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) { `rmdir /s /q $tmpdir 2>nul`; `mkdir $tmpdir`; } elsif ($^O eq 'VMS') { `if f\$search("[.$tmpdir]*.*") .nes. "" then delete/nolog/noconfirm [.$tmpdir]*.*.*`; `if f\$search("$tmpdir.dir") .nes. "" then set file/prot=o:rwed $tmpdir.dir;`; `if f\$search("$tmpdir.dir") .nes. "" then delete/nolog/noconfirm $tmpdir.dir;`; `create/directory [.$tmpdir]`; } else { `rm -f $tmpdir 2>/dev/null; mkdir $tmpdir 2>/dev/null`; } chdir catdir(curdir(), $tmpdir); `/bin/rm -rf a b c x` if -x '/bin/rm'; umask(022); SKIP: { skip "bogus umask", 1 if ($^O eq 'MSWin32') || ($^O eq 'NetWare') || ($^O eq 'epoc'); is((umask(0)&0777), 022, 'umask'), } open(FH,'>x') || die "Can't create x"; close(FH); open(FH,'>a') || die "Can't create a"; close(FH); my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks,$a_mode); SKIP: { skip("no link", 4) unless $has_link; ok(link('a','b'), "link a b"); ok(link('b','c'), "link b c"); $a_mode = (stat('a'))[2]; ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('c'); SKIP: { skip "no nlink", 1 if $Config{dont_use_nlink}; is($nlink, 3, "link count of triply-linked file"); } SKIP: { skip "hard links not that hard in $^O", 1 if $^O eq 'amigaos'; skip "no mode checks", 1 if $skip_mode_checks; # if ($^O eq 'cygwin') { # new files on cygwin get rwx instead of rw- # is($mode & 0777, 0777, "mode of triply-linked file"); # } else { is(sprintf("0%o", $mode & 0777), sprintf("0%o", $a_mode & 0777), "mode of triply-linked file"); # } } } $newmode = (($^O eq 'MSWin32') || ($^O eq 'NetWare')) ? 0444 : 0777; is(chmod($newmode,'a'), 1, "chmod succeeding"); SKIP: { skip("no link", 7) unless $has_link; ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('c'); SKIP: { skip "no mode checks", 1 if $skip_mode_checks; is($mode & 0777, $newmode, "chmod going through"); } $newmode = 0700; chmod 0444, 'x'; $newmode = 0666; is(chmod($newmode,'c','x'), 2, "chmod two files"); ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('c'); SKIP: { skip "no mode checks", 1 if $skip_mode_checks; is($mode & 0777, $newmode, "chmod going through to c"); } ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('x'); SKIP: { skip "no mode checks", 1 if $skip_mode_checks; is($mode & 0777, $newmode, "chmod going through to x"); } is(unlink('b','x'), 2, "unlink two files"); ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('b'); is($ino, undef, "ino of removed file b should be undef"); ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('x'); is($ino, undef, "ino of removed file x should be undef"); } SKIP: { skip "no fchmod", 5 unless ($Config{d_fchmod} || "") eq "define"; ok(open(my $fh, "<", "a"), "open a"); is(chmod(0, $fh), 1, "fchmod"); $mode = (stat "a")[2]; SKIP: { skip "no mode checks", 1 if $skip_mode_checks; is($mode & 0777, 0, "perm reset"); } is(chmod($newmode, "a"), 1, "fchmod"); $mode = (stat $fh)[2]; SKIP: { skip "no mode checks", 1 if $skip_mode_checks; is($mode & 0777, $newmode, "perm restored"); } } SKIP: { skip "no fchown", 1 unless ($Config{d_fchown} || "") eq "define"; open(my $fh, "<", "a"); is(chown(-1, -1, $fh), 1, "fchown"); } SKIP: { skip "has fchmod", 1 if ($Config{d_fchmod} || "") eq "define"; open(my $fh, "<", "a"); eval { chmod(0777, $fh); }; like($@, qr/^The fchmod function is unimplemented at/, "fchmod is unimplemented"); } SKIP: { skip "has fchown", 1 if ($Config{d_fchown} || "") eq "define"; open(my $fh, "<", "a"); eval { chown(0, 0, $fh); }; like($@, qr/^The f?chown function is unimplemented at/, "fchown is unimplemented"); } is(rename('a','b'), 1, "rename a b"); ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('a'); is($ino, undef, "ino of renamed file a should be undef"); $delta = $accurate_timestamps ? 1 : 2; # Granularity of time on the filesystem chmod 0777, 'b'; $foo = (utime 500000000,500000000 + $delta,'b'); is($foo, 1, "utime"); check_utime_result(); utime undef, undef, 'b'; ($atime,$mtime) = (stat 'b')[8,9]; print "# utime undef, undef --> $atime, $mtime\n"; isnt($atime, 500000000, 'atime'); isnt($mtime, 500000000 + $delta, 'mtime'); SKIP: { skip "no futimes", 4 unless ($Config{d_futimes} || "") eq "define"; open(my $fh, "<", 'b'); $foo = (utime 500000000,500000000 + $delta, $fh); is($foo, 1, "futime"); check_utime_result(); } sub check_utime_result { ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('b'); SKIP: { skip "bogus inode num", 1 if ($^O eq 'MSWin32') || ($^O eq 'NetWare'); ok($ino, 'non-zero inode num'); } SKIP: { skip "filesystem atime/mtime granularity too low", 2 unless $accurate_timestamps; print "# atime - $atime mtime - $mtime delta - $delta\n"; if($atime == 500000000 && $mtime == 500000000 + $delta) { pass('atime'); pass('mtime'); } else { if ($^O =~ /\blinux\b/i) { print "# Maybe stat() cannot get the correct atime, ". "as happens via NFS on linux?\n"; $foo = (utime 400000000,500000000 + 2*$delta,'b'); my ($new_atime, $new_mtime) = (stat('b'))[8,9]; print "# newatime - $new_atime nemtime - $new_mtime\n"; if ($new_atime == $atime && $new_mtime - $mtime == $delta) { pass("atime - accounted for possible NFS/glibc2.2 bug on linux"); pass("mtime - accounted for possible NFS/glibc2.2 bug on linux"); } else { fail("atime - $atime/$new_atime $mtime/$new_mtime"); fail("mtime - $atime/$new_atime $mtime/$new_mtime"); } } elsif ($^O eq 'VMS') { # why is this 1 second off? is( $atime, 500000001, 'atime' ); is( $mtime, 500000000 + $delta, 'mtime' ); } elsif ($^O eq 'beos' || $^O eq 'haiku') { SKIP: { skip "atime not updated", 1; } is($mtime, 500000001, 'mtime'); } else { fail("atime"); fail("mtime"); } } } } SKIP: { skip "has futimes", 1 if ($Config{d_futimes} || "") eq "define"; open(my $fh, "<", "b") || die; eval { utime(undef, undef, $fh); }; like($@, qr/^The futimes function is unimplemented at/, "futimes is unimplemented"); } is(unlink('b'), 1, "unlink b"); ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('b'); is($ino, undef, "ino of unlinked file b should be undef"); unlink 'c'; chdir $wd || die "Can't cd back to $wd"; # Yet another way to look for links (perhaps those that cannot be # created by perl?). Hopefully there is an ls utility in your # %PATH%. N.B. that $^O is 'cygwin' on Cygwin. SKIP: { skip "Win32/Netware specific test", 2 unless ($^O eq 'MSWin32') || ($^O eq 'NetWare'); skip "No symbolic links found to test with", 2 unless `ls -l perl 2>nul` =~ /^l.*->/; system("cp TEST TEST$$"); # we have to copy because e.g. GNU grep gets huffy if we have # a symlink forest to another disk (it complains about too many # levels of symbolic links, even if we have only two) is(symlink("TEST$$","c"), 1, "symlink"); $foo = `grep perl c 2>&1`; ok($foo, "found perl in c"); unlink 'c'; unlink("TEST$$"); } my $tmpfile = tempfile(); open IOFSCOM, ">$tmpfile" or die "Could not write IOfs.tmp: $!"; print IOFSCOM 'helloworld'; close(IOFSCOM); # TODO: pp_truncate needs to be taught about F_CHSIZE and F_FREESP, # as per UNIX FAQ. SKIP: { # Check truncating a closed file. eval { truncate $tmpfile, 5; }; skip("no truncate - $@", 8) if $@; is(-s $tmpfile, 5, "truncation to five bytes"); truncate $tmpfile, 0; ok(-z $tmpfile, "truncation to zero bytes"); #these steps are necessary to check if file is really truncated #On Win95, FH is updated, but file properties aren't open(FH, ">$tmpfile") or die "Can't create $tmpfile"; print FH "x\n" x 200; close FH; # Check truncating an open file. open(FH, ">>$tmpfile") or die "Can't open $tmpfile for appending"; binmode FH; select FH; $| = 1; select STDOUT; { use strict; print FH "x\n" x 200; ok(truncate(FH, 200), "fh resize to 200"); } if ($needs_fh_reopen) { close (FH); open (FH, ">>$tmpfile") or die "Can't reopen $tmpfile"; } SKIP: { if ($^O eq 'vos') { skip ("# TODO - hit VOS bug posix-973 - cannot resize an open file below the current file pos.", 5); } is(-s $tmpfile, 200, "fh resize to 200 working (filename check)"); ok(truncate(FH, 0), "fh resize to zero"); if ($needs_fh_reopen) { close (FH); open (FH, ">>$tmpfile") or die "Can't reopen $tmpfile"; } ok(-z $tmpfile, "fh resize to zero working (filename check)"); close FH; open(FH, ">>$tmpfile") or die "Can't open $tmpfile for appending"; binmode FH; select FH; $| = 1; select STDOUT; { use strict; print FH "x\n" x 200; ok(truncate(*FH{IO}, 100), "fh resize by IO slot"); } if ($needs_fh_reopen) { close (FH); open (FH, ">>$tmpfile") or die "Can't reopen $tmpfile"; } is(-s $tmpfile, 100, "fh resize by IO slot working"); close FH; } } # check if rename() can be used to just change case of filename SKIP: { skip "Works in Cygwin only if check_case is set to relaxed", 1 if ($ENV{'CYGWIN'} && ($ENV{'CYGWIN'} =~ /check_case:(?:adjust|strict)/)); chdir "./$tmpdir"; open(FH,'>x') || die "Can't create x"; close(FH); rename('x', 'X'); # this works on win32 only, because fs isn't casesensitive ok(-e 'X', "rename working"); 1 while unlink 'X'; chdir $wd || die "Can't cd back to $wd"; } # check if rename() works on directories if ($^O eq 'VMS') { # must have delete access to rename a directory `set file $tmpdir.dir/protection=o:d`; ok(rename("$tmpdir.dir", "$tmpdir1.dir"), "rename on directories") || print "# errno: $!\n"; } else { ok(rename($tmpdir, $tmpdir1), "rename on directories"); } ok(-d $tmpdir1, "rename on directories working"); { # Change 26011: Re: A surprising segfault # to make sure only that these obfuscated sentences will not crash. map chmod(+()), ('')x68; ok(1, "extend sp in pp_chmod"); map chown(+()), ('')x68; ok(1, "extend sp in pp_chown"); } # need to remove $tmpdir if rename() in test 28 failed! END { rmdir $tmpdir1; rmdir $tmpdir; } perl-5.12.0-RC0/t/io/perlio_fail.t0000555000175000017500000000213511325125742015457 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require "../t/test.pl"; skip_all("No perlio") unless (find PerlIO::Layer 'perlio'); plan (15); } use warnings 'layer'; my $warn; my $file = "fail$$"; $SIG{__WARN__} = sub { $warn = shift }; END { 1 while unlink($file) } ok(open(FH,">",$file),"Create works"); close(FH); ok(open(FH,"<",$file),"Normal open works"); $warn = ''; $! = 0; ok(!binmode(FH,":-)"),"All punctuation fails binmode"); print "# $!\n"; isnt($!,0,"Got errno"); like($warn,qr/in PerlIO layer/,"Got warning"); $warn = ''; $! = 0; ok(!binmode(FH,":nonesuch"),"Bad package fails binmode"); print "# $!\n"; isnt($!,0,"Got errno"); like($warn,qr/nonesuch/,"Got warning"); close(FH); $warn = ''; $! = 0; ok(!open(FH,"<:-)",$file),"All punctuation fails open"); print "# $!\n"; isnt($!,"","Got errno"); like($warn,qr/in PerlIO layer/,"Got warning"); $warn = ''; $! = 0; ok(!open(FH,"<:nonesuch",$file),"Bad package fails open"); print "# $!\n"; isnt($!,0,"Got errno"); like($warn,qr/nonesuch/,"Got warning"); ok(open(FH,"<",$file),"Normal open (still) works"); close(FH); perl-5.12.0-RC0/t/io/pvbm.t0000555000175000017500000000461311325125742014141 0ustar jessejesse#!./perl # Test that various IO functions don't try to treat PVBMs as # filehandles. Most of these will segfault perl if they fail. BEGIN { chdir 't' if -d 't'; @INC = qw(. ../lib); require "./test.pl"; } BEGIN { $| = 1 } plan(28); sub PVBM () { 'foo' } { my $dummy = index 'foo', PVBM } { my $which; { package Tie; sub TIEHANDLE { $which = 'TIEHANDLE' } sub TIESCALAR { $which = 'TIESCALAR' } } my $pvbm = PVBM; tie $pvbm, 'Tie'; is ($which, 'TIESCALAR', 'PVBM gets TIESCALAR'); } { my $pvbm = PVBM; ok (scalar eval { untie $pvbm; 1 }, 'untie(PVBM) doesn\'t segfault'); ok (scalar eval { tied $pvbm; 1 }, 'tied(PVBM) doesn\'t segfault'); } { my $pvbm = PVBM; ok (scalar eval { pipe $pvbm, PIPE; }, 'pipe(PVBM, ) succeeds'); close foo; close PIPE; ok (scalar eval { pipe PIPE, $pvbm; }, 'pipe(, PVBM) succeeds'); close foo; close PIPE; ok (!eval { pipe \$pvbm, PIPE; }, 'pipe(PVBM ref, ) fails'); ok (!eval { pipe PIPE, \$pvbm; }, 'pipe(, PVBM ref) fails'); ok (!eval { truncate $pvbm, 0 }, 'truncate(PVBM) fails'); ok (!eval { truncate \$pvbm, 0}, 'truncate(PVBM ref) fails'); ok (!eval { stat $pvbm }, 'stat(PVBM) fails'); ok (!eval { stat \$pvbm }, 'stat(PVBM ref) fails'); ok (!eval { lstat $pvbm }, 'lstat(PVBM) fails'); ok (!eval { lstat \$pvbm }, 'lstat(PVBM ref) fails'); ok (!eval { chdir $pvbm }, 'chdir(PVBM) fails'); ok (!eval { chdir \$pvbm }, 'chdir(pvbm ref) fails'); ok (!eval { close $pvbm }, 'close(PVBM) fails'); ok (!eval { close $pvbm }, 'close(PVBM ref) fails'); ok (!eval { chmod 0600, $pvbm }, 'chmod(PVBM) fails'); ok (!eval { chmod 0600, \$pvbm }, 'chmod(PVBM ref) fails'); SKIP: { skip('chown() not implemented on Win32', 2) if $^O eq 'MSWin32'; ok (!eval { chown 0, 0, $pvbm }, 'chown(PVBM) fails'); ok (!eval { chown 0, 0, \$pvbm }, 'chown(PVBM ref) fails'); } ok (!eval { utime 0, 0, $pvbm }, 'utime(PVBM) fails'); ok (!eval { utime 0, 0, \$pvbm }, 'utime(PVBM ref) fails'); ok (!eval { <$pvbm> }, ' fails'); ok (!eval { readline $pvbm }, 'readline(PVBM) fails'); ok (!eval { readline \$pvbm }, 'readline(PVBM ref) fails'); ok (!eval { open $pvbm, '<', 'none.such' }, 'open(PVBM) fails'); ok (!eval { open \$pvbm, '<', 'none.such', }, 'open(PVBM ref) fails'); } perl-5.12.0-RC0/t/io/layers.t0000555000175000017500000001315611325127001014464 0ustar jessejesse#!./perl my $PERLIO; BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; unless (find PerlIO::Layer 'perlio') { print "1..0 # Skip: not perlio\n"; exit 0; } eval 'use Encode'; if ($@ =~ /dynamic loading not available/) { print "1..0 # miniperl cannot load Encode\n"; exit 0; } # Makes testing easier. $ENV{PERLIO} = 'stdio' if exists $ENV{PERLIO} && $ENV{PERLIO} eq ''; if (exists $ENV{PERLIO} && $ENV{PERLIO} !~ /^(stdio|perlio|mmap)$/) { # We are not prepared for anything else. print "1..0 # PERLIO='$ENV{PERLIO}' unknown\n"; exit 0; } $PERLIO = exists $ENV{PERLIO} ? $ENV{PERLIO} : "(undef)"; } use Config; my $DOSISH = $^O =~ /^(?:MSWin32|os2|dos|NetWare)$/ ? 1 : 0; $DOSISH = 1 if !$DOSISH and $^O =~ /^uwin/; my $NONSTDIO = exists $ENV{PERLIO} && $ENV{PERLIO} ne 'stdio' ? 1 : 0; my $FASTSTDIO = $Config{d_faststdio} && $Config{usefaststdio} ? 1 : 0; my $UTF8_STDIN; if (${^UNICODE} & 1) { if (${^UNICODE} & 64) { # Conditional on the locale $UTF8_STDIN = ${^UTF8LOCALE}; } else { # Unconditional $UTF8_STDIN = 1; } } else { $UTF8_STDIN = 0; } my $NTEST = 44 - (($DOSISH || !$FASTSTDIO) ? 7 : 0) - ($DOSISH ? 5 : 0) + $UTF8_STDIN; sub PerlIO::F_UTF8 () { 0x00008000 } # from perliol.h plan tests => $NTEST; print <<__EOH__; # PERLIO = $PERLIO # DOSISH = $DOSISH # NONSTDIO = $NONSTDIO # FASTSTDIO = $FASTSTDIO # UNICODE = ${^UNICODE} # UTF8LOCALE = ${^UTF8LOCALE} # UTF8_STDIN = $UTF8_STDIN __EOH__ SKIP: { # FIXME - more of these could be tested without Encode or full perl skip("This perl does not have Encode", $NTEST) unless " $Config{extensions} " =~ / Encode /; skip("miniperl does not have Encode", $NTEST) if $ENV{PERL_CORE_MINITEST}; sub check { my ($result, $expected, $id) = @_; # An interesting dance follows where we try to make the following # IO layer stack setups to compare equal: # # PERLIO UNIX-like DOS-like # # unset / "" unix perlio / stdio [1] unix crlf # stdio unix perlio / stdio [1] stdio # perlio unix perlio unix perlio # mmap unix mmap unix mmap # # [1] "stdio" if Configure found out how to do "fast stdio" (depends # on the stdio implementation) and in Perl 5.8, otherwise "unix perlio" # if ($NONSTDIO) { # Get rid of "unix". shift @$result if $result->[0] eq "unix"; # Change expectations. if ($FASTSTDIO) { $expected->[0] = $ENV{PERLIO}; } else { $expected->[0] = $ENV{PERLIO} if $expected->[0] eq "stdio"; } } elsif (!$FASTSTDIO && !$DOSISH) { splice(@$result, 0, 2, "stdio") if @$result >= 2 && $result->[0] eq "unix" && $result->[1] eq "perlio"; } elsif ($DOSISH) { splice(@$result, 0, 2, "stdio") if @$result >= 2 && $result->[0] eq "unix" && $result->[1] eq "crlf"; } if ($DOSISH && grep { $_ eq 'crlf' } @$expected) { # 5 tests potentially skipped because # DOSISH systems already have a CRLF layer # which will make new ones not stick. @$expected = grep { $_ ne 'crlf' } @$expected; } my $n = scalar @$expected; is(scalar @$result, $n, "$id - layers == $n"); for (my $i = 0; $i < $n; $i++) { my $j = $expected->[$i]; if (ref $j eq 'CODE') { ok($j->($result->[$i]), "$id - $i is ok"); } else { is($result->[$i], $j, sprintf("$id - $i is %s", defined $j ? $j : "undef")); } } } check([ PerlIO::get_layers(STDIN) ], $UTF8_STDIN ? [ "stdio", "utf8" ] : [ "stdio" ], "STDIN"); my $afile = tempfile(); open(F, ">:crlf", $afile); check([ PerlIO::get_layers(F) ], [ qw(stdio crlf) ], "open :crlf"); binmode(F, ":encoding(cp1047)"); check([ PerlIO::get_layers(F) ], [ qw[stdio crlf encoding(cp1047) utf8] ], ":encoding(cp1047)"); binmode(F, ":pop"); check([ PerlIO::get_layers(F) ], [ qw(stdio crlf) ], ":pop"); binmode(F, ":raw"); check([ PerlIO::get_layers(F) ], [ "stdio" ], ":raw"); binmode(F, ":utf8"); check([ PerlIO::get_layers(F) ], [ qw(stdio utf8) ], ":utf8"); binmode(F, ":bytes"); check([ PerlIO::get_layers(F) ], [ "stdio" ], ":bytes"); binmode(F, ":encoding(utf8)"); check([ PerlIO::get_layers(F) ], [ qw[stdio encoding(utf8) utf8] ], ":encoding(utf8)"); binmode(F, ":raw :crlf"); check([ PerlIO::get_layers(F) ], [ qw(stdio crlf) ], ":raw:crlf"); binmode(F, ":raw :encoding(latin1)"); # "latin1" will be canonized # 7 tests potentially skipped. unless ($DOSISH || !$FASTSTDIO) { my @results = PerlIO::get_layers(F, details => 1); # Get rid of the args and the flags. splice(@results, 1, 2) if $NONSTDIO; check([ @results ], [ "stdio", undef, sub { $_[0] > 0 }, "encoding", "iso-8859-1", sub { $_[0] & PerlIO::F_UTF8() } ], ":raw:encoding(latin1)"); } binmode(F); check([ PerlIO::get_layers(F) ], [ "stdio" ], "binmode"); close F; { use open(IN => ":crlf", OUT => ":encoding(cp1252)"); open F, '<', $afile; open G, '>', $afile; check([ PerlIO::get_layers(F, input => 1) ], [ qw(stdio crlf) ], "use open IN"); check([ PerlIO::get_layers(G, output => 1) ], [ qw[stdio encoding(cp1252) utf8] ], "use open OUT"); close F; close G; } # Check that PL_sigwarn's reference count is correct, and that # &PerlIO::Layer::NoWarnings isn't prematurely freed. fresh_perl_like (<<"EOT", qr/^CODE/); open(UTF, "<:raw:encoding(utf8)", '$afile') or die \$!; print ref *PerlIO::Layer::NoWarnings{CODE}; EOT } perl-5.12.0-RC0/t/io/nargv.t0000555000175000017500000000223611325125742014311 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require "./test.pl"; } print "1..5\n"; my $j = 1; for $i ( 1,2,5,4,3 ) { $file = mkfiles($i); open(FH, "> $file") || die "can't create $file: $!"; print FH "not ok " . $j++ . "\n"; close(FH) || die "Can't close $file: $!"; } { local *ARGV; local $^I = '.bak'; local $_; @ARGV = mkfiles(1..3); $n = 0; while (<>) { print STDOUT "# initial \@ARGV: [@ARGV]\n"; if ($n++ == 2) { other(); } show(); } } $^I = undef; @ARGV = mkfiles(1..3); $n = 0; while (<>) { print STDOUT "#final \@ARGV: [@ARGV]\n"; if ($n++ == 2) { other(); } show(); } sub show { #warn "$ARGV: $_"; s/^not //; print; } sub other { no warnings 'once'; print STDOUT "# Calling other\n"; local *ARGV; local *ARGVOUT; local $_; @ARGV = mkfiles(5, 4); while (<>) { print STDOUT "# inner \@ARGV: [@ARGV]\n"; show(); } } my @files; sub mkfiles { foreach (@_) { $files[$_] ||= tempfile(); } my @results = @files[@_]; return wantarray ? @results : @results[-1]; } END { unlink map { ($_, "$_.bak") } mkfiles(1..5) } perl-5.12.0-RC0/t/io/iprefix.t0000555000175000017500000000130311325125742014634 0ustar jessejesse#!./perl use strict; require './test.pl'; $^I = 'bak.*'; # Modified from the original inplace.t to test adding prefixes plan( tests => 2 ); my @tfiles = (tempfile(), tempfile(), tempfile()); my @tfiles_bak = map "bak.$_", @tfiles; END { unlink_all(@tfiles_bak); } for my $file (@tfiles) { runperl( prog => 'print qq(foo\n);', args => ['>', $file] ); } @ARGV = @tfiles; while (<>) { s/foo/bar/; } continue { print; } is ( runperl( prog => 'print<>;', args => \@tfiles ), "bar\nbar\nbar\n", "file contents properly replaced" ); is ( runperl( prog => 'print<>;', args => \@tfiles_bak ), "foo\nfoo\nfoo\n", "backup file contents stay the same" ); perl-5.12.0-RC0/t/io/argv.t0000555000175000017500000000603711325125742014136 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } BEGIN { require "./test.pl"; } plan(tests => 23); use File::Spec; my $devnull = File::Spec->devnull; open(TRY, '>Io_argv1.tmp') || (die "Can't open temp file: $!"); print TRY "a line\n"; close TRY or die "Could not close: $!"; $x = runperl( prog => 'while (<>) { print $., $_; }', args => [ 'Io_argv1.tmp', 'Io_argv1.tmp' ], ); is($x, "1a line\n2a line\n", '<> from two files'); { $x = runperl( prog => 'while (<>) { print $_; }', stdin => "foo\n", args => [ 'Io_argv1.tmp', '-' ], ); is($x, "a line\nfoo\n", ' from a file and STDIN'); $x = runperl( prog => 'while (<>) { print $_; }', stdin => "foo\n", ); is($x, "foo\n", ' from just STDIN'); } { # 5.10 stopped autovivifying scalars in globs leading to a # segfault when $ARGV is written to. runperl( prog => 'eof()', stdin => "nothing\n" ); is( 0+$?, 0, q(eof() doesn't segfault) ); } @ARGV = ('Io_argv1.tmp', 'Io_argv1.tmp', $devnull, 'Io_argv1.tmp'); while (<>) { $y .= $. . $_; if (eof()) { is($., 3, '$. counts <>'); } } is($y, "1a line\n2a line\n3a line\n", '<> from @ARGV'); open(TRY, '>Io_argv1.tmp') or die "Can't open temp file: $!"; close TRY or die "Could not close: $!"; open(TRY, '>Io_argv2.tmp') or die "Can't open temp file: $!"; close TRY or die "Could not close: $!"; @ARGV = ('Io_argv1.tmp', 'Io_argv2.tmp'); $^I = '_bak'; # not .bak which confuses VMS $/ = undef; my $i = 7; while (<>) { s/^/ok $i\n/; ++$i; print; next_test(); } open(TRY, '; open(TRY, '; close TRY or die "Could not close: $!"; undef $^I; ok( eof TRY ); { no warnings 'once'; ok( eof NEVEROPENED, 'eof() true on unopened filehandle' ); } open STDIN, 'Io_argv1.tmp' or die $!; @ARGV = (); ok( !eof(), 'STDIN has something' ); is( <>, "ok 7\n" ); open STDIN, $devnull or die $!; @ARGV = (); ok( eof(), 'eof() true with empty @ARGV' ); @ARGV = ('Io_argv1.tmp'); ok( !eof() ); @ARGV = ($devnull, $devnull); ok( !eof() ); close ARGV or die $!; ok( eof(), 'eof() true after closing ARGV' ); { local $/; open F, 'Io_argv1.tmp' or die "Could not open Io_argv1.tmp: $!"; ; # set $. = 1 is( , undef ); open F, $devnull or die; ok( defined() ); is( , undef ); is( , undef ); open F, $devnull or die; # restart cycle again ok( defined() ); is( , undef ); close F or die "Could not close: $!"; } # This used to dump core fresh_perl_is( <<'**PROG**', "foobar", {}, "ARGV aliasing and eof()" ); open OUT, ">Io_argv3.tmp" or die "Can't open temp file: $!"; print OUT "foo"; close OUT; open IN, "Io_argv3.tmp" or die "Can't open temp file: $!"; *ARGV = *IN; while (<>) { print; print "bar" if eof(); } close IN; unlink "Io_argv3.tmp"; **PROG** END { 1 while unlink 'Io_argv1.tmp', 'Io_argv1.tmp_bak', 'Io_argv2.tmp', 'Io_argv2.tmp_bak', 'Io_argv3.tmp'; } perl-5.12.0-RC0/t/io/errno.t0000555000175000017500000000235611350231132014311 0ustar jessejesse#!./perl # vim: ts=4 sts=4 sw=4: # $! may not be set if EOF was reached without any error. # http://rt.perl.org/rt3/Ticket/Display.html?id=39060 use strict; use Config; require './test.pl'; plan( tests => 16 ); my $test_prog = 'undef $!;while(<>){print}; print $!'; my $saved_perlio; BEGIN { $saved_perlio = $ENV{PERLIO}; } END { delete $ENV{PERLIO}; $ENV{PERLIO} = $saved_perlio if defined $saved_perlio; } for my $perlio ('perlio', 'stdio') { $ENV{PERLIO} = $perlio; SKIP: for my $test_in ("test\n", "test") { skip("Guaranteed newline at EOF on VMS", 4) if $^O eq 'VMS' && $test_in eq 'test'; skip("[perl #71504] OpenBSD test failures in errno.t with ithreads and perlio", 8) if $^O eq 'openbsd' && $Config{useithreads} && $perlio eq 'stdio'; my $test_in_esc = $test_in; $test_in_esc =~ s/\n/\\n/g; for my $rs_code ('', '$/=undef', '$/=\2', '$/=\1024') { TODO: { local $::TODO = "We get RMS\$_IOP at EOF on VMS when \$/ is undef" if $^O eq 'VMS' && $rs_code eq '$/=undef'; is( runperl( prog => "$rs_code; $test_prog", stdin => $test_in, stderr => 1), $test_in, "Wrong errno, PERLIO=$ENV{PERLIO} stdin='$test_in_esc', $rs_code"); } } } } perl-5.12.0-RC0/t/io/utf8.t0000555000175000017500000001767211325125742014074 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; unless (find PerlIO::Layer 'perlio') { print "1..0 # Skip: not perlio\n"; exit 0; } } no utf8; # needed for use utf8 not griping about the raw octets BEGIN { require "./test.pl"; } plan(tests => 55); $| = 1; my $a_file = tempfile(); open(F,"+>:utf8",$a_file); print F chr(0x100).'£'; cmp_ok( tell(F), '==', 4, tell(F) ); print F "\n"; cmp_ok( tell(F), '>=', 5, tell(F) ); seek(F,0,0); is( getc(F), chr(0x100) ); is( getc(F), "£" ); is( getc(F), "\n" ); seek(F,0,0); binmode(F,":bytes"); my $chr = chr(0xc4); if (ord($a_file) == 193) { $chr = chr(0x8c); } # EBCDIC is( getc(F), $chr ); $chr = chr(0x80); if (ord($a_file) == 193) { $chr = chr(0x41); } # EBCDIC is( getc(F), $chr ); $chr = chr(0xc2); if (ord($a_file) == 193) { $chr = chr(0x80); } # EBCDIC is( getc(F), $chr ); $chr = chr(0xa3); if (ord($a_file) == 193) { $chr = chr(0x44); } # EBCDIC is( getc(F), $chr ); is( getc(F), "\n" ); seek(F,0,0); binmode(F,":utf8"); is( scalar(), "\x{100}£\n" ); seek(F,0,0); $buf = chr(0x200); $count = read(F,$buf,2,1); cmp_ok( $count, '==', 2 ); is( $buf, "\x{200}\x{100}£" ); close(F); { $a = chr(300); # This *is* UTF-encoded $b = chr(130); # This is not. open F, ">:utf8", $a_file or die $!; print F $a,"\n"; close F; open F, "<:utf8", $a_file or die $!; $x = ; chomp($x); is( $x, chr(300) ); open F, $a_file or die $!; # Not UTF binmode(F, ":bytes"); $x = ; chomp($x); $chr = chr(196).chr(172); if (ord($a_file) == 193) { $chr = chr(141).chr(83); } # EBCDIC is( $x, $chr ); close F; open F, ">:utf8", $a_file or die $!; binmode(F); # we write a "\n" and then tell() - avoid CRLF issues. binmode(F,":utf8"); # turn UTF-8-ness back on print F $a; my $y; { my $x = tell(F); { use bytes; $y = length($a);} cmp_ok( $x, '==', $y ); } { # Check byte length of $b use bytes; my $y = length($b); cmp_ok( $y, '==', 1 ); } print F $b,"\n"; # Don't upgrades $b { # Check byte length of $b use bytes; my $y = length($b); cmp_ok( $y, '==', 1 ); } { my $x = tell(F); { use bytes; if (ord('A')==193){$y += 2;}else{$y += 3;}} # EBCDIC ASCII cmp_ok( $x, '==', $y ); } close F; open F, $a_file or die $!; # Not UTF binmode(F, ":bytes"); $x = ; chomp($x); $chr = v196.172.194.130; if (ord('A') == 193) { $chr = v141.83.130; } # EBCDIC is( $x, $chr, sprintf('(%vd)', $x) ); open F, "<:utf8", $a_file or die $!; $x = ; chomp($x); close F; is( $x, chr(300).chr(130), sprintf('(%vd)', $x) ); open F, ">", $a_file or die $!; binmode(F, ":bytes:"); # Now let's make it suffer. my $w; { use warnings 'utf8'; local $SIG{__WARN__} = sub { $w = $_[0] }; print F $a; ok( (!$@)); like($w, qr/Wide character in print/i ); } } # Hm. Time to get more evil. open F, ">:utf8", $a_file or die $!; print F $a; binmode(F, ":bytes"); print F chr(130)."\n"; close F; open F, "<", $a_file or die $!; binmode(F, ":bytes"); $x = ; chomp $x; $chr = v196.172.130; if (ord('A') == 193) { $chr = v141.83.130; } # EBCDIC is( $x, $chr ); # Right. open F, ">:utf8", $a_file or die $!; print F $a; close F; open F, ">>", $a_file or die $!; binmode(F, ":bytes"); print F chr(130)."\n"; close F; open F, "<", $a_file or die $!; binmode(F, ":bytes"); $x = ; chomp $x; SKIP: { skip("Defaulting to UTF-8 output means that we can't generate a mangled file") if $UTF8_OUTPUT; is( $x, $chr ); } # Now we have a deformed file. SKIP: { if (ord('A') == 193) { skip("EBCDIC doesn't complain", 2); } else { my @warnings; open F, "<:utf8", $a_file or die $!; $x = ; chomp $x; local $SIG{__WARN__} = sub { push @warnings, $_[0]; }; eval { sprintf "%vd\n", $x }; is (scalar @warnings, 1); like ($warnings[0], qr/Malformed UTF-8 character \(unexpected continuation byte 0x82, with no preceding start byte/); } } close F; unlink($a_file); open F, ">:utf8", $a_file; @a = map { chr(1 << ($_ << 2)) } 0..5; # 0x1, 0x10, .., 0x100000 unshift @a, chr(0); # ... and a null byte in front just for fun print F @a; close F; my $c; # read() should work on characters, not bytes open F, "<:utf8", $a_file; $a = 0; my $failed; for (@a) { unless (($c = read(F, $b, 1) == 1) && length($b) == 1 && ord($b) == ord($_) && tell(F) == ($a += bytes::length($b))) { print '# ord($_) == ', ord($_), "\n"; print '# ord($b) == ', ord($b), "\n"; print '# length($b) == ', length($b), "\n"; print '# bytes::length($b) == ', bytes::length($b), "\n"; print '# tell(F) == ', tell(F), "\n"; print '# $a == ', $a, "\n"; print '# $c == ', $c, "\n"; $failed++; last; } } close F; is($failed, undef); { # Check that warnings are on on I/O, and that they can be muffled. local $SIG{__WARN__} = sub { $@ = shift }; undef $@; open F, ">$a_file"; binmode(F, ":bytes"); print F chr(0x100); close(F); like( $@, 'Wide character in print' ); undef $@; open F, ">:utf8", $a_file; print F chr(0x100); close(F); isnt( defined $@, !0 ); undef $@; open F, ">$a_file"; binmode(F, ":utf8"); print F chr(0x100); close(F); isnt( defined $@, !0 ); no warnings 'utf8'; undef $@; open F, ">$a_file"; print F chr(0x100); close(F); isnt( defined $@, !0 ); use warnings 'utf8'; undef $@; open F, ">$a_file"; binmode(F, ":bytes"); print F chr(0x100); close(F); like( $@, 'Wide character in print' ); } { open F, ">:bytes",$a_file; print F "\xde"; close F; open F, "<:bytes", $a_file; my $b = chr 0x100; $b .= ; is( $b, chr(0x100).chr(0xde), "21395 '.= <>' utf8 vs. bytes" ); close F; } { open F, ">:utf8",$a_file; print F chr 0x100; close F; open F, "<:utf8", $a_file; my $b = "\xde"; $b .= ; is( $b, chr(0xde).chr(0x100), "21395 '.= <>' bytes vs. utf8" ); close F; } { my @a = ( [ 0x007F, "bytes" ], [ 0x0080, "bytes" ], [ 0x0080, "utf8" ], [ 0x0100, "utf8" ] ); my $t = 34; for my $u (@a) { for my $v (@a) { # print "# @$u - @$v\n"; open F, ">$a_file"; binmode(F, ":" . $u->[1]); print F chr($u->[0]); close F; open F, "<$a_file"; binmode(F, ":" . $u->[1]); my $s = chr($v->[0]); utf8::upgrade($s) if $v->[1] eq "utf8"; $s .= ; is( $s, chr($v->[0]) . chr($u->[0]), 'rcatline utf8' ); close F; $t++; } } # last test here 49 } { # [perl #23428] Somethings rotten in unicode semantics open F, ">$a_file"; binmode F, ":utf8"; syswrite(F, $a = chr(0x100)); close F; is( ord($a), 0x100, '23428 syswrite should not downgrade scalar' ); like( $a, qr/^\w+/, '23428 syswrite should not downgrade scalar' ); } # sysread() and syswrite() tested in lib/open.t since Fcntl is used { # on a :utf8 stream should complain immediately with -w # if it finds bad UTF-8 (:encoding(utf8) works this way) use warnings 'utf8'; undef $@; local $SIG{__WARN__} = sub { $@ = shift }; open F, ">$a_file"; binmode F; my ($chrE4, $chrF6) = (chr(0xE4), chr(0xF6)); if (ord('A') == 193) # EBCDIC { ($chrE4, $chrF6) = (chr(0x43), chr(0xEC)); } print F "foo", $chrE4, "\n"; print F "foo", $chrF6, "\n"; close F; open F, "<:utf8", $a_file; undef $@; my $line = ; my ($chrE4, $chrF6) = ("E4", "F6"); if (ord('A') == 193) { ($chrE4, $chrF6) = ("43", "EC"); } # EBCDIC like( $@, qr/utf8 "\\x$chrE4" does not map to Unicode .+ line 1/, "<:utf8 readline must warn about bad utf8"); undef $@; $line .= ; like( $@, qr/utf8 "\\x$chrF6" does not map to Unicode .+ line 2/, "<:utf8 rcatline must warn about bad utf8"); close F; } perl-5.12.0-RC0/t/io/perlio_leaks.t0000555000175000017500000000124311325127001015630 0ustar jessejesse#!perl # ioleaks.t BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } use strict; use warnings; plan 'no_plan'; # :unix -> not ok # :stdio -> not ok # :perlio -> ok # :crlf -> ok TODO: { foreach my $layer(qw(:unix :stdio :perlio :crlf)){ my $base_fd = do{ open my $in, '<', $0 or die $!; fileno $in }; for(1 .. 3){ local $::TODO; if ($_ > 1 && $layer =~ /^:(unix|stdio)$/) { $::TODO = "[perl #56644] PerlIO resource leaks on open() and then :pop in :unix and :stdio" } open my $fh, "<$layer", $0 or die $!; is fileno($fh), $base_fd, $layer; binmode $fh, ':pop'; } } } perl-5.12.0-RC0/t/io/pipe.t0000555000175000017500000001443611325127001014124 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require Config; import Config; require './test.pl'; if (!$Config{'d_fork'}) { skip_all("fork required to pipe"); } else { plan(tests => 24); } } my $Perl = which_perl(); $| = 1; open(PIPE, "|-") || exec $Perl, '-pe', 'tr/YX/ko/'; printf PIPE "Xk %d - open |- || exec\n", curr_test(); next_test(); printf PIPE "oY %d - again\n", curr_test(); next_test(); close PIPE; SKIP: { # Technically this should be TODO. Someone try it if you happen to # have a vmesa machine. skip "Doesn't work here yet", 6 if $^O eq 'vmesa'; if (open(PIPE, "-|")) { while() { s/^not //; print; } close PIPE; # avoid zombies } else { printf STDOUT "not ok %d - open -|\n", curr_test(); next_test(); my $tnum = curr_test; next_test(); exec $Perl, '-le', "print q{not ok $tnum - again}"; } # This has to be *outside* the fork next_test() for 1..2; my $raw = "abc\nrst\rxyz\r\nfoo\n"; if (open(PIPE, "-|")) { $_ = join '', ; (my $raw1 = $_) =~ s/not ok \d+ - //; my @r = map ord, split //, $raw; my @r1 = map ord, split //, $raw1; if ($raw1 eq $raw) { s/^not (ok \d+ -) .*/$1 '@r1' passes through '-|'\n/s; } else { s/^(not ok \d+ -) .*/$1 expect '@r', got '@r1'\n/s; } print; close PIPE; # avoid zombies } else { printf STDOUT "not ok %d - $raw", curr_test(); exec $Perl, '-e0'; # Do not run END()... } # This has to be *outside* the fork next_test(); if (open(PIPE, "|-")) { printf PIPE "not ok %d - $raw", curr_test(); close PIPE; # avoid zombies } else { $_ = join '', ; (my $raw1 = $_) =~ s/not ok \d+ - //; my @r = map ord, split //, $raw; my @r1 = map ord, split //, $raw1; if ($raw1 eq $raw) { s/^not (ok \d+ -) .*/$1 '@r1' passes through '|-'\n/s; } else { s/^(not ok \d+ -) .*/$1 expect '@r', got '@r1'\n/s; } print; exec $Perl, '-e0'; # Do not run END()... } # This has to be *outside* the fork next_test(); SKIP: { skip "fork required", 2 unless $Config{d_fork}; pipe(READER,WRITER) || die "Can't open pipe"; if ($pid = fork) { close WRITER; while() { s/^not //; y/A-Z/a-z/; print; } close READER; # avoid zombies } else { die "Couldn't fork" unless defined $pid; close READER; printf WRITER "not ok %d - pipe & fork\n", curr_test; next_test; open(STDOUT,">&WRITER") || die "Can't dup WRITER to STDOUT"; close WRITER; my $tnum = curr_test; next_test; exec $Perl, '-le', "print q{not ok $tnum - with fh dup }"; } # This has to be done *outside* the fork. next_test() for 1..2; } } wait; # Collect from $pid pipe(READER,WRITER) || die "Can't open pipe"; close READER; $SIG{'PIPE'} = 'broken_pipe'; sub broken_pipe { $SIG{'PIPE'} = 'IGNORE'; # loop preventer printf "ok %d - SIGPIPE\n", curr_test; } printf WRITER "not ok %d - SIGPIPE\n", curr_test; close WRITER; sleep 1; next_test; pass(); # VMS doesn't like spawning subprocesses that are still connected to # STDOUT. Someone should modify these tests to work with VMS. SKIP: { skip "doesn't like spawning subprocesses that are still connected", 10 if $^O eq 'VMS'; SKIP: { # Sfio doesn't report failure when closing a broken pipe # that has pending output. Go figure. # BeOS will not write to broken pipes, either. # Nor does POSIX-BC. skip "Won't report failure on broken pipe", 1 if $Config{d_sfio} || $^O eq 'beos' || $^O eq 'posix-bc'; local $SIG{PIPE} = 'IGNORE'; open NIL, qq{|$Perl -e "exit 0"} or die "open failed: $!"; sleep 5; if (print NIL 'foo') { # If print was allowed we had better get an error on close ok( !close NIL, 'close error on broken pipe' ); } else { ok(close NIL, 'print failed on broken pipe'); } } SKIP: { skip "Don't work yet", 9 if $^O eq 'vmesa'; # check that errno gets forced to 0 if the piped program exited # non-zero open NIL, qq{|$Perl -e "exit 23";} or die "fork failed: $!"; $! = 1; ok(!close NIL, 'close failure on non-zero piped exit'); is($!, '', ' errno'); isnt($?, 0, ' status'); SKIP: { skip "Don't work yet", 6 if $^O eq 'mpeix'; # check that status for the correct process is collected my $zombie; unless( $zombie = fork ) { $NO_ENDING=1; exit 37; } my $pipe = open *FH, "sleep 2;exit 13|" or die "Open: $!\n"; $SIG{ALRM} = sub { return }; alarm(1); is( close FH, '', 'close failure for... umm, something' ); is( $?, 13*256, ' status' ); is( $!, '', ' errno'); my $wait = wait; is( $?, 37*256, 'status correct after wait' ); is( $wait, $zombie, ' wait pid' ); is( $!, '', ' errno'); } } } # Test new semantics for missing command in piped open # 19990114 M-J. Dominus mjd@plover.com { local *P; no warnings 'pipe'; ok( !open(P, "| "), 'missing command in piped open input' ); ok( !open(P, " |"), ' output'); } # check that status is unaffected by implicit close { local(*NIL); open NIL, qq{|$Perl -e "exit 23"} or die "fork failed: $!"; $? = 42; # NIL implicitly closed here } is($?, 42, 'status unaffected by implicit close'); $? = 0; # check that child is reaped if the piped program can't be executed SKIP: { skip "/no_such_process exists", 1 if -e "/no_such_process"; open NIL, '/no_such_process |'; close NIL; my $child = 0; eval { local $SIG{ALRM} = sub { die; }; alarm 2; $child = wait; alarm 0; }; is($child, -1, 'child reaped if piped program cannot be executed'); } perl-5.12.0-RC0/t/io/perlio_open.t0000555000175000017500000000173311325127001015476 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; if ($ENV{PERL_CORE_MINITEST}) { print "1..0 # Skip: no Fcntl under miniperl\n"; exit 0; } unless (find PerlIO::Layer 'perlio') { print "1..0 # Skip: not perlio\n"; exit 0; } use Config; unless (" $Config{extensions} " =~ / Fcntl /) { print "1..0 # Skip: no Fcntl (how did you get this far?)\n"; exit 0; } require './test.pl'; } use strict; use warnings; plan tests => 6; use Fcntl qw(:seek); { ok((open my $fh, "+>", undef), "open my \$fh, '+>', undef"); print $fh "the right write stuff"; ok(seek($fh, 0, SEEK_SET), "seek to zero"); my $data = <$fh>; is($data, "the right write stuff", "found the right stuff"); } { ok((open my $fh, "+<", undef), "open my \$fh, '+<', undef"); print $fh "the right read stuff"; ok(seek($fh, 0, SEEK_SET), "seek to zero"); my $data = <$fh>; is($data, "the right read stuff", "found the right stuff"); } perl-5.12.0-RC0/t/io/open.t0000555000175000017500000002147411325127001014130 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } $| = 1; use warnings; use Config; plan tests => 108; my $Perl = which_perl(); my $afile = tempfile(); { unlink($afile) if -f $afile; $! = 0; # the -f above will set $! if $afile doesn't exist. ok( open(my $f,"+>$afile"), 'open(my $f, "+>...")' ); binmode $f; ok( -f $afile, ' its a file'); ok( (print $f "SomeData\n"), ' we can print to it'); is( tell($f), 9, ' tell()' ); ok( seek($f,0,0), ' seek set' ); $b = <$f>; is( $b, "SomeData\n", ' readline' ); ok( -f $f, ' still a file' ); eval { die "Message" }; like( $@, qr/<\$f> line 1/, ' die message correct' ); ok( close($f), ' close()' ); ok( unlink($afile), ' unlink()' ); } { ok( open(my $f,'>', $afile), "open(my \$f, '>', $afile)" ); ok( (print $f "a row\n"), ' print'); ok( close($f), ' close' ); ok( -s $afile < 10, ' -s' ); } { ok( open(my $f,'>>', $afile), "open(my \$f, '>>', $afile)" ); ok( (print $f "a row\n"), ' print' ); ok( close($f), ' close' ); ok( -s $afile > 10, ' -s' ); } { ok( open(my $f, '<', $afile), "open(my \$f, '<', $afile)" ); my @rows = <$f>; is( scalar @rows, 2, ' readline, list context' ); is( $rows[0], "a row\n", ' first line read' ); is( $rows[1], "a row\n", ' second line' ); ok( close($f), ' close' ); } { ok( -s $afile < 20, '-s' ); ok( open(my $f, '+<', $afile), 'open +<' ); my @rows = <$f>; is( scalar @rows, 2, ' readline, list context' ); ok( seek($f, 0, 1), ' seek cur' ); ok( (print $f "yet another row\n"), ' print' ); ok( close($f), ' close' ); ok( -s $afile > 20, ' -s' ); unlink($afile); } { ok( open(my $f, '-|', <; is( scalar @rows, 2, ' readline, list context' ); ok( close($f), ' close' ); } { ok( open(my $f, '|-', <; my $test = curr_test; print $f "not ok $test - piped in\n"; next_test; $test = curr_test; print $f "not ok $test - piped in\n"; next_test; ok( close($f), ' close' ); sleep 1; pass('flushing'); } ok( !eval { open my $f, '<&', $afile; 1; }, '<& on a non-filehandle' ); like( $@, qr/Bad filehandle:\s+$afile/, ' right error' ); # local $file tests { unlink($afile) if -f $afile; ok( open(local $f,"+>$afile"), 'open local $f, "+>", ...' ); binmode $f; ok( -f $afile, ' -f' ); ok( (print $f "SomeData\n"), ' print' ); is( tell($f), 9, ' tell' ); ok( seek($f,0,0), ' seek set' ); $b = <$f>; is( $b, "SomeData\n", ' readline' ); ok( -f $f, ' still a file' ); eval { die "Message" }; like( $@, qr/<\$f> line 1/, ' proper die message' ); ok( close($f), ' close' ); unlink($afile); } { ok( open(local $f,'>', $afile), 'open local $f, ">", ...' ); ok( (print $f "a row\n"), ' print'); ok( close($f), ' close'); ok( -s $afile < 10, ' -s' ); } { ok( open(local $f,'>>', $afile), 'open local $f, ">>", ...' ); ok( (print $f "a row\n"), ' print'); ok( close($f), ' close'); ok( -s $afile > 10, ' -s' ); } { ok( open(local $f, '<', $afile), 'open local $f, "<", ...' ); my @rows = <$f>; is( scalar @rows, 2, ' readline list context' ); ok( close($f), ' close' ); } ok( -s $afile < 20, ' -s' ); { ok( open(local $f, '+<', $afile), 'open local $f, "+<", ...' ); my @rows = <$f>; is( scalar @rows, 2, ' readline list context' ); ok( seek($f, 0, 1), ' seek cur' ); ok( (print $f "yet another row\n"), ' print' ); ok( close($f), ' close' ); ok( -s $afile > 20, ' -s' ); unlink($afile); } { ok( open(local $f, '-|', <; is( scalar @rows, 2, ' readline list context' ); ok( close($f), ' close' ); } { ok( open(local $f, '|-', <; my $test = curr_test; print $f "not ok $test - piping\n"; next_test; $test = curr_test; print $f "not ok $test - piping\n"; next_test; ok( close($f), ' close' ); sleep 1; pass("Flush"); } ok( !eval { open local $f, '<&', $afile; 1 }, 'local <& on non-filehandle'); like( $@, qr/Bad filehandle:\s+$afile/, ' right error' ); { local *F; for (1..2) { ok( open(F, qq{$Perl -le "print 'ok'"|}), 'open to pipe' ); is(scalar , "ok\n", ' readline'); ok( close F, ' close' ); } for (1..2) { ok( open(F, "-|", qq{$Perl -le "print 'ok'"}), 'open -|'); is( scalar , "ok\n", ' readline'); ok( close F, ' close' ); } } # other dupping techniques { ok( open(my $stdout, ">&", \*STDOUT), 'dup \*STDOUT into lexical fh'); ok( open(STDOUT, ">&", $stdout), 'restore dupped STDOUT from lexical fh'); { use strict; # the below should not warn ok( open(my $stdout, ">&", STDOUT), 'dup STDOUT into lexical fh'); } # used to try to open a file [perl #17830] ok( open(my $stdin, "<&", fileno STDIN), 'dup fileno(STDIN) into lexical fh') or _diag $!; } SKIP: { skip "This perl uses perlio", 1 if $Config{useperlio}; skip "miniperl cannot be relied on to load %Errno" if $ENV{PERL_CORE_MINITEST}; # Force the reference to %! to be run time by writing ! as {"!"} skip "This system doesn't understand EINVAL", 1 unless exists ${"!"}{EINVAL}; no warnings 'io'; ok(!open(F,'>',\my $s) && ${"!"}{EINVAL}, 'open(reference) raises EINVAL'); } { ok( !eval { open F, "BAR", "QUUX" }, 'Unknown open() mode' ); like( $@, qr/\QUnknown open() mode 'BAR'/, ' right error' ); } { local $SIG{__WARN__} = sub { $@ = shift }; sub gimme { my $tmphandle = shift; my $line = scalar <$tmphandle>; warn "gimme"; return $line; } open($fh0[0], "TEST"); gimme($fh0[0]); like($@, qr/<\$fh0\[...\]> line 1\./, "autoviv fh package aelem"); open($fh1{k}, "TEST"); gimme($fh1{k}); like($@, qr/<\$fh1{...}> line 1\./, "autoviv fh package helem"); my @fh2; open($fh2[0], "TEST"); gimme($fh2[0]); like($@, qr/<\$fh2\[...\]> line 1\./, "autoviv fh lexical aelem"); my %fh3; open($fh3{k}, "TEST"); gimme($fh3{k}); like($@, qr/<\$fh3{...}> line 1\./, "autoviv fh lexical helem"); } SKIP: { skip("These tests use perlio", 5) unless $Config{useperlio}; my $w; use warnings 'layer'; local $SIG{__WARN__} = sub { $w = shift }; eval { open(F, ">>>", $afile) }; like($w, qr/Invalid separator character '>' in PerlIO layer spec/, "bad open (>>>) warning"); like($@, qr/Unknown open\(\) mode '>>>'/, "bad open (>>>) failure"); eval { open(F, ">:u", $afile ) }; like($w, qr/Unknown PerlIO layer "u"/, 'bad layer ">:u" warning'); eval { open(F, "<:u", $afile ) }; like($w, qr/Unknown PerlIO layer "u"/, 'bad layer "<:u" warning'); eval { open(F, ":c", $afile ) }; like($@, qr/Unknown open\(\) mode ':c'/, 'bad layer ":c" failure'); } # [perl #28986] "open m" crashes Perl fresh_perl_like('open m', qr/^Search pattern not terminated at/, { stderr => 1 }, 'open m test'); fresh_perl_is( 'sub f { open(my $fh, "xxx"); $fh = "f"; } f; f;print "ok"', 'ok', { stderr => 1 }, '#29102: Crash on assignment to lexical filehandle'); # [perl #31767] Using $1 as a filehandle via open $1, "file" doesn't raise # an exception eval { open $99, "foo" }; like($@, qr/Modification of a read-only value attempted/, "readonly fh"); perl-5.12.0-RC0/t/io/perlio.t0000555000175000017500000001166511325127001014462 0ustar jessejesseBEGIN { chdir 't' if -d 't'; @INC = '../lib'; require Config; import Config; unless (find PerlIO::Layer 'perlio') { print "1..0 # Skip: PerlIO not used\n"; exit 0; } require './test.pl'; } plan tests => 42; use_ok('PerlIO'); my $txt = "txt$$"; my $bin = "bin$$"; my $utf = "utf$$"; my $nonexistent = "nex$$"; my $txtfh; my $binfh; my $utffh; ok(open($txtfh, ">:crlf", $txt)); ok(open($binfh, ">:raw", $bin)); ok(open($utffh, ">:utf8", $utf)); print $txtfh "foo\n"; print $txtfh "bar\n"; ok(close($txtfh)); print $binfh "foo\n"; print $binfh "bar\n"; ok(close($binfh)); print $utffh "foo\x{ff}\n"; print $utffh "bar\x{abcd}\n"; ok(close($utffh)); ok(open($txtfh, "<:crlf", $txt)); ok(open($binfh, "<:raw", $bin)); ok(open($utffh, "<:utf8", $utf)); is(scalar <$txtfh>, "foo\n"); is(scalar <$txtfh>, "bar\n"); is(scalar <$binfh>, "foo\n"); is(scalar <$binfh>, "bar\n"); is(scalar <$utffh>, "foo\x{ff}\n"); is(scalar <$utffh>, "bar\x{abcd}\n"); ok(eof($txtfh));; ok(eof($binfh)); ok(eof($utffh)); ok(close($txtfh)); ok(close($binfh)); ok(close($utffh)); # magic temporary file via 3 arg open with undef { ok( open(my $x,"+<",undef), 'magic temp file via 3 arg open with undef'); ok( defined fileno($x), ' fileno' ); select $x; ok( (print "ok\n"), ' print' ); select STDOUT; ok( seek($x,0,0), ' seek' ); is( scalar <$x>, "ok\n", ' readline' ); ok( tell($x) >= 3, ' tell' ); # test magic temp file over STDOUT open OLDOUT, ">&STDOUT" or die "cannot dup STDOUT: $!"; my $status = open(STDOUT,"+<",undef); open STDOUT, ">&OLDOUT" or die "cannot dup OLDOUT: $!"; # report after STDOUT is restored ok($status, ' re-open STDOUT'); close OLDOUT; SKIP: { skip("TMPDIR not honored on this platform", 4) if !$Config{d_mkstemp} || $^O eq 'VMS' || $^O eq 'MSwin32' || $^O eq 'os2'; local $ENV{TMPDIR} = $nonexistent; # hardcoded default temp path my $perlio_tmp_file_glob = '/tmp/PerlIO_??????'; ok( open(my $x,"+<",undef), 'TMPDIR honored by magic temp file via 3 arg open with undef - works if TMPDIR points to a non-existent dir'); my $filename = find_filename($x, $perlio_tmp_file_glob); is($filename, undef, "No tmp files leaked"); unlink $filename if defined $filename; mkdir $ENV{TMPDIR}; ok(open(my $x,"+<",undef), 'TMPDIR honored by magic temp file via 3 arg open with undef - works if TMPDIR points to an existent dir'); $filename = find_filename($x, $perlio_tmp_file_glob); is($filename, undef, "No tmp files leaked"); unlink $filename if defined $filename; } } sub find_filename { my ($fh, @globs) = @_; my ($dev, $inode) = stat $fh; die "Can't stat $fh: $!" unless defined $dev; foreach (@globs) { foreach my $file (glob $_) { my ($this_dev, $this_inode) = stat $file; next unless defined $this_dev; return $file if $this_dev == $dev && $this_inode == $inode; } } return; } # in-memory open SKIP: { eval { require PerlIO::scalar }; unless (find PerlIO::Layer 'scalar') { skip("PerlIO::scalar not found", 9); } my $var; ok( open(my $x,"+<",\$var), 'magic in-memory file via 3 arg open with \\$var'); ok( defined fileno($x), ' fileno' ); select $x; ok( (print "ok\n"), ' print' ); select STDOUT; ok( seek($x,0,0), ' seek' ); is( scalar <$x>, "ok\n", ' readline' ); ok( tell($x) >= 3, ' tell' ); TODO: { local $TODO = "broken"; # test in-memory open over STDOUT open OLDOUT, ">&STDOUT" or die "cannot dup STDOUT: $!"; #close STDOUT; my $status = open(STDOUT,">",\$var); my $error = "$!" unless $status; # remember the error close STDOUT unless $status; open STDOUT, ">&OLDOUT" or die "cannot dup OLDOUT: $!"; print "# $error\n" unless $status; # report after STDOUT is restored ok($status, ' open STDOUT into in-memory var'); # test in-memory open over STDERR open OLDERR, ">&STDERR" or die "cannot dup STDERR: $!"; #close STDERR; ok( open(STDERR,">",\$var), ' open STDERR into in-memory var'); open STDERR, ">&OLDERR" or die "cannot dup OLDERR: $!"; } { local $TODO = 'fails well back into 5.8.x'; sub read_fh_and_return_final_rv { my ($fh) = @_; my $buf = ''; my $rv; for (1..3) { $rv = read($fh, $buf, 1, length($buf)); next if $rv; } return $rv } open(my $no_perlio, '<', \'ab') or die; open(my $perlio, '<:crlf', \'ab') or die; is(read_fh_and_return_final_rv($perlio), read_fh_and_return_final_rv($no_perlio), "RT#69332 - perlio should return the same value as nonperlio after EOF"); close ($perlio); close ($no_perlio); } } END { 1 while unlink $txt; 1 while unlink $bin; 1 while unlink $utf; rmdir $nonexistent; } perl-5.12.0-RC0/t/io/binmode.t0000555000175000017500000000210411143650501014575 0ustar jessejesse#!./perl -w BEGIN { chdir 't' if -d 't'; @INC = qw(. ../lib); require './test.pl'; } use Config; BEGIN { eval {require Errno; Errno->import;}; } plan(tests => 9); ok( binmode(STDERR), 'STDERR made binary' ); if (find PerlIO::Layer 'perlio') { ok( binmode(STDERR, ":unix"), ' with unix discipline' ); } else { ok(1, ' skip unix discipline without PerlIO layers' ); } ok( binmode(STDERR, ":raw"), ' raw' ); ok( binmode(STDERR, ":crlf"), ' and crlf' ); # If this one fails, we're in trouble. So we just bail out. ok( binmode(STDOUT), 'STDOUT made binary' ) || exit(1); if (find PerlIO::Layer 'perlio') { ok( binmode(STDOUT, ":unix"), ' with unix discipline' ); } else { ok(1, ' skip unix discipline without PerlIO layers' ); } ok( binmode(STDOUT, ":raw"), ' raw' ); ok( binmode(STDOUT, ":crlf"), ' and crlf' ); SKIP: { skip "minitest", 1 if $ENV{PERL_CORE_MINITEST}; skip "no EBADF", 1 if (!exists &Errno::EBADF); no warnings 'io', 'once'; $! = 0; binmode(B); ok($! == &Errno::EBADF); } perl-5.12.0-RC0/t/cmd/0000755000175000017500000000000011351321566013140 5ustar jessejesseperl-5.12.0-RC0/t/cmd/for.t0000555000175000017500000003466011325125742014124 0ustar jessejesse#!./perl print "1..118\n"; for ($i = 0; $i <= 10; $i++) { $x[$i] = $i; } $y = $x[10]; print "#1 :$y: eq :10:\n"; $y = join(' ', @x); print "#1 :$y: eq :0 1 2 3 4 5 6 7 8 9 10:\n"; if (join(' ', @x) eq '0 1 2 3 4 5 6 7 8 9 10') { print "ok 1\n"; } else { print "not ok 1\n"; } $i = $c = 0; for (;;) { $c++; last if $i++ > 10; } if ($c == 12) {print "ok 2\n";} else {print "not ok 2\n";} $foo = 3210; @ary = (1,2,3,4,5); foreach $foo (@ary) { $foo *= 2; } if (join('',@ary) eq '246810') {print "ok 3\n";} else {print "not ok 3\n";} for (@ary) { s/(.*)/ok $1\n/; } print $ary[1]; # test for internal scratch array generation # this also tests that $foo was restored to 3210 after test 3 for (split(' ','a b c d e')) { $foo .= $_; } if ($foo eq '3210abcde') {print "ok 5\n";} else {print "not ok 5 $foo\n";} foreach $foo (("ok 6\n","ok 7\n")) { print $foo; } sub foo { for $i (1..5) { return $i if $_[0] == $i; } } print foo(1) == 1 ? "ok" : "not ok", " 8\n"; print foo(2) == 2 ? "ok" : "not ok", " 9\n"; print foo(5) == 5 ? "ok" : "not ok", " 10\n"; sub bar { return (1, 2, 4); } $a = 0; foreach $b (bar()) { $a += $b; } print $a == 7 ? "ok" : "not ok", " 11\n"; $loop_count = 0; for ("-3" .. "0") { $loop_count++; } print $loop_count == 4 ? "ok" : "not ok", " 12\n"; # modifying arrays in loops is a no-no @a = (3,4); eval { @a = () for (1,2,@a) }; print $@ =~ /Use of freed value in iteration/ ? "ok" : "not ok", " 13\n"; # [perl #30061] double destory when same iterator variable (eg $_) used in # DESTROY as used in for loop that triggered the destroy { my $x = 0; sub X::DESTROY { my $o = shift; $x++; 1 for (1); } my %h; $h{foo} = bless [], 'X'; delete $h{foo} for $h{foo}, 1; print $x == 1 ? "ok" : "not ok", " 14 - double destroy, x=$x\n"; } # A lot of tests to check that reversed for works. my $test = 14; sub is { my ($got, $expected, $name) = @_; ++$test; if ($got eq $expected) { print "ok $test # $name\n"; return 1; } print "not ok $test # $name\n"; print "# got '$got', expected '$expected'\n"; return 0; } @array = ('A', 'B', 'C'); for (@array) { $r .= $_; } is ($r, 'ABC', 'Forwards for array'); $r = ''; for (1,2,3) { $r .= $_; } is ($r, '123', 'Forwards for list'); $r = ''; for (map {$_} @array) { $r .= $_; } is ($r, 'ABC', 'Forwards for array via map'); $r = ''; for (map {$_} 1,2,3) { $r .= $_; } is ($r, '123', 'Forwards for list via map'); $r = ''; for (1 .. 3) { $r .= $_; } is ($r, '123', 'Forwards for list via ..'); $r = ''; for ('A' .. 'C') { $r .= $_; } is ($r, 'ABC', 'Forwards for list via ..'); $r = ''; for (reverse @array) { $r .= $_; } is ($r, 'CBA', 'Reverse for array'); $r = ''; for (reverse 1,2,3) { $r .= $_; } is ($r, '321', 'Reverse for list'); $r = ''; for (reverse map {$_} @array) { $r .= $_; } is ($r, 'CBA', 'Reverse for array via map'); $r = ''; for (reverse map {$_} 1,2,3) { $r .= $_; } is ($r, '321', 'Reverse for list via map'); $r = ''; for (reverse 1 .. 3) { $r .= $_; } is ($r, '321', 'Reverse for list via ..'); $r = ''; for (reverse 'A' .. 'C') { $r .= $_; } is ($r, 'CBA', 'Reverse for list via ..'); $r = ''; for my $i (@array) { $r .= $i; } is ($r, 'ABC', 'Forwards for array with var'); $r = ''; for my $i (1,2,3) { $r .= $i; } is ($r, '123', 'Forwards for list with var'); $r = ''; for my $i (map {$_} @array) { $r .= $i; } is ($r, 'ABC', 'Forwards for array via map with var'); $r = ''; for my $i (map {$_} 1,2,3) { $r .= $i; } is ($r, '123', 'Forwards for list via map with var'); $r = ''; for my $i (1 .. 3) { $r .= $i; } is ($r, '123', 'Forwards for list via .. with var'); $r = ''; for my $i ('A' .. 'C') { $r .= $i; } is ($r, 'ABC', 'Forwards for list via .. with var'); $r = ''; for my $i (reverse @array) { $r .= $i; } is ($r, 'CBA', 'Reverse for array with var'); $r = ''; for my $i (reverse 1,2,3) { $r .= $i; } is ($r, '321', 'Reverse for list with var'); $r = ''; for my $i (reverse map {$_} @array) { $r .= $i; } is ($r, 'CBA', 'Reverse for array via map with var'); $r = ''; for my $i (reverse map {$_} 1,2,3) { $r .= $i; } is ($r, '321', 'Reverse for list via map with var'); $r = ''; for my $i (reverse 1 .. 3) { $r .= $i; } is ($r, '321', 'Reverse for list via .. with var'); $r = ''; for my $i (reverse 'A' .. 'C') { $r .= $i; } is ($r, 'CBA', 'Reverse for list via .. with var'); # For some reason the generate optree is different when $_ is implicit. $r = ''; for $_ (@array) { $r .= $_; } is ($r, 'ABC', 'Forwards for array with explicit $_'); $r = ''; for $_ (1,2,3) { $r .= $_; } is ($r, '123', 'Forwards for list with explicit $_'); $r = ''; for $_ (map {$_} @array) { $r .= $_; } is ($r, 'ABC', 'Forwards for array via map with explicit $_'); $r = ''; for $_ (map {$_} 1,2,3) { $r .= $_; } is ($r, '123', 'Forwards for list via map with explicit $_'); $r = ''; for $_ (1 .. 3) { $r .= $_; } is ($r, '123', 'Forwards for list via .. with var with explicit $_'); $r = ''; for $_ ('A' .. 'C') { $r .= $_; } is ($r, 'ABC', 'Forwards for list via .. with var with explicit $_'); $r = ''; for $_ (reverse @array) { $r .= $_; } is ($r, 'CBA', 'Reverse for array with explicit $_'); $r = ''; for $_ (reverse 1,2,3) { $r .= $_; } is ($r, '321', 'Reverse for list with explicit $_'); $r = ''; for $_ (reverse map {$_} @array) { $r .= $_; } is ($r, 'CBA', 'Reverse for array via map with explicit $_'); $r = ''; for $_ (reverse map {$_} 1,2,3) { $r .= $_; } is ($r, '321', 'Reverse for list via map with explicit $_'); $r = ''; for $_ (reverse 1 .. 3) { $r .= $_; } is ($r, '321', 'Reverse for list via .. with var with explicit $_'); $r = ''; for $_ (reverse 'A' .. 'C') { $r .= $_; } is ($r, 'CBA', 'Reverse for list via .. with var with explicit $_'); # I don't think that my is that different from our in the optree. But test a # few: $r = ''; for our $i (reverse @array) { $r .= $i; } is ($r, 'CBA', 'Reverse for array with our var'); $r = ''; for our $i (reverse 1,2,3) { $r .= $i; } is ($r, '321', 'Reverse for list with our var'); $r = ''; for our $i (reverse map {$_} @array) { $r .= $i; } is ($r, 'CBA', 'Reverse for array via map with our var'); $r = ''; for our $i (reverse map {$_} 1,2,3) { $r .= $i; } is ($r, '321', 'Reverse for list via map with our var'); $r = ''; for our $i (reverse 1 .. 3) { $r .= $i; } is ($r, '321', 'Reverse for list via .. with our var'); $r = ''; for our $i (reverse 'A' .. 'C') { $r .= $i; } is ($r, 'CBA', 'Reverse for list via .. with our var'); $r = ''; for (1, reverse @array) { $r .= $_; } is ($r, '1CBA', 'Reverse for array with leading value'); $r = ''; for ('A', reverse 1,2,3) { $r .= $_; } is ($r, 'A321', 'Reverse for list with leading value'); $r = ''; for (1, reverse map {$_} @array) { $r .= $_; } is ($r, '1CBA', 'Reverse for array via map with leading value'); $r = ''; for ('A', reverse map {$_} 1,2,3) { $r .= $_; } is ($r, 'A321', 'Reverse for list via map with leading value'); $r = ''; for ('A', reverse 1 .. 3) { $r .= $_; } is ($r, 'A321', 'Reverse for list via .. with leading value'); $r = ''; for (1, reverse 'A' .. 'C') { $r .= $_; } is ($r, '1CBA', 'Reverse for list via .. with leading value'); $r = ''; for (reverse (@array), 1) { $r .= $_; } is ($r, 'CBA1', 'Reverse for array with trailing value'); $r = ''; for (reverse (1,2,3), 'A') { $r .= $_; } is ($r, '321A', 'Reverse for list with trailing value'); $r = ''; for (reverse (map {$_} @array), 1) { $r .= $_; } is ($r, 'CBA1', 'Reverse for array via map with trailing value'); $r = ''; for (reverse (map {$_} 1,2,3), 'A') { $r .= $_; } is ($r, '321A', 'Reverse for list via map with trailing value'); $r = ''; for (reverse (1 .. 3), 'A') { $r .= $_; } is ($r, '321A', 'Reverse for list via .. with trailing value'); $r = ''; for (reverse ('A' .. 'C'), 1) { $r .= $_; } is ($r, 'CBA1', 'Reverse for list via .. with trailing value'); $r = ''; for $_ (1, reverse @array) { $r .= $_; } is ($r, '1CBA', 'Reverse for array with leading value with explicit $_'); $r = ''; for $_ ('A', reverse 1,2,3) { $r .= $_; } is ($r, 'A321', 'Reverse for list with leading value with explicit $_'); $r = ''; for $_ (1, reverse map {$_} @array) { $r .= $_; } is ($r, '1CBA', 'Reverse for array via map with leading value with explicit $_'); $r = ''; for $_ ('A', reverse map {$_} 1,2,3) { $r .= $_; } is ($r, 'A321', 'Reverse for list via map with leading value with explicit $_'); $r = ''; for $_ ('A', reverse 1 .. 3) { $r .= $_; } is ($r, 'A321', 'Reverse for list via .. with leading value with explicit $_'); $r = ''; for $_ (1, reverse 'A' .. 'C') { $r .= $_; } is ($r, '1CBA', 'Reverse for list via .. with leading value with explicit $_'); $r = ''; for $_ (reverse (@array), 1) { $r .= $_; } is ($r, 'CBA1', 'Reverse for array with trailing value with explicit $_'); $r = ''; for $_ (reverse (1,2,3), 'A') { $r .= $_; } is ($r, '321A', 'Reverse for list with trailing value with explicit $_'); $r = ''; for $_ (reverse (map {$_} @array), 1) { $r .= $_; } is ($r, 'CBA1', 'Reverse for array via map with trailing value with explicit $_'); $r = ''; for $_ (reverse (map {$_} 1,2,3), 'A') { $r .= $_; } is ($r, '321A', 'Reverse for list via map with trailing value with explicit $_'); $r = ''; for $_ (reverse (1 .. 3), 'A') { $r .= $_; } is ($r, '321A', 'Reverse for list via .. with trailing value with explicit $_'); $r = ''; for $_ (reverse ('A' .. 'C'), 1) { $r .= $_; } is ($r, 'CBA1', 'Reverse for list via .. with trailing value with explicit $_'); $r = ''; for my $i (1, reverse @array) { $r .= $i; } is ($r, '1CBA', 'Reverse for array with leading value and var'); $r = ''; for my $i ('A', reverse 1,2,3) { $r .= $i; } is ($r, 'A321', 'Reverse for list with leading value and var'); $r = ''; for my $i (1, reverse map {$_} @array) { $r .= $i; } is ($r, '1CBA', 'Reverse for array via map with leading value and var'); $r = ''; for my $i ('A', reverse map {$_} 1,2,3) { $r .= $i; } is ($r, 'A321', 'Reverse for list via map with leading value and var'); $r = ''; for my $i ('A', reverse 1 .. 3) { $r .= $i; } is ($r, 'A321', 'Reverse for list via .. with leading value and var'); $r = ''; for my $i (1, reverse 'A' .. 'C') { $r .= $i; } is ($r, '1CBA', 'Reverse for list via .. with leading value and var'); $r = ''; for my $i (reverse (@array), 1) { $r .= $i; } is ($r, 'CBA1', 'Reverse for array with trailing value and var'); $r = ''; for my $i (reverse (1,2,3), 'A') { $r .= $i; } is ($r, '321A', 'Reverse for list with trailing value and var'); $r = ''; for my $i (reverse (map {$_} @array), 1) { $r .= $i; } is ($r, 'CBA1', 'Reverse for array via map with trailing value and var'); $r = ''; for my $i (reverse (map {$_} 1,2,3), 'A') { $r .= $i; } is ($r, '321A', 'Reverse for list via map with trailing value and var'); $r = ''; for my $i (reverse (1 .. 3), 'A') { $r .= $i; } is ($r, '321A', 'Reverse for list via .. with trailing value and var'); $r = ''; for my $i (reverse ('A' .. 'C'), 1) { $r .= $i; } is ($r, 'CBA1', 'Reverse for list via .. with trailing value and var'); $r = ''; for (reverse 1, @array) { $r .= $_; } is ($r, 'CBA1', 'Reverse for value and array'); $r = ''; for (reverse map {$_} 1, @array) { $r .= $_; } is ($r, 'CBA1', 'Reverse for value and array via map'); $r = ''; for (reverse 1 .. 3, @array) { $r .= $_; } is ($r, 'CBA321', 'Reverse for .. and array'); $r = ''; for (reverse 'X' .. 'Z', @array) { $r .= $_; } is ($r, 'CBAZYX', 'Reverse for .. and array'); $r = ''; for (reverse map {$_} 1 .. 3, @array) { $r .= $_; } is ($r, 'CBA321', 'Reverse for .. and array via map'); $r = ''; for (reverse map {$_} 'X' .. 'Z', @array) { $r .= $_; } is ($r, 'CBAZYX', 'Reverse for .. and array via map'); $r = ''; for (reverse (@array, 1)) { $r .= $_; } is ($r, '1CBA', 'Reverse for array and value'); $r = ''; for (reverse (map {$_} @array, 1)) { $r .= $_; } is ($r, '1CBA', 'Reverse for array and value via map'); $r = ''; for $_ (reverse 1, @array) { $r .= $_; } is ($r, 'CBA1', 'Reverse for value and array with explicit $_'); $r = ''; for $_ (reverse map {$_} 1, @array) { $r .= $_; } is ($r, 'CBA1', 'Reverse for value and array via map with explicit $_'); $r = ''; for $_ (reverse 1 .. 3, @array) { $r .= $_; } is ($r, 'CBA321', 'Reverse for .. and array with explicit $_'); $r = ''; for $_ (reverse 'X' .. 'Z', @array) { $r .= $_; } is ($r, 'CBAZYX', 'Reverse for .. and array with explicit $_'); $r = ''; for $_ (reverse map {$_} 1 .. 3, @array) { $r .= $_; } is ($r, 'CBA321', 'Reverse for .. and array via map with explicit $_'); $r = ''; for $_ (reverse map {$_} 'X' .. 'Z', @array) { $r .= $_; } is ($r, 'CBAZYX', 'Reverse for .. and array via map with explicit $_'); $r = ''; for $_ (reverse (@array, 1)) { $r .= $_; } is ($r, '1CBA', 'Reverse for array and value with explicit $_'); $r = ''; for $_ (reverse (map {$_} @array, 1)) { $r .= $_; } is ($r, '1CBA', 'Reverse for array and value via map with explicit $_'); $r = ''; for my $i (reverse 1, @array) { $r .= $i; } is ($r, 'CBA1', 'Reverse for value and array with var'); $r = ''; for my $i (reverse map {$_} 1, @array) { $r .= $i; } is ($r, 'CBA1', 'Reverse for value and array via map with var'); $r = ''; for my $i (reverse 1 .. 3, @array) { $r .= $i; } is ($r, 'CBA321', 'Reverse for .. and array with var'); $r = ''; for my $i (reverse 'X' .. 'Z', @array) { $r .= $i; } is ($r, 'CBAZYX', 'Reverse for .. and array with var'); $r = ''; for my $i (reverse map {$_} 1 .. 3, @array) { $r .= $i; } is ($r, 'CBA321', 'Reverse for .. and array via map with var'); $r = ''; for my $i (reverse map {$_} 'X' .. 'Z', @array) { $r .= $i; } is ($r, 'CBAZYX', 'Reverse for .. and array via map with var'); $r = ''; for my $i (reverse (@array, 1)) { $r .= $i; } is ($r, '1CBA', 'Reverse for array and value with var'); $r = ''; for my $i (reverse (map {$_} @array, 1)) { $r .= $i; } is ($r, '1CBA', 'Reverse for array and value via map with var'); TODO: { $test++; local $TODO = "RT #1085: what should be output of perl -we 'print do { foreach (1, 2) { 1; } }'"; if (do {17; foreach (1, 2) { 1; } } != 17) { print "not "; } print "ok $test # TODO $TODO\n"; } TODO: { $test++; no warnings 'reserved'; local $TODO = "RT #2166: foreach spuriously autovivifies"; my %h; foreach (@h{a, b}) {} if(keys(%h)) { print "not "; } print "ok $test # TODO $TODO\n"; } perl-5.12.0-RC0/t/cmd/elsif.t0000555000175000017500000000071711325125742014434 0ustar jessejesse#!./perl sub foo { if ($_[0] == 1) { 1; } elsif ($_[0] == 2) { 2; } elsif ($_[0] == 3) { 3; } else { 4; } } print "1..4\n"; if (($x = &foo(1)) == 1) {print "ok 1\n";} else {print "not ok 1 '$x'\n";} if (($x = &foo(2)) == 2) {print "ok 2\n";} else {print "not ok 2 '$x'\n";} if (($x = &foo(3)) == 3) {print "ok 3\n";} else {print "not ok 3 '$x'\n";} if (($x = &foo(4)) == 4) {print "ok 4\n";} else {print "not ok 4 '$x'\n";} perl-5.12.0-RC0/t/cmd/while.t0000555000175000017500000000670711325125742014447 0ustar jessejesse#!./perl print "1..22\n"; open (tmp,'>Cmd_while.tmp') || die "Can't create Cmd_while.tmp."; print tmp "tvi925\n"; print tmp "tvi920\n"; print tmp "vt100\n"; print tmp "Amiga\n"; print tmp "paper\n"; close tmp or die "Could not close: $!"; # test "last" command open(fh,'Cmd_while.tmp') || die "Can't open Cmd_while.tmp."; while () { last if /vt100/; } if (!eof && /vt100/) {print "ok 1\n";} else {print "not ok 1 $_\n";} # test "next" command $bad = ''; open(fh,'Cmd_while.tmp') || die "Can't open Cmd_while.tmp."; while () { next if /vt100/; $bad = 1 if /vt100/; } if (!eof || /vt100/ || $bad) {print "not ok 2\n";} else {print "ok 2\n";} # test "redo" command $bad = ''; open(fh,'Cmd_while.tmp') || die "Can't open Cmd_while.tmp."; while () { if (s/vt100/VT100/g) { s/VT100/Vt100/g; redo; } $bad = 1 if /vt100/; $bad = 1 if /VT100/; } if (!eof || $bad) {print "not ok 3\n";} else {print "ok 3\n";} # now do the same with a label and a continue block # test "last" command $badcont = ''; open(fh,'Cmd_while.tmp') || die "Can't open Cmd_while.tmp."; line: while () { if (/vt100/) {last line;} } continue { $badcont = 1 if /vt100/; } if (!eof && /vt100/) {print "ok 4\n";} else {print "not ok 4\n";} if (!$badcont) {print "ok 5\n";} else {print "not ok 5\n";} # test "next" command $bad = ''; $badcont = 1; open(fh,'Cmd_while.tmp') || die "Can't open Cmd_while.tmp."; entry: while () { next entry if /vt100/; $bad = 1 if /vt100/; } continue { $badcont = '' if /vt100/; } if (!eof || /vt100/ || $bad) {print "not ok 6\n";} else {print "ok 6\n";} if (!$badcont) {print "ok 7\n";} else {print "not ok 7\n";} # test "redo" command $bad = ''; $badcont = ''; open(fh,'Cmd_while.tmp') || die "Can't open Cmd_while.tmp."; loop: while () { if (s/vt100/VT100/g) { s/VT100/Vt100/g; redo loop; } $bad = 1 if /vt100/; $bad = 1 if /VT100/; } continue { $badcont = 1 if /vt100/; } if (!eof || $bad) {print "not ok 8\n";} else {print "ok 8\n";} if (!$badcont) {print "ok 9\n";} else {print "not ok 9\n";} close(fh) || die "Can't close Cmd_while.tmp."; unlink 'Cmd_while.tmp' || `/bin/rm Cmd_While.tmp`; #$x = 0; #while (1) { # if ($x > 1) {last;} # next; #} continue { # if ($x++ > 10) {last;} # next; #} # #if ($x < 10) {print "ok 10\n";} else {print "not ok 10\n";} $i = 9; { $i++; } print "ok $i\n"; # Check curpm is reset when jumping out of a scope 'abc' =~ /b/; WHILE: while (1) { $i++; print "#$`,$&,$',\nnot " unless $` . $& . $' eq "abc"; print "ok $i\n"; { # Localize changes to $` and friends 'end' =~ /end/; redo WHILE if $i == 11; next WHILE if $i == 12; # 13 do a normal loop last WHILE if $i == 14; } } $i++; print "not " unless $` . $& . $' eq "abc"; print "ok $i\n"; # check that scope cleanup happens right when there's a continue block { my $var = 16; while (my $i = ++$var) { next if $i == 17; last if $i > 17; my $i = 0; } continue { print "ok ", $var-1, "\nok $i\n"; } } { local $l = 18; { local $l = 0 } continue { print "ok $l\n" } } { local $l = 19; my $x = 0; while (!$x++) { local $l = 0 } continue { print "ok $l\n" } } $i = 20; { while (1) { my $x; print $x if defined $x; $x = "not "; print "ok $i\n"; ++$i; if ($i == 21) { next; } last; } continue { print "ok $i\n"; ++$i; } } perl-5.12.0-RC0/t/cmd/mod.t0000555000175000017500000000212511325125742014104 0ustar jessejesse#!./perl print "1..13\n"; print "ok 1\n" if 1; print "not ok 1\n" unless 1; print "ok 2\n" unless 0; print "not ok 2\n" if 0; 1 && (print "not ok 3\n") if 0; 1 && (print "ok 3\n") if 1; 0 || (print "not ok 4\n") if 0; 0 || (print "ok 4\n") if 1; $x = 0; do {$x[$x] = $x;} while ($x++) < 10; if (join(' ',@x) eq '0 1 2 3 4 5 6 7 8 9 10') { print "ok 5\n"; } else { print "not ok 5 @x\n"; } $x = 15; $x = 10 while $x < 10; if ($x == 15) {print "ok 6\n";} else {print "not ok 6\n";} $y[$_] = $_ * 2 foreach @x; if (join(' ',@y) eq '0 2 4 6 8 10 12 14 16 18 20') { print "ok 7\n"; } else { print "not ok 7 @y\n"; } open(foo,'./TEST') || open(foo,'TEST') || open(foo,'t/TEST'); $x = 0; $x++ while ; print $x > 50 && $x < 1000 ? "ok 8\n" : "not ok 8\n"; $x = -0.5; print "not " if scalar($x) < 0 and $x >= 0; print "ok 9\n"; print "not " unless (-(-$x) < 0) == ($x < 0); print "ok 10\n"; print "ok 11\n" if $x < 0; print "not ok 11\n" unless $x < 0; print "ok 12\n" unless $x > 0; print "not ok 12\n" if $x > 0; # This used to cause a segfault $x = "".("".do{"foo" for (1)}); print "ok 13\n"; perl-5.12.0-RC0/t/cmd/subval.t0000555000175000017500000000731511325125742014627 0ustar jessejesse#!./perl sub foo1 { 'true1'; if ($_[0]) { 'true2'; } } sub foo2 { 'true1'; if ($_[0]) { return 'true2'; } else { return 'true3'; } 'true0'; } sub foo3 { 'true1'; unless ($_[0]) { 'true2'; } } sub foo4 { 'true1'; unless ($_[0]) { 'true2'; } else { 'true3'; } } sub foo5 { 'true1'; 'true2' if $_[0]; } sub foo6 { 'true1'; 'true2' unless $_[0]; } print "1..36\n"; if (&foo1(0) eq '0') {print "ok 1\n";} else {print "not ok 1 $foo\n";} if (&foo1(1) eq 'true2') {print "ok 2\n";} else {print "not ok 2\n";} if (&foo2(0) eq 'true3') {print "ok 3\n";} else {print "not ok 3\n";} if (&foo2(1) eq 'true2') {print "ok 4\n";} else {print "not ok 4\n";} if (&foo3(0) eq 'true2') {print "ok 5\n";} else {print "not ok 5\n";} if (&foo3(1) eq '1') {print "ok 6\n";} else {print "not ok 6\n";} if (&foo4(0) eq 'true2') {print "ok 7\n";} else {print "not ok 7\n";} if (&foo4(1) eq 'true3') {print "ok 8\n";} else {print "not ok 8\n";} if (&foo5(0) eq '0') {print "ok 9\n";} else {print "not ok 9\n";} if (&foo5(1) eq 'true2') {print "ok 10\n";} else {print "not ok 10\n";} if (&foo6(0) eq 'true2') {print "ok 11\n";} else {print "not ok 11\n";} if (&foo6(1) eq '1') {print "ok 12\n";} else {print "not ok 12 $x\n";} # Now test to see that recursion works using a Fibonacci number generator sub fib { my($arg) = @_; my($foo); $level++; if ($arg <= 2) { $foo = 1; } else { $foo = &fib($arg-1) + &fib($arg-2); } $level--; $foo; } @good = (0,1,1,2,3,5,8,13,21,34,55,89); for ($i = 1; $i <= 10; $i++) { $foo = $i + 12; if (&fib($i) == $good[$i]) { print "ok $foo\n"; } else { print "not ok $foo\n"; } } sub ary1 { (1,2,3); } print &ary1 eq 3 ? "ok 23\n" : "not ok 23\n"; print join(':',&ary1) eq '1:2:3' ? "ok 24\n" : "not ok 24\n"; sub ary2 { do { return (1,2,3); (3,2,1); }; 0; } print &ary2 eq 3 ? "ok 25\n" : "not ok 25\n"; $x = join(':',&ary2); print $x eq '1:2:3' ? "ok 26\n" : "not ok 26 $x\n"; sub somesub { local($num,$P,$F,$L) = @_; ($p,$f,$l) = caller; print "$p:$f:$l" eq "$P:$F:$L" ? "ok $num\n" : "not ok $num $p:$f:$l ne $P:$F:$L\n"; } &somesub(27, 'main', __FILE__, __LINE__); package foo; &main'somesub(28, 'foo', __FILE__, __LINE__); package main; $i = 28; open(FOO,">Cmd_subval.tmp"); print FOO "blah blah\n"; close FOO or die "Can't close Cmd_subval.tmp: $!"; &file_main(*F); close F or die "Can't close: $!"; &info_main; &file_package(*F); close F or die "Can't close: $!"; &info_package; unlink 'Cmd_subval.tmp'; sub file_main { local(*F) = @_; open(F, 'Cmd_subval.tmp') || die "can't open: $!\n"; $i++; eof F ? print "not ok $i\n" : print "ok $i\n"; } sub info_main { local(*F); open(F, 'Cmd_subval.tmp') || die "test: can't open: $!\n"; $i++; eof F ? print "not ok $i\n" : print "ok $i\n"; &iseof(*F); close F or die "Can't close: $!"; } sub iseof { local(*UNIQ) = @_; $i++; eof UNIQ ? print "(not ok $i)\n" : print "ok $i\n"; } {package foo; sub main'file_package { local(*F) = @_; open(F, 'Cmd_subval.tmp') || die "can't open: $!\n"; $main'i++; eof F ? print "not ok $main'i\n" : print "ok $main'i\n"; } sub main'info_package { local(*F); open(F, 'Cmd_subval.tmp') || die "can't open: $!\n"; $main'i++; eof F ? print "not ok $main'i\n" : print "ok $main'i\n"; &iseof(*F); } sub iseof { local(*UNIQ) = @_; $main'i++; eof UNIQ ? print "not ok $main'i\n" : print "ok $main'i\n"; } } sub autov { $_[0] = 23 }; my $href = {}; print keys %$href ? 'not ' : '', "ok 35\n"; autov($href->{b}); print join(':', %$href) eq 'b:23' ? '' : 'not ', "ok 36\n"; perl-5.12.0-RC0/t/cmd/switch.t0000555000175000017500000000265711325127001014626 0ustar jessejesse#!./perl print "1..18\n"; sub foo1 { $_ = shift(@_); $a = 0; until ($a++) { next if $_ eq 1; next if $_ eq 2; next if $_ eq 3; next if $_ eq 4; return 20; } continue { return $_; } } print foo1(0) == 20 ? "ok 1\n" : "not ok 1\n"; print foo1(1) == 1 ? "ok 2\n" : "not ok 2\n"; print foo1(2) == 2 ? "ok 3\n" : "not ok 3\n"; print foo1(3) == 3 ? "ok 4\n" : "not ok 4\n"; print foo1(4) == 4 ? "ok 5\n" : "not ok 5\n"; print foo1(5) == 20 ? "ok 6\n" : "not ok 6\n"; sub foo2 { $_ = shift(@_); { last if $_ == 1; last if $_ == 2; last if $_ == 3; last if $_ == 4; } continue { return 20; } return $_; } print foo2(0) == 20 ? "ok 7\n" : "not ok 7\n"; print foo2(1) == 1 ? "ok 8\n" : "not ok 8\n"; print foo2(2) == 2 ? "ok 9\n" : "not ok 9\n"; print foo2(3) == 3 ? "ok 10\n" : "not ok 10\n"; print foo2(4) == 4 ? "ok 11\n" : "not ok 11\n"; print foo2(5) == 20 ? "ok 12\n" : "not ok 12\n"; sub foo3 { $_ = shift(@_); if (/^1/) { return 1; } elsif (/^2/) { return 2; } elsif (/^3/) { return 3; } elsif (/^4/) { return 4; } else { return 20; } return 40; } print foo3(0) == 20 ? "ok 13\n" : "not ok 13\n"; print foo3(1) == 1 ? "ok 14\n" : "not ok 14\n"; print foo3(2) == 2 ? "ok 15\n" : "not ok 15\n"; print foo3(3) == 3 ? "ok 16\n" : "not ok 16\n"; print foo3(4) == 4 ? "ok 17\n" : "not ok 17\n"; print foo3(5) == 20 ? "ok 18\n" : "not ok 18\n"; perl-5.12.0-RC0/t/lib/0000755000175000017500000000000011351321566013143 5ustar jessejesseperl-5.12.0-RC0/t/lib/compmod.pl0000444000175000017500000000042211143650501015123 0ustar jessejesse#!./perl BEGIN { chdir 't'; @INC = '../lib'; } my $module = shift; # 'require open' confuses Perl, so we use instead. eval "use $module ();"; if( $@ ) { print "not "; $@ =~ s/\n/\n# /g; warn "# require failed with '$@'\n"; } print "ok - $module\n"; perl-5.12.0-RC0/t/lib/h2ph.h0000444000175000017500000000760511325125742014162 0ustar jessejesse/* * Test header file for h2ph * * Try to test as many constructs as possible * For example, the multi-line comment :) */ /* And here's a single line comment :) */ /* Test #define with no indenting, over multiple lines */ #define SQUARE(x) \ ((x)*(x)) /* Test #ifndef and parameter interpretation*/ #ifndef ERROR #define ERROR(x) fprintf(stderr, "%s\n", x[2][3][0]) #endif /* ERROR */ #ifndef _H2PH_H_ #define _H2PH_H_ /* #ident - doesn't really do anything, but I think it always gets included anyway */ #ident "$Revision h2ph.h,v 1.0 98/05/04 20:42:14 billy $" /* Test #undef */ #undef MAX #define MAX(a,b) ((a) > (b) ? (a) : (b)) /* Test #undef'ining an existing constant function */ #define NOTTRUE 0 #undef NOTTRUE /* Test #ifdef */ #ifdef __SOME_UNIMPORTANT_PROPERTY #define MIN(a,b) ((a) < (b) ? (a) : (b)) #endif /* __SOME_UNIMPORTANT_PROPERTY */ /* * Test #if, #elif, #else, #endif, #warn and #error, and `!' * Also test whitespace between the `#' and the command */ #if !(defined __SOMETHING_MORE_IMPORTANT) # warn Be careful... #elif !(defined __SOMETHING_REALLY_REALLY_IMPORTANT) # error "Nup, can't go on" /* ' /* stupid font-lock-mode */ #else /* defined __SOMETHING_MORE_IMPORTANT && defined __SOMETHING_REALLY_REALLY_IMPORTANT */ # define EVERYTHING_IS_OK #endif /* Test && and || */ #undef WHATEVER #if (!((defined __SOMETHING_TRIVIAL && defined __SOMETHING_LESS_SO)) \ || defined __SOMETHING_OVERPOWERING) # define WHATEVER 6 #elif !(defined __SOMETHING_TRIVIAL) /* defined __SOMETHING_LESS_SO */ # define WHATEVER 7 #elif !(defined __SOMETHING_LESS_SO) /* defined __SOMETHING_TRIVIAL */ # define WHATEVER 8 #else /* defined __SOMETHING_TRIVIAL && defined __SOMETHING_LESS_SO */ # define WHATEVER 1000 #endif /* Test passing through the alien constructs (perlbug #34493) */ #ifdef __LANGUAGE_PASCAL__ function Tru64_Pascal(n: Integer): Integer; #endif /* * Test #include, #import and #include_next * #include_next is difficult to test, it really depends on the actual * circumstances - for example, `#include_next ' on a Linux system * with `use lib qw(/opt/perl5/lib/site_perl/i586-linux/linux);' or whatever * your equivalent is... */ #if 0 #include #import "sys/ioctl.h" #include_next #endif /* typedefs should be ignored */ typedef struct a_struct { int typedefs_should; char be_ignored; long as_well; } a_typedef; /* * however, typedefs of enums and just plain enums should end up being treated * like a bunch of #defines... */ typedef enum _days_of_week { sun, mon, tue, wed, thu, fri, sat, Sun=0, Mon, Tue, Wed, Thu, Fri, Sat } days_of_week; /* * Some moderate flexing of tri-graph pre substitution. */ ??=ifndef _SOMETHING_TRIGRAPHIC ??=define _SOMETHING_TRIGRAPHIC ??= define SOMETHING_ELSE_TRIGRAPHIC_0 "??!" /* | ??!| || */ ??=define SOMETHING_ELSE_TRIGRAPHIC_1 "??'" /* | ??'| ^| */ ??= 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_6 "??<" /* | ??<| {| */ ??=define SOMETHING_ELSE_TRIGRAPHIC_7 "??=" /* | ??=| #| */ ??= define SOMETHING_ELSE_TRIGRAPHIC_8 "??>" /* | ??>| }| */ ??=endif // test C++-style comment #if 1 typdef struct empty_struct { } // trailing C++-style comment should not force continuation #endif /* comments (that look like string) inside enums... */ enum { /* foo; can't */ }; enum flimflam { flim, /* foo; can't */ flam } flamflim; /* Handle multi-line quoted strings: */ __asm__ __volatile__(" this produces no output "); #define multiline "multiline string" #endif /* _H2PH_H_ */ perl-5.12.0-RC0/t/lib/cygwin.t0000555000175000017500000000435611346121271014634 0ustar jessejesse#!perl BEGIN { chdir 't' if -d 't'; @INC = ('../lib'); unless ($^O eq "cygwin") { print "1..0 # skipped: cygwin specific test\n"; exit 0; } require './test.pl'; } plan(tests => 16); is(Cygwin::winpid_to_pid(Cygwin::pid_to_winpid($$)), $$, "perl pid translates to itself"); my $parent = getppid; SKIP: { skip "test not run from cygwin process", 1 if $parent <= 1; is(Cygwin::winpid_to_pid(Cygwin::pid_to_winpid($parent)), $parent, "parent pid translates to itself"); } my $catpid = open my $cat, "|cat" or die "Couldn't cat: $!"; open my $ps, "ps|" or die "Couldn't do ps: $!"; my ($catwinpid) = map /^.\s+$catpid\s+\d+\s+\d+\s+(\d+)/, <$ps>; close($ps); is(Cygwin::winpid_to_pid($catwinpid), $catpid, "winpid to pid"); is(Cygwin::pid_to_winpid($catpid), $catwinpid, "pid to winpid"); close($cat); is(Cygwin::win_to_posix_path("t\\lib"), "t/lib", "win to posix path: t/lib"); is(Cygwin::posix_to_win_path("t/lib"), "t\\lib", "posix to win path: t\\lib"); use Win32; use Cwd; my $pwd = getcwd(); chdir("/"); my $winpath = Win32::GetCwd(); is(Cygwin::posix_to_win_path("/", 1), $winpath, "posix to absolute win path"); chdir($pwd); is(Cygwin::win_to_posix_path($winpath, 1), "/", "win to absolute posix path"); my $mount = join '', `/usr/bin/mount`; $mount =~ m|on /usr/bin type .+ \((\w+)[,\)]|m; my $binmode = $1 =~ /binmode|binary/; is(Cygwin::is_binmount("/"), $binmode ? 1 : '', "check / for binmount"); my $rootmnt = Cygwin::mount_flags("/"); ok($binmode ? ($rootmnt =~ /,(binmode|binary)/) : ($rootmnt =~ /,textmode/), "check / mount_flags"); is(Cygwin::mount_flags("/cygdrive") =~ /,cygdrive/, 1, "check cygdrive mount_flags"); # Cygdrive mount prefix my @flags = split(/,/, Cygwin::mount_flags('/cygdrive')); my $prefix = pop(@flags); ok($prefix, "cygdrive mount prefix = " . (($prefix) ? $prefix : '')); chomp(my $prefix2 = `df | grep -i '^c: ' | cut -d% -f2 | xargs`); $prefix2 =~ s/\/c$//i; if (! $prefix2) { $prefix2 = '/'; } is($prefix, $prefix2, 'cygdrive mount prefix'); my @mnttbl = Cygwin::mount_table(); ok(@mnttbl > 0, "non empty mount_table"); for $i (@mnttbl) { if ($i->[0] eq '/') { is($i->[2].",".$i->[3], $rootmnt, "same root mount flags"); last; } } ok(Cwd->cwd(), "bug#38628 legacy"); perl-5.12.0-RC0/t/lib/test_use_14937.pm0000444000175000017500000000000311325127001016057 0ustar jessejesse1; perl-5.12.0-RC0/t/lib/mypragma.pm0000444000175000017500000000112411325125742015311 0ustar jessejesse=head1 NAME mypragma - an example of a user pragma =head1 SYNOPSIS In your code use mypragma; # Enable the pragma mypragma::in_effect() # returns true; pragma is enabled no mypragma; mypragma::in_effect() # returns false; pragma is not enabled =head1 DESCRIPTION An example of how to write a pragma. =head1 AUTHOR Rafael Garcia-Suarez =cut package mypragma; use strict; use warnings; sub import { $^H{mypragma} = 42; } sub unimport { $^H{mypragma} = 0; } sub in_effect { my $hinthash = (caller(0))[10]; return $hinthash->{mypragma}; } 1; perl-5.12.0-RC0/t/lib/mypragma.t0000555000175000017500000000250611325127001015136 0ustar jessejesse#!./perl use strict; use warnings; BEGIN { unshift @INC, 'lib'; require './test.pl'; plan(tests => 14); } use mypragma (); # don't enable this pragma yet BEGIN { is($^H{mypragma}, undef, "Shouldn't be in %^H yet"); } is(mypragma::in_effect(), undef, "pragma not in effect yet"); { is(mypragma::in_effect(), undef, "pragma not in effect yet"); eval qq{is(mypragma::in_effect(), undef, "pragma not in effect yet"); 1} or die $@; use mypragma; use Sans_mypragma; is(mypragma::in_effect(), 42, "pragma is in effect within this block"); is(Sans_mypragma::affected(), undef, "pragma not in effect outside this file"); eval qq{is(mypragma::in_effect(), 42, "pragma is in effect within this eval"); 1} or die $@; { no mypragma; is(mypragma::in_effect(), 0, "pragma no longer in effect"); eval qq{is(mypragma::in_effect(), 0, "pragma no longer in effect"); 1} or die $@; } is(mypragma::in_effect(), 42, "pragma is in effect within this block"); eval qq{is(mypragma::in_effect(), 42, "pragma is in effect within this eval"); 1} or die $@; } is(mypragma::in_effect(), undef, "pragma no longer in effect"); eval qq{is(mypragma::in_effect(), undef, "pragma not in effect"); 1} or die $@; BEGIN { is($^H{mypragma}, undef, "Should no longer be in %^H"); } perl-5.12.0-RC0/t/lib/overload_fallback.t0000555000175000017500000000060411325127001016750 0ustar jessejesseuse warnings; use strict; use Test::Simple tests => 2; use overload '""' => sub { 'stringvalue' }, fallback => 1; BEGIN { my $x = bless {}, 'main'; ok ($x eq 'stringvalue', 'fallback worked'); } # NOTE: delete the next line and this test script will pass use overload '+' => sub { die "unused"; }; my $x = bless {}, 'main'; ok (eval {$x eq 'stringvalue'}, 'fallback worked again'); perl-5.12.0-RC0/t/lib/Cname.pm0000444000175000017500000000164611340037012014515 0ustar jessejessepackage Cname; our $Evil='A'; sub translator { my $str = shift; if ( $str eq 'EVIL' ) { # Returns A first time, AB second, ABC third ... A-ZA the 27th time. (my $c=substr("A".$Evil,-1))++; my $r=$Evil; $Evil.=$c; return $r; } if ( $str eq 'EMPTY-STR') { return ""; } if ( $str eq 'NULL') { return "\0"; } if ( $str eq 'LONG-STR') { return 'A' x 255; } # Should exceed limit for regex \N bytes in a sequence. Anyway it will if # UCHAR_MAX is 255. if ( $str eq 'TOO-LONG-STR') { return 'A' x 256; } if ($str eq 'MALFORMED') { $str = "\xDF\xDFabc"; utf8::upgrade($str); # Create a malformed in first and second characters. $str =~ s/^\C/A/; $str =~ s/^(\C\C)\C/$1A/; } return $str; } sub import { shift; $^H{charnames} = \&translator; } 1; perl-5.12.0-RC0/t/lib/deprecate/0000755000175000017500000000000011351321566015077 5ustar jessejesseperl-5.12.0-RC0/t/lib/deprecate/Deprecated.pm0000444000175000017500000000007711325125742017476 0ustar jessejessepackage Deprecated; use strict; use deprecate; q(Harmless); perl-5.12.0-RC0/t/lib/deprecate/Optionally.pm0000444000175000017500000000014511325125742017564 0ustar jessejessepackage Optionally::Deprecated; use strict; use if $] >= 5.011, 'deprecate'; q(Mostly harmless); perl-5.12.0-RC0/t/lib/test_use.pm0000444000175000017500000000017611325127001015323 0ustar jessejesse#!perl -w # Don't use strict because this is for testing use package test_use; sub import { shift; @got = @_; } 1; perl-5.12.0-RC0/t/lib/Devel/0000755000175000017500000000000011351321566014202 5ustar jessejesseperl-5.12.0-RC0/t/lib/Devel/switchd.pm0000444000175000017500000000037011325125742016202 0ustar jessejessepackage Devel::switchd; use strict; BEGIN { } # use strict; BEGIN { ... } to incite [perl #21890] sub import { print "import<@_>;" } package DB; sub DB { print "DB<", join(",", caller), ">;" } sub sub { print "sub<$DB::sub>;"; goto &$DB::sub } 1; perl-5.12.0-RC0/t/lib/warnings/0000755000175000017500000000000011351321566014773 5ustar jessejesseperl-5.12.0-RC0/t/lib/warnings/regcomp0000444000175000017500000001600211325125742016346 0ustar jessejesse regcomp.c AOK Quantifier unexpected on zero-length expression [S_study_chunk] Useless (%s%c) - %suse /%c modifier [S_reg] Useless (%sc) - %suse /gc modifier [S_reg] Strange *+?{} on zero-length expression [S_study_chunk] /(?=a)?/ %.*s matches null string many times [S_regpiece] $a = "ABC123" ; $a =~ /(?=a)*/' /%.127s/: Unrecognized escape \\%c passed through [S_regatom] $x = '\m' ; /$x/ POSIX syntax [%c %c] belongs inside character classes [S_checkposixcc] Character class [:%.*s:] unknown [S_regpposixcc] Character class syntax [%c %c] belongs inside character classes [S_checkposixcc] /%.127s/: false [] range \"%*.*s\" in regexp [S_regclass] /%.127s/: false [] range \"%*.*s\" in regexp [S_regclassutf8] /%.127s/: Unrecognized escape \\%c in character class passed through" [S_regclass] /%.127s/: Unrecognized escape \\%c in character class passed through" [S_regclassutf8] False [] range \"%*.*s\" [S_regclass] __END__ # regcomp.c [S_regpiece] use warnings 'regexp' ; my $a = "ABC123" ; $a =~ /(?=a)*/ ; no warnings 'regexp' ; $a =~ /(?=a)*/ ; EXPECT (?=a)* matches null string many times in regex; marked by <-- HERE in m/(?=a)* <-- HERE / at - line 4. ######## # regcomp.c [S_regatom] $x = '\m' ; use warnings 'regexp' ; $a =~ /a$x/ ; no warnings 'regexp' ; $a =~ /a$x/ ; EXPECT Unrecognized escape \m passed through in regex; marked by <-- HERE in m/a\m <-- HERE / at - line 4. ######## # regcomp.c [S_regatom] # The \q should warn, the \_ should NOT warn. use warnings 'regexp'; "foo" =~ /\q/; "bar" =~ /\_/; no warnings 'regexp'; "foo" =~ /\q/; "bar" =~ /\_/; EXPECT Unrecognized escape \q passed through in regex; marked by <-- HERE in m/\q <-- HERE / at - line 4. ######## # regcomp.c [S_regpposixcc S_checkposixcc] # use warnings 'regexp' ; $_ = "" ; /[:alpha:]/; /[:zog:]/; no warnings 'regexp' ; /[:alpha:]/; /[:zog:]/; EXPECT POSIX syntax [: :] belongs inside character classes in regex; marked by <-- HERE in m/[:alpha:] <-- HERE / at - line 5. POSIX syntax [: :] belongs inside character classes in regex; marked by <-- HERE in m/[:zog:] <-- HERE / at - line 6. ######## # regcomp.c [S_checkposixcc] # use warnings 'regexp' ; $_ = "" ; /[.zog.]/; no warnings 'regexp' ; /[.zog.]/; EXPECT POSIX syntax [. .] belongs inside character classes in regex; marked by <-- HERE in m/[.zog.] <-- HERE / at - line 5. POSIX syntax [. .] is reserved for future extensions in regex; marked by <-- HERE in m/[.zog.] <-- HERE / at - line 5. ######## # regcomp.c [S_regclass] $_ = ""; use warnings 'regexp' ; /[a-b]/; /[a-\d]/; /[\d-b]/; /[\s-\d]/; /[\d-\s]/; /[a-[:digit:]]/; /[[:digit:]-b]/; /[[:alpha:]-[:digit:]]/; /[[:digit:]-[:alpha:]]/; no warnings 'regexp' ; /[a-b]/; /[a-\d]/; /[\d-b]/; /[\s-\d]/; /[\d-\s]/; /[a-[:digit:]]/; /[[:digit:]-b]/; /[[:alpha:]-[:digit:]]/; /[[:digit:]-[:alpha:]]/; EXPECT False [] range "a-\d" in regex; marked by <-- HERE in m/[a-\d <-- HERE ]/ at - line 5. False [] range "\d-" in regex; marked by <-- HERE in m/[\d- <-- HERE b]/ at - line 6. False [] range "\s-" in regex; marked by <-- HERE in m/[\s- <-- HERE \d]/ at - line 7. False [] range "\d-" in regex; marked by <-- HERE in m/[\d- <-- HERE \s]/ at - line 8. False [] range "a-[:digit:]" in regex; marked by <-- HERE in m/[a-[:digit:] <-- HERE ]/ at - line 9. False [] range "[:digit:]-" in regex; marked by <-- HERE in m/[[:digit:]- <-- HERE b]/ at - line 10. False [] range "[:alpha:]-" in regex; marked by <-- HERE in m/[[:alpha:]- <-- HERE [:digit:]]/ at - line 11. False [] range "[:digit:]-" in regex; marked by <-- HERE in m/[[:digit:]- <-- HERE [:alpha:]]/ at - line 12. ######## # regcomp.c [S_regclassutf8] BEGIN { if (ord("\t") == 5) { print "SKIPPED\n# ebcdic regular expression ranges differ."; exit 0; } } use utf8; $_ = ""; use warnings 'regexp' ; /[a-b]/; /[a-\d]/; /[\d-b]/; /[\s-\d]/; /[\d-\s]/; /[a-[:digit:]]/; /[[:digit:]-b]/; /[[:alpha:]-[:digit:]]/; /[[:digit:]-[:alpha:]]/; no warnings 'regexp' ; /[a-b]/; /[a-\d]/; /[\d-b]/; /[\s-\d]/; /[\d-\s]/; /[a-[:digit:]]/; /[[:digit:]-b]/; /[[:alpha:]-[:digit:]]/; /[[:digit:]-[:alpha:]]/; EXPECT False [] range "a-\d" in regex; marked by <-- HERE in m/[a-\d <-- HERE ]/ at - line 12. False [] range "\d-" in regex; marked by <-- HERE in m/[\d- <-- HERE b]/ at - line 13. False [] range "\s-" in regex; marked by <-- HERE in m/[\s- <-- HERE \d]/ at - line 14. False [] range "\d-" in regex; marked by <-- HERE in m/[\d- <-- HERE \s]/ at - line 15. False [] range "a-[:digit:]" in regex; marked by <-- HERE in m/[a-[:digit:] <-- HERE ]/ at - line 16. False [] range "[:digit:]-" in regex; marked by <-- HERE in m/[[:digit:]- <-- HERE b]/ at - line 17. False [] range "[:alpha:]-" in regex; marked by <-- HERE in m/[[:alpha:]- <-- HERE [:digit:]]/ at - line 18. False [] range "[:digit:]-" in regex; marked by <-- HERE in m/[[:digit:]- <-- HERE [:alpha:]]/ at - line 19. ######## # regcomp.c [S_regclass S_regclassutf8] use warnings 'regexp' ; $a =~ /[a\zb]/ ; no warnings 'regexp' ; $a =~ /[a\zb]/ ; EXPECT Unrecognized escape \z in character class passed through in regex; marked by <-- HERE in m/[a\z <-- HERE b]/ at - line 3. ######## # regcomp.c [S_reg] use warnings 'regexp' ; $a = qr/(?c)/; $a = qr/(?-c)/; $a = qr/(?g)/; $a = qr/(?-g)/; $a = qr/(?o)/; $a = qr/(?-o)/; $a = qr/(?g-o)/; $a = qr/(?g-c)/; $a = qr/(?o-cg)/; # (?c) means (?g) error won't be thrown $a = qr/(?ogc)/; no warnings 'regexp' ; $a = qr/(?c)/; $a = qr/(?-c)/; $a = qr/(?g)/; $a = qr/(?-g)/; $a = qr/(?o)/; $a = qr/(?-o)/; $a = qr/(?g-o)/; $a = qr/(?g-c)/; $a = qr/(?o-cg)/; # (?c) means (?g) error won't be thrown $a = qr/(?ogc)/; #EXPECT EXPECT Useless (?c) - use /gc modifier in regex; marked by <-- HERE in m/(?c <-- HERE )/ at - line 3. Useless (?-c) - don't use /gc modifier in regex; marked by <-- HERE in m/(?-c <-- HERE )/ at - line 4. Useless (?g) - use /g modifier in regex; marked by <-- HERE in m/(?g <-- HERE )/ at - line 5. Useless (?-g) - don't use /g modifier in regex; marked by <-- HERE in m/(?-g <-- HERE )/ at - line 6. Useless (?o) - use /o modifier in regex; marked by <-- HERE in m/(?o <-- HERE )/ at - line 7. Useless (?-o) - don't use /o modifier in regex; marked by <-- HERE in m/(?-o <-- HERE )/ at - line 8. Useless (?g) - use /g modifier in regex; marked by <-- HERE in m/(?g <-- HERE -o)/ at - line 9. Useless (?-o) - don't use /o modifier in regex; marked by <-- HERE in m/(?g-o <-- HERE )/ at - line 9. Useless (?g) - use /g modifier in regex; marked by <-- HERE in m/(?g <-- HERE -c)/ at - line 10. Useless (?-c) - don't use /gc modifier in regex; marked by <-- HERE in m/(?g-c <-- HERE )/ at - line 10. Useless (?o) - use /o modifier in regex; marked by <-- HERE in m/(?o <-- HERE -cg)/ at - line 11. Useless (?-c) - don't use /gc modifier in regex; marked by <-- HERE in m/(?o-c <-- HERE g)/ at - line 11. Useless (?o) - use /o modifier in regex; marked by <-- HERE in m/(?o <-- HERE gc)/ at - line 12. Useless (?g) - use /g modifier in regex; marked by <-- HERE in m/(?og <-- HERE c)/ at - line 12. Useless (?c) - use /gc modifier in regex; marked by <-- HERE in m/(?ogc <-- HERE )/ at - line 12. perl-5.12.0-RC0/t/lib/warnings/av0000444000175000017500000000024011143650501015307 0ustar jessejesse av.c Mandatory Warnings ALL TODO ------------------ av_reify called on tied array [av_reify] Attempt to clear deleted array [av_clear] __END__ perl-5.12.0-RC0/t/lib/warnings/1global0000444000175000017500000000554711143650501016241 0ustar jessejesseCheck existing $^W functionality __END__ # warnable code, warnings disabled $a =+ 3 ; EXPECT ######## -w # warnable code, warnings enabled via command line switch $a =+ 3 ; EXPECT Reversed += operator at - line 3. Name "main::a" used only once: possible typo at - line 3. ######## #! perl -w # warnable code, warnings enabled via #! line $a =+ 3 ; EXPECT Reversed += operator at - line 3. Name "main::a" used only once: possible typo at - line 3. ######## # warnable code, warnings enabled via compile time $^W BEGIN { $^W = 1 } $a =+ 3 ; EXPECT Reversed += operator at - line 4. Name "main::a" used only once: possible typo at - line 4. ######## # compile-time warnable code, warnings enabled via runtime $^W # so no warning printed. $^W = 1 ; $a =+ 3 ; EXPECT ######## # warnable code, warnings enabled via runtime $^W $^W = 1 ; my $b ; chop $b ; EXPECT Use of uninitialized value $b in scalar chop at - line 4. ######## # warnings enabled at compile time, disabled at run time BEGIN { $^W = 1 } $^W = 0 ; my $b ; chop $b ; EXPECT ######## # warnings disabled at compile time, enabled at run time BEGIN { $^W = 0 } $^W = 1 ; my $b ; chop $b ; EXPECT Use of uninitialized value $b in scalar chop at - line 5. ######## -w --FILE-- abcd my $b ; chop $b ; 1 ; --FILE-- require "./abcd"; EXPECT Use of uninitialized value $b in scalar chop at ./abcd line 1. ######## --FILE-- abcd my $b ; chop $b ; 1 ; --FILE-- #! perl -w require "./abcd"; EXPECT Use of uninitialized value $b in scalar chop at ./abcd line 1. ######## --FILE-- abcd my $b ; chop $b ; 1 ; --FILE-- $^W =1 ; require "./abcd"; EXPECT Use of uninitialized value $b in scalar chop at ./abcd line 1. ######## --FILE-- abcd $^W = 0; my $b ; chop $b ; 1 ; --FILE-- $^W =1 ; require "./abcd"; EXPECT ######## --FILE-- abcd $^W = 1; 1 ; --FILE-- $^W =0 ; require "./abcd"; my $b ; chop $b ; EXPECT Use of uninitialized value $b in scalar chop at - line 3. ######## $^W = 1; eval 'my $b ; chop $b ;' ; print $@ ; EXPECT Use of uninitialized value $b in scalar chop at (eval 1) line 1. ######## eval '$^W = 1;' ; print $@ ; my $b ; chop $b ; EXPECT Use of uninitialized value $b in scalar chop at - line 4. ######## eval {$^W = 1;} ; print $@ ; my $b ; chop $b ; EXPECT Use of uninitialized value $b in scalar chop at - line 4. ######## { local ($^W) = 1; } my $b ; chop $b ; EXPECT ######## my $a ; chop $a ; { local ($^W) = 1; my $b ; chop $b ; } my $c ; chop $c ; EXPECT Use of uninitialized value $b in scalar chop at - line 5. ######## -w -e undef EXPECT Use of uninitialized value in -e at - line 2. ######## $^W = 1 + 2 ; EXPECT ######## $^W = $a ; EXPECT ######## sub fred {} $^W = fred() ; EXPECT ######## sub fred { my $b ; chop $b ;} { local $^W = 0 ; fred() ; } EXPECT ######## sub fred { my $b ; chop $b ;} { local $^W = 1 ; fred() ; } EXPECT Use of uninitialized value $b in scalar chop at - line 2. perl-5.12.0-RC0/t/lib/warnings/gv0000444000175000017500000000221511325125742015327 0ustar jessejesse gv.c AOK Can't locate package %s for @%s::ISA @ISA = qw(Fred); joe() Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated sub Other::AUTOLOAD { 1 } sub Other::fred {} @ISA = qw(Other) ; fred() ; $# is no longer supported $* is no longer supported $a = ${"#"} ; $a = ${"*"} ; Mandatory Warnings ALL TODO ------------------ Had to create %s unexpectedly [gv_fetchpv] Attempt to free unreferenced glob pointers [gp_free] __END__ # gv.c use warnings 'syntax' ; @ISA = qw(Fred); joe() EXPECT Can't locate package Fred for @main::ISA at - line 3. Undefined subroutine &main::joe called at - line 3. ######## # gv.c no warnings 'syntax' ; @ISA = qw(Fred); joe() EXPECT Undefined subroutine &main::joe called at - line 3. ######## # gv.c sub Other::AUTOLOAD { 1 } sub Other::fred {} @ISA = qw(Other) ; use warnings 'deprecated' ; fred() ; EXPECT Use of inherited AUTOLOAD for non-method main::fred() is deprecated at - line 5. ######## # gv.c $a = ${"#"}; $a = ${"*"}; no warnings 'deprecated' ; $a = ${"#"}; $a = ${"*"}; EXPECT $# is no longer supported at - line 2. $* is no longer supported at - line 3. perl-5.12.0-RC0/t/lib/warnings/mg0000444000175000017500000000225211325127001015305 0ustar jessejesse mg.c AOK No such signal: SIG%s $SIG{FRED} = sub {} SIG%s handler \"%s\" not defined. $SIG{"INT"} = "ok3"; kill "INT",$$; Mandatory Warnings TODO ------------------ Can't break at that line [magic_setdbline] __END__ # mg.c use warnings 'signal' ; $SIG{FRED} = sub {}; EXPECT No such signal: SIGFRED at - line 3. ######## # mg.c no warnings 'signal' ; $SIG{FRED} = sub {}; EXPECT ######## # mg.c use warnings 'signal' ; if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') { print "SKIPPED\n# $^O, can't kill() to raise()\n"; exit; } $|=1; $SIG{"INT"} = "fred"; kill "INT",$$; EXPECT SIGINT handler "fred" not defined. ######## # mg.c no warnings 'signal' ; if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') { print "SKIPPED\n# $^O, can't kill() to raise()\n"; exit; } $|=1; $SIG{"INT"} = "fred"; kill "INT",$$; EXPECT ######## # mg.c use warnings 'uninitialized'; 'foo' =~ /(foo)/; oct $3; EXPECT Use of uninitialized value $3 in oct at - line 4. ######## # mg.c use warnings 'uninitialized'; oct $3; EXPECT Use of uninitialized value $3 in oct at - line 3. ######## # mg.c use warnings 'uninitialized'; $ENV{FOO} = undef; # should not warn EXPECT perl-5.12.0-RC0/t/lib/warnings/7fatal0000444000175000017500000002063211325125742016074 0ustar jessejesseCheck FATAL functionality __END__ # Check compile time warning use warnings FATAL => 'syntax' ; { no warnings ; $a =+ 1 ; } $a =+ 1 ; print STDERR "The End.\n" ; EXPECT Reversed += operator at - line 8. ######## # Check compile time warning use warnings FATAL => 'all' ; { no warnings ; my $a =+ 1 ; } my $a =+ 1 ; print STDERR "The End.\n" ; EXPECT Reversed += operator at - line 8. ######## # Check runtime scope of pragma use warnings FATAL => 'uninitialized' ; { no warnings ; my $b ; chop $b ; } my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT Use of uninitialized value $b in scalar chop at - line 8. ######## # Check runtime scope of pragma use warnings FATAL => 'all' ; { no warnings ; my $b ; chop $b ; } my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT Use of uninitialized value $b in scalar chop at - line 8. ######## # Check runtime scope of pragma no warnings ; { use warnings FATAL => 'uninitialized' ; $a = sub { my $b ; chop $b ; } } &$a ; print STDERR "The End.\n" ; EXPECT Use of uninitialized value $b in scalar chop at - line 6. ######## # Check runtime scope of pragma no warnings ; { use warnings FATAL => 'all' ; $a = sub { my $b ; chop $b ; } } &$a ; print STDERR "The End.\n" ; EXPECT Use of uninitialized value $b in scalar chop at - line 6. ######## --FILE-- abc $a =+ 1 ; 1; --FILE-- use warnings FATAL => 'syntax' ; require "./abc"; EXPECT ######## --FILE-- abc use warnings FATAL => 'syntax' ; 1; --FILE-- require "./abc"; $a =+ 1 ; EXPECT ######## --FILE-- abc use warnings 'syntax' ; $a =+ 1 ; 1; --FILE-- use warnings FATAL => 'uninitialized' ; require "./abc"; my $a ; chop $a ; print STDERR "The End.\n" ; EXPECT Reversed += operator at ./abc line 2. Use of uninitialized value $a in scalar chop at - line 3. ######## --FILE-- abc.pm use warnings 'syntax' ; $a =+ 1 ; 1; --FILE-- use warnings FATAL => 'uninitialized' ; use abc; my $a ; chop $a ; print STDERR "The End.\n" ; EXPECT Reversed += operator at abc.pm line 2. Use of uninitialized value $a in scalar chop at - line 3. ######## # Check scope of pragma with eval no warnings ; eval { use warnings FATAL => 'uninitialized' ; my $b ; chop $b ; }; print STDERR "-- $@" ; my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT -- Use of uninitialized value $b in scalar chop at - line 6. The End. ######## # Check scope of pragma with eval use warnings FATAL => 'uninitialized' ; eval { my $b ; chop $b ; }; print STDERR "-- $@" ; my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT -- Use of uninitialized value $b in scalar chop at - line 5. Use of uninitialized value $b in scalar chop at - line 7. ######## # Check scope of pragma with eval use warnings FATAL => 'uninitialized' ; eval { no warnings ; my $b ; chop $b ; }; print STDERR $@ ; my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT Use of uninitialized value $b in scalar chop at - line 8. ######## # Check scope of pragma with eval no warnings ; eval { use warnings FATAL => 'syntax' ; $a =+ 1 ; }; print STDERR "-- $@" ; $a =+ 1 ; print STDERR "The End.\n" ; EXPECT Reversed += operator at - line 6. ######## # Check scope of pragma with eval use warnings FATAL => 'syntax' ; eval { $a =+ 1 ; }; print STDERR "-- $@" ; $a =+ 1 ; print STDERR "The End.\n" ; EXPECT Reversed += operator at - line 5. ######## # Check scope of pragma with eval use warnings FATAL => 'syntax' ; eval { no warnings ; $a =+ 1 ; }; print STDERR $@ ; $a =+ 1 ; print STDERR "The End.\n" ; EXPECT Reversed += operator at - line 8. ######## # Check scope of pragma with eval no warnings ; eval { use warnings FATAL => 'syntax' ; }; print STDERR $@ ; $a =+ 1 ; print STDERR "The End.\n" ; EXPECT The End. ######## # Check scope of pragma with eval no warnings ; eval q[ use warnings FATAL => 'uninitialized' ; my $b ; chop $b ; ]; print STDERR "-- $@"; my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT -- Use of uninitialized value $b in scalar chop at (eval 1) line 3. The End. ######## # Check scope of pragma with eval use warnings FATAL => 'uninitialized' ; eval ' my $b ; chop $b ; '; print STDERR "-- $@" ; my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT -- Use of uninitialized value $b in scalar chop at (eval 1) line 2. Use of uninitialized value $b in scalar chop at - line 7. ######## # Check scope of pragma with eval use warnings FATAL => 'uninitialized' ; eval ' no warnings ; my $b ; chop $b ; '; print STDERR $@ ; my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT Use of uninitialized value $b in scalar chop at - line 8. ######## # Check scope of pragma with eval no warnings ; eval q[ use warnings FATAL => 'syntax' ; $a =+ 1 ; ]; print STDERR "-- $@"; $a =+ 1 ; print STDERR "The End.\n" ; EXPECT -- Reversed += operator at (eval 1) line 3. The End. ######## # Check scope of pragma with eval use warnings FATAL => 'syntax' ; eval ' $a =+ 1 ; '; print STDERR "-- $@"; print STDERR "The End.\n" ; EXPECT -- Reversed += operator at (eval 1) line 2. The End. ######## # Check scope of pragma with eval use warnings FATAL => 'syntax' ; eval ' no warnings ; $a =+ 1 ; '; print STDERR "-- $@"; $a =+ 1 ; print STDERR "The End.\n" ; EXPECT Reversed += operator at - line 8. ######## # TODO ? !$Config{usethreads} && $::UTF8 && ($ENV{PERL_DESTRUCT_LEVEL} || 0) > 1 ? "Parser leaks OPs, which leak shared hash keys" : '' use warnings 'void' ; time ; { use warnings FATAL => qw(void) ; $a = "abc"; length $a ; } join "", 1,2,3 ; print "done\n" ; EXPECT Useless use of time in void context at - line 4. Useless use of length in void context at - line 9. ######## # TODO ? !$Config{usethreads} && $::UTF8 && ($ENV{PERL_DESTRUCT_LEVEL} || 0) > 1 ? "Parser leaks OPs, which leak shared hash keys" : '' use warnings ; time ; { use warnings FATAL => qw(void) ; $a = "abc"; length $a ; } join "", 1,2,3 ; print "done\n" ; EXPECT Useless use of time in void context at - line 4. Useless use of length in void context at - line 9. ######## use warnings FATAL => 'all'; { no warnings; my $b ; chop $b; { use warnings ; my $b ; chop $b; } } my $b ; chop $b; print STDERR "The End.\n" ; EXPECT Use of uninitialized value $b in scalar chop at - line 8. Use of uninitialized value $b in scalar chop at - line 11. ######## use warnings FATAL => 'all'; { no warnings FATAL => 'all'; my $b ; chop $b; { use warnings ; my $b ; chop $b; } } my $b ; chop $b; print STDERR "The End.\n" ; EXPECT Use of uninitialized value $b in scalar chop at - line 8. Use of uninitialized value $b in scalar chop at - line 11. ######## use warnings FATAL => 'all'; { no warnings 'syntax'; { use warnings ; my $b ; chop $b; } } my $b ; chop $b; print STDERR "The End.\n" ; EXPECT Use of uninitialized value $b in scalar chop at - line 7. ######## use warnings FATAL => 'syntax', NONFATAL => 'void' ; $a = "abc"; length $a; print STDERR "The End.\n" ; EXPECT Useless use of length in void context at - line 5. The End. ######## use warnings FATAL => 'all', NONFATAL => 'void' ; $a = "abc"; length $a; print STDERR "The End.\n" ; EXPECT Useless use of length in void context at - line 5. The End. ######## use warnings FATAL => 'all', NONFATAL => 'void' ; my $a ; chomp $a; $b = "abc" ; length $b; print STDERR "The End.\n" ; EXPECT Useless use of length in void context at - line 7. Use of uninitialized value $a in scalar chomp at - line 4. ######## use warnings FATAL => 'void', NONFATAL => 'void' ; $a = "abc"; length $a; print STDERR "The End.\n" ; EXPECT Useless use of length in void context at - line 4. The End. ######## # TODO ? !$Config{usethreads} && $::UTF8 && ($ENV{PERL_DESTRUCT_LEVEL} || 0) > 1 ? "Parser leaks OPs, which leak shared hash keys" : '' use warnings NONFATAL => 'void', FATAL => 'void' ; $a = "abc"; length $a; print STDERR "The End.\n" ; EXPECT Useless use of length in void context at - line 4. ######## use warnings FATAL => 'all', NONFATAL => 'io'; no warnings 'once'; open(F, " 'all', NONFATAL => 'io', FATAL => 'unopened' ; no warnings 'once'; open(F, " end+1 %p Setting cnt to %d, ptr implies %d Invalid separator character %c%c%c in PerlIO layer specification %s open(F, ">:-aa", "bb") Argument list not closed for PerlIO layer \"%.*s\"" open(F, ">:aa(", "bb") Unknown PerlIO layer \"%.*s\" # PerlIO/xyz.pm has 1; open(F, ">xyz", "bb") __END__ # perlio [PerlIO_parse_layers] no warnings 'layer'; open(F, ">:-aa", "bb"); use warnings 'layer'; open(F, ">:-aa", "bb"); close F; EXPECT Invalid separator character '-' in PerlIO layer specification -aa at - line 6. ######## # perlio [PerlIO_parse_layers] no warnings 'layer'; open(F, ">:aa(", "bb"); use warnings 'layer'; open(F, ">:aa(", "bb"); close F; EXPECT Argument list not closed for PerlIO layer "aa(" at - line 6. ######## --FILE-- PerlIO_test_dir/xyz.pm 1; --FILE-- # perlio [PerlIO_parse_layers] no warnings 'layer'; open(F, ">:xyz", "bb"); use warnings 'layer'; open(F, ">:xyz", "bb"); close F; END { 1 while unlink "bb" } # KEEP THIS WITH THE LAST TEST. EXPECT Unknown PerlIO layer "xyz" at - line 5. perl-5.12.0-RC0/t/lib/warnings/util0000444000175000017500000000746111143650501015672 0ustar jessejesse util.c AOK Illegal octal digit ignored my $a = oct "029" ; Illegal hex digit ignored my $a = hex "0xv9" ; Illegal binary digit ignored my $a = oct "0b9" ; Integer overflow in binary number my $a = oct "0b111111111111111111111111111111111111111111" ; Binary number > 0b11111111111111111111111111111111 non-portable $a = oct "0b111111111111111111111111111111111" ; Integer overflow in octal number my $a = oct "077777777777777777777777777777" ; Octal number > 037777777777 non-portable $a = oct "0047777777777" ; Integer overflow in hexadecimal number my $a = hex "0xffffffffffffffffffff" ; Hexadecimal number > 0xffffffff non-portable $a = hex "0x1ffffffff" ; __END__ # util.c use warnings 'digit' ; my $a = oct "029" ; no warnings 'digit' ; $a = oct "029" ; EXPECT Illegal octal digit '9' ignored at - line 3. ######## # util.c use warnings 'digit' ; my $a = hex "0xv9" ; no warnings 'digit' ; $a = hex "0xv9" ; EXPECT Illegal hexadecimal digit 'v' ignored at - line 3. ######## # util.c use warnings 'digit' ; my $a = oct "0b9" ; no warnings 'digit' ; $a = oct "0b9" ; EXPECT Illegal binary digit '9' ignored at - line 3. ######## # util.c use warnings 'overflow' ; my $a = oct "0b11111111111111111111111111111111111111111111111111111111111111111"; no warnings 'overflow' ; $a = oct "0b11111111111111111111111111111111111111111111111111111111111111111"; EXPECT Integer overflow in binary number at - line 3. ######## # util.c use warnings 'overflow' ; my $a = hex "0xffffffffffffffffffff" ; no warnings 'overflow' ; $a = hex "0xffffffffffffffffffff" ; EXPECT Integer overflow in hexadecimal number at - line 3. ######## # util.c use warnings 'overflow' ; my $a = oct "077777777777777777777777777777" ; no warnings 'overflow' ; $a = oct "077777777777777777777777777777" ; EXPECT Integer overflow in octal number at - line 3. ######## # util.c use warnings 'portable' ; my $a = oct "0b011111111111111111111111111111110" ; $a = oct "0b011111111111111111111111111111111" ; $a = oct "0b111111111111111111111111111111111" ; no warnings 'portable' ; $a = oct "0b011111111111111111111111111111110" ; $a = oct "0b011111111111111111111111111111111" ; $a = oct "0b111111111111111111111111111111111" ; EXPECT Binary number > 0b11111111111111111111111111111111 non-portable at - line 5. ######## # util.c use warnings 'portable' ; my $a = hex "0x0fffffffe" ; $a = hex "0x0ffffffff" ; $a = hex "0x1ffffffff" ; no warnings 'portable' ; $a = hex "0x0fffffffe" ; $a = hex "0x0ffffffff" ; $a = hex "0x1ffffffff" ; EXPECT Hexadecimal number > 0xffffffff non-portable at - line 5. ######## # util.c use warnings 'portable' ; my $a = oct "0037777777776" ; $a = oct "0037777777777" ; $a = oct "0047777777777" ; no warnings 'portable' ; $a = oct "0037777777776" ; $a = oct "0037777777777" ; $a = oct "0047777777777" ; EXPECT Octal number > 037777777777 non-portable at - line 5. ######## # util.c use warnings; $x = 1; if ($x) { print $y; } EXPECT Name "main::y" used only once: possible typo at - line 5. Use of uninitialized value $y in print at - line 5. ######## # util.c use warnings; $x = 1; if ($x) { $x++; print $y; } EXPECT Name "main::y" used only once: possible typo at - line 6. Use of uninitialized value $y in print at - line 6. ######## # util.c use warnings; $x = 0; if ($x) { print "1\n"; } elsif (!$x) { print $y; } else { print "0\n"; } EXPECT Name "main::y" used only once: possible typo at - line 7. Use of uninitialized value $y in print at - line 7. ######## # util.c use warnings; $x = 0; if ($x) { print "1\n"; } elsif (!$x) { $x++; print $y; } else { print "0\n"; } EXPECT Name "main::y" used only once: possible typo at - line 8. Use of uninitialized value $y in print at - line 8. perl-5.12.0-RC0/t/lib/warnings/pp_sys0000444000175000017500000003004111325125742016226 0ustar jessejesse pp_sys.c AOK untie attempted while %d inner references still exist [pp_untie] sub TIESCALAR { bless [] } ; tie $a, 'main'; untie $a ; fileno() on unopened filehandle abc [pp_fileno] $a = "abc"; fileno($a) binmode() on unopened filehandle abc [pp_binmode] $a = "abc"; fileno($a) printf() on unopened filehandle abc [pp_prtf] $a = "abc"; printf $a "fred" Filehandle %s opened only for input [pp_leavewrite] format STDIN = . write STDIN; write() on closed filehandle %s [pp_leavewrite] format STDIN = . close STDIN; write STDIN ; page overflow [pp_leavewrite] printf() on unopened filehandle abc [pp_prtf] $a = "abc"; printf $a "fred" Filehandle %s opened only for input [pp_prtf] $a = "abc"; printf $a "fred" printf() on closed filehandle %s [pp_prtf] close STDIN ; printf STDIN "fred" syswrite() on closed filehandle %s [pp_send] close STDIN; syswrite STDIN, "fred", 1; send() on closed socket %s [pp_send] close STDIN; send STDIN, "fred", 1 bind() on closed socket %s [pp_bind] close STDIN; bind STDIN, "fred" ; connect() on closed socket %s [pp_connect] close STDIN; connect STDIN, "fred" ; listen() on closed socket %s [pp_listen] close STDIN; listen STDIN, 2; accept() on closed socket %s [pp_accept] close STDIN; accept "fred", STDIN ; shutdown() on closed socket %s [pp_shutdown] close STDIN; shutdown STDIN, 0; setsockopt() on closed socket %s [pp_ssockopt] getsockopt() on closed socket %s [pp_ssockopt] close STDIN; setsockopt STDIN, 1,2,3; getsockopt STDIN, 1,2; getsockname() on closed socket %s [pp_getpeername] getpeername() on closed socket %s [pp_getpeername] close STDIN; getsockname STDIN; getpeername STDIN; flock() on closed socket %s [pp_flock] flock() on closed socket [pp_flock] close STDIN; flock STDIN, 8; flock $a, 8; warn(warn_nl, "stat"); [pp_stat] -T on closed filehandle %s stat() on closed filehandle %s close STDIN ; -T STDIN ; stat(STDIN) ; warn(warn_nl, "open"); [pp_fttext] -T "abc\ndef" ; Filehandle %s opened only for output [pp_sysread] my $file = "./xcv" ; open(F, ">$file") ; my $a = sysread(F, $a,10) ; lstat on filehandle %s [pp_lstat] getc() on unopened filehandle [pp_getc] getc() on closed filehandle [pp_getc] Non-string passed as bitmask [pp_sselect] __END__ # pp_sys.c [pp_untie] use warnings 'untie' ; sub TIESCALAR { bless [] } ; $b = tie $a, 'main'; untie $a ; no warnings 'untie' ; $c = tie $d, 'main'; untie $d ; EXPECT untie attempted while 1 inner references still exist at - line 5. ######## # pp_sys.c [pp_leavewrite] use warnings 'io' ; format STDIN = . write STDIN; no warnings 'io' ; write STDIN; EXPECT Filehandle STDIN opened only for input at - line 5. ######## # pp_sys.c [pp_leavewrite] use warnings 'closed' ; format STDIN = . close STDIN; write STDIN; opendir STDIN, "."; write STDIN; closedir STDIN; no warnings 'closed' ; write STDIN; opendir STDIN, "."; write STDIN; EXPECT write() on closed filehandle STDIN at - line 6. write() on closed filehandle STDIN at - line 8. (Are you trying to call write() on dirhandle STDIN?) ######## # pp_sys.c [pp_leavewrite] use warnings 'io' ; format STDOUT_TOP = abc . format STDOUT = def ghi . $= = 1 ; $- =1 ; open STDOUT, ">".($^O eq 'VMS'? 'NL:' : '/dev/null') ; write ; no warnings 'io' ; write ; EXPECT page overflow at - line 13. ######## # pp_sys.c [pp_prtf] use warnings 'unopened' ; $a = "abc"; printf $a "fred"; no warnings 'unopened' ; printf $a "fred"; EXPECT printf() on unopened filehandle abc at - line 4. ######## # pp_sys.c [pp_prtf] use warnings 'closed' ; close STDIN ; printf STDIN "fred"; opendir STDIN, "."; printf STDIN "fred"; closedir STDIN; no warnings 'closed' ; printf STDIN "fred"; opendir STDIN, "."; printf STDIN "fred"; EXPECT printf() on closed filehandle STDIN at - line 4. printf() on closed filehandle STDIN at - line 6. (Are you trying to call printf() on dirhandle STDIN?) ######## # pp_sys.c [pp_prtf] use warnings 'io' ; printf STDIN "fred"; no warnings 'io' ; printf STDIN "fred"; EXPECT Filehandle STDIN opened only for input at - line 3. ######## # pp_sys.c [pp_send] use warnings 'io' ; syswrite STDIN, "fred"; no warnings 'io' ; syswrite STDIN, "fred"; EXPECT Filehandle STDIN opened only for input at - line 3. ######## # pp_sys.c [pp_send] use warnings 'closed' ; close STDIN; syswrite STDIN, "fred", 1; opendir STDIN, "."; syswrite STDIN, "fred", 1; closedir STDIN; no warnings 'closed' ; syswrite STDIN, "fred", 1; opendir STDIN, "."; syswrite STDIN, "fred", 1; EXPECT syswrite() on closed filehandle STDIN at - line 4. syswrite() on closed filehandle STDIN at - line 6. (Are you trying to call syswrite() on dirhandle STDIN?) ######## # pp_sys.c [pp_flock] use Config; BEGIN { if ( !$Config{d_flock} && !$Config{d_fcntl_can_lock} && !$Config{d_lockf} ) { print <$file") ; my $a = sysread(F, $a,10) ; no warnings 'io' ; my $a = sysread(F, $a,10) ; close F ; use warnings 'io' ; sysread(F, $a, 10); read(F, $a, 10); sysread(NONEXISTENT, $a, 10); read(NONEXISTENT, $a, 10); unlink $file ; EXPECT Filehandle F opened only for output at - line 12. sysread() on closed filehandle F at - line 17. read() on closed filehandle F at - line 18. sysread() on unopened filehandle NONEXISTENT at - line 19. read() on unopened filehandle NONEXISTENT at - line 20. ######## # pp_sys.c [pp_binmode] use warnings 'unopened' ; binmode(BLARG); $a = "BLERG";binmode($a); EXPECT binmode() on unopened filehandle BLARG at - line 3. binmode() on unopened filehandle at - line 4. ######## # pp_sys.c [pp_lstat] use warnings 'io'; open FH, "harness" or die "# $!"; lstat FH; open my $fh, $0 or die "# $!"; lstat $fh; no warnings 'io'; lstat FH; lstat $fh; close FH; close $fh; EXPECT lstat() on filehandle FH at - line 4. lstat() on filehandle $fh at - line 6. ######## # pp_sys.c [pp_getc] use warnings qw(unopened closed) ; getc FOO; close STDIN; getc STDIN; # Create an empty file $file = 'getcwarn.tmp'; open FH1, ">$file" or die "# $!"; close FH1; open FH2, $file or die "# $!"; getc FH2; # Should not warn at EOF close FH2; getc FH2; # Warns, now unlink $file; no warnings qw(unopened closed) ; getc FOO; getc STDIN; getc FH2; EXPECT getc() on unopened filehandle FOO at - line 3. getc() on closed filehandle STDIN at - line 5. getc() on closed filehandle FH2 at - line 12. ######## # pp_sys.c [pp_sselect] use warnings 'misc'; $x = 1; select $x, undef, undef, 1; no warnings 'misc'; select $x, undef, undef, 1; EXPECT Non-string passed as bitmask at - line 4. ######## use Config; BEGIN { if (!$Config{d_fchdir}) { print < %s non-portable my $a = 0b011111111111111111111111111111110 ; $a = 0b011111111111111111111111111111111 ; $a = 0b111111111111111111111111111111111 ; $a = 0x0fffffffe ; $a = 0x0ffffffff ; $a = 0x1ffffffff ; $a = 0037777777776 ; $a = 0037777777777 ; $a = 0047777777777 ; Integer overflow in binary number my $a = 0b011111111111111111111111111111110 ; $a = 0b011111111111111111111111111111111 ; $a = 0b111111111111111111111111111111111 ; $a = 0x0fffffffe ; $a = 0x0ffffffff ; $a = 0x1ffffffff ; $a = 0037777777776 ; $a = 0037777777777 ; $a = 0047777777777 ; dump() better written as CORE::dump() Use of /c modifier is meaningless without /g Use of /c modifier is meaningless in s/// Mandatory Warnings ------------------ Use of "%s" without parentheses is ambiguous [check_uni] rand + 4 Ambiguous use of -%s resolved as -&%s() [yylex] sub fred {} ; - fred ; Precedence problem: open %.*s should be open(%.*s) [yylex] open FOO || die; Operator or semicolon missing before %c%s [yylex] Ambiguous use of %c resolved as operator %c *foo *foo __END__ # toke.c format STDOUT = @<<< @||| @>>> @>>> $a $b "abc" 'def' . no warnings 'deprecated' ; format STDOUT = @<<< @||| @>>> @>>> $a $b "abc" 'def' . EXPECT Use of comma-less variable list is deprecated at - line 4. Use of comma-less variable list is deprecated at - line 4. Use of comma-less variable list is deprecated at - line 4. ######## # toke.c $a = <<; no warnings 'deprecated' ; $a = <<; EXPECT Use of bare << to mean <<"" is deprecated at - line 2. ######## # toke.c use warnings 'syntax' ; s/(abc)/\1/; no warnings 'syntax' ; s/(abc)/\1/; EXPECT \1 better written as $1 at - line 3. ######## # toke.c use warnings 'semicolon' ; $a = 1 &time ; no warnings 'semicolon' ; $a = 1 &time ; EXPECT Semicolon seems to be missing at - line 3. ######## # toke.c use warnings 'syntax' ; my $a =+ 2 ; $a =- 2 ; $a =* 2 ; $a =% 2 ; $a =& 2 ; $a =. 2 ; $a =^ 2 ; $a =| 2 ; $a =< 2 ; $a =/ 2 ; EXPECT Reversed += operator at - line 3. Reversed -= operator at - line 4. Reversed *= operator at - line 5. Reversed %= operator at - line 6. Reversed &= operator at - line 7. Reversed .= operator at - line 8. Reversed ^= operator at - line 9. Reversed |= operator at - line 10. Reversed <= operator at - line 11. syntax error at - line 8, near "=." syntax error at - line 9, near "=^" syntax error at - line 10, near "=|" Unterminated <> operator at - line 11. ######## # toke.c no warnings 'syntax' ; my $a =+ 2 ; $a =- 2 ; $a =* 2 ; $a =% 2 ; $a =& 2 ; $a =. 2 ; $a =^ 2 ; $a =| 2 ; $a =< 2 ; $a =/ 2 ; EXPECT syntax error at - line 8, near "=." syntax error at - line 9, near "=^" syntax error at - line 10, near "=|" Unterminated <> operator at - line 11. ######## # toke.c use warnings 'syntax' ; my $a = $a[1,2] ; no warnings 'syntax' ; my $a = $a[1,2] ; EXPECT Multidimensional syntax $a[1,2] not supported at - line 3. ######## # toke.c use warnings 'syntax' ; sub fred {} ; $SIG{TERM} = fred; no warnings 'syntax' ; $SIG{TERM} = fred; EXPECT You need to quote "fred" at - line 3. ######## # toke.c use warnings 'syntax' ; @a[3] = 2; @a{3} = 2; no warnings 'syntax' ; @a[3] = 2; @a{3} = 2; EXPECT Scalar value @a[3] better written as $a[3] at - line 3. Scalar value @a{3} better written as $a{3} at - line 4. ######## # toke.c use warnings 'syntax' ; $_ = "ab" ; s/(ab)/\1/e; no warnings 'syntax' ; $_ = "ab" ; s/(ab)/\1/e; EXPECT Can't use \1 to mean $1 in expression at - line 4. ######## # toke.c use warnings 'reserved' ; $a = abc; $a = { def => 1 }; no warnings 'reserved' ; $a = abc; EXPECT Unquoted string "abc" may clash with future reserved word at - line 3. ######## # toke.c use warnings 'qw' ; @a = qw(a, b, c) ; no warnings 'qw' ; @a = qw(a, b, c) ; EXPECT Possible attempt to separate words with commas at - line 3. ######## # toke.c use warnings 'qw' ; @a = qw(a b #) ; no warnings 'qw' ; @a = qw(a b #) ; EXPECT Possible attempt to put comments in qw() list at - line 3. ######## # toke.c use warnings 'syntax' ; print (""); print ("") and $x = 1; print ("") or die; print ("") // die; print (1+2) * 3 if 0; # only this one should warn print (1+2) if 0; EXPECT print (...) interpreted as function at - line 7. ######## # toke.c no warnings 'syntax' ; print ("") EXPECT ######## # toke.c use warnings 'syntax' ; printf (""); printf ("") . ''; EXPECT printf (...) interpreted as function at - line 4. ######## # toke.c no warnings 'syntax' ; printf ("") EXPECT ######## # toke.c use warnings 'syntax' ; sort (""); sort ("") . ''; EXPECT sort (...) interpreted as function at - line 4. ######## # toke.c no warnings 'syntax' ; sort ("") EXPECT ######## # toke.c use warnings 'ambiguous' ; $a = ${time[2]}; no warnings 'ambiguous' ; $a = ${time[2]}; EXPECT Ambiguous use of ${time[...]} resolved to $time[...] at - line 3. ######## # toke.c use warnings 'ambiguous' ; $a = ${time{2}}; EXPECT Ambiguous use of ${time{...}} resolved to $time{...} at - line 3. ######## # toke.c no warnings 'ambiguous' ; $a = ${time{2}}; EXPECT ######## # toke.c use warnings 'ambiguous' ; $a = ${time} ; no warnings 'ambiguous' ; $a = ${time} ; EXPECT Ambiguous use of ${time} resolved to $time at - line 3. ######## # toke.c use warnings 'ambiguous' ; sub fred {} $a = ${fred} ; no warnings 'ambiguous' ; $a = ${fred} ; EXPECT Ambiguous use of ${fred} resolved to $fred at - line 4. ######## # toke.c use warnings 'syntax' ; $a = _123; print "$a\n"; #( 3 string) $a = 1_23; print "$a\n"; $a = 12_3; print "$a\n"; $a = 123_; print "$a\n"; # 6 $a = _+123; print "$a\n"; # 7 string) $a = +_123; print "$a\n"; #( 8 string) $a = +1_23; print "$a\n"; $a = +12_3; print "$a\n"; $a = +123_; print "$a\n"; # 11 $a = _-123; print "$a\n"; #(12 string) $a = -_123; print "$a\n"; #(13 string) $a = -1_23; print "$a\n"; $a = -12_3; print "$a\n"; $a = -123_; print "$a\n"; # 16 $a = 123._456; print "$a\n"; # 17 $a = 123.4_56; print "$a\n"; $a = 123.45_6; print "$a\n"; $a = 123.456_; print "$a\n"; # 20 $a = +123._456; print "$a\n"; # 21 $a = +123.4_56; print "$a\n"; $a = +123.45_6; print "$a\n"; $a = +123.456_; print "$a\n"; # 24 $a = -123._456; print "$a\n"; # 25 $a = -123.4_56; print "$a\n"; $a = -123.45_6; print "$a\n"; $a = -123.456_; print "$a\n"; # 28 $a = 123.456E_12; printf("%.0f\n", $a); # 29 $a = 123.456E1_2; printf("%.0f\n", $a); $a = 123.456E12_; printf("%.0f\n", $a); # 31 $a = 123.456E_+12; printf("%.0f\n", $a); # 32 $a = 123.456E+_12; printf("%.0f\n", $a); # 33 $a = 123.456E+1_2; printf("%.0f\n", $a); $a = 123.456E+12_; printf("%.0f\n", $a); # 35 $a = 123.456E_-12; print "$a\n"; # 36 $a = 123.456E-_12; print "$a\n"; # 37 $a = 123.456E-1_2; print "$a\n"; $a = 123.456E-12_; print "$a\n"; # 39 $a = 1__23; print "$a\n"; # 40 $a = 12.3__4; print "$a\n"; # 41 $a = 12.34e1__2; printf("%.0f\n", $a); # 42 no warnings 'syntax' ; $a = _123; print "$a\n"; $a = 1_23; print "$a\n"; $a = 12_3; print "$a\n"; $a = 123_; print "$a\n"; $a = _+123; print "$a\n"; $a = +_123; print "$a\n"; $a = +1_23; print "$a\n"; $a = +12_3; print "$a\n"; $a = +123_; print "$a\n"; $a = _-123; print "$a\n"; $a = -_123; print "$a\n"; $a = -1_23; print "$a\n"; $a = -12_3; print "$a\n"; $a = -123_; print "$a\n"; $a = 123._456; print "$a\n"; $a = 123.4_56; print "$a\n"; $a = 123.45_6; print "$a\n"; $a = 123.456_; print "$a\n"; $a = +123._456; print "$a\n"; $a = +123.4_56; print "$a\n"; $a = +123.45_6; print "$a\n"; $a = +123.456_; print "$a\n"; $a = -123._456; print "$a\n"; $a = -123.4_56; print "$a\n"; $a = -123.45_6; print "$a\n"; $a = -123.456_; print "$a\n"; $a = 123.456E_12; printf("%.0f\n", $a); $a = 123.456E1_2; printf("%.0f\n", $a); $a = 123.456E12_; printf("%.0f\n", $a); $a = 123.456E_+12; printf("%.0f\n", $a); $a = 123.456E+_12; printf("%.0f\n", $a); $a = 123.456E+1_2; printf("%.0f\n", $a); $a = 123.456E+12_; printf("%.0f\n", $a); $a = 123.456E_-12; print "$a\n"; $a = 123.456E-_12; print "$a\n"; $a = 123.456E-1_2; print "$a\n"; $a = 123.456E-12_; print "$a\n"; $a = 1__23; print "$a\n"; $a = 12.3__4; print "$a\n"; $a = 12.34e1__2; printf("%.0f\n", $a); EXPECT OPTIONS regex Misplaced _ in number at - line 6. Misplaced _ in number at - line 11. Misplaced _ in number at - line 16. Misplaced _ in number at - line 17. Misplaced _ in number at - line 20. Misplaced _ in number at - line 21. Misplaced _ in number at - line 24. Misplaced _ in number at - line 25. Misplaced _ in number at - line 28. Misplaced _ in number at - line 29. Misplaced _ in number at - line 31. Misplaced _ in number at - line 32. Misplaced _ in number at - line 33. Misplaced _ in number at - line 35. Misplaced _ in number at - line 36. Misplaced _ in number at - line 37. Misplaced _ in number at - line 39. Misplaced _ in number at - line 40. Misplaced _ in number at - line 41. Misplaced _ in number at - line 42. _123 123 123 123 123 _123 123 123 123 -123 -_123 -123 -123 -123 123.456 123.456 123.456 123.456 123.456 123.456 123.456 123.456 -123.456 -123.456 -123.456 -123.456 123456000000000 123456000000000 123456000000000 123456000000000 123456000000000 123456000000000 123456000000000 1.23456e-0?10 1.23456e-0?10 1.23456e-0?10 1.23456e-0?10 123 12.34 12340000000000 _123 123 123 123 123 _123 123 123 123 -123 -_123 -123 -123 -123 123.456 123.456 123.456 123.456 123.456 123.456 123.456 123.456 -123.456 -123.456 -123.456 -123.456 123456000000000 123456000000000 123456000000000 123456000000000 123456000000000 123456000000000 123456000000000 1.23456e-0?10 1.23456e-0?10 1.23456e-0?10 1.23456e-0?10 123 12.34 12340000000000 ######## # toke.c use warnings 'bareword' ; #line 25 "bar" $a = FRED:: ; no warnings 'bareword' ; #line 25 "bar" $a = FRED:: ; EXPECT Bareword "FRED::" refers to nonexistent package at bar line 25. ######## # toke.c use warnings 'ambiguous' ; sub time {} my $a = time() ; no warnings 'ambiguous' ; my $b = time() ; EXPECT Ambiguous call resolved as CORE::time(), qualify as such or use & at - line 4. ######## # toke.c use warnings ; eval <<'EOE'; # line 30 "foo" warn "yelp"; { $_ = " \x{123} " ; } EOE EXPECT yelp at foo line 30. ######## # toke.c my $a = rand + 4 ; EXPECT Warning: Use of "rand" without parentheses is ambiguous at - line 2. ######## # toke.c $^W = 0 ; my $a = rand + 4 ; { no warnings 'ambiguous' ; $a = rand + 4 ; use warnings 'ambiguous' ; $a = rand + 4 ; } $a = rand + 4 ; EXPECT Warning: Use of "rand" without parentheses is ambiguous at - line 3. Warning: Use of "rand" without parentheses is ambiguous at - line 8. Warning: Use of "rand" without parentheses is ambiguous at - line 10. ######## # toke.c use warnings "ambiguous"; print for keys %+; # should not warn EXPECT ######## # toke.c sub fred {}; -fred ; EXPECT Ambiguous use of -fred resolved as -&fred() at - line 3. ######## # toke.c $^W = 0 ; sub fred {} ; -fred ; { no warnings 'ambiguous' ; -fred ; use warnings 'ambiguous' ; -fred ; } -fred ; EXPECT Ambiguous use of -fred resolved as -&fred() at - line 4. Ambiguous use of -fred resolved as -&fred() at - line 9. Ambiguous use of -fred resolved as -&fred() at - line 11. ######## # toke.c open FOO || time; EXPECT Precedence problem: open FOO should be open(FOO) at - line 2. ######## # toke.c (and [perl #16184]) open FOO => "<&0"; close FOO; EXPECT ######## # toke.c $^W = 0 ; open FOO || time; { no warnings 'precedence' ; open FOO || time; use warnings 'precedence' ; open FOO || time; } open FOO || time; EXPECT Precedence problem: open FOO should be open(FOO) at - line 3. Precedence problem: open FOO should be open(FOO) at - line 8. Precedence problem: open FOO should be open(FOO) at - line 10. ######## # toke.c $^W = 0 ; *foo *foo ; { no warnings 'ambiguous' ; *foo *foo ; use warnings 'ambiguous' ; *foo *foo ; } *foo *foo ; EXPECT Operator or semicolon missing before *foo at - line 3. Ambiguous use of * resolved as operator * at - line 3. Operator or semicolon missing before *foo at - line 8. Ambiguous use of * resolved as operator * at - line 8. Operator or semicolon missing before *foo at - line 10. Ambiguous use of * resolved as operator * at - line 10. ######## # toke.c use warnings 'misc' ; my $a = "\m" ; no warnings 'misc' ; $a = "\m" ; EXPECT Unrecognized escape \m passed through at - line 3. ######## # toke.c use warnings 'portable' ; my $a = 0b011111111111111111111111111111110 ; $a = 0b011111111111111111111111111111111 ; $a = 0b111111111111111111111111111111111 ; $a = 0x0fffffffe ; $a = 0x0ffffffff ; $a = 0x1ffffffff ; $a = 0037777777776 ; $a = 0037777777777 ; $a = 0047777777777 ; no warnings 'portable' ; $a = 0b011111111111111111111111111111110 ; $a = 0b011111111111111111111111111111111 ; $a = 0b111111111111111111111111111111111 ; $a = 0x0fffffffe ; $a = 0x0ffffffff ; $a = 0x1ffffffff ; $a = 0037777777776 ; $a = 0037777777777 ; $a = 0047777777777 ; EXPECT Binary number > 0b11111111111111111111111111111111 non-portable at - line 5. Hexadecimal number > 0xffffffff non-portable at - line 8. Octal number > 037777777777 non-portable at - line 11. ######## # toke.c use warnings 'overflow' ; my $a = 0b011111111111111111111111111111110 ; $a = 0b011111111111111111111111111111111 ; $a = 0b10000000000000000000000000000000000000000000000000000000000000000 ; $a = 0x0fffffffe ; $a = 0x0ffffffff ; $a = 0x10000000000000000 ; $a = 0037777777776 ; $a = 0037777777777 ; $a = 002000000000000000000000; no warnings 'overflow' ; $a = 0b011111111111111111111111111111110 ; $a = 0b011111111111111111111111111111111 ; $a = 0b10000000000000000000000000000000000000000000000000000000000000000 ; $a = 0x0fffffffe ; $a = 0x0ffffffff ; $a = 0x10000000000000000 ; $a = 0037777777776 ; $a = 0037777777777 ; $a = 002000000000000000000000; EXPECT Integer overflow in binary number at - line 5. Integer overflow in hexadecimal number at - line 8. Integer overflow in octal number at - line 11. ######## # toke.c BEGIN { $^C = 1; } use warnings 'misc'; dump; CORE::dump; EXPECT dump() better written as CORE::dump() at - line 4. - syntax OK ######## # toke.c use warnings 'misc'; use subs qw/dump/; sub dump { print "no warning for overriden dump\n"; } dump; EXPECT no warning for overriden dump ######## # toke.c use warnings 'ambiguous'; "@mjd_previously_unused_array"; no warnings 'ambiguous'; "@mjd_previously_unused_array"; EXPECT Possible unintended interpolation of @mjd_previously_unused_array in string at - line 3. ######## # toke.c # 20020328 mjd-perl-patch+@plover.com at behest of jfriedl@yahoo.com use warnings 'regexp'; "foo" =~ /foo/c; "foo" =~ /foo/cg; no warnings 'regexp'; "foo" =~ /foo/c; "foo" =~ /foo/cg; EXPECT Use of /c modifier is meaningless without /g at - line 4. ######## # toke.c # 20020328 mjd-perl-patch+@plover.com at behest of jfriedl@yahoo.com use warnings 'regexp'; $_ = "ab" ; s/ab/ab/c; s/ab/ab/cg; no warnings 'regexp'; s/ab/ab/c; s/ab/ab/cg; EXPECT Use of /c modifier is meaningless in s/// at - line 5. Use of /c modifier is meaningless in s/// at - line 6. ######## -wa # toke.c # 20020414 mjd-perl-patch+@plover.com # -a flag should suppress these warnings print "@F\n"; EXPECT ######## -w # toke.c # 20020414 mjd-perl-patch+@plover.com # -a flag should suppress these warnings print "@F\n"; EXPECT Possible unintended interpolation of @F in string at - line 4. Name "main::F" used only once: possible typo at - line 4. ######## -wa # toke.c # 20020414 mjd-perl-patch+@plover.com EXPECT ######## # toke.c # 20020414 mjd-perl-patch+@plover.com # In 5.7.3, this emitted "Possible unintended interpolation" warnings use warnings 'ambiguous'; $s = "(@-)(@+)"; EXPECT ######## # toke.c # mandatory warning eval q/if ($a) { } elseif ($b) { }/; no warnings "syntax"; eval q/if ($a) { } elseif ($b) { }/; EXPECT elseif should be elsif at (eval 1) line 1. ######## # toke.c # mandatory warning eval q/5 6/; no warnings "syntax"; eval q/5 6/; EXPECT Number found where operator expected at (eval 1) line 1, near "5 6" (Missing operator before 6?) ######## # toke.c use warnings "syntax"; $_ = $a = 1; $a !=~ /1/; $a !=~ m#1#; $a !=~/1/; $a !=~ ?/?; $a !=~ y/1//; $a !=~ tr/1//; $a !=~ s/1//; $a != ~/1/; no warnings "syntax"; $a !=~ /1/; $a !=~ m#1#; $a !=~/1/; $a !=~ ?/?; $a !=~ y/1//; $a !=~ tr/1//; $a !=~ s/1//; EXPECT !=~ should be !~ at - line 4. !=~ should be !~ at - line 5. !=~ should be !~ at - line 6. !=~ should be !~ at - line 7. !=~ should be !~ at - line 8. !=~ should be !~ at - line 9. !=~ should be !~ at - line 10. ######## # toke.c our $foo :unique; sub pam :locked; sub glipp :locked { } sub whack_eth ($) : locked { } no warnings 'deprecated'; our $bar :unique; sub zapeth :locked; sub ker_plop :locked { } sub swa_a_p ($) : locked { } EXPECT Use of :unique is deprecated at - line 2. Use of :locked is deprecated at - line 3. Use of :locked is deprecated at - line 4. Use of :locked is deprecated at - line 6. ######## # toke.c use warnings "syntax"; sub proto_after_array(@$); sub proto_after_arref(\@$); sub proto_after_arref2(\[@$]); sub proto_after_arref3(\[@$]_); sub proto_after_hash(%$); sub proto_after_hashref(\%$); sub proto_after_hashref2(\[%$]); sub underscore_last_pos($_); sub underscore2($_;$); sub underscore_fail($_$); sub underscore_after_at(@_); no warnings "syntax"; sub proto_after_array(@$); sub proto_after_hash(%$); sub underscore_fail($_$); EXPECT Prototype after '@' for main::proto_after_array : @$ at - line 3. Prototype after '%' for main::proto_after_hash : %$ at - line 7. Illegal character after '_' in prototype for main::underscore_fail : $_$ at - line 12. Prototype after '@' for main::underscore_after_at : @_ at - line 13. ######## # toke.c use warnings "ambiguous"; "foo\nn" =~ /^foo$\n/; "foo\nn" =~ /^foo${\}n/; my $foo = qr/^foo$\n/; my $bar = qr/^foo${\}n/; no warnings "ambiguous"; "foo\nn" =~ /^foo$\n/; "foo\nn" =~ /^foo${\}n/; my $foo = qr/^foo$\n/; my $bar = qr/^foo${\}n/; EXPECT Possible unintended interpolation of $\ in regex at - line 3. Possible unintended interpolation of $\ in regex at - line 5. ######## # toke.c use feature 'state'; # This one is fine as an empty attribute list my $holy_Einstein : = ''; # This one is deprecated my $krunch := 4; our $FWISK_FWISK_FWIZZACH_FWACH_ZACHITTY_ZICH_SHAZZATZ_FWISK := ''; state $thump := 'Trumpets'; # Lather rinse repeat in my usual obsessive style my @holy_perfect_pitch : = (); my @zok := (); our @GUKGUK := (); # state @widget_mark := (); my %holy_seditives : = (); my %bang := (); our %GIGAZING := (); # state %hex := (); no warnings 'deprecated'; my $holy_giveaways : = ''; my $eee_yow := []; our $TWOYYOYYOING_THUK_UGH := 1 == 1; state $octothorn := 'Tinky Winky'; my @holy_Taj_Mahal : = (); my @touche := (); our @PLAK_DAK_THUK_FRIT := (); # state @hash_mark := (); my %holy_priceless_collection_of_Etruscan_snoods : = (); my %wham_eth := (); our %THWUK := (); # state %octalthorpe := (); use warnings; my $holy_sewer_pipe : = ''; my $thunk := undef; our $BLIT := time; state $crunch := 'Laa Laa'; my @glurpp := (); my @holy_harem : = (); our @FABADAP := (); # state @square := (); my %holy_pin_cushions : = (); my %swoosh := (); our %RRRRR := (); # state %scratchmark := (); EXPECT Use of := for an empty attribute list is deprecated at - line 6. Use of := for an empty attribute list is deprecated at - line 7. Use of := for an empty attribute list is deprecated at - line 8. Use of := for an empty attribute list is deprecated at - line 11. Use of := for an empty attribute list is deprecated at - line 12. Use of := for an empty attribute list is deprecated at - line 15. Use of := for an empty attribute list is deprecated at - line 16. Use of := for an empty attribute list is deprecated at - line 33. Use of := for an empty attribute list is deprecated at - line 34. Use of := for an empty attribute list is deprecated at - line 35. Use of := for an empty attribute list is deprecated at - line 36. Use of := for an empty attribute list is deprecated at - line 38. Use of := for an empty attribute list is deprecated at - line 41. Use of := for an empty attribute list is deprecated at - line 42. perl-5.12.0-RC0/t/lib/warnings/universal0000444000175000017500000000052311143650501016715 0ustar jessejesse universal.c AOK Can't locate package %s for @%s::ISA [S_isa_lookup] __END__ # universal.c [S_isa_lookup] print("SKIPPED\n# todo fix: overloading triggers spurious warnings\n"),exit; use warnings 'misc' ; @ISA = qw(Joe) ; my $a = bless [] ; UNIVERSAL::isa $a, Jim ; EXPECT Can't locate package Joe for @main::ISA at - line 5. perl-5.12.0-RC0/t/lib/warnings/taint0000444000175000017500000000171211325125742016033 0ustar jessejesse taint.c AOK Insecure %s%s while running with -T switch __END__ -T --FILE-- abc def --FILE-- # taint.c open(FH, " ; close FH ; chdir $a ; print "xxx\n" ; EXPECT Insecure dependency in chdir while running with -T switch at - line 5. ######## -TU --FILE-- abc def --FILE-- # taint.c open(FH, " ; close FH ; chdir $a; no warnings 'taint' ; chdir $a ; print "xxx\n" ; use warnings 'taint' ; chdir $a ; print "yyy\n" ; EXPECT Insecure dependency in chdir while running with -T switch at - line 5. Insecure dependency in chdir while running with -T switch at - line 10. xxx yyy ######## -t --FILE-- abc def --FILE-- # taint.c open(FH, " ; close FH ; chdir $a; no warnings 'taint' ; chdir $a ; print "xxx\n" ; use warnings 'taint' ; chdir $a ; print "yyy\n" ; EXPECT Insecure dependency in chdir while running with -t switch at - line 5. Insecure dependency in chdir while running with -t switch at - line 10. xxx yyy perl-5.12.0-RC0/t/lib/warnings/run0000444000175000017500000000013611143650501015511 0ustar jessejesse run.c Mandatory Warnings ALL TODO ------------------ NULL OP IN RUN __END__ perl-5.12.0-RC0/t/lib/warnings/sv0000444000175000017500000002007611325125742015350 0ustar jessejesse sv.c warn(warn_uninit); warn(warn_uninit); warn(warn_uninit); warn(warn_uninit); not_a_number(sv); not_a_number(sv); warn(warn_uninit); not_a_number(sv); warn(warn_uninit); not_a_number(sv); not_a_number(sv); warn(warn_uninit); warn(warn_uninit); Subroutine %s redefined Invalid conversion in %s: Undefined value assigned to typeglob Reference is already weak [Perl_sv_rvweaken] < "def" ; no warnings 'numeric' ; my $z = pack i => "def" ; EXPECT Argument "def" isn't numeric in pack at - line 3. ######## # sv.c use warnings 'numeric' ; my $a = "d\0f" ; my $x = 1 + $a ; no warnings 'numeric' ; my $z = 1 + $a ; EXPECT Argument "d\0f" isn't numeric in addition (+) at - line 4. ######## # sv.c use warnings 'redefine' ; sub fred {} sub joe {} *fred = \&joe ; no warnings 'redefine' ; sub jim {} *jim = \&joe ; EXPECT Subroutine main::fred redefined at - line 5. ######## # sv.c use warnings 'printf' ; open F, ">".($^O eq 'VMS'? 'NL:' : '/dev/null') ; printf F "%z\n" ; my $a = sprintf "%z" ; printf F "%" ; $a = sprintf "%" ; printf F "%\x02" ; $a = sprintf "%\x02" ; printf F "%llz" ; $a = sprintf "%llz" ; printf F "%25llz" ; $a = sprintf "%25llz" ; printf F "%+2Lz" ; $a = sprintf "%+2Lz" ; printf F "%+2ll" ; $a = sprintf "%+2ll" ; printf F "%+2L\x03" ; $a = sprintf "%+2L\x03" ; no warnings 'printf' ; printf F "%z\n" ; $a = sprintf "%z" ; printf F "%" ; $a = sprintf "%" ; printf F "%\x02" ; $a = sprintf "%\x02" ; printf F "%llz" ; $a = sprintf "%llz" ; printf F "%25llz" ; $a = sprintf "%25llz" ; printf F "%+2Lz" ; $a = sprintf "%+2Lz" ; printf F "%+2ll" ; $a = sprintf "%+2ll" ; printf F "%+2L\x03" ; $a = sprintf "%+2L\x03" ; EXPECT Invalid conversion in printf: "%z" at - line 4. Invalid conversion in sprintf: "%z" at - line 5. Invalid conversion in printf: end of string at - line 6. Invalid conversion in sprintf: end of string at - line 7. Invalid conversion in printf: "%\002" at - line 8. Invalid conversion in sprintf: "%\002" at - line 9. Invalid conversion in printf: "%llz" at - line 10. Invalid conversion in sprintf: "%llz" at - line 11. Invalid conversion in printf: "%25llz" at - line 12. Invalid conversion in sprintf: "%25llz" at - line 13. Invalid conversion in printf: "%+2Lz" at - line 14. Invalid conversion in sprintf: "%+2Lz" at - line 15. Invalid conversion in printf: "%+2ll" at - line 16. Invalid conversion in sprintf: "%+2ll" at - line 17. Invalid conversion in printf: "%+2L\003" at - line 18. Invalid conversion in sprintf: "%+2L\003" at - line 19. ######## # sv.c use warnings 'misc' ; *a = undef ; no warnings 'misc' ; *b = undef ; EXPECT Undefined value assigned to typeglob at - line 3. ######## # sv.c use warnings 'numeric' ; $a = "\x{100}\x{200}" * 42; no warnings 'numeric' ; $a = "\x{100}\x{200}" * 42; EXPECT Argument "\x{100}\x{200}" isn't numeric in multiplication (*) at - line 3. ######## # sv.c use warnings 'numeric' ; $a = "\x{100}\x{200}"; $a = -$a; no warnings 'numeric' ; $a = "\x{100}\x{200}"; $a = -$a; EXPECT Argument "\x{100}\x{200}" isn't numeric in negation (-) at - line 3. perl-5.12.0-RC0/t/lib/warnings/8signal0000444000175000017500000000066211143650501016256 0ustar jessejesseCheck interaction of __WARN__, __DIE__ & lexical Warnings TODO __END__ # 8signal BEGIN { $| = 1; $SIG{__WARN__} = sub { print "WARN -- @_" } } BEGIN { $SIG{__DIE__} = sub { print "DIE -- @_" } } $a =+ 1 ; use warnings qw(syntax) ; $a =+ 1 ; use warnings FATAL => qw(syntax) ; $a =+ 1 ; print "The End.\n" ; EXPECT WARN -- Reversed += operator at - line 6. DIE -- Reversed += operator at - line 8. Reversed += operator at - line 8. perl-5.12.0-RC0/t/lib/warnings/regexec0000444000175000017500000000622211143650501016331 0ustar jessejesse regexec.c This test generates "bad free" warnings when run under PERL_DESTRUCT_LEVEL. This file merely serves as a placeholder for investigation. Complex regular subexpression recursion limit (%d) exceeded $_ = 'a' x (2**15+1); /^()(a\1)*$/ ; Complex regular subexpression recursion limit (%d) exceeded $_ = 'a' x (2**15+1); /^()(a\1)*?$/ ; (The actual value substituted for %d is masked in the tests so that REG_INFTY configuration variable value does not affect outcome.) __END__ # regexec.c print("SKIPPED\n# most systems run into stacksize limits\n"),exit; use warnings 'regexp' ; $SIG{__WARN__} = sub{local ($m) = shift; $m =~ s/\(\d+\)/(*MASKED*)/; print STDERR $m}; $_ = 'a' x (2**15+1); /^()(a\1)*$/ ; # # If this test fails with a segmentation violation or similar, # you may have to increase the default stacksize limit in your # shell. You may need superuser privileges. # # Under the sh, ksh, zsh: # $ ulimit -s # 8192 # $ ulimit -s 16000 # # Under the csh: # % limit stacksize # stacksize 8192 kbytes # % limit stacksize 16000 # EXPECT Complex regular subexpression recursion limit (*MASKED*) exceeded at - line 9. ######## # regexec.c print("SKIPPED\n# most systems run into stacksize limits\n"),exit; no warnings 'regexp' ; $SIG{__WARN__} = sub{local ($m) = shift; $m =~ s/\(\d+\)/(*MASKED*)/; print STDERR $m}; $_ = 'a' x (2**15+1); /^()(a\1)*$/ ; # # If this test fails with a segmentation violation or similar, # you may have to increase the default stacksize limit in your # shell. You may need superuser privileges. # # Under the sh, ksh, zsh: # $ ulimit -s # 8192 # $ ulimit -s 16000 # # Under the csh: # % limit stacksize # stacksize 8192 kbytes # % limit stacksize 16000 # EXPECT ######## # regexec.c print("SKIPPED\n# most systems run into stacksize limits\n"),exit; use warnings 'regexp' ; $SIG{__WARN__} = sub{local ($m) = shift; $m =~ s/\(\d+\)/(*MASKED*)/; print STDERR $m}; $_ = 'a' x (2**15+1); /^()(a\1)*?$/ ; # # If this test fails with a segmentation violation or similar, # you may have to increase the default stacksize limit in your # shell. You may need superuser privileges. # # Under the sh, ksh, zsh: # $ ulimit -s # 8192 # $ ulimit -s 16000 # # Under the csh: # % limit stacksize # stacksize 8192 kbytes # % limit stacksize 16000 # EXPECT Complex regular subexpression recursion limit (*MASKED*) exceeded at - line 9. ######## # regexec.c print("SKIPPED\n# most systems run into stacksize limits\n"),exit; no warnings 'regexp' ; $SIG{__WARN__} = sub{local ($m) = shift; $m =~ s/\(\d+\)/(*MASKED*)/; print STDERR $m}; $_ = 'a' x (2**15+1); /^()(a\1)*?$/ ; # # If this test fails with a segmentation violation or similar, # you may have to increase the default stacksize limit in your # shell. You may need superuser privileges. # # Under the sh, ksh, zsh: # $ ulimit -s # 8192 # $ ulimit -s 16000 # # Under the csh: # % limit stacksize # stacksize 8192 kbytes # % limit stacksize 16000 # EXPECT perl-5.12.0-RC0/t/lib/warnings/pp0000444000175000017500000000411011143650501015320 0ustar jessejesse pp.c TODO substr outside of string $a = "ab" ; $b = substr($a, 4,5) ; Attempt to use reference as lvalue in substr $a = "ab" ; $b = \$a ; substr($b, 1,1) = $b Use of uninitialized value in ref-to-glob cast [pp_rv2gv()] *b = *{ undef()} Use of uninitialized value in scalar dereference [pp_rv2sv()] my $a = undef ; my $b = $$a Odd number of elements in hash list my $a = { 1,2,3 } ; Explicit blessing to '' (assuming package main) bless \[], ""; Constant subroutine %s undefined sub foo () { 1 }; undef &foo; Constant subroutine (anonymous) undefined $foo = sub () { 3 }; undef &$foo; __END__ # pp.c use warnings 'substr' ; $a = "ab" ; $b = substr($a, 4,5) ; no warnings 'substr' ; $a = "ab" ; $b = substr($a, 4,5) ; EXPECT substr outside of string at - line 4. ######## # pp.c use warnings 'substr' ; $a = "ab" ; $b = \$a ; substr($b, 1,1) = "ab" ; no warnings 'substr' ; substr($b, 1,1) = "ab" ; EXPECT Attempt to use reference as lvalue in substr at - line 5. ######## # pp.c use warnings 'uninitialized' ; *x = *{ undef() }; no warnings 'uninitialized' ; *y = *{ undef() }; EXPECT Use of uninitialized value in ref-to-glob cast at - line 3. ######## # pp.c use warnings 'uninitialized'; $x = undef; $y = $$x; no warnings 'uninitialized' ; $u = undef; $v = $$u; EXPECT Use of uninitialized value $x in scalar dereference at - line 3. ######## # pp.c use warnings 'misc' ; my $a = { 1,2,3}; no warnings 'misc' ; my $b = { 1,2,3}; EXPECT Odd number of elements in anonymous hash at - line 3. ######## # pp.c use warnings 'misc' ; bless \[], "" ; no warnings 'misc' ; bless \[], "" ; EXPECT Explicit blessing to '' (assuming package main) at - line 3. ######## # pp.c use warnings 'misc'; sub foo () { 1 } undef &foo; no warnings 'misc'; sub bar () { 2 } undef &bar; EXPECT Constant subroutine foo undefined at - line 4. ######## # pp.c use warnings 'misc'; $foo = sub () { 3 }; undef &$foo; no warnings 'misc'; $bar = sub () { 4 }; undef &$bar; EXPECT Constant subroutine (anonymous) undefined at - line 4. ######## # pp.c use utf8 ; $_ = "\x80 \xff" ; reverse ; EXPECT perl-5.12.0-RC0/t/lib/warnings/3both0000444000175000017500000001001711143650501015723 0ustar jessejesseCheck interaction of $^W and lexical __END__ # Check interaction of $^W and use warnings sub fred { use warnings ; my $b ; chop $b ; } { local $^W = 0 ; fred() ; } EXPECT Use of uninitialized value $b in scalar chop at - line 6. ######## # Check interaction of $^W and use warnings sub fred { use warnings ; my $b ; chop $b ; } { $^W = 0 ; fred() ; } EXPECT Use of uninitialized value $b in scalar chop at - line 6. ######## # Check interaction of $^W and use warnings sub fred { no warnings ; my $b ; chop $b ; } { local $^W = 1 ; fred() ; } EXPECT ######## # Check interaction of $^W and use warnings sub fred { no warnings ; my $b ; chop $b ; } { $^W = 1 ; fred() ; } EXPECT ######## # Check interaction of $^W and use warnings use warnings ; $^W = 1 ; my $b ; chop $b ; EXPECT Use of uninitialized value $b in scalar chop at - line 6. ######## # Check interaction of $^W and use warnings $^W = 1 ; use warnings ; my $b ; chop $b ; EXPECT Use of uninitialized value $b in scalar chop at - line 6. ######## # Check interaction of $^W and use warnings $^W = 1 ; no warnings ; my $b ; chop $b ; EXPECT ######## # Check interaction of $^W and use warnings no warnings ; $^W = 1 ; my $b ; chop $b ; EXPECT ######## -w # Check interaction of $^W and use warnings no warnings ; my $b ; chop $b ; EXPECT ######## -w # Check interaction of $^W and use warnings use warnings ; my $b ; chop $b ; EXPECT Use of uninitialized value $b in scalar chop at - line 5. ######## # Check interaction of $^W and use warnings sub fred { use warnings ; my $b ; chop $b ; } BEGIN { $^W = 0 } fred() ; EXPECT Use of uninitialized value $b in scalar chop at - line 6. ######## # Check interaction of $^W and use warnings sub fred { no warnings ; my $b ; chop $b ; } BEGIN { $^W = 1 } fred() ; EXPECT ######## # Check interaction of $^W and use warnings use warnings ; BEGIN { $^W = 1 } my $b ; chop $b ; EXPECT Use of uninitialized value $b in scalar chop at - line 6. ######## # Check interaction of $^W and use warnings BEGIN { $^W = 1 } use warnings ; my $b ; chop $b ; EXPECT Use of uninitialized value $b in scalar chop at - line 6. ######## # Check interaction of $^W and use warnings BEGIN { $^W = 1 } no warnings ; my $b ; chop $b ; EXPECT ######## # Check interaction of $^W and use warnings no warnings ; BEGIN { $^W = 1 } my $b ; chop $b ; EXPECT ######## # Check interaction of $^W and use warnings BEGIN { $^W = 1 } { no warnings ; my $b ; chop $b ; } my $b ; chop $b ; EXPECT Use of uninitialized value $b in scalar chop at - line 10. ######## # Check interaction of $^W and use warnings BEGIN { $^W = 0 } { use warnings ; my $b ; chop $b ; } my $b ; chop $b ; EXPECT Use of uninitialized value $b in scalar chop at - line 7. ######## # Check scope of pragma with eval BEGIN { $^W = 1 } { no warnings ; eval ' my $b ; chop $b ; '; print STDERR $@ ; my $b ; chop $b ; } EXPECT ######## # Check scope of pragma with eval BEGIN { $^W = 1 } use warnings; { no warnings ; eval q[ use warnings 'uninitialized' ; my $b ; chop $b ; ]; print STDERR $@; my $b ; chop $b ; } EXPECT Use of uninitialized value $b in scalar chop at (eval 1) line 3. ######## # Check scope of pragma with eval BEGIN { $^W = 0 } { use warnings 'uninitialized' ; eval ' my $b ; chop $b ; '; print STDERR $@ ; my $b ; chop $b ; } EXPECT Use of uninitialized value $b in scalar chop at (eval 1) line 2. Use of uninitialized value $b in scalar chop at - line 9. ######## # Check scope of pragma with eval BEGIN { $^W = 0 } { use warnings 'uninitialized' ; eval ' no warnings ; my $b ; chop $b ; '; print STDERR $@ ; my $b ; chop $b ; } EXPECT Use of uninitialized value $b in scalar chop at - line 10. ######## # Check scope of pragma with eval BEGIN { $^W = 1 } { no warnings ; eval ' my $a =+ 1 ; '; print STDERR $@ ; my $a =+ 1 ; } EXPECT perl-5.12.0-RC0/t/lib/warnings/perly0000444000175000017500000000125711143650501016045 0ustar jessejesse perly.y AOK dep() => deprecate("\"do\" to call subroutines") Use of "do" to call subroutines is deprecated sub fred {} do fred() sub fred {} do fred(1) sub fred {} $a = "fred" ; do $a() sub fred {} $a = "fred" ; do $a(1) __END__ # perly.y use warnings 'deprecated' ; sub fred {} do fred() ; do fred(1) ; $a = "fred" ; do $a() ; do $a(1) ; no warnings 'deprecated' ; do fred() ; do fred(1) ; $a = "fred" ; do $a() ; do $a(1) ; EXPECT Use of "do" to call subroutines is deprecated at - line 4. Use of "do" to call subroutines is deprecated at - line 5. Use of "do" to call subroutines is deprecated at - line 7. Use of "do" to call subroutines is deprecated at - line 8. perl-5.12.0-RC0/t/lib/warnings/pp_pack0000444000175000017500000000407311143650501016326 0ustar jessejesse pp.c TODO Invalid type in unpack: '%c my $A = pack ("A,A", 1,2) ; my @A = unpack ("A,A", "22") ; Attempt to pack pointer to temporary value pack("p", "abc") ; __END__ # pp_pack.c use warnings 'pack' ; use warnings 'unpack' ; my @a = unpack ("A,A", "22") ; my $a = pack ("A,A", 1,2) ; no warnings 'pack' ; no warnings 'unpack' ; my @b = unpack ("A,A", "22") ; my $b = pack ("A,A", 1,2) ; EXPECT Invalid type ',' in unpack at - line 4. Invalid type ',' in pack at - line 5. ######## # pp.c use warnings 'uninitialized' ; my $a = undef ; my $b = $$a; no warnings 'uninitialized' ; my $c = $$a; EXPECT Use of uninitialized value $a in scalar dereference at - line 4. ######## # pp_pack.c use warnings 'pack' ; sub foo { my $a = "a"; return $a . $a++ . $a++ } my $a = pack("p", &foo) ; no warnings 'pack' ; my $b = pack("p", &foo) ; EXPECT Attempt to pack pointer to temporary value at - line 4. ######## # pp.c use warnings 'misc' ; bless \[], "" ; no warnings 'misc' ; bless \[], "" ; EXPECT Explicit blessing to '' (assuming package main) at - line 3. ######## # pp.c use utf8 ; $_ = "\x80 \xff" ; reverse ; EXPECT ######## # pp_pack.c use warnings 'pack' ; print unpack("C", pack("C", -1)), "\n", unpack("C", pack("C", 0)), "\n", unpack("C", pack("C", 255)), "\n", unpack("C", pack("C", 256)), "\n", unpack("c", pack("c", -129)), "\n", unpack("c", pack("c", -128)), "\n", unpack("c", pack("c", 127)), "\n", unpack("c", pack("c", 128)), "\n"; no warnings 'pack' ; print unpack("C", pack("C", -1)), "\n"; print unpack("C", pack("C", 0)), "\n"; print unpack("C", pack("C", 255)), "\n"; print unpack("C", pack("C", 256)), "\n"; print unpack("c", pack("c", -129)), "\n"; print unpack("c", pack("c", -128)), "\n"; print unpack("c", pack("c", 127)), "\n"; print unpack("c", pack("c", 128)), "\n"; EXPECT Character in 'C' format wrapped in pack at - line 3. Character in 'C' format wrapped in pack at - line 3. Character in 'c' format wrapped in pack at - line 3. Character in 'c' format wrapped in pack at - line 3. 255 0 255 0 127 -128 127 -128 255 0 255 0 127 -128 127 -128 perl-5.12.0-RC0/t/lib/warnings/9enabled0000444000175000017500000005264511325127001016400 0ustar jessejesseCheck warnings::enabled & warnings::warn __END__ --FILE-- abc0.pm package abc0 ; use warnings "io" ; print "ok1\n" if ! warnings::enabled('all') ; print "ok2\n" if ! warnings::enabled("io") ; 1; --FILE-- no warnings; use abc0 ; EXPECT ok1 ok2 ######## --FILE-- abc1.pm package abc1 ; no warnings ; print "ok1\n" if !warnings::enabled('all') ; print "ok2\n" if warnings::enabled("syntax") ; 1; --FILE-- use warnings 'syntax' ; use abc1 ; EXPECT ok1 ok2 ######## --FILE-- abc2.pm package abc2 ; use warnings 'syntax' ; print "ok1\n" if warnings::enabled('io') ; print "ok2\n" if ! warnings::enabled("syntax") ; 1; --FILE-- use warnings 'io' ; use abc2 ; EXPECT ok1 ok2 ######## --FILE-- abc3 no warnings ; print "ok1\n" if !warnings::enabled('all') ; print "ok2\n" if !warnings::enabled("syntax") ; 1; --FILE-- use warnings 'syntax' ; require "abc3" ; EXPECT ok1 ok2 ######## --FILE-- abc4 use warnings 'syntax' ; print "ok1\n" if ! warnings::enabled('all') ; print "ok2\n" if ! warnings::enabled("syntax") ; print "ok3\n" if ! warnings::enabled("io") ; 1; --FILE-- use warnings 'io' ; require "abc4" ; EXPECT ok1 ok2 ok3 ######## --FILE-- abc5.pm package abc5 ; no warnings ; sub check { print "ok1\n" if !warnings::enabled('all') ; print "ok2\n" if warnings::enabled("syntax") ; } 1; --FILE-- use warnings 'syntax' ; use abc5 ; abc5::check() ; EXPECT ok1 ok2 ######## --FILE-- abc6.pm package abc6 ; use warnings 'io' ; sub check { print "ok1\n" if ! warnings::enabled('all') ; print "ok2\n" if warnings::enabled("syntax") ; print "ok3\n" if ! warnings::enabled("io") ; } 1; --FILE-- use warnings 'syntax' ; use abc6 ; abc6::check() ; EXPECT ok1 ok2 ok3 ######## --FILE-- abc7 package abc7 ; no warnings ; sub check { print "ok1\n" if !warnings::enabled('all') ; print "ok2\n" if warnings::enabled("syntax") ; } 1; --FILE-- use warnings 'syntax' ; require "abc7" ; abc7::check() ; EXPECT ok1 ok2 ######## --FILE-- abc8 package abc8 ; use warnings 'io' ; sub check { print "ok1\n" if ! warnings::enabled('all') ; print "ok2\n" if warnings::enabled("syntax") ; print "ok3\n" if ! warnings::enabled("io") ; } 1; --FILE-- use warnings 'syntax' ; require "abc8" ; abc8::check() ; EXPECT ok1 ok2 ok3 ######## --FILE-- abc9.pm package abc9 ; use warnings "io" ; print "ok1\n" if ! warnings::enabled('all') ; print "ok2\n" if ! warnings::enabled("io") ; 1; --FILE-- def.pm package def; no warnings; use abc9 ; 1; --FILE-- use warnings; use def ; EXPECT ok1 ok2 ######## --FILE-- abc10.pm package abc10 ; no warnings ; print "ok1\n" if ! warnings::enabled('all') ; print "ok2\n" if warnings::enabled("syntax") ; print "ok3\n" if !warnings::enabled("io") ; 1; --FILE-- def.pm use warnings 'syntax' ; print "ok4\n" if !warnings::enabled('all') ; print "ok5\n" if !warnings::enabled("io") ; use abc10 ; 1; --FILE-- use warnings 'io' ; use def ; EXPECT ok1 ok2 ok3 ok4 ok5 ######## --FILE-- abc11.pm package abc11 ; no warnings ; sub check { print "ok1\n" if !warnings::enabled('all') ; print "ok2\n" if warnings::enabled("syntax") ; } 1; --FILE-- use warnings 'syntax' ; use abc11 ; eval { abc11::check() ; }; print $@ ; EXPECT ok1 ok2 ######## --FILE-- abc12.pm package abc12 ; use warnings 'io' ; sub check { print "ok1\n" if ! warnings::enabled('all') ; print "ok2\n" if warnings::enabled("syntax") ; print "ok3\n" if ! warnings::enabled("io") ; } 1; --FILE-- use warnings 'syntax' ; use abc12 ; eval { abc12::check() ; } ; print $@ ; EXPECT ok1 ok2 ok3 ######## --FILE-- abc13 package abc13 ; no warnings ; sub check { print "ok1\n" if !warnings::enabled('all') ; print "ok2\n" if warnings::enabled("syntax") ; } 1; --FILE-- use warnings 'syntax' ; require "abc13" ; eval { abc13::check() ; } ; print $@ ; EXPECT ok1 ok2 ######## --FILE-- abc14 package abc14 ; use warnings 'io' ; sub check { print "ok1\n" if !warnings::enabled('all') ; print "ok2\n" if warnings::enabled("syntax") ; print "ok3\n" if warnings::enabled("io") ; } 1; --FILE-- use warnings 'syntax' ; require "abc14" ; eval { use warnings 'io' ; abc14::check() ; }; abc14::check() ; print $@ ; EXPECT ok1 ok2 ok3 ok1 ok2 ######## --FILE-- abc15.pm package abc15 ; use warnings 'io' ; sub check { print "ok1\n" if ! warnings::enabled('all') ; print "ok2\n" if warnings::enabled("syntax") ; print "ok3\n" if ! warnings::enabled("io") ; } 1; --FILE-- use warnings 'syntax' ; use abc15 ; sub fred { abc15::check() } fred() ; EXPECT ok1 ok2 ok3 ######## --FILE-- abc16.pm package abc16 ; use warnings 'io' ; sub check { print "ok1\n" if ! warnings::enabled('all') ; } 1; --FILE-- use warnings 'syntax' ; use abc16 ; sub fred { no warnings ; abc16::check() } fred() ; EXPECT ok1 ######## --FILE-- abc17.pm package abc17 ; use warnings 'misc' ; sub check { print "ok1\n" if ! warnings::enabled('all') ; print "ok2\n" if warnings::enabled("syntax") ; print "ok3\n" if warnings::enabled("io") ; print "ok4\n" if ! warnings::enabled("misc") ; } 1; --FILE-- use warnings 'syntax' ; use abc17 ; sub fred { use warnings 'io' ; abc17::check() } fred() ; EXPECT ok1 ok2 ok3 ok4 ######## # check warnings::warn use warnings ; eval { warnings::warn() } ; print $@ ; eval { warnings::warn("fred", "joe") } ; print $@ ; EXPECT Usage: warnings::warn([category,] 'message') at - line 5 Unknown warnings category 'fred' at - line 9 ######## # check warnings::warnif use warnings ; eval { warnings::warnif() } ; print $@ ; eval { warnings::warnif("fred", "joe") } ; print $@ ; EXPECT Usage: warnings::warnif([category,] 'message') at - line 5 Unknown warnings category 'fred' at - line 9 ######## --FILE-- abc18.pm package abc18 ; use warnings 'misc' ; sub check { warnings::warn("io", "hello") } 1; --FILE-- use warnings "io" ; use abc18; abc18::check() ; EXPECT hello at - line 3 ######## --FILE-- abc19.pm package abc19 ; use warnings 'misc' ; sub check { warnings::warn("misc", "hello") } 1; --FILE-- use warnings "io" ; use abc19; abc19::check() ; EXPECT hello at - line 3 ######## --FILE-- abc20.pm package abc20 ; use warnings 'misc' ; sub check { warnings::warn("io", "hello") } 1; --FILE-- use warnings qw( FATAL deprecated ) ; use abc20; eval { abc20::check() ; } ; print "[[$@]]\n"; EXPECT hello at - line 4 [[]] ######## --FILE-- abc21.pm package abc21 ; use warnings 'misc' ; sub check { warnings::warn("io", "hello") } 1; --FILE-- use warnings qw( FATAL io ) ; use abc21; eval { abc21::check() ; } ; print "[[$@]]\n"; EXPECT [[hello at - line 4 ]] ######## -W --FILE-- abc22.pm package abc22 ; use warnings "io" ; print "ok1\n" if warnings::enabled("io") ; print "ok2\n" if warnings::enabled("all") ; 1; --FILE-- no warnings; use abc22 ; EXPECT ok1 ok2 ######## -X --FILE-- abc23.pm package abc23 ; use warnings "io" ; print "ok1\n" if !warnings::enabled("io") ; print "ok2\n" if !warnings::enabled("all") ; 1; --FILE-- use warnings; use abc23 ; EXPECT ok1 ok2 ######## --FILE-- abc24.pm package abc24 ; no warnings ; sub check { print "ok\n" if ! warnings::enabled() ; } 1; --FILE-- use warnings 'syntax' ; use abc24 ; abc24::check() ; EXPECT package 'abc24' not registered for warnings at abc24.pm line 4 ######## --FILE-- abc25.pm package abc25 ; no warnings ; sub check { warnings::warn("fred") ; } 1; --FILE-- use warnings 'syntax' ; use abc25 ; abc25::check() ; EXPECT package 'abc25' not registered for warnings at abc25.pm line 4 ######## --FILE-- abc26.pm package abc26 ; no warnings ; sub check { warnings::warnif("fred") ; } 1; --FILE-- use warnings 'syntax' ; use abc26 ; abc26::check() ; EXPECT package 'abc26' not registered for warnings at abc26.pm line 4 ######## --FILE-- abc27.pm package abc27 ; use warnings 'io' ; use warnings::register ; sub check { print "ok1\n" if warnings::enabled ; print "ok2\n" if warnings::enabled("syntax") ; print "ok3\n" if !warnings::enabled("io") ; } 1; --FILE-- use warnings 'syntax' ; use abc27 ; use warnings 'abc27' ; abc27::check() ; EXPECT ok1 ok2 ok3 ######## --FILE-- abc28.pm package abc28 ; use warnings 'io' ; use warnings::register ; sub check { print "ok1\n" if !warnings::enabled ; print "ok2\n" if warnings::enabled("syntax") ; print "ok3\n" if !warnings::enabled("io") ; } 1; --FILE-- use warnings 'syntax' ; use abc28 ; abc28::check() ; EXPECT ok1 ok2 ok3 ######## --FILE-- abc29.pm package abc29 ; no warnings ; use warnings::register ; sub check { print "ok1\n" if warnings::enabled ; print "ok2\n" if warnings::enabled("syntax") ; } 1; --FILE-- use warnings 'syntax' ; use abc29 ; use warnings 'abc29' ; eval { abc29::check() ; }; print $@ ; EXPECT ok1 ok2 ######## --FILE-- abc30.pm package abc30 ; use warnings 'io' ; use warnings::register ; sub check { print "ok1\n" if !warnings::enabled ; print "ok2\n" if warnings::enabled("syntax") ; print "ok3\n" if !warnings::enabled("io") ; } 1; --FILE-- use warnings 'syntax' ; use abc30 ; eval { abc30::check() ; } ; print $@ ; EXPECT ok1 ok2 ok3 ######## --FILE-- abc31.pm package abc31 ; use warnings 'io' ; use warnings::register ; sub check { print "ok1\n" if warnings::enabled ; print "ok2\n" if warnings::enabled("syntax") ; print "ok3\n" if !warnings::enabled("io") ; } 1; --FILE-- use warnings 'syntax' ; use abc31 ; use warnings 'abc31' ; sub fred { abc31::check() } fred() ; EXPECT ok1 ok2 ok3 ######## --FILE-- abc32.pm package abc32 ; use warnings 'io' ; use warnings::register ; sub check { print "ok1\n" if ! warnings::enabled ; } 1; --FILE-- use warnings 'syntax' ; use abc32 ; sub fred { no warnings ; abc32::check() } fred() ; EXPECT ok1 ######## --FILE-- abc33.pm package abc33 ; use warnings 'misc' ; use warnings::register; sub check { print "ok1\n" if warnings::enabled ; print "ok2\n" if warnings::enabled("syntax") ; print "ok3\n" if warnings::enabled("io") ; print "ok4\n" if ! warnings::enabled("misc") ; } 1; --FILE-- use warnings 'syntax' ; use abc33 ; use warnings 'abc33' ; sub fred { use warnings 'io' ; abc33::check() } fred() ; EXPECT ok1 ok2 ok3 ok4 ######## --FILE-- abc34.pm package abc34 ; use warnings 'misc' ; use warnings::register; sub check { warnings::warn("hello") } 1; --FILE-- use abc34; use warnings "abc34" ; abc34::check() ; EXPECT hello at - line 3 ######## --FILE-- abc35.pm package abc35 ; use warnings::register; sub check { warnings::warn("hello") } 1; --FILE-- use abc35; abc35::check() ; EXPECT hello at - line 2 ######## --FILE-- abc36.pm package abc36 ; use warnings::register ; sub check { warnings::warn("hello") } 1; --FILE-- use abc36; use warnings qw( FATAL deprecated ) ; eval { abc36::check() ; } ; print "[[$@]]\n"; EXPECT hello at - line 4 [[]] ######## --FILE-- abc37.pm package abc37 ; use warnings::register ; sub check { warnings::warn("hello") } 1; --FILE-- use abc37; use warnings qw( FATAL abc37 ) ; eval { abc37::check() ; } ; print "[[$@]]\n"; EXPECT [[hello at - line 4 ]] ######## -W --FILE-- abc38.pm package abc38 ; use warnings "io" ; use warnings::register ; sub check { print "ok1\n" if warnings::enabled() ; print "ok2\n" if warnings::enabled("io") ; print "ok3\n" if warnings::enabled("all") ; } 1; --FILE-- no warnings; use abc38 ; abc38::check() ; EXPECT ok1 ok2 ok3 ######## -X --FILE-- abc39.pm package abc39 ; use warnings "io" ; use warnings::register ; sub check { print "ok1\n" if !warnings::enabled() ; print "ok2\n" if !warnings::enabled("io") ; print "ok3\n" if !warnings::enabled("all") ; } 1; --FILE-- no warnings; use abc39 ; abc39::check() ; EXPECT ok1 ok2 ok3 ######## --FILE-- abc40.pm package abc40 ; use warnings "io" ; use warnings::register ; sub check { print "ok1\n" if warnings::enabled() ; print "ok2\n" if warnings::enabled("io") ; print "ok3\n" if warnings::enabled("all") ; } 1; --FILE-- use warnings 'all'; use abc40 ; abc40::check() ; EXPECT ok1 ok2 ok3 ######## --FILE-- abc41.pm package abc41 ; use warnings "io" ; use warnings::register ; sub check { print "ok1\n" if !warnings::enabled() ; print "ok2\n" if !warnings::enabled("io") ; print "ok3\n" if !warnings::enabled("all") ; } 1; --FILE-- use abc41 ; no warnings ; abc41::check() ; EXPECT ok1 ok2 ok3 ######## --FILE-- abc42.pm package abc42 ; use warnings "io" ; use warnings::register ; sub check { print "ok1\n" if !warnings::enabled() ; print "ok2\n" if !warnings::enabled("io") ; print "ok3\n" if !warnings::enabled("all") ; warnings::warnif("my message 1") ; warnings::warnif('abc42', "my message 2") ; warnings::warnif('io', "my message 3") ; warnings::warnif('all', "my message 4") ; } 1; --FILE-- use abc42 ; use warnings 'abc42'; no warnings ; abc42::check() ; EXPECT ok1 ok2 ok3 ######## --FILE-- abc43.pm package abc43 ; use warnings "io" ; use warnings::register ; sub check { print "abc43 self" . (warnings::enabled() ? "" : " not") . " enabled\n" ; print "abc43 def" . (warnings::enabled('def') ? "" : " not") . " enabled\n" ; print "abc43 all" . (warnings::enabled('all') ? "" : " not") . " enabled\n" ; } 1; --FILE-- def.pm package def ; use warnings "io" ; use warnings::register ; sub check { print "def self" . (warnings::enabled() ? "" : " not") . " enabled\n" ; print "def abc43" . (warnings::enabled('abc43') ? "" : " not") . " enabled\n" ; print "def all" . (warnings::enabled('all') ? "" : " not") . " enabled\n" ; } 1; --FILE-- use abc43 ; use def ; use warnings 'abc43'; abc43::check() ; def::check() ; no warnings 'abc43' ; use warnings 'def' ; abc43::check() ; def::check() ; use warnings 'abc43' ; use warnings 'def' ; abc43::check() ; def::check() ; no warnings 'abc43' ; no warnings 'def' ; abc43::check() ; def::check() ; use warnings; abc43::check() ; def::check() ; no warnings 'abc43' ; abc43::check() ; def::check() ; EXPECT abc43 self enabled abc43 def not enabled abc43 all not enabled def self not enabled def abc43 enabled def all not enabled abc43 self not enabled abc43 def enabled abc43 all not enabled def self enabled def abc43 not enabled def all not enabled abc43 self enabled abc43 def enabled abc43 all not enabled def self enabled def abc43 enabled def all not enabled abc43 self not enabled abc43 def not enabled abc43 all not enabled def self not enabled def abc43 not enabled def all not enabled abc43 self enabled abc43 def enabled abc43 all enabled def self enabled def abc43 enabled def all enabled abc43 self not enabled abc43 def enabled abc43 all not enabled def self enabled def abc43 not enabled def all not enabled ######## -w --FILE-- abc44.pm package abc44 ; no warnings ; use warnings::register ; sub check { print "ok1\n" if warnings::enabled() ; print "ok2\n" if warnings::enabled("io") ; print "ok3\n" if warnings::enabled("all") ; } 1; --FILE-- use abc44 ; abc44::check() ; EXPECT ok1 ok2 ok3 ######## -w --FILE-- abc45.pm package abc45 ; no warnings ; use warnings::register ; sub check { print "ok1\n" if !warnings::enabled() ; print "ok2\n" if !warnings::enabled("io") ; print "ok3\n" if !warnings::enabled("all") ; } 1; --FILE-- use abc45 ; use warnings 'abc45'; no warnings ; abc45::check() ; EXPECT ok1 ok2 ok3 ######## --FILE-- abc46.pm package abc46 ; no warnings ; use warnings::register ; sub check { print "ok1\n" if !warnings::enabled() ; print "ok2\n" if !warnings::enabled("io") ; print "ok3\n" if !warnings::enabled("all") ; warnings::warnif("my message 1") ; warnings::warnif('abc46', "my message 2") ; warnings::warnif('io', "my message 3") ; warnings::warnif('all', "my message 4") ; } 1; --FILE-- use abc46 ; use warnings 'abc46'; no warnings ; BEGIN { $^W = 1 ; } abc46::check() ; EXPECT ok1 ok2 ok3 ######## --FILE-- abc47.pm package abc47 ; no warnings ; use warnings::register ; sub check { print "ok1\n" if !warnings::enabled() ; print "ok2\n" if !warnings::enabled("io") ; print "ok3\n" if !warnings::enabled("all") ; } 1; --FILE-- use abc47 ; use warnings 'abc47'; no warnings ; $^W = 1 ; abc47::check() ; EXPECT ok1 ok2 ok3 ######## --FILE-- abc48.pm $| = 1; package abc48 ; no warnings ; use warnings::register ; sub check { print "ok1\n" if warnings::enabled() ; print "ok2\n" if !warnings::enabled("io") ; print "ok3\n" if !warnings::enabled("all") ; print "ok4\n" if warnings::enabled("abc48") ; warnings::warn("my message 1") ; warnings::warnif("my message 2") ; warnings::warnif('abc48', "my message 3") ; warnings::warnif('io', "my message 4") ; warnings::warnif('all', "my message 5") ; } sub in2 { no warnings ; check() } sub in1 { no warnings ; in2() } 1; --FILE-- use abc48 ; use warnings 'abc48'; abc48::in1() ; EXPECT ok1 ok2 ok3 ok4 my message 1 at - line 3 my message 2 at - line 3 my message 3 at - line 3 ######## --FILE-- def.pm package def ; no warnings ; use warnings::register ; sub check { print "ok1\n" if warnings::enabled() ; print "ok2\n" if !warnings::enabled("io") ; print "ok3\n" if !warnings::enabled("all") ; print "ok4\n" if warnings::enabled("def") ; warnings::warn("my message 1") ; warnings::warnif("my message 2") ; warnings::warnif('def', "my message 3") ; warnings::warnif('io', "my message 4") ; warnings::warnif('all', "my message 5") ; } sub in2 { no warnings ; check() } sub in1 { no warnings ; in2() } 1; --FILE-- abc49.pm $| = 1; package abc49 ; use def ; use warnings 'def'; sub in1 { def::in1() ; } 1; --FILE-- use abc49 ; no warnings; abc49::in1() ; EXPECT ok1 ok2 ok3 ok4 my message 1 at abc49.pm line 5 my message 2 at abc49.pm line 5 my message 3 at abc49.pm line 5 ######## --FILE-- def.pm $| = 1; package def ; no warnings ; use warnings::register ; require Exporter; @ISA = qw( Exporter ) ; @EXPORT = qw( in1 ) ; sub check { print "ok1\n" if warnings::enabled() ; print "ok2\n" if !warnings::enabled("io") ; print "ok3\n" if !warnings::enabled("all") ; print "ok4\n" if warnings::enabled("abc50") ; print "ok5\n" if !warnings::enabled("def") ; warnings::warn("my message 1") ; warnings::warnif("my message 2") ; warnings::warnif('abc50', "my message 3") ; warnings::warnif('def', "my message 4") ; warnings::warnif('io', "my message 5") ; warnings::warnif('all', "my message 6") ; } sub in2 { no warnings ; check() } sub in1 { no warnings ; in2() } 1; --FILE-- abc50.pm package abc50 ; use warnings::register ; use def ; #@ISA = qw(def) ; 1; --FILE-- use abc50 ; no warnings; use warnings 'abc50'; abc50::in1() ; EXPECT ok2 ok3 ok4 ok5 my message 1 at - line 4 my message 3 at - line 4 ######## --FILE-- def.pm package def ; no warnings ; use warnings::register ; sub new { my $class = shift ; bless [], $class ; } sub check { my $self = shift ; print "ok1\n" if !warnings::enabled() ; print "ok2\n" if !warnings::enabled("io") ; print "ok3\n" if !warnings::enabled("all") ; print "ok4\n" if warnings::enabled("abc51") ; print "ok5\n" if !warnings::enabled("def") ; print "ok6\n" if warnings::enabled($self) ; warnings::warn("my message 1") ; warnings::warn($self, "my message 2") ; warnings::warnif("my message 3") ; warnings::warnif('abc51', "my message 4") ; warnings::warnif('def', "my message 5") ; warnings::warnif('io', "my message 6") ; warnings::warnif('all', "my message 7") ; warnings::warnif($self, "my message 8") ; } sub in2 { no warnings ; my $self = shift ; $self->check() ; } sub in1 { no warnings ; my $self = shift ; $self->in2(); } 1; --FILE-- abc51.pm $| = 1; package abc51 ; use warnings::register ; use def ; @ISA = qw(def) ; sub new { my $class = shift ; bless [], $class ; } 1; --FILE-- use abc51 ; no warnings; use warnings 'abc51'; $a = new abc51 ; $a->in1() ; print "**\n"; $b = new def ; $b->in1() ; EXPECT ok1 ok2 ok3 ok4 ok5 ok6 my message 1 at - line 5 my message 2 at - line 5 my message 4 at - line 5 my message 8 at - line 5 ** ok1 ok2 ok3 ok4 ok5 my message 1 at - line 8 my message 2 at - line 8 my message 4 at - line 8 ######## --FILE-- # test for bug [perl #15395] my ( $warn_cat, # warning category we'll try to control $warn_msg, # the error message to catch ); package SomeModule; use warnings::register; BEGIN { $warn_cat = __PACKAGE__; $warn_msg = 'from ' . __PACKAGE__; } # a sub that generates a random warning sub gen_warning { warnings::warnif( $warn_msg ); } package ClientModule; # use SomeModule; (would go here) our @CARP_NOT = ( $warn_cat ); # deliver warnings to *our* client # call_warner provokes a warning. It is delivered to its caller, # who should also be able to control it sub call_warner { SomeModule::gen_warning(); } # user package main; my $warn_line = __LINE__ + 3; # this line should be in the error message eval { use warnings FATAL => $warn_cat; # we want to know if this works ClientModule::call_warner(); }; # have we caught an error, and is it the one we generated? print "ok1\n" if $@ =~ /$warn_msg/; # does it indicate the right line? print "ok2\n" if $@ =~ /line $warn_line/; EXPECT ok1 ok2 ######## --FILE-- fatal1.pm package fatal1 ; no warnings ; print "ok1\n" if !warnings::fatal_enabled('all') ; print "ok2\n" if !warnings::fatal_enabled("syntax") ; 1; --FILE-- use fatal1 ; EXPECT ok1 ok2 ######## --FILE-- fatal2.pm package fatal2; no warnings ; print "ok1\n" if !warnings::fatal_enabled('all') ; print "ok2\n" if warnings::fatal_enabled("syntax") ; 1; --FILE-- use warnings FATAL => 'syntax' ; use fatal2 ; EXPECT ok1 ok2 ######## --FILE-- fatal3.pm package fatal3 ; no warnings ; print "ok1\n" if warnings::fatal_enabled('all') ; print "ok2\n" if warnings::fatal_enabled("syntax") ; 1; --FILE-- use warnings FATAL => 'all' ; use fatal3 ; EXPECT ok1 ok2 ######## --FILE-- fatal4.pm package fatal4 ; no warnings ; print "ok1\n" if !warnings::fatal_enabled('all') ; print "ok2\n" if warnings::fatal_enabled("void") ; print "ok3\n" if !warnings::fatal_enabled("syntax") ; 1; --FILE-- use warnings FATAL => 'all', NONFATAL => 'syntax' ; use fatal4 ; EXPECT ok1 ok2 ok3 perl-5.12.0-RC0/t/lib/warnings/5nolint0000444000175000017500000000540411143650501016300 0ustar jessejessesyntax anti-lint __END__ -X # nolint: check compile time $^W is zapped BEGIN { $^W = 1 ;} $a = $b = 1 ; $a =+ 1 ; close STDIN ; print STDIN "abc" ; EXPECT ######## -X # nolint: check runtime $^W is zapped $^W = 1 ; close STDIN ; print STDIN "abc" ; EXPECT ######## -X # nolint: check runtime $^W is zapped { $^W = 1 ; close STDIN ; print STDIN "abc" ; } EXPECT ######## -X # nolint: check "no warnings" is zapped use warnings ; $a = $b = 1 ; $a =+ 1 ; close STDIN ; print STDIN "abc" ; EXPECT ######## -X # nolint: check "no warnings" is zapped { use warnings ; close STDIN ; print STDIN "abc" ; } EXPECT ######## -Xw # nolint: check combination of -w and -X { $^W = 1 ; close STDIN ; print STDIN "abc" ; } EXPECT ######## -X --FILE-- abc.pm use warnings 'syntax' ; my $a = 0; $a =+ 1 ; 1; --FILE-- use warnings 'uninitialized' ; use abc; my $a ; chop $a ; EXPECT ######## -X --FILE-- abc use warnings 'syntax' ; my $a = 0; $a =+ 1 ; 1; --FILE-- use warnings 'uninitialized' ; require "./abc"; my $a ; chop $a ; EXPECT ######## -X --FILE-- abc.pm BEGIN {$^W = 1} my ($a, $b) = (0,0); $a =+ 1 ; 1; --FILE-- $^W = 1 ; use abc; my $a ; chop $a ; EXPECT ######## -X --FILE-- abc BEGIN {$^W = 1} my ($a, $b) = (0,0); $a =+ 1 ; 1; --FILE-- $^W = 1 ; require "./abc"; my $a ; chop $a ; EXPECT ######## -X # Check scope of pragma with eval use warnings; { no warnings ; eval ' my $b ; chop $b ; '; print STDERR $@ ; my $b ; chop $b ; } EXPECT ######## -X # Check scope of pragma with eval use warnings; { no warnings ; eval q[ use warnings 'uninitialized' ; my $b ; chop $b ; ]; print STDERR $@; my $b ; chop $b ; } EXPECT ######## -X # Check scope of pragma with eval no warnings; { use warnings 'uninitialized' ; eval ' my $b ; chop $b ; '; print STDERR $@ ; my $b ; chop $b ; } EXPECT ######## -X # Check scope of pragma with eval no warnings; { use warnings 'uninitialized' ; eval ' no warnings ; my $b ; chop $b ; '; print STDERR $@ ; my $b ; chop $b ; } EXPECT ######## -X # Check scope of pragma with eval use warnings; { no warnings ; eval ' my $a =+ 1 ; '; print STDERR $@ ; my $a =+ 1 ; } EXPECT ######## -X # Check scope of pragma with eval use warnings; { no warnings ; eval q[ use warnings 'syntax' ; my $a =+ 1 ; ]; print STDERR $@; my $a =+ 1 ; } EXPECT ######## -X # Check scope of pragma with eval no warnings; { use warnings 'syntax' ; eval ' my $a =+ 1 ; '; print STDERR $@; my $a =+ 1 ; } EXPECT ######## -X # Check scope of pragma with eval no warnings; { use warnings 'syntax' ; eval ' no warnings ; my $a =+ 1 ; '; print STDERR $@; my $a =+ 1 ; } EXPECT perl-5.12.0-RC0/t/lib/warnings/4lint0000444000175000017500000001007611143650501015743 0ustar jessejesseCheck lint __END__ -W # lint: check compile time $^W is zapped BEGIN { $^W = 0 ;} $a = 1 ; $a =+ 1 ; close STDIN ; print STDIN "abc" ; EXPECT Reversed += operator at - line 5. print() on closed filehandle STDIN at - line 6. ######## -W # lint: check runtime $^W is zapped $^W = 0 ; close STDIN ; print STDIN "abc" ; EXPECT print() on closed filehandle STDIN at - line 4. ######## -W # lint: check runtime $^W is zapped { $^W = 0 ; close STDIN ; print STDIN "abc" ; } EXPECT print() on closed filehandle STDIN at - line 5. ######## -W # lint: check "no warnings" is zapped no warnings ; $a = 1 ; $a =+ 1 ; close STDIN ; print STDIN "abc" ; EXPECT Reversed += operator at - line 5. print() on closed filehandle STDIN at - line 6. ######## -W # lint: check "no warnings" is zapped { no warnings ; close STDIN ; print STDIN "abc" ; } EXPECT print() on closed filehandle STDIN at - line 5. ######## -Ww # lint: check combination of -w and -W { $^W = 0 ; close STDIN ; print STDIN "abc" ; } EXPECT print() on closed filehandle STDIN at - line 5. ######## -W --FILE-- abc.pm package abc; no warnings 'syntax' ; my $a = 0; $a =+ 1 ; 1; --FILE-- no warnings 'uninitialized' ; use abc; my $a ; chop $a ; EXPECT Reversed += operator at abc.pm line 4. Use of uninitialized value $a in scalar chop at - line 3. ######## -W --FILE-- abc package abc; no warnings 'syntax' ; my $a = 0; $a =+ 1 ; 1; --FILE-- no warnings 'uninitialized' ; require "./abc"; my $a ; chop $a ; EXPECT Reversed += operator at ./abc line 4. Use of uninitialized value $a in scalar chop at - line 3. ######## -W --FILE-- abc.pm package abc; BEGIN {$^W = 0} my $a = 0 ; $a =+ 1 ; 1; --FILE-- $^W = 0 ; use abc; my $a ; chop $a ; EXPECT Reversed += operator at abc.pm line 4. Use of uninitialized value $a in scalar chop at - line 3. ######## -W --FILE-- abc BEGIN {$^W = 0} my $a = 0 ; $a =+ 1 ; 1; --FILE-- $^W = 0 ; require "./abc"; my $a ; chop $a ; EXPECT Reversed += operator at ./abc line 3. Use of uninitialized value $a in scalar chop at - line 3. ######## -W # Check scope of pragma with eval { no warnings ; eval ' my $b ; chop $b ; '; print STDERR $@ ; my $b ; chop $b ; } EXPECT Use of uninitialized value $b in scalar chop at (eval 1) line 2. Use of uninitialized value $b in scalar chop at - line 8. ######## -W # Check scope of pragma with eval use warnings; { no warnings ; eval q[ use warnings 'uninitialized' ; my $b ; chop $b ; ]; print STDERR $@; my $b ; chop $b ; } EXPECT Use of uninitialized value $b in scalar chop at (eval 1) line 3. Use of uninitialized value $b in scalar chop at - line 10. ######## -W # Check scope of pragma with eval no warnings; { use warnings 'uninitialized' ; eval ' my $b ; chop $b ; '; print STDERR $@ ; my $b ; chop $b ; } EXPECT Use of uninitialized value $b in scalar chop at (eval 1) line 2. Use of uninitialized value $b in scalar chop at - line 9. ######## -W # Check scope of pragma with eval no warnings; { use warnings 'uninitialized' ; eval ' no warnings ; my $b ; chop $b ; '; print STDERR $@ ; my $b ; chop $b ; } EXPECT Use of uninitialized value $b in scalar chop at (eval 1) line 3. Use of uninitialized value $b in scalar chop at - line 10. ######## -W # Check scope of pragma with eval use warnings; { my $a = "1"; my $b = "2"; no warnings ; eval q[ use warnings 'syntax' ; $a =+ 1 ; ]; print STDERR $@; $a =+ 1 ; } EXPECT Reversed += operator at - line 11. Reversed += operator at (eval 1) line 3. ######## -W # Check scope of pragma with eval no warnings; { my $a = "1"; my $b = "2"; use warnings 'syntax' ; eval ' $a =+ 1 ; '; print STDERR $@; $a =+ 1 ; } EXPECT Reversed += operator at - line 10. Reversed += operator at (eval 1) line 2. ######## -W # Check scope of pragma with eval no warnings; { my $a = "1"; my $b = "2"; use warnings 'syntax' ; eval ' no warnings ; $a =+ 1 ; '; print STDERR $@; $a =+ 1 ; } EXPECT Reversed += operator at - line 11. Reversed += operator at (eval 1) line 3. perl-5.12.0-RC0/t/lib/warnings/op0000444000175000017500000006576011325127001015335 0ustar jessejesse op.c AOK Found = in conditional, should be == 1 if $a = 1 ; Useless use of time in void context Useless use of a variable in void context Useless use of a constant in void context time ; $a ; "abc" Useless use of sort in scalar context my $x = sort (2,1,3); Applying %s to %s will act on scalar(%s) my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ; @a =~ /abc/ ; @a =~ s/a/b/ ; @a =~ tr/a/b/ ; @$b =~ /abc/ ; @$b =~ s/a/b/ ; @$b =~ tr/a/b/ ; %a =~ /abc/ ; %a =~ s/a/b/ ; %a =~ tr/a/b/ ; %$c =~ /abc/ ; %$c =~ s/a/b/ ; %$c =~ tr/a/b/ ; Parentheses missing around "my" list at -e line 1. my $a, $b = (1,2); Parentheses missing around "local" list at -e line 1. local $a, $b = (1,2); Bareword found in conditional at -e line 1. use warnings 'bareword'; my $x = print(ABC || 1); Value of %s may be \"0\"; use \"defined\" $x = 1 if $x = ; $x = 1 while $x = ; Subroutine fred redefined at -e line 1. sub fred{1;} sub fred{1;} Constant subroutine %s redefined sub fred() {1;} sub fred() {1;} Format FRED redefined at /tmp/x line 5. format FRED = . format FRED = . Array @%s missing the @ in argument %d of %s() push fred ; Hash %%%s missing the %% in argument %d of %s() keys joe ; Statement unlikely to be reached (Maybe you meant system() when you said exec()? exec "true" ; my $a defined(@array) is deprecated (Maybe you should just omit the defined()?) my @a ; defined @a ; defined (@a = (1,2,3)) ; defined(%hash) is deprecated (Maybe you should just omit the defined()?) my %h ; defined %h ; /---/ should probably be written as "---" join(/---/, @foo); %s() called too early to check prototype [Perl_peep] fred() ; sub fred ($$) {} Package `%s' not found (did you use the incorrect case?) Use of /g modifier is meaningless in split Possible precedence problem on bitwise %c operator [Perl_ck_bitop] Mandatory Warnings ------------------ Prototype mismatch: [cv_ckproto] sub fred() ; sub fred($) {} Runaway prototype [newSUB] TODO oops: oopsAV [oopsAV] TODO oops: oopsHV [oopsHV] TODO __END__ # op.c use warnings 'syntax' ; 1 if $a = 1 ; no warnings 'syntax' ; 1 if $a = 1 ; EXPECT Found = in conditional, should be == at - line 3. ######## # op.c my (@foo, %foo); %main::foo->{"bar"}; %foo->{"bar"}; @main::foo->[23]; @foo->[23]; $main::foo = {}; %$main::foo->{"bar"}; $foo = {}; %$foo->{"bar"}; $main::foo = []; @$main::foo->[34]; $foo = []; @$foo->[34]; no warnings 'deprecated'; %main::foo->{"bar"}; %foo->{"bar"}; @main::foo->[23]; @foo->[23]; $main::foo = {}; %$main::foo->{"bar"}; $foo = {}; %$foo->{"bar"}; $main::foo = []; @$main::foo->[34]; $foo = []; @$foo->[34]; EXPECT Using a hash as a reference is deprecated at - line 3. Using a hash as a reference is deprecated at - line 4. Using an array as a reference is deprecated at - line 5. Using an array as a reference is deprecated at - line 6. Using a hash as a reference is deprecated at - line 7. Using a hash as a reference is deprecated at - line 8. Using an array as a reference is deprecated at - line 9. Using an array as a reference is deprecated at - line 10. ######## # op.c use warnings 'void' ; close STDIN ; 1 x 3 ; # OP_REPEAT # OP_GVSV wantarray ; # OP_WANTARRAY # OP_GV # OP_PADSV # OP_PADAV # OP_PADHV # OP_PADANY # OP_AV2ARYLEN ref ; # OP_REF \@a ; # OP_REFGEN \$a ; # OP_SREFGEN defined $a ; # OP_DEFINED hex $a ; # OP_HEX oct $a ; # OP_OCT length $a ; # OP_LENGTH substr $a,1 ; # OP_SUBSTR vec $a,1,2 ; # OP_VEC index $a,1,2 ; # OP_INDEX rindex $a,1,2 ; # OP_RINDEX sprintf $a ; # OP_SPRINTF $a[0] ; # OP_AELEM # OP_AELEMFAST @a[0] ; # OP_ASLICE #values %a ; # OP_VALUES #keys %a ; # OP_KEYS $a{0} ; # OP_HELEM @a{0} ; # OP_HSLICE unpack "a", "a" ; # OP_UNPACK pack $a,"" ; # OP_PACK join "" ; # OP_JOIN (@a)[0,1] ; # OP_LSLICE # OP_ANONLIST # OP_ANONHASH sort(1,2) ; # OP_SORT reverse(1,2) ; # OP_REVERSE # OP_RANGE # OP_FLIP (1 ..2) ; # OP_FLOP caller ; # OP_CALLER fileno STDIN ; # OP_FILENO eof STDIN ; # OP_EOF tell STDIN ; # OP_TELL readlink 1; # OP_READLINK time ; # OP_TIME localtime ; # OP_LOCALTIME gmtime ; # OP_GMTIME eval { getgrnam 1 }; # OP_GGRNAM eval { getgrgid 1 }; # OP_GGRGID eval { getpwnam 1 }; # OP_GPWNAM eval { getpwuid 1 }; # OP_GPWUID prototype "foo"; # OP_PROTOTYPE $a ~~ $b; # OP_SMARTMATCH $a <=> $b; # OP_NCMP EXPECT Useless use of repeat (x) in void context at - line 3. Useless use of wantarray in void context at - line 5. Useless use of reference-type operator in void context at - line 12. Useless use of reference constructor in void context at - line 13. Useless use of single ref constructor in void context at - line 14. Useless use of defined operator in void context at - line 15. Useless use of hex in void context at - line 16. Useless use of oct in void context at - line 17. Useless use of length in void context at - line 18. Useless use of substr in void context at - line 19. Useless use of vec in void context at - line 20. Useless use of index in void context at - line 21. Useless use of rindex in void context at - line 22. Useless use of sprintf in void context at - line 23. Useless use of array element in void context at - line 24. Useless use of array slice in void context at - line 26. Useless use of hash element in void context at - line 29. Useless use of hash slice in void context at - line 30. Useless use of unpack in void context at - line 31. Useless use of pack in void context at - line 32. Useless use of join or string in void context at - line 33. Useless use of list slice in void context at - line 34. Useless use of sort in void context at - line 37. Useless use of reverse in void context at - line 38. Useless use of range (or flop) in void context at - line 41. Useless use of caller in void context at - line 42. Useless use of fileno in void context at - line 43. Useless use of eof in void context at - line 44. Useless use of tell in void context at - line 45. Useless use of readlink in void context at - line 46. Useless use of time in void context at - line 47. Useless use of localtime in void context at - line 48. Useless use of gmtime in void context at - line 49. Useless use of getgrnam in void context at - line 50. Useless use of getgrgid in void context at - line 51. Useless use of getpwnam in void context at - line 52. Useless use of getpwuid in void context at - line 53. Useless use of subroutine prototype in void context at - line 54. Useless use of smart match in void context at - line 55. Useless use of numeric comparison (<=>) in void context at - line 56. ######## # op.c use warnings 'void' ; close STDIN ; my $x = sort (2,1,3); no warnings 'void' ; $x = sort (2,1,3); EXPECT Useless use of sort in scalar context at - line 3. ######## # op.c no warnings 'void' ; close STDIN ; 1 x 3 ; # OP_REPEAT # OP_GVSV wantarray ; # OP_WANTARRAY # OP_GV # OP_PADSV # OP_PADAV # OP_PADHV # OP_PADANY # OP_AV2ARYLEN ref ; # OP_REF \@a ; # OP_REFGEN \$a ; # OP_SREFGEN defined $a ; # OP_DEFINED hex $a ; # OP_HEX oct $a ; # OP_OCT length $a ; # OP_LENGTH substr $a,1 ; # OP_SUBSTR vec $a,1,2 ; # OP_VEC index $a,1,2 ; # OP_INDEX rindex $a,1,2 ; # OP_RINDEX sprintf $a ; # OP_SPRINTF $a[0] ; # OP_AELEM # OP_AELEMFAST @a[0] ; # OP_ASLICE #values %a ; # OP_VALUES #keys %a ; # OP_KEYS $a{0} ; # OP_HELEM @a{0} ; # OP_HSLICE unpack "a", "a" ; # OP_UNPACK pack $a,"" ; # OP_PACK join "" ; # OP_JOIN (@a)[0,1] ; # OP_LSLICE # OP_ANONLIST # OP_ANONHASH sort(1,2) ; # OP_SORT reverse(1,2) ; # OP_REVERSE # OP_RANGE # OP_FLIP (1 ..2) ; # OP_FLOP caller ; # OP_CALLER fileno STDIN ; # OP_FILENO eof STDIN ; # OP_EOF tell STDIN ; # OP_TELL readlink 1; # OP_READLINK time ; # OP_TIME localtime ; # OP_LOCALTIME gmtime ; # OP_GMTIME eval { getgrnam 1 }; # OP_GGRNAM eval { getgrgid 1 }; # OP_GGRGID eval { getpwnam 1 }; # OP_GPWNAM eval { getpwuid 1 }; # OP_GPWUID prototype "foo"; # OP_PROTOTYPE EXPECT ######## # op.c use warnings 'void' ; for (@{[0]}) { "$_" } # check warning isn't duplicated no warnings 'void' ; for (@{[0]}) { "$_" } # check warning isn't duplicated EXPECT Useless use of string in void context at - line 3. ######## # op.c use warnings 'void' ; use Config ; BEGIN { if ( ! $Config{d_telldir}) { print < undef; U; 5 || print "bad\n"; # test OPpCONST_SHORTCIRCUIT print "boo\n" if U; # test OPpCONST_SHORTCIRCUIT $[ = 2; # should not warn no warnings 'void' ; "abc"; # OP_CONST 7 ; # OP_CONST "x" . "y"; # optimized to OP_CONST 2 + 2; # optimized to OP_CONST EXPECT Useless use of a constant (abc) in void context at - line 3. Useless use of a constant (7) in void context at - line 4. Useless use of a constant (xy) in void context at - line 5. Useless use of a constant (4) in void context at - line 6. Useless use of a constant (undef) in void context at - line 8. ######## # op.c # use warnings 'misc' ; my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ;my $d = 'test'; @a =~ /abc/ ; @a =~ s/a/b/ ; @a =~ tr/a/b/ ; @$b =~ /abc/ ; @$b =~ s/a/b/ ; @$b =~ tr/a/b/ ; %a =~ /abc/ ; %a =~ s/a/b/ ; %a =~ tr/a/b/ ; %$c =~ /abc/ ; %$c =~ s/a/b/ ; %$c =~ tr/a/b/ ; $d =~ tr/a/b/d ; $d =~ tr/a/bc/; { no warnings 'misc' ; my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ; my $d = 'test'; @a =~ /abc/ ; @a =~ s/a/b/ ; @a =~ tr/a/b/ ; @$b =~ /abc/ ; @$b =~ s/a/b/ ; @$b =~ tr/a/b/ ; %a =~ /abc/ ; %a =~ s/a/b/ ; %a =~ tr/a/b/ ; %$c =~ /abc/ ; %$c =~ s/a/b/ ; %$c =~ tr/a/b/ ; $d =~ tr/a/b/d ; $d =~ tr/a/bc/ ; } EXPECT Applying pattern match (m//) to @array will act on scalar(@array) at - line 5. Applying substitution (s///) to @array will act on scalar(@array) at - line 6. Applying transliteration (tr///) to @array will act on scalar(@array) at - line 7. Applying pattern match (m//) to @array will act on scalar(@array) at - line 8. Applying substitution (s///) to @array will act on scalar(@array) at - line 9. Applying transliteration (tr///) to @array will act on scalar(@array) at - line 10. Applying pattern match (m//) to %hash will act on scalar(%hash) at - line 11. Applying substitution (s///) to %hash will act on scalar(%hash) at - line 12. Applying transliteration (tr///) to %hash will act on scalar(%hash) at - line 13. Applying pattern match (m//) to %hash will act on scalar(%hash) at - line 14. Applying substitution (s///) to %hash will act on scalar(%hash) at - line 15. Applying transliteration (tr///) to %hash will act on scalar(%hash) at - line 16. Useless use of /d modifier in transliteration operator at - line 17. Replacement list is longer than search list at - line 18. Can't modify private array in substitution (s///) at - line 6, near "s/a/b/ ;" BEGIN not safe after errors--compilation aborted at - line 20. ######## # op.c use warnings 'parenthesis' ; my $a, $b = (1,2); my @foo,%bar, $quux; # there's a TAB here my $x, $y or print; no warnings 'parenthesis' ; my $c, $d = (1,2); EXPECT Parentheses missing around "my" list at - line 3. Parentheses missing around "my" list at - line 4. ######## # op.c use warnings 'parenthesis' ; our $a, $b = (1,2); no warnings 'parenthesis' ; our $c, $d = (1,2); EXPECT Parentheses missing around "our" list at - line 3. ######## # op.c use warnings 'parenthesis' ; local $a, $b = (1,2); local *f, *g; no warnings 'parenthesis' ; local $c, $d = (1,2); EXPECT Parentheses missing around "local" list at - line 3. Parentheses missing around "local" list at - line 4. ######## # op.c use warnings 'bareword' ; print (ABC || 1) ; no warnings 'bareword' ; print (ABC || 1) ; EXPECT Bareword found in conditional at - line 3. ######## --FILE-- abc --FILE-- # op.c use warnings 'misc' ; open FH, " ; no warnings 'misc' ; $x = 1 if $x = ; EXPECT Value of construct can be "0"; test with defined() at - line 4. ######## # op.c use warnings 'misc' ; opendir FH, "." ; $x = 1 if $x = readdir FH ; no warnings 'misc' ; $x = 1 if $x = readdir FH ; closedir FH ; EXPECT Value of readdir() operator can be "0"; test with defined() at - line 4. ######## # op.c use warnings 'misc' ; $x = 1 if $x = <*> ; no warnings 'misc' ; $x = 1 if $x = <*> ; EXPECT Value of glob construct can be "0"; test with defined() at - line 3. ######## # op.c use warnings 'misc' ; %a = (1,2,3,4) ; $x = 1 if $x = each %a ; no warnings 'misc' ; $x = 1 if $x = each %a ; EXPECT Value of each() operator can be "0"; test with defined() at - line 4. ######## # op.c use warnings 'misc' ; $x = 1 while $x = <*> and 0 ; no warnings 'misc' ; $x = 1 while $x = <*> and 0 ; EXPECT Value of glob construct can be "0"; test with defined() at - line 3. ######## # op.c use warnings 'misc' ; opendir FH, "." ; $x = 1 while $x = readdir FH and 0 ; no warnings 'misc' ; $x = 1 while $x = readdir FH and 0 ; closedir FH ; EXPECT Value of readdir() operator can be "0"; test with defined() at - line 4. ######## # op.c use warnings 'misc'; open FH, ") // ($_ = 1); opendir DH, "."; %a = (1,2,3,4) ; EXPECT ######## # op.c use warnings 'redefine' ; sub fred {} sub fred {} no warnings 'redefine' ; sub fred {} EXPECT Subroutine fred redefined at - line 4. ######## # op.c use warnings 'redefine' ; sub fred () { 1 } sub fred () { 1 } no warnings 'redefine' ; sub fred () { 1 } EXPECT Constant subroutine fred redefined at - line 4. ######## # op.c no warnings 'redefine' ; sub fred () { 1 } sub fred () { 2 } EXPECT Constant subroutine fred redefined at - line 4. ######## # op.c no warnings 'redefine' ; sub fred () { 1 } *fred = sub () { 2 }; EXPECT Constant subroutine main::fred redefined at - line 4. ######## # op.c use warnings 'redefine' ; format FRED = . format FRED = . no warnings 'redefine' ; format FRED = . EXPECT Format FRED redefined at - line 5. ######## # op.c push FRED; no warnings 'deprecated' ; push FRED; EXPECT Array @FRED missing the @ in argument 1 of push() at - line 2. ######## # op.c @a = keys FRED ; no warnings 'deprecated' ; @a = keys FRED ; EXPECT Hash %FRED missing the % in argument 1 of keys() at - line 2. ######## # op.c use warnings 'syntax' ; exec "$^X -e 1" ; my $a EXPECT Statement unlikely to be reached at - line 4. (Maybe you meant system() when you said exec()?) ######## # op.c my @a; defined(@a); EXPECT defined(@array) is deprecated at - line 2. (Maybe you should just omit the defined()?) ######## # op.c defined(@a = (1,2,3)); EXPECT defined(@array) is deprecated at - line 2. (Maybe you should just omit the defined()?) ######## # op.c my %h; defined(%h); EXPECT defined(%hash) is deprecated at - line 2. (Maybe you should just omit the defined()?) ######## # op.c no warnings 'syntax' ; exec "$^X -e 1" ; my $a EXPECT ######## # op.c sub fred(); sub fred($) {} EXPECT Prototype mismatch: sub main::fred () vs ($) at - line 3. ######## # op.c $^W = 0 ; sub fred() ; sub fred($) {} { no warnings 'prototype' ; sub Fred() ; sub Fred($) {} use warnings 'prototype' ; sub freD() ; sub freD($) {} } sub FRED() ; sub FRED($) {} EXPECT Prototype mismatch: sub main::fred () vs ($) at - line 4. Prototype mismatch: sub main::freD () vs ($) at - line 11. Prototype mismatch: sub main::FRED () vs ($) at - line 14. ######## # op.c use warnings 'syntax' ; join /---/, 'x', 'y', 'z'; EXPECT /---/ should probably be written as "---" at - line 3. ######## # op.c [Perl_peep] use warnings 'prototype' ; fred() ; sub fred ($$) {} no warnings 'prototype' ; joe() ; sub joe ($$) {} EXPECT main::fred() called too early to check prototype at - line 3. ######## # op.c [Perl_newATTRSUB] --FILE-- abc.pm use warnings 'void' ; BEGIN { $| = 1; print "in begin\n"; } CHECK { print "in check\n"; } INIT { print "in init\n"; } END { print "in end\n"; } print "in mainline\n"; 1; --FILE-- use abc; delete $INC{"abc.pm"}; require abc; do "abc.pm"; EXPECT in begin in mainline in check in init in begin Too late to run CHECK block at abc.pm line 3. Too late to run INIT block at abc.pm line 4. in mainline in begin Too late to run CHECK block at abc.pm line 3. Too late to run INIT block at abc.pm line 4. in mainline in end in end in end ######## # op.c [Perl_newATTRSUB] --FILE-- abc.pm no warnings 'void' ; BEGIN { $| = 1; print "in begin\n"; } CHECK { print "in check\n"; } INIT { print "in init\n"; } END { print "in end\n"; } print "in mainline\n"; 1; --FILE-- require abc; do "abc.pm"; EXPECT in begin in mainline in begin in mainline in end in end ######## # op.c my @x; use warnings 'syntax' ; push(@x); unshift(@x); no warnings 'syntax' ; push(@x); unshift(@x); EXPECT Useless use of push with no values at - line 4. Useless use of unshift with no values at - line 5. ######## # op.c # 20020401 mjd@plover.com at suggestion of jfriedl@yahoo.com use warnings 'regexp'; split /blah/g, "blah"; no warnings 'regexp'; split /blah/g, "blah"; EXPECT Use of /g modifier is meaningless in split at - line 4. ######## # op.c use warnings 'precedence'; $a = $b & $c == $d; $a = $b ^ $c != $d; $a = $b | $c > $d; $a = $b < $c & $d; $a = $b >= $c ^ $d; $a = $b <= $c | $d; $a = $b <=> $c & $d; $a &= $b == $c; $a |= $b == $c; $a ^= $b == $c; # shouldn't warn no warnings 'precedence'; $a = $b & $c == $d; $a = $b ^ $c != $d; $a = $b | $c > $d; $a = $b < $c & $d; $a = $b >= $c ^ $d; $a = $b <= $c | $d; $a = $b <=> $c & $d; EXPECT Possible precedence problem on bitwise & operator at - line 3. Possible precedence problem on bitwise ^ operator at - line 4. Possible precedence problem on bitwise | operator at - line 5. Possible precedence problem on bitwise & operator at - line 6. Possible precedence problem on bitwise ^ operator at - line 7. Possible precedence problem on bitwise | operator at - line 8. Possible precedence problem on bitwise & operator at - line 9. ######## # op.c use integer; use warnings 'precedence'; $a = $b & $c == $d; $a = $b ^ $c != $d; $a = $b | $c > $d; $a = $b < $c & $d; $a = $b >= $c ^ $d; $a = $b <= $c | $d; $a = $b <=> $c & $d; no warnings 'precedence'; $a = $b & $c == $d; $a = $b ^ $c != $d; $a = $b | $c > $d; $a = $b < $c & $d; $a = $b >= $c ^ $d; $a = $b <= $c | $d; $a = $b <=> $c & $d; EXPECT Possible precedence problem on bitwise & operator at - line 4. Possible precedence problem on bitwise ^ operator at - line 5. Possible precedence problem on bitwise | operator at - line 6. Possible precedence problem on bitwise & operator at - line 7. Possible precedence problem on bitwise ^ operator at - line 8. Possible precedence problem on bitwise | operator at - line 9. Possible precedence problem on bitwise & operator at - line 10. ######## # op.c # ok => local() has desired effect; # ignore=> local() silently ignored use warnings 'syntax'; local(undef); # OP_UNDEF ignore sub lval : lvalue {}; local(lval()); # OP_ENTERSUB local($x **= 1); # OP_POW local($x *= 1); # OP_MULTIPLY local($x /= 1); # OP_DIVIDE local($x %= 1); # OP_MODULO local($x x= 1); # OP_REPEAT local($x += 1); # OP_ADD local($x -= 1); # OP_SUBTRACT local($x .= 1); # OP_CONCAT local($x <<= 1); # OP_LEFT_SHIFT local($x >>= 1); # OP_RIGHT_SHIFT local($x &= 1); # OP_BIT_AND local($x ^= 1); # OP_BIT_XOR local($x |= 1); # OP_BIT_OR { use integer; local($x *= 1); # OP_I_MULTIPLY local($x /= 1); # OP_I_DIVIDE local($x %= 1); # OP_I_MODULO local($x += 1); # OP_I_ADD local($x -= 1); # OP_I_SUBTRACT } local($x?$y:$z) = 1; # OP_COND_EXPR ok # these two are fatal run-time errors instead #local(@$a); # OP_RV2AV ok #local(%$a); # OP_RV2HV ok local(*a); # OP_RV2GV ok local(@a[1,2]); # OP_ASLICE ok local(@a{1,2}); # OP_HSLICE ok local(@a = (1,2)); # OP_AASSIGN local($$x); # OP_RV2SV ok local($#a); # OP_AV2ARYLEN local($x = 1); # OP_SASSIGN local($x &&= 1); # OP_ANDASSIGN local($x ||= 1); # OP_ORASSIGN local($x //= 1); # OP_DORASSIGN local($a[0]); # OP_AELEMFAST ok local(substr($x,0,1)); # OP_SUBSTR local(pos($x)); # OP_POS local(vec($x,0,1)); # OP_VEC local($a[$b]); # OP_AELEM ok local($a{$b}); # OP_HELEM ok local($[); # OP_CONST no warnings 'syntax'; EXPECT Useless localization of subroutine entry at - line 10. Useless localization of exponentiation (**) at - line 11. Useless localization of multiplication (*) at - line 12. Useless localization of division (/) at - line 13. Useless localization of modulus (%) at - line 14. Useless localization of repeat (x) at - line 15. Useless localization of addition (+) at - line 16. Useless localization of subtraction (-) at - line 17. Useless localization of concatenation (.) or string at - line 18. Useless localization of left bitshift (<<) at - line 19. Useless localization of right bitshift (>>) at - line 20. Useless localization of bitwise and (&) at - line 21. Useless localization of bitwise xor (^) at - line 22. Useless localization of bitwise or (|) at - line 23. Useless localization of integer multiplication (*) at - line 26. Useless localization of integer division (/) at - line 27. Useless localization of integer modulus (%) at - line 28. Useless localization of integer addition (+) at - line 29. Useless localization of integer subtraction (-) at - line 30. Useless localization of list assignment at - line 39. Useless localization of array length at - line 41. Useless localization of scalar assignment at - line 42. Useless localization of logical and assignment (&&=) at - line 43. Useless localization of logical or assignment (||=) at - line 44. Useless localization of defined or assignment (//=) at - line 45. Useless localization of substr at - line 48. Useless localization of match position at - line 49. Useless localization of vec at - line 50. ######## # op.c my $x1 if 0; my @x2 if 0; my %x3 if 0; my ($x4) if 0; my ($x5,@x6, %x7) if 0; 0 && my $z1; 0 && my (%z2); # these shouldn't warn our $x if 0; our $x unless 0; if (0) { my $w1 } if (my $w2) { $a=1 } if ($a && (my $w3 = 1)) {$a = 2} EXPECT Deprecated use of my() in false conditional at - line 2. Deprecated use of my() in false conditional at - line 3. Deprecated use of my() in false conditional at - line 4. Deprecated use of my() in false conditional at - line 5. Deprecated use of my() in false conditional at - line 6. Deprecated use of my() in false conditional at - line 7. Deprecated use of my() in false conditional at - line 8. ######## # op.c $[ = 1; use warnings 'deprecated'; $[ = 2; no warnings 'deprecated'; $[ = 3; EXPECT Use of assignment to $[ is deprecated at - line 2. Use of assignment to $[ is deprecated at - line 4. ######## # op.c use warnings 'void'; @x = split /y/, "z"; $x = split /y/, "z"; split /y/, "z"; no warnings 'void'; @x = split /y/, "z"; $x = split /y/, "z"; split /y/, "z"; EXPECT Useless use of split in void context at - line 5. perl-5.12.0-RC0/t/lib/warnings/2use0000444000175000017500000001410511143650501015564 0ustar jessejesseCheck lexical warnings functionality TODO check that the warning hierarchy works. __END__ # check illegal category is caught use warnings 'this-should-never-be-a-warning-category' ; EXPECT Unknown warnings category 'this-should-never-be-a-warning-category' at - line 3 BEGIN failed--compilation aborted at - line 3. ######## # Check compile time scope of pragma use warnings 'syntax' ; { no warnings ; my $a =+ 1 ; } my $a =+ 1 ; EXPECT Reversed += operator at - line 8. ######## # Check compile time scope of pragma no warnings; { use warnings 'syntax' ; my $a =+ 1 ; } my $a =+ 1 ; EXPECT Reversed += operator at - line 6. ######## # Check runtime scope of pragma use warnings 'uninitialized' ; { no warnings ; my $b ; chop $b ; } my $b ; chop $b ; EXPECT Use of uninitialized value $b in scalar chop at - line 8. ######## # Check runtime scope of pragma no warnings ; { use warnings 'uninitialized' ; my $b ; chop $b ; } my $b ; chop $b ; EXPECT Use of uninitialized value $b in scalar chop at - line 6. ######## # Check runtime scope of pragma no warnings ; { use warnings 'uninitialized' ; $a = sub { my $b ; chop $b ; } } &$a ; EXPECT Use of uninitialized value $b in scalar chop at - line 6. ######## use warnings 'syntax' ; my $a =+ 1 ; EXPECT Reversed += operator at - line 3. ######## -w no warnings 'reserved' ; foo.bar; EXPECT Useless use of concatenation (.) or string in void context at - line 3. ######## --FILE-- abc my $a =+ 1 ; 1; --FILE-- use warnings 'syntax' ; require "./abc"; EXPECT ######## --FILE-- abc use warnings 'syntax' ; 1; --FILE-- require "./abc"; my $a =+ 1 ; EXPECT ######## --FILE-- abc use warnings 'syntax' ; my $a =+ 1 ; 1; --FILE-- use warnings 'uninitialized' ; require "./abc"; my $a ; chop $a ; EXPECT Reversed += operator at ./abc line 2. Use of uninitialized value $a in scalar chop at - line 3. ######## --FILE-- abc.pm use warnings 'syntax' ; my $a =+ 1 ; 1; --FILE-- use warnings 'uninitialized' ; use abc; my $a ; chop $a ; EXPECT Reversed += operator at abc.pm line 2. Use of uninitialized value $a in scalar chop at - line 3. ######## # Check scope of pragma with eval use warnings; { no warnings ; eval { my $b ; chop $b ; }; print STDERR $@ ; my $b ; chop $b ; } EXPECT ######## # Check scope of pragma with eval use warnings; { no warnings ; eval { use warnings 'uninitialized' ; my $b ; chop $b ; }; print STDERR $@ ; my $b ; chop $b ; } EXPECT Use of uninitialized value $b in scalar chop at - line 8. ######## # Check scope of pragma with eval no warnings; { use warnings 'uninitialized' ; eval { my $b ; chop $b ; }; print STDERR $@ ; my $b ; chop $b ; } EXPECT Use of uninitialized value $b in scalar chop at - line 7. Use of uninitialized value $b in scalar chop at - line 9. ######## # Check scope of pragma with eval no warnings; { use warnings 'uninitialized' ; eval { no warnings ; my $b ; chop $b ; }; print STDERR $@ ; my $b ; chop $b ; } EXPECT Use of uninitialized value $b in scalar chop at - line 10. ######## # Check scope of pragma with eval use warnings; { no warnings ; eval { my $a =+ 1 ; }; print STDERR $@ ; my $a =+ 1 ; } EXPECT ######## # Check scope of pragma with eval use warnings; { no warnings ; eval { use warnings 'syntax' ; my $a =+ 1 ; }; print STDERR $@ ; my $a =+ 1 ; } EXPECT Reversed += operator at - line 8. ######## # Check scope of pragma with eval no warnings; { use warnings 'syntax' ; eval { my $a =+ 1 ; }; print STDERR $@ ; my $a =+ 1 ; } EXPECT Reversed += operator at - line 7. Reversed += operator at - line 9. ######## # Check scope of pragma with eval no warnings; { use warnings 'syntax' ; eval { no warnings ; my $a =+ 1 ; }; print STDERR $@ ; my $a =+ 1 ; } EXPECT Reversed += operator at - line 10. ######## # Check scope of pragma with eval use warnings; { no warnings ; eval ' my $b ; chop $b ; '; print STDERR $@ ; my $b ; chop $b ; } EXPECT ######## # Check scope of pragma with eval use warnings; { no warnings ; eval q[ use warnings 'uninitialized' ; my $b ; chop $b ; ]; print STDERR $@; my $b ; chop $b ; } EXPECT Use of uninitialized value $b in scalar chop at (eval 1) line 3. ######## # Check scope of pragma with eval no warnings; { use warnings 'uninitialized' ; eval ' my $b ; chop $b ; '; print STDERR $@ ; my $b ; chop $b ; } EXPECT Use of uninitialized value $b in scalar chop at (eval 1) line 2. Use of uninitialized value $b in scalar chop at - line 9. ######## # Check scope of pragma with eval no warnings; { use warnings 'uninitialized' ; eval ' no warnings ; my $b ; chop $b ; '; print STDERR $@ ; my $b ; chop $b ; } EXPECT Use of uninitialized value $b in scalar chop at - line 10. ######## # Check scope of pragma with eval use warnings; { no warnings ; eval ' my $a =+ 1 ; '; print STDERR $@ ; my $a =+ 1 ; } EXPECT ######## # Check scope of pragma with eval use warnings; { no warnings ; eval q[ use warnings 'syntax' ; my $a =+ 1 ; ]; print STDERR $@; my $a =+ 1 ; } EXPECT Reversed += operator at (eval 1) line 3. ######## # Check scope of pragma with eval no warnings; { use warnings 'syntax' ; eval ' my $a =+ 1 ; '; print STDERR $@; my $a =+ 1 ; } EXPECT Reversed += operator at - line 9. Reversed += operator at (eval 1) line 2. ######## # Check scope of pragma with eval no warnings; { use warnings 'syntax' ; eval ' no warnings ; my $a =+ 1 ; '; print STDERR $@; my $a =+ 1 ; } EXPECT Reversed += operator at - line 10. ######## # Check the additive nature of the pragma my $a =+ 1 ; my $a ; chop $a ; use warnings 'syntax' ; $a =+ 1 ; my $b ; chop $b ; use warnings 'uninitialized' ; my $c ; chop $c ; no warnings 'syntax' ; $a =+ 1 ; EXPECT Reversed += operator at - line 6. Use of uninitialized value $c in scalar chop at - line 9. perl-5.12.0-RC0/t/lib/warnings/doop0000444000175000017500000000007711143650501015652 0ustar jessejesse# doop.c use utf8 ; $_ = "\x80 \xff" ; chop ; EXPECT ######## perl-5.12.0-RC0/t/lib/warnings/malloc0000444000175000017500000000023011143650501016147 0ustar jessejesse malloc.c Mandatory Warnings ALL TODO ------------------ %s free() ignored [Perl_mfree] %s", "Bad free() ignored [Perl_mfree] __END__ perl-5.12.0-RC0/t/lib/warnings/6default0000444000175000017500000000573211143650501016426 0ustar jessejesseCheck default warnings __END__ # default warnings should be displayed if you don't add anything # optional shouldn't my $a = oct "7777777777777777777777777777777777779" ; EXPECT Integer overflow in octal number at - line 3. ######## # no warnings should be displayed no warnings ; my $a = oct "7777777777777777777777777777777777778" ; EXPECT ######## # all warnings should be displayed use warnings ; my $a = oct "7777777777777777777777777777777777778" ; EXPECT Integer overflow in octal number at - line 3. Illegal octal digit '8' ignored at - line 3. Octal number > 037777777777 non-portable at - line 3. ######## # check scope use warnings ; my $a = oct "7777777777777777777777777777777777778" ; { no warnings ; my $a = oct "7777777777777777777777777777777777778" ; } my $c = oct "7777777777777777777777777777777777778" ; EXPECT Integer overflow in octal number at - line 3. Illegal octal digit '8' ignored at - line 3. Octal number > 037777777777 non-portable at - line 3. Integer overflow in octal number at - line 8. Illegal octal digit '8' ignored at - line 8. Octal number > 037777777777 non-portable at - line 8. ######## # all warnings should be displayed use warnings ; my $a = oct "0xfffffffffffffffffg" ; EXPECT Integer overflow in hexadecimal number at - line 3. Illegal hexadecimal digit 'g' ignored at - line 3. Hexadecimal number > 0xffffffff non-portable at - line 3. ######## # all warnings should be displayed use warnings ; my $a = oct "0b111111111111111111111111111111111111111111111111111111111111111112"; EXPECT Integer overflow in binary number at - line 3. Illegal binary digit '2' ignored at - line 3. Binary number > 0b11111111111111111111111111111111 non-portable at - line 3. ######## # Check scope of pragma with eval use warnings; { no warnings ; eval ' my $a = oct "0xfffffffffffffffffg" ; '; print STDERR $@ ; my $a = oct "0xfffffffffffffffffg" ; } EXPECT ######## # Check scope of pragma with eval use warnings; { no warnings ; eval q[ use warnings ; my $a = oct "0xfffffffffffffffffg" ; ]; print STDERR $@; my $a = oct "0xfffffffffffffffffg" ; } EXPECT Integer overflow in hexadecimal number at (eval 1) line 3. Illegal hexadecimal digit 'g' ignored at (eval 1) line 3. Hexadecimal number > 0xffffffff non-portable at (eval 1) line 3. ######## # Check scope of pragma with eval no warnings; { use warnings ; eval ' my $a = oct "0xfffffffffffffffffg" ; '; print STDERR $@ ; } EXPECT Integer overflow in hexadecimal number at (eval 1) line 2. Illegal hexadecimal digit 'g' ignored at (eval 1) line 2. Hexadecimal number > 0xffffffff non-portable at (eval 1) line 2. ######## # Check scope of pragma with eval no warnings; { use warnings; eval ' no warnings ; my $a = oct "0xfffffffffffffffffg" ; '; print STDERR $@ ; } EXPECT ######## # Check scope of pragma with eval no warnings; { use warnings 'deprecated' ; eval ' my $a = oct "0xfffffffffffffffffg" ; '; print STDERR $@; } EXPECT perl-5.12.0-RC0/t/lib/warnings/pp_hot0000444000175000017500000001616511325125742016215 0ustar jessejesse pp_hot.c print() on unopened filehandle abc [pp_print] $f = $a = "abc" ; print $f $a Filehandle %s opened only for input [pp_print] print STDIN "abc" ; Filehandle %s opened only for output [pp_print] $a = ; print() on closed filehandle %s [pp_print] close STDIN ; print STDIN "abc" ; uninitialized [pp_rv2av] my $a = undef ; my @b = @$a uninitialized [pp_rv2hv] my $a = undef ; my %b = %$a Odd number of elements in hash list [pp_aassign] %X = (1,2,3) ; Reference found where even-sized list expected [pp_aassign] $X = [ 1 ..3 ]; Filehandle %s opened only for output [Perl_do_readline] open (FH, ">./xcv") ; my $a = ; glob failed (can't start child: %s) [Perl_do_readline] <; readline() on closed filehandle %s [Perl_do_readline] readline(NONESUCH); glob failed (child exited with status %d%s) [Perl_do_readline] <$file") or die $! ; close FH or die $! ; die "There is no file $file" unless -f $file ; open (FH, "<$file") or die $! ; print FH "anc" ; open(FOO, "<&FH") or die $! ; print FOO "anc" ; no warnings 'io' ; print FH "anc" ; print FOO "anc" ; use warnings 'io' ; print FH "anc" ; print FOO "anc" ; close (FH) or die $! ; close (FOO) or die $! ; unlink $file ; EXPECT Filehandle FH opened only for input at - line 12. Filehandle FOO opened only for input at - line 14. Filehandle FH opened only for input at - line 19. Filehandle FOO opened only for input at - line 20. ######## # pp_hot.c [pp_print] use warnings 'closed' ; close STDIN ; print STDIN "anc"; opendir STDIN, "."; print STDIN "anc"; closedir STDIN; no warnings 'closed' ; print STDIN "anc"; opendir STDIN, "."; print STDIN "anc"; use warnings; no warnings 'closed' ; print STDIN "anc"; EXPECT print() on closed filehandle STDIN at - line 4. print() on closed filehandle STDIN at - line 6. (Are you trying to call print() on dirhandle STDIN?) ######## # pp_hot.c [pp_print] # [ID 20020425.012] from Dave Steiner # This goes segv on 5.7.3 use warnings 'closed' ; my $fh = *STDOUT{IO}; close STDOUT or die "Can't close STDOUT"; print $fh "Shouldn't print anything, but shouldn't SEGV either\n"; EXPECT print() on closed filehandle at - line 7. ######## # pp_hot.c [pp_print] package foo; use warnings 'closed'; open my $fh1, "nonexistent"; print $fh1 42; open $fh2, "nonexistent"; print $fh2 42; open $bar::fh3, "nonexistent"; print $bar::fh3 42; open bar::FH4, "nonexistent"; print bar::FH4 42; EXPECT print() on closed filehandle $fh1 at - line 5. print() on closed filehandle $fh2 at - line 7. print() on closed filehandle $fh3 at - line 9. print() on closed filehandle FH4 at - line 11. ######## # pp_hot.c [pp_rv2av] use warnings 'uninitialized' ; my $a = undef ; my @b = @$a; no warnings 'uninitialized' ; my @c = @$a; EXPECT Use of uninitialized value $a in array dereference at - line 4. ######## # pp_hot.c [pp_rv2hv] use warnings 'uninitialized' ; my $a = undef ; my %b = %$a; no warnings 'uninitialized' ; my %c = %$a; EXPECT Use of uninitialized value $a in hash dereference at - line 4. ######## # pp_hot.c [pp_aassign] use warnings 'misc' ; my %X ; %X = (1,2,3) ; no warnings 'misc' ; my %Y ; %Y = (1,2,3) ; EXPECT Odd number of elements in hash assignment at - line 3. ######## # pp_hot.c [pp_aassign] use warnings 'misc' ; my %X ; %X = [1 .. 3] ; no warnings 'misc' ; my %Y ; %Y = [1 .. 3] ; EXPECT Reference found where even-sized list expected at - line 3. ######## # pp_hot.c [Perl_do_readline] use warnings 'closed' ; close STDIN ; $a = ; opendir STDIN, "." ; $a = ; closedir STDIN; no warnings 'closed' ; opendir STDIN, "." ; $a = ; $a = ; EXPECT readline() on closed filehandle STDIN at - line 3. readline() on closed filehandle STDIN at - line 4. (Are you trying to call readline() on dirhandle STDIN?) ######## # pp_hot.c [Perl_do_readline] use warnings 'io' ; my $file = "./xcv" ; unlink $file ; open (FH, ">$file") or die $! ; my $a = ; no warnings 'io' ; $a = ; use warnings 'io' ; open(FOO, ">&FH") or die $! ; $a = ; no warnings 'io' ; $a = ; use warnings 'io' ; $a = ; $a = ; close (FH) or die $! ; close (FOO) or die $! ; unlink $file ; EXPECT Filehandle FH opened only for output at - line 5. Filehandle FOO opened only for output at - line 10. Filehandle FOO opened only for output at - line 14. Filehandle FH opened only for output at - line 15. ######## # pp_hot.c [Perl_sub_crush_depth] use warnings 'recursion' ; sub fred { fred() if $a++ < 200 } { local $SIG{__WARN__} = sub { die "ok\n" if $_[0] =~ /^Deep recursion on subroutine "main::fred"/ }; fred(); } EXPECT ok ######## # pp_hot.c [Perl_sub_crush_depth] no warnings 'recursion' ; sub fred { fred() if $a++ < 200 } { local $SIG{__WARN__} = sub { die "ok\n" if $_[0] =~ /^Deep recursion on subroutine "main::fred"/ }; fred(); } EXPECT ######## # pp_hot.c [Perl_sub_crush_depth] use warnings 'recursion' ; $b = sub { &$b if $a++ < 200 } ; &$b ; EXPECT Deep recursion on anonymous subroutine at - line 5. ######## # pp_hot.c [Perl_sub_crush_depth] no warnings 'recursion' ; $b = sub { &$b if $a++ < 200 } ; &$b ; EXPECT ######## # pp_hot.c [pp_concat] use warnings 'uninitialized'; my($x, $y); sub a { shift } a($x . "x"); # should warn once a($x . $y); # should warn twice $x .= $y; # should warn once $y .= $y; # should warn once EXPECT Use of uninitialized value $x in concatenation (.) or string at - line 5. Use of uninitialized value $x in concatenation (.) or string at - line 6. Use of uninitialized value $y in concatenation (.) or string at - line 6. Use of uninitialized value $y in concatenation (.) or string at - line 7. Use of uninitialized value $y in concatenation (.) or string at - line 8. ######## # pp_hot.c [pp_aelem] { use warnings 'misc'; print $x[\1]; } { no warnings 'misc'; print $x[\1]; } EXPECT OPTION regex Use of reference ".*" as array index at - line 4. ######## # pp_hot.c [pp_aelem] package Foo;use overload q("") => sub {};package main;$a = bless {}, "Foo"; $b = {}; { use warnings 'misc'; print $x[$a]; print $x[$b]; } { no warnings 'misc'; print $x[$a]; print $x[$b]; } EXPECT OPTION regex Use of reference ".*" as array index at - line 7. perl-5.12.0-RC0/t/lib/warnings/hv0000444000175000017500000000020211143650501015314 0ustar jessejesse hv.c Mandatory Warnings ALL TODO ------------------ Attempt to free non-existent shared string [unsharepvn] __END__ perl-5.12.0-RC0/t/lib/warnings/pp_ctl0000444000175000017500000000731111325125742016176 0ustar jessejesse pp_ctl.c AOK Not enough format arguments format STDOUT = @<<< @<<< $a . write; Exiting substitution via %s $_ = "abc" ; while ($i ++ == 0) { s/ab/last/e ; } Exiting subroutine via %s sub fred { last } { fred() } Exiting eval via %s { eval "last" } Exiting pseudo-block via %s @a = (1,2) ; @b = sort { last } @a ; Exiting substitution via %s $_ = "abc" ; last fred: while ($i ++ == 0) { s/ab/last fred/e ; } Exiting subroutine via %s sub fred { last joe } joe: { fred() } Exiting eval via %s fred: { eval "last fred" } Exiting pseudo-block via %s @a = (1,2) ; fred: @b = sort { last fred } @a ; Deep recursion on subroutine \"%s\" sub fred { fred() if $a++ < 200 } fred() (in cleanup) foo bar package Foo; DESTROY { die "foo bar" } { bless [], 'Foo' for 1..10 } __END__ # pp_ctl.c use warnings 'syntax' ; format STDOUT = @<<< @<<< 1 . write; EXPECT Not enough format arguments at - line 5. 1 ######## # pp_ctl.c no warnings 'syntax' ; format = @<<< @<<< 1 . write ; EXPECT 1 ######## # pp_ctl.c use warnings 'exiting' ; $_ = "abc" ; while ($i ++ == 0) { s/ab/last/e ; } no warnings 'exiting' ; while ($i ++ == 0) { s/ab/last/e ; } EXPECT Exiting substitution via last at - line 7. ######## # pp_ctl.c use warnings 'exiting' ; sub fred { last } { fred() } no warnings 'exiting' ; sub joe { last } { joe() } EXPECT Exiting subroutine via last at - line 3. ######## # pp_ctl.c { eval "use warnings 'exiting' ; last;" } print STDERR $@ ; { eval "no warnings 'exiting' ;last;" } print STDERR $@ ; EXPECT Exiting eval via last at (eval 1) line 1. ######## # pp_ctl.c use warnings 'exiting' ; @a = (1,2) ; @b = sort { last } @a ; no warnings 'exiting' ; @b = sort { last } @a ; EXPECT Exiting pseudo-block via last at - line 4. Can't "last" outside a loop block at - line 4. ######## # pp_ctl.c use warnings 'exiting' ; $_ = "abc" ; fred: while ($i ++ == 0) { s/ab/last fred/e ; } no warnings 'exiting' ; while ($i ++ == 0) { s/ab/last fred/e ; } EXPECT Exiting substitution via last at - line 7. ######## # pp_ctl.c use warnings 'exiting' ; sub fred { last joe } joe: { fred() } no warnings 'exiting' ; sub Fred { last Joe } Joe: { Fred() } EXPECT Exiting subroutine via last at - line 3. ######## # pp_ctl.c joe: { eval "use warnings 'exiting' ; last joe;" } print STDERR $@ ; Joe: { eval "no warnings 'exiting' ; last Joe;" } print STDERR $@ ; EXPECT Exiting eval via last at (eval 1) line 1. ######## # pp_ctl.c use warnings 'exiting' ; @a = (1,2) ; fred: @b = sort { last fred } @a ; no warnings 'exiting' ; Fred: @b = sort { last Fred } @a ; EXPECT Exiting pseudo-block via last at - line 4. Label not found for "last fred" at - line 4. ######## # pp_ctl.c use warnings 'recursion' ; BEGIN { warn "PREFIX\n" ;} sub fred { fred() if $a++ < 200 } fred() EXPECT Deep recursion on subroutine "main::fred" at - line 6. ######## # pp_ctl.c no warnings 'recursion' ; BEGIN { warn "PREFIX\n" ;} sub fred { fred() if $a++ < 200 } fred() EXPECT ######## # pp_ctl.c use warnings 'misc' ; package Foo; DESTROY { die "@{$_[0]} foo bar" } { bless ['A'], 'Foo' for 1..10 } { bless ['B'], 'Foo' for 1..10 } EXPECT (in cleanup) A foo bar at - line 4. (in cleanup) B foo bar at - line 4. ######## # pp_ctl.c no warnings 'misc' ; package Foo; DESTROY { die "@{$_[0]} foo bar" } { bless ['A'], 'Foo' for 1..10 } { bless ['B'], 'Foo' for 1..10 } EXPECT ######## # pp_ctl.c use warnings; eval 'print $foo'; EXPECT Use of uninitialized value $foo in print at (eval 1) line 1. ######## # pp_ctl.c use warnings; { no warnings; eval 'print $foo'; } EXPECT ######## # pp_ctl.c use warnings; eval 'use 5.006; use 5.10.0'; EXPECT perl-5.12.0-RC0/t/lib/warnings/perl0000444000175000017500000000300211143650501015642 0ustar jessejesse perl.c AOK gv_check(defstash) Name \"%s::%s\" used only once: possible typo Mandatory Warnings All TODO ------------------ Recompile perl with -DDEBUGGING to use -D switch [moreswitches] Unbalanced scopes: %ld more ENTERs than LEAVEs [perl_destruct] Unbalanced saves: %ld more saves than restores [perl_destruct] Unbalanced tmps: %ld more allocs than frees [perl_destruct] Unbalanced context: %ld more PUSHes than POPs [perl_destruct] Unbalanced string table refcount: (%d) for \"%s\" [perl_destruct] Scalars leaked: %ld [perl_destruct] __END__ # perl.c no warnings 'once' ; $x = 3 ; use warnings 'once' ; $z = 3 ; EXPECT Name "main::z" used only once: possible typo at - line 5. ######## -w # perl.c $x = 3 ; no warnings 'once' ; $z = 3 EXPECT Name "main::x" used only once: possible typo at - line 3. ######## # perl.c BEGIN { $^W =1 ; } $x = 3 ; no warnings 'once' ; $z = 3 EXPECT Name "main::x" used only once: possible typo at - line 3. ######## -W # perl.c no warnings 'once' ; $x = 3 ; use warnings 'once' ; $z = 3 ; EXPECT OPTION random Name "main::z" used only once: possible typo at - line 6. Name "main::x" used only once: possible typo at - line 4. ######## -X # perl.c use warnings 'once' ; $x = 3 ; EXPECT ######## # perl.c { use warnings 'once' ; $x = 3 ; } $y = 3 ; EXPECT Name "main::x" used only once: possible typo at - line 3. ######## # perl.c $z = 3 ; BEGIN { $^W = 1 } { no warnings 'once' ; $x = 3 ; } $y = 3 ; EXPECT Name "main::y" used only once: possible typo at - line 6. perl-5.12.0-RC0/t/lib/warnings/pad0000444000175000017500000001130611325127001015446 0ustar jessejesse pad.c AOK "%s" variable %s masks earlier declaration in same scope my $x; my $x ; Variable "%s" will not stay shared sub x { my $x; sub y { sub { $x } } } sub x { my $x; sub y { $x } } "our" variable %s redeclared (Did you mean "local" instead of "our"?) our $x; { our $x; } %s never introduced [pad_leavemy] TODO __END__ # pad.c use warnings 'misc' ; my $x ; my $x ; my $y = my $y ; my $p ; package X ; my $p ; package main ; no warnings 'misc' ; my $x ; my $y ; my $p ; EXPECT "my" variable $x masks earlier declaration in same scope at - line 4. "my" variable $y masks earlier declaration in same statement at - line 5. "my" variable $p masks earlier declaration in same scope at - line 8. ######## # pad.c use warnings 'misc' ; our $x ; my $x ; our $y = my $y ; our $p ; package X ; my $p ; package main ; no warnings 'misc' ; our $z ; my $z ; our $t = my $t ; our $q ; package X ; my $q ; EXPECT "my" variable $x masks earlier declaration in same scope at - line 4. "my" variable $y masks earlier declaration in same statement at - line 5. "my" variable $p masks earlier declaration in same scope at - line 8. ######## # pad.c use warnings 'misc' ; my $x ; our $x ; my $y = our $y ; my $p ; package X ; our $p ; package main ; no warnings 'misc' ; my $z ; our $z ; my $t = our $t ; my $q ; package X ; our $q ; EXPECT "our" variable $x masks earlier declaration in same scope at - line 4. "our" variable $y masks earlier declaration in same statement at - line 5. "our" variable $p masks earlier declaration in same scope at - line 8. ######## # pad.c use warnings 'closure' ; sub x { my $x; sub y { $x } } EXPECT Variable "$x" will not stay shared at - line 7. ######## # pad.c no warnings 'closure' ; sub x { my $x; sub y { $x } } EXPECT ######## # pad.c use warnings 'closure' ; sub x { my $x; sub y { sub { $x } } } EXPECT Variable "$x" will not stay shared at - line 6. ######## # pad.c use warnings 'closure' ; sub x { my $x; sub { $x; sub y { $x } }->(); } EXPECT Variable "$x" will not stay shared at - line 9. ######## # pad.c use warnings 'closure' ; my $x; sub { $x; sub f { sub { $x }->(); } }->(); EXPECT ######## # pad.c use warnings 'closure' ; sub { my $x; sub f { $x } }->(); EXPECT Variable "$x" is not available at - line 5. ######## # pad.c use warnings 'closure' ; sub { my $x; eval 'sub f { $x }'; }->(); EXPECT ######## # pad.c use warnings 'closure' ; sub { my $x; sub f { eval '$x' } }->(); f(); EXPECT Variable "$x" is not available at (eval 1) line 2. ######## # pad.c use warnings 'closure' ; sub x { our $x; sub y { $x } } EXPECT ######## # pad.c # see bugid 1754 use warnings 'closure' ; sub f { my $x; sub { eval '$x' }; } f()->(); EXPECT Variable "$x" is not available at (eval 1) line 2. ######## use warnings 'closure' ; { my $x = 1; $y = \$x; # force abandonment rather than clear-in-place at scope exit sub f2 { eval '$x' } } f2(); EXPECT Variable "$x" is not available at (eval 1) line 2. ######## use warnings 'closure' ; for my $x (1,2,3) { sub f { eval '$x' } f(); } f(); EXPECT Variable "$x" is not available at (eval 4) line 2. ######## # pad.c no warnings 'closure' ; sub x { my $x; sub y { sub { $x } } } EXPECT ######## use warnings 'misc' ; my $x; { my $x; } EXPECT ######## # pad.c use warnings 'misc' ; our $x ; our $x ; our $y = our $y ; our $p ; package X ; our $p ; package main ; no warnings 'misc' ; our $a ; our $a ; our $b = our $b ; our $c ; package X ; our $c ; EXPECT "our" variable $x redeclared at - line 4. "our" variable $y redeclared at - line 5. ######## use warnings 'misc' ; our $x; { our $x; } our $x; no warnings 'misc' ; our $y; { our $y; } our $y; EXPECT "our" variable $x redeclared at - line 4. (Did you mean "local" instead of "our"?) "our" variable $x redeclared at - line 6. ######## use warnings 'misc' ; our $x; { my $x; } no warnings 'misc' ; our $y; { my $y; } EXPECT ######## use warnings 'misc' ; my $x; { our $x; } no warnings 'misc' ; my $y; { our $y; } EXPECT ######## use warnings 'misc' ; my $x; { my $x; } no warnings 'misc' ; my $y; { my $y; } EXPECT ######## # an our var being introduced should suppress errors about global syms use strict; use warnings; our $x unless $x; EXPECT ######## use warnings 'misc'; our $qunckkk; our $_; package clank_est; our $qunckkk; our $_; no warnings 'misc'; our $ouch; our $_; package whack; our $ouch; our $_; EXPECT "our" variable $_ redeclared at - line 6. perl-5.12.0-RC0/t/lib/warnings/9uninit0000444000175000017500000016703411325125742016325 0ustar jessejesseDAPM 4/2004. Test the appearance of variable names in "Use of uninitialized value" warnings. The following ops aren't tested, mainly because they do IO or non-portable stuff: send recv bind conect listen accept shutdown chdir chown chroot unlink chmod utime rename link symlink readlink mkdir rmdir opendir seekdir system exec kill getpgrp alarm sleep dofile require gethostbyname gethostbyaddr getnetbyname getnetbyaddr getprotobyname getprotobynumber getservbyname getservbyport sethostent setnetent setprotoent setservent getpwnam getpwuid getgrnam getgrgid waitpid setpgrp setpriority getpriority syscall dbmopen ioctl fcntl truncate getsockopt setsockopt semctl semop semget msgget msgctl msgsnd msgrcv shmget shmctl shmread shmwrite --------------------------------------------------- __END__ use warnings 'uninitialized'; my ($m1, $m2, $v); $v = $m1 + 10; $v = 22 + $m2; $v = $m1 + $m2; EXPECT Use of uninitialized value $m1 in addition (+) at - line 4. Use of uninitialized value $m2 in addition (+) at - line 5. Use of uninitialized value $m2 in addition (+) at - line 6. Use of uninitialized value $m1 in addition (+) at - line 6. ######## use warnings 'uninitialized'; my ($m1, $v); our ($g1, $g2); $v = $g1 + 21; $v = 31 + $g2; $v = $g1 + $g2; $v = $m1 + $g2; EXPECT Use of uninitialized value $g1 in addition (+) at - line 5. Use of uninitialized value $g2 in addition (+) at - line 6. Use of uninitialized value $g2 in addition (+) at - line 7. Use of uninitialized value $g1 in addition (+) at - line 7. Use of uninitialized value $g2 in addition (+) at - line 8. Use of uninitialized value $m1 in addition (+) at - line 8. ######## use warnings 'uninitialized'; my ($m1, @ma, $v); $v = $ma[5] + 45; $v = 56 + $ma[6]; $v = $ma[7] + $m1; $v = $ma[8] + $ma[9]; $v = $ma[-1] + $ma[-2]; EXPECT Use of uninitialized value $ma[5] in addition (+) at - line 4. Use of uninitialized value $ma[6] in addition (+) at - line 5. Use of uninitialized value $m1 in addition (+) at - line 6. Use of uninitialized value in addition (+) at - line 6. Use of uninitialized value in addition (+) at - line 7. Use of uninitialized value in addition (+) at - line 7. Use of uninitialized value in addition (+) at - line 8. Use of uninitialized value in addition (+) at - line 8. ######## use warnings 'uninitialized'; my ($v); my @mau = (undef) x 258; my %mhu = ('foo', undef, 'bar', undef); $v = $mau[5] + 23; $v = $mau[-5] + 45; $v = 56 + $mau[6]; $v = 78 + $mau[-6]; $v = $mau[7] + $mau[8]; $v = $mau[256] + $mau[257]; $v = $mau[-1] + $mau[-2]; $v = $mhu{foo} + $mhu{bar}; EXPECT Use of uninitialized value $mau[5] in addition (+) at - line 6. Use of uninitialized value $mau[-5] in addition (+) at - line 7. Use of uninitialized value $mau[6] in addition (+) at - line 8. Use of uninitialized value $mau[-6] in addition (+) at - line 9. Use of uninitialized value $mau[8] in addition (+) at - line 10. Use of uninitialized value $mau[7] in addition (+) at - line 10. Use of uninitialized value $mau[257] in addition (+) at - line 11. Use of uninitialized value $mau[256] in addition (+) at - line 11. Use of uninitialized value $mau[-2] in addition (+) at - line 12. Use of uninitialized value $mau[-1] in addition (+) at - line 12. Use of uninitialized value $mhu{"bar"} in addition (+) at - line 13. Use of uninitialized value $mhu{"foo"} in addition (+) at - line 13. ######## use warnings 'uninitialized'; my ($v); our (@ga); $v = $ga[8] + 21; $v = $ga[-8] + 46; $v = 57 + $ga[9]; $v = 58 + $ga[-9]; $v = $ga[10] + $ga[11]; $v = $ga[-10] + $ga[-11]; EXPECT Use of uninitialized value $ga[8] in addition (+) at - line 5. Use of uninitialized value $ga[-8] in addition (+) at - line 6. Use of uninitialized value $ga[9] in addition (+) at - line 7. Use of uninitialized value $ga[-9] in addition (+) at - line 8. Use of uninitialized value in addition (+) at - line 9. Use of uninitialized value in addition (+) at - line 9. Use of uninitialized value in addition (+) at - line 10. Use of uninitialized value in addition (+) at - line 10. ######## use warnings 'uninitialized'; my ($v); our @gau = (undef) x 258; our %ghu = ('foo', undef, 'bar', undef); $v = $gau[8] + 46; $v = $gau[-8] + 47; $v = 57 + $gau[9]; $v = 57 + $gau[-9]; $v = $gau[10] + $gau[11]; $v = $gau[256] + $gau[257]; $v = $gau[-1] + $gau[-2]; $v = $ghu{foo} + $ghu{bar}; EXPECT Use of uninitialized value $gau[8] in addition (+) at - line 6. Use of uninitialized value $gau[-8] in addition (+) at - line 7. Use of uninitialized value $gau[9] in addition (+) at - line 8. Use of uninitialized value $gau[-9] in addition (+) at - line 9. Use of uninitialized value $gau[11] in addition (+) at - line 10. Use of uninitialized value $gau[10] in addition (+) at - line 10. Use of uninitialized value $gau[257] in addition (+) at - line 11. Use of uninitialized value $gau[256] in addition (+) at - line 11. Use of uninitialized value $gau[-2] in addition (+) at - line 12. Use of uninitialized value $gau[-1] in addition (+) at - line 12. Use of uninitialized value $ghu{"bar"} in addition (+) at - line 13. Use of uninitialized value $ghu{"foo"} in addition (+) at - line 13. ######## use warnings 'uninitialized'; my ($v); our @gau = (undef) x 258; our %ghu = ('foo', undef, 'bar', undef); my @mau = (undef) x 258; my %mhu = ('foo', undef, 'bar', undef); my $i1 = 10; my $i2 = 20; my $i3 = 2000; my $k1 = 'foo'; my $k2 = 'bar'; my $k3 = 'baz'; $v = $mau[$i1] + $mau[$i2]; $v = $gau[$i1] + $gau[$i2]; $v = $gau[$i1] + $gau[$i3]; $v = $mhu{$k1} + $mhu{$k2}; $v = $ghu{$k1} + $ghu{$k2}; $v = $ghu{$k1} + $ghu{$k3}; EXPECT Use of uninitialized value $mau[20] in addition (+) at - line 14. Use of uninitialized value $mau[10] in addition (+) at - line 14. Use of uninitialized value $gau[20] in addition (+) at - line 15. Use of uninitialized value $gau[10] in addition (+) at - line 15. Use of uninitialized value in addition (+) at - line 16. Use of uninitialized value $gau[10] in addition (+) at - line 16. Use of uninitialized value $mhu{"bar"} in addition (+) at - line 17. Use of uninitialized value $mhu{"foo"} in addition (+) at - line 17. Use of uninitialized value $ghu{"bar"} in addition (+) at - line 18. Use of uninitialized value $ghu{"foo"} in addition (+) at - line 18. Use of uninitialized value in addition (+) at - line 19. Use of uninitialized value $ghu{"foo"} in addition (+) at - line 19. ######## use warnings 'uninitialized'; my ($m1, $m2, @ma, %mh, $v); our ($g1, $g2, @ga, %gh); $v = $ma[$m1]; $v = $ma[$g1]; $v = $ga[$m2]; $v = $ga[$g2]; $v = $mh{$m1}; $v = $mh{$g1}; $v = $gh{$m2}; $v = $gh{$g2}; $v = $m1+($m2-$g1); $v = $ma[$ga[3]]; $v = $ga[$ma[4]]; EXPECT Use of uninitialized value $m1 in array element at - line 5. Use of uninitialized value $g1 in array element at - line 6. Use of uninitialized value $m2 in array element at - line 7. Use of uninitialized value $g2 in array element at - line 8. Use of uninitialized value $m1 in hash element at - line 10. Use of uninitialized value $g1 in hash element at - line 11. Use of uninitialized value $m2 in hash element at - line 12. Use of uninitialized value $g2 in hash element at - line 13. Use of uninitialized value $g1 in subtraction (-) at - line 15. Use of uninitialized value $m2 in subtraction (-) at - line 15. Use of uninitialized value $m1 in addition (+) at - line 15. Use of uninitialized value $ga[3] in array element at - line 16. Use of uninitialized value $ma[4] in array element at - line 17. ######## use warnings 'uninitialized'; my (@ma, %mh, $v); our (@ga, %gh); $v = sin $ga[1000]; $v = sin $ma[1000]; $v = sin $gh{foo}; $v = sin $mh{bar}; $v = sin $ga[$$]; $v = sin $ma[$$]; $v = sin $gh{$$}; $v = sin $mh{$$}; EXPECT Use of uninitialized value $ga[1000] in sin at - line 5. Use of uninitialized value $ma[1000] in sin at - line 6. Use of uninitialized value $gh{"foo"} in sin at - line 7. Use of uninitialized value $mh{"bar"} in sin at - line 8. Use of uninitialized value within @ga in sin at - line 10. Use of uninitialized value within @ma in sin at - line 11. Use of uninitialized value within %gh in sin at - line 12. Use of uninitialized value within %mh in sin at - line 13. ######## use warnings 'uninitialized'; my (@mat, %mht, $v); sub X::TIEARRAY { bless [], 'X' } sub X::TIEHASH { bless [], 'X' } sub X::FETCH { undef } tie @mat, 'X'; tie %mht, 'X'; my $key1 = 'akey'; my $key2 = 'bkey'; my $index1 = 33; my $index2 = 55; $v = sin $mat[0]; $v = $mat[0] + $mat[1]; $v = sin $mat[1000]; $v = $mat[1000] + $mat[1001]; $v = sin $mat[$index1]; $v = $mat[$index1] + $mat[$index2]; $v = sin $mht{foo}; $v = $mht{foo} + $mht{bar}; $v = sin $mht{$key1}; $v = $mht{$key1} + $mht{$key2}; $v = $1+1; EXPECT Use of uninitialized value $mat[0] in sin at - line 13. Use of uninitialized value in addition (+) at - line 14. Use of uninitialized value in addition (+) at - line 14. Use of uninitialized value $mat[1000] in sin at - line 15. Use of uninitialized value in addition (+) at - line 16. Use of uninitialized value in addition (+) at - line 16. Use of uninitialized value within @mat in sin at - line 18. Use of uninitialized value in addition (+) at - line 19. Use of uninitialized value in addition (+) at - line 19. Use of uninitialized value $mht{"foo"} in sin at - line 21. Use of uninitialized value in addition (+) at - line 22. Use of uninitialized value in addition (+) at - line 22. Use of uninitialized value within %mht in sin at - line 24. Use of uninitialized value in addition (+) at - line 25. Use of uninitialized value in addition (+) at - line 25. Use of uninitialized value $1 in addition (+) at - line 27. ######## use warnings 'uninitialized'; my ($m1); our ($g1, @ga); print $ga[1000]; print STDERR $ga[1000]; print STDERR $m1, $g1, $ga[1],$m2; print STDERR "", $ga[1],""; EXPECT Use of uninitialized value in print at - line 5. Use of uninitialized value in print at - line 6. Use of uninitialized value $m1 in print at - line 7. Use of uninitialized value $g1 in print at - line 7. Use of uninitialized value in print at - line 7. Use of uninitialized value $m2 in print at - line 7. Use of uninitialized value in print at - line 8. ######## use warnings 'uninitialized'; my ($m1); our ($g1); close $m1; # exercises rv2gv close $g1; # exercises rv2gv EXPECT Use of uninitialized value $m1 in ref-to-glob cast at - line 5. Use of uninitialized value $g1 in ref-to-glob cast at - line 6. ######## use warnings 'uninitialized'; my ($m1, $m2, $v); our ($g1, $g2); $v = $$m1; $v = $$g1; $v = @$m1; $v = @$g1; $v = %$m2; $v = %$g2; $v = ${"foo.bar"}+1; $v = ${"foo$m1"}+1; $v = ${"foo$g1"}+1; EXPECT Use of uninitialized value $m1 in scalar dereference at - line 5. Use of uninitialized value $g1 in scalar dereference at - line 6. Use of uninitialized value $m1 in array dereference at - line 8. Use of uninitialized value $g1 in array dereference at - line 9. Use of uninitialized value $m2 in hash dereference at - line 10. Use of uninitialized value $g2 in hash dereference at - line 11. Use of uninitialized value in addition (+) at - line 13. Use of uninitialized value $m1 in concatenation (.) or string at - line 14. Use of uninitialized value in addition (+) at - line 14. Use of uninitialized value $g1 in concatenation (.) or string at - line 15. Use of uninitialized value in addition (+) at - line 15. ######## use warnings 'uninitialized'; my ($m1, $v); our ($g1); $v = $m1 | $m2; $v = $m1 & $m2; $v = $m1 ^ $m2; $v = ~$m1; $v = $g1 | $g2; $v = $g1 & $g2; $v = $g1 ^ $g2; $v = ~$g1; EXPECT Use of uninitialized value $m1 in bitwise or (|) at - line 5. Use of uninitialized value $m2 in bitwise or (|) at - line 5. Use of uninitialized value $m1 in bitwise and (&) at - line 6. Use of uninitialized value $m2 in bitwise and (&) at - line 6. Use of uninitialized value $m1 in bitwise xor (^) at - line 7. Use of uninitialized value $m2 in bitwise xor (^) at - line 7. Use of uninitialized value $m1 in 1's complement (~) at - line 8. Use of uninitialized value $g1 in bitwise or (|) at - line 10. Use of uninitialized value $g2 in bitwise or (|) at - line 10. Use of uninitialized value $g1 in bitwise and (&) at - line 11. Use of uninitialized value $g2 in bitwise and (&) at - line 11. Use of uninitialized value $g1 in bitwise xor (^) at - line 12. Use of uninitialized value $g2 in bitwise xor (^) at - line 12. Use of uninitialized value $g1 in 1's complement (~) at - line 13. ######## use warnings 'uninitialized'; my ($v); my $tmp1; $v = $tmp1++; # (doesn't warn) our $tmp2; $v = $tmp2++; # (doesn't warn) my $tmp3; $v = ++$tmp1; # (doesn't warn) our $tmp4; $v = ++$tmp2; # (doesn't warn) my $tmp5; $v = $tmp5--; # (doesn't warn) our $tmp6; $v = $tmp6--; # (doesn't warn) my $tmp7; $v = --$tmp7; # (doesn't warn) our $tmp8; $v = --$tmp8; # (doesn't warn) EXPECT ######## use warnings 'uninitialized'; my $s1; chomp $s1; my $s2; chop $s2; my ($s3,$s4); chomp ($s3,$s4); my ($s5,$s6); chop ($s5,$s6); EXPECT Use of uninitialized value $s1 in scalar chomp at - line 3. Use of uninitialized value $s2 in scalar chop at - line 4. Use of uninitialized value $s4 in chomp at - line 5. Use of uninitialized value $s3 in chomp at - line 5. Use of uninitialized value $s5 in chop at - line 6. Use of uninitialized value $s6 in chop at - line 6. ######## use warnings 'uninitialized'; my ($m1); local $/ =\$m1; my $x = "abc"; chomp $x; chop $x; my $y; chomp ($x, $y); chop ($x, $y); EXPECT Use of uninitialized value ${$/} in scalar chomp at - line 6. Use of uninitialized value ${$/} in chomp at - line 8. Use of uninitialized value $y in chomp at - line 8. Use of uninitialized value ${$/} in chomp at - line 8. Use of uninitialized value $y in chop at - line 8. ######## use warnings 'uninitialized'; my ($m1, @ma, %mh); our ($g1); delete $ma[$m1]; delete @ma[$m1, $g1]; delete $mh{$m1}; delete @mh{$m1, $g1}; EXPECT Use of uninitialized value $m1 in delete at - line 5. Use of uninitialized value $m1 in delete at - line 6. Use of uninitialized value $g1 in delete at - line 6. Use of uninitialized value $m1 in delete at - line 7. Use of uninitialized value $m1 in delete at - line 8. Use of uninitialized value $g1 in delete at - line 8. ######## use warnings 'uninitialized'; my ($m1, @ma, %mh); our ($g1); my @a = @ma[$m1, $g1]; @a = (4,5)[$m1, $g1]; @a = @mh{$m1, $g1}; EXPECT Use of uninitialized value $m1 in array slice at - line 5. Use of uninitialized value $g1 in array slice at - line 5. Use of uninitialized value $m1 in list slice at - line 6. Use of uninitialized value $g1 in list slice at - line 6. Use of uninitialized value $m1 in hash slice at - line 7. Use of uninitialized value $g1 in hash slice at - line 7. ######## use warnings 'uninitialized'; my ($m1, @ma, %mh, $v); our ($g1, @ga, %gh); $v = exists $ma[$m1]; $v = exists $ga[$g1]; $v = exists $mh{$m1}; $v = exists $gh{$g1}; EXPECT Use of uninitialized value $m1 in exists at - line 5. Use of uninitialized value $g1 in exists at - line 6. Use of uninitialized value $m1 in exists at - line 7. Use of uninitialized value $g1 in exists at - line 8. ######## use warnings 'uninitialized'; my ($m1, $m2); my ($v, @a); my ($t, $u) = (1, 1); local $.; @ma = (1 .. 2); @ma = ($t .. 2); @ma = ($m1 .. 2); @ma = (1 .. $u); @ma = (1 .. $m2); @ma = (1 ... 2); @ma = ($t ... 2); @ma = ($m1 ... 2); @ma = (1 ... $u); @ma = (1 ... $m2); $v = (1 .. 2); $v = ($t .. 2); $v = ($m1 .. 2); $v = (1 .. $u); $v = (1 .. $m2); $v = (1 ... 2); $v = ($t ... 2); $v = ($m1 ... 2); $v = (1 ... $u); $v = (1 ... $m2); EXPECT Use of uninitialized value $m1 in range (or flop) at - line 10. Use of uninitialized value $m2 in range (or flop) at - line 12. Use of uninitialized value $m1 in range (or flop) at - line 16. Use of uninitialized value $m2 in range (or flop) at - line 18. Use of uninitialized value $. in range (or flip) at - line 20. Use of uninitialized value $. in range (or flop) at - line 21. Use of uninitialized value $. in range (or flip) at - line 23. Use of uninitialized value $. in range (or flip) at - line 24. Use of uninitialized value $. in range (or flip) at - line 26. Use of uninitialized value $. in range (or flip) at - line 29. Use of uninitialized value $. in range (or flip) at - line 30. ######## use warnings 'uninitialized'; my ($m1, $m2); my ($v, @a); my ($t, $u) = (1, 1); @ma = ($t .. $u); @ma = ($m1 .. $u); @ma = ($t .. $m2); @ma = ($m1 .. $m2); @ma = ($t ... $u); @ma = ($m1 ... $u); @ma = ($t ... $m2); @ma = ($m1 ... $m2); $v = ($t .. $u); $v = ($m1 .. $u); $v = ($t .. $m2); $v = ($m1 .. $m2); $v = ($t ... $u); $v = ($m1 ... $u); $v = ($t ... $m2); $v = ($m1 ... $m2); EXPECT Use of uninitialized value $m1 in range (or flop) at - line 7. Use of uninitialized value $m2 in range (or flop) at - line 8. Use of uninitialized value in range (or flop) at - line 9. Use of uninitialized value in range (or flop) at - line 9. Use of uninitialized value $m1 in range (or flop) at - line 12. Use of uninitialized value $m2 in range (or flop) at - line 13. Use of uninitialized value in range (or flop) at - line 14. Use of uninitialized value in range (or flop) at - line 14. ######## use warnings 'uninitialized'; my ($m1, $v); our ($g1); my ($x1,$x2); $v = $x1 << $m1; $v = $x2 << $g1; EXPECT Use of uninitialized value $m1 in left bitshift (<<) at - line 6. Use of uninitialized value $x1 in left bitshift (<<) at - line 6. Use of uninitialized value $g1 in left bitshift (<<) at - line 7. Use of uninitialized value $x2 in left bitshift (<<) at - line 7. ######## use warnings 'uninitialized'; my ($m1, $m2, $v); our ($g1, $g2); use integer; $v = $m1 + $g1; $v = $m1 - $g1; $v = $m1 * $g1; eval {$v = $m1 / $g1}; $v = $m2 / 2; eval {$v = $m1 % $g1}; $v = $m2 % 2; $v = $m1 < $g1; $v = $m1 > $g1; $v = $m1 <= $g1; $v = $m1 >= $g1; $v = $m1 == $g1; $v = $m1 != $g1; $v = $m1 <=> $g1; $v = -$m1; EXPECT Use of uninitialized value $g1 in integer addition (+) at - line 6. Use of uninitialized value $m1 in integer addition (+) at - line 6. Use of uninitialized value $g1 in integer subtraction (-) at - line 7. Use of uninitialized value $m1 in integer subtraction (-) at - line 7. Use of uninitialized value $g1 in integer multiplication (*) at - line 8. Use of uninitialized value $m1 in integer multiplication (*) at - line 8. Use of uninitialized value $g1 in integer division (/) at - line 9. Use of uninitialized value $m2 in integer division (/) at - line 10. Use of uninitialized value $g1 in integer modulus (%) at - line 11. Use of uninitialized value $m1 in integer modulus (%) at - line 11. Use of uninitialized value $m2 in integer modulus (%) at - line 12. Use of uninitialized value $g1 in integer lt (<) at - line 13. Use of uninitialized value $m1 in integer lt (<) at - line 13. Use of uninitialized value $g1 in integer gt (>) at - line 14. Use of uninitialized value $m1 in integer gt (>) at - line 14. Use of uninitialized value $g1 in integer le (<=) at - line 15. Use of uninitialized value $m1 in integer le (<=) at - line 15. Use of uninitialized value $g1 in integer ge (>=) at - line 16. Use of uninitialized value $m1 in integer ge (>=) at - line 16. Use of uninitialized value $g1 in integer eq (==) at - line 17. Use of uninitialized value $m1 in integer eq (==) at - line 17. Use of uninitialized value $g1 in integer ne (!=) at - line 18. Use of uninitialized value $m1 in integer ne (!=) at - line 18. Use of uninitialized value $g1 in integer comparison (<=>) at - line 19. Use of uninitialized value $m1 in integer comparison (<=>) at - line 19. Use of uninitialized value $m1 in integer negation (-) at - line 20. ######## use warnings 'uninitialized'; my ($m1, $m2, $v); our ($g1, $g2); $v = int($g1); $v = abs($g2); EXPECT Use of uninitialized value $g1 in int at - line 5. Use of uninitialized value $g2 in abs at - line 6. ######## use warnings 'uninitialized'; my ($m1, $m2, $v); our ($g1); $v = pack $m1; $v = pack "i*", $m2, $g1, $g2; my @unpack = unpack $m1, $m2; EXPECT Use of uninitialized value $m1 in pack at - line 5. Use of uninitialized value $m2 in pack at - line 6. Use of uninitialized value $g1 in pack at - line 6. Use of uninitialized value $g2 in pack at - line 6. Use of uninitialized value $m1 in unpack at - line 7. Use of uninitialized value $m2 in unpack at - line 7. ######## use warnings 'uninitialized'; my ($m1); our ($g1); my @sort; @sort = sort $m1, $g1; @sort = sort {$a <=> $b} $m1, $g1; sub sortf {$a-1 <=> $b-1}; @sort = sort &sortf, $m1, $g1; EXPECT Use of uninitialized value $m1 in sort at - line 6. Use of uninitialized value $g1 in sort at - line 6. Use of uninitialized value $m1 in sort at - line 6. Use of uninitialized value $g1 in sort at - line 6. Use of uninitialized value $m1 in sort at - line 7. Use of uninitialized value $g1 in sort at - line 7. Use of uninitialized value $m1 in sort at - line 7. Use of uninitialized value $g1 in sort at - line 7. Use of uninitialized value $a in subtraction (-) at - line 8. Use of uninitialized value $b in subtraction (-) at - line 8. Use of uninitialized value $m1 in sort at - line 9. Use of uninitialized value $g1 in sort at - line 9. Use of uninitialized value $m1 in sort at - line 9. Use of uninitialized value $m1 in sort at - line 9. Use of uninitialized value $g1 in sort at - line 9. Use of uninitialized value $g1 in sort at - line 9. ######## use warnings 'uninitialized'; my ($m1, $m2, $v); our ($g1); eval { $v = $m1 / $g1 }; $v = $m2 / 2; eval { $v = $m1 % $g1 }; $v = $m2 % 2; $v = $m1 == $g1; $v = $m1 >= $g1; $v = $m1 > $g1; $v = $m1 <= $g1; $v = $m1 < $g1; $v = $m1 * $g1; $v = $m1 <=>$g1; $v = $m1 != $g1; $v = $m1 -$g1; $v = $m1 ** $g1; $v = $m1 + $g1; $v = $m1 - $g1; EXPECT Use of uninitialized value $g1 in division (/) at - line 5. Use of uninitialized value $m1 in division (/) at - line 5. Use of uninitialized value $m2 in division (/) at - line 6. Use of uninitialized value $g1 in modulus (%) at - line 7. Use of uninitialized value $m1 in modulus (%) at - line 7. Use of uninitialized value $m2 in modulus (%) at - line 8. Use of uninitialized value $g1 in numeric eq (==) at - line 9. Use of uninitialized value $m1 in numeric eq (==) at - line 9. Use of uninitialized value $g1 in numeric ge (>=) at - line 10. Use of uninitialized value $m1 in numeric ge (>=) at - line 10. Use of uninitialized value $g1 in numeric gt (>) at - line 11. Use of uninitialized value $m1 in numeric gt (>) at - line 11. Use of uninitialized value $g1 in numeric le (<=) at - line 12. Use of uninitialized value $m1 in numeric le (<=) at - line 12. Use of uninitialized value $g1 in numeric lt (<) at - line 13. Use of uninitialized value $m1 in numeric lt (<) at - line 13. Use of uninitialized value $g1 in multiplication (*) at - line 14. Use of uninitialized value $m1 in multiplication (*) at - line 14. Use of uninitialized value $g1 in numeric comparison (<=>) at - line 15. Use of uninitialized value $m1 in numeric comparison (<=>) at - line 15. Use of uninitialized value $g1 in numeric ne (!=) at - line 16. Use of uninitialized value $m1 in numeric ne (!=) at - line 16. Use of uninitialized value $g1 in subtraction (-) at - line 17. Use of uninitialized value $m1 in subtraction (-) at - line 17. Use of uninitialized value $g1 in exponentiation (**) at - line 18. Use of uninitialized value $m1 in exponentiation (**) at - line 18. Use of uninitialized value $g1 in addition (+) at - line 19. Use of uninitialized value $m1 in addition (+) at - line 19. Use of uninitialized value $g1 in subtraction (-) at - line 20. Use of uninitialized value $m1 in subtraction (-) at - line 20. ######## use warnings 'uninitialized'; my ($m1, $v); our ($g1); $v = *global1{$m1}; $v = prototype $g1; $v = bless [], $g1; $v = `$m1`; $v = $m1 . $g1; EXPECT Use of uninitialized value $m1 in glob elem at - line 5. Use of uninitialized value $g1 in subroutine prototype at - line 6. Use of uninitialized value $g1 in bless at - line 7. Use of uninitialized value $m1 in quoted execution (``, qx) at - line 8. Use of uninitialized value $m1 in concatenation (.) or string at - line 10. Use of uninitialized value $g1 in concatenation (.) or string at - line 10. ######## use warnings 'uninitialized'; my ($m1); our ($g1, $g2); /y/; /$m1/; /$g1/; s/y/z/; undef $_; s/$m1/z/; undef $_; s//$g1/; undef $_; s/$m1/$g1/; undef $_; tr/x/y/; undef $_; my $_; /y/; /$m1/; /$g1/; s/y/z/; undef $_; s/$m1/z/; undef $_; s//$g1/; undef $_; s/$m1/$g1/; undef $_; tr/x/y/; undef $_; $g2 =~ /y/; $g2 =~ /$m1/; $g2 =~ /$g1/; $g2 =~ s/y/z/; undef $g2; $g2 =~ s/$m1/z/; undef $g2; $g2 =~ s//$g1/; undef $g2; $g2 =~ s/$m1/$g1/; undef $g2; $g2 =~ tr/x/y/; undef $g2; # XXX can't extract var name yet my $foo = "abc"; $foo =~ /$m1/; $foo =~ /$g1/; $foo =~ s/y/z/; $foo =~ s/$m1/z/; $foo =~ s//$g1/; $foo =~ s/$m1/$g1/; $foo =~ s/./$m1/e; undef $g1; $m1 = '$g1'; $foo =~ s//$m1/ee; EXPECT Use of uninitialized value $_ in pattern match (m//) at - line 5. Use of uninitialized value $m1 in regexp compilation at - line 6. Use of uninitialized value $_ in pattern match (m//) at - line 6. Use of uninitialized value $g1 in regexp compilation at - line 7. Use of uninitialized value $_ in pattern match (m//) at - line 7. Use of uninitialized value $_ in substitution (s///) at - line 9. Use of uninitialized value $m1 in regexp compilation at - line 10. Use of uninitialized value $_ in substitution (s///) at - line 10. Use of uninitialized value $_ in substitution (s///) at - line 10. Use of uninitialized value $_ in substitution (s///) at - line 11. Use of uninitialized value $g1 in substitution (s///) at - line 11. Use of uninitialized value $_ in substitution (s///) at - line 11. Use of uninitialized value $g1 in substitution (s///) at - line 11. Use of uninitialized value $m1 in regexp compilation at - line 12. Use of uninitialized value $_ in substitution (s///) at - line 12. Use of uninitialized value $_ in substitution (s///) at - line 12. Use of uninitialized value $g1 in substitution iterator at - line 12. Use of uninitialized value $_ in transliteration (tr///) at - line 13. Use of uninitialized value $_ in pattern match (m//) at - line 16. Use of uninitialized value $m1 in regexp compilation at - line 17. Use of uninitialized value $_ in pattern match (m//) at - line 17. Use of uninitialized value $g1 in regexp compilation at - line 18. Use of uninitialized value $_ in pattern match (m//) at - line 18. Use of uninitialized value $_ in substitution (s///) at - line 19. Use of uninitialized value $m1 in regexp compilation at - line 20. Use of uninitialized value $_ in substitution (s///) at - line 20. Use of uninitialized value $_ in substitution (s///) at - line 20. Use of uninitialized value $_ in substitution (s///) at - line 21. Use of uninitialized value $g1 in substitution (s///) at - line 21. Use of uninitialized value $_ in substitution (s///) at - line 21. Use of uninitialized value $g1 in substitution (s///) at - line 21. Use of uninitialized value $m1 in regexp compilation at - line 22. Use of uninitialized value $_ in substitution (s///) at - line 22. Use of uninitialized value $_ in substitution (s///) at - line 22. Use of uninitialized value $g1 in substitution iterator at - line 22. Use of uninitialized value $_ in transliteration (tr///) at - line 23. Use of uninitialized value $g2 in pattern match (m//) at - line 25. Use of uninitialized value $m1 in regexp compilation at - line 26. Use of uninitialized value $g2 in pattern match (m//) at - line 26. Use of uninitialized value $g1 in regexp compilation at - line 27. Use of uninitialized value $g2 in pattern match (m//) at - line 27. Use of uninitialized value $g2 in substitution (s///) at - line 28. Use of uninitialized value $m1 in regexp compilation at - line 29. Use of uninitialized value $g2 in substitution (s///) at - line 29. Use of uninitialized value $g2 in substitution (s///) at - line 29. Use of uninitialized value $g2 in substitution (s///) at - line 30. Use of uninitialized value $g1 in substitution (s///) at - line 30. Use of uninitialized value $g2 in substitution (s///) at - line 30. Use of uninitialized value $g1 in substitution (s///) at - line 30. Use of uninitialized value $m1 in regexp compilation at - line 31. Use of uninitialized value $g2 in substitution (s///) at - line 31. Use of uninitialized value $g2 in substitution (s///) at - line 31. Use of uninitialized value $g1 in substitution iterator at - line 31. Use of uninitialized value in transliteration (tr///) at - line 32. Use of uninitialized value $m1 in regexp compilation at - line 35. Use of uninitialized value $g1 in regexp compilation at - line 36. Use of uninitialized value $m1 in regexp compilation at - line 38. Use of uninitialized value $g1 in substitution (s///) at - line 39. Use of uninitialized value $m1 in regexp compilation at - line 40. Use of uninitialized value $g1 in substitution iterator at - line 40. Use of uninitialized value $m1 in substitution iterator at - line 41. Use of uninitialized value in substitution iterator at - line 44. ######## use warnings 'uninitialized'; my ($m1); { my $foo = "abc"; (substr($foo,0,0)) = ($m1) } EXPECT Use of uninitialized value $m1 in list assignment at - line 4. ######## use warnings 'uninitialized'; our ($g1); study; study $g1; EXPECT Use of uninitialized value $_ in study at - line 4. Use of uninitialized value $g1 in study at - line 5. ######## use warnings 'uninitialized'; my ($m1); pos()=0; pos($m1)=0; EXPECT Use of uninitialized value $_ in scalar assignment at - line 4. Use of uninitialized value $m1 in scalar assignment at - line 5. ######## use warnings 'uninitialized'; my ($m1); our ($g1); $v = pos($m1) + 1; $v = pos($g1) + 1; $m1 = 0; $g1 = ""; $v = pos($m1) + 1; $v = pos($g1) + 1; EXPECT Use of uninitialized value in addition (+) at - line 5. Use of uninitialized value in addition (+) at - line 6. Use of uninitialized value in addition (+) at - line 9. Use of uninitialized value in addition (+) at - line 10. ######## use warnings 'uninitialized'; my ($m1); { my $x = "a" x $m1 } # NB LHS of repeat does not warn { my @x = ("a") x $m1 } EXPECT Use of uninitialized value $m1 in repeat (x) at - line 4. Use of uninitialized value $m1 in repeat (x) at - line 5. ######## use warnings 'uninitialized'; my ($m1, $v); our ($g1); $v = "$m1"; $v = $m1 lt $g1; $v = $m1 le $g1; $v = $m1 gt $g1; $v = $m1 ge $g1; $v = $m1 eq $g1; $v = $m1 ne $g1; $v = $m1 cmp $g1; EXPECT Use of uninitialized value $m1 in string at - line 5. Use of uninitialized value $m1 in string lt at - line 7. Use of uninitialized value $g1 in string lt at - line 7. Use of uninitialized value $m1 in string le at - line 8. Use of uninitialized value $g1 in string le at - line 8. Use of uninitialized value $m1 in string gt at - line 9. Use of uninitialized value $g1 in string gt at - line 9. Use of uninitialized value $m1 in string ge at - line 10. Use of uninitialized value $g1 in string ge at - line 10. Use of uninitialized value $m1 in string eq at - line 11. Use of uninitialized value $g1 in string eq at - line 11. Use of uninitialized value $m1 in string ne at - line 12. Use of uninitialized value $g1 in string ne at - line 12. Use of uninitialized value $m1 in string comparison (cmp) at - line 13. Use of uninitialized value $g1 in string comparison (cmp) at - line 13. ######## use warnings 'uninitialized'; my ($m1, $v); our ($g1); $v = atan2($m1,$g1); $v = sin $m1; $v = cos $m1; $v = rand $m1; $v = srand $m1; $v = exp $m1; $v = eval {log $m1}; $v = sqrt $m1; $v = hex $m1; $v = oct $m1; $v = oct; $v = length; # does not warn EXPECT Use of uninitialized value $g1 in atan2 at - line 5. Use of uninitialized value $m1 in atan2 at - line 5. Use of uninitialized value $m1 in sin at - line 6. Use of uninitialized value $m1 in cos at - line 7. Use of uninitialized value $m1 in rand at - line 8. Use of uninitialized value $m1 in srand at - line 9. Use of uninitialized value $m1 in exp at - line 10. Use of uninitialized value $m1 in log at - line 11. Use of uninitialized value $m1 in sqrt at - line 12. Use of uninitialized value $m1 in hex at - line 13. Use of uninitialized value $m1 in oct at - line 14. Use of uninitialized value $_ in oct at - line 15. ######## use warnings 'uninitialized'; my ($m1, $v); our ($g1); $v = substr $m1, $g1; $v = substr $m1, $g1, $m2; $v = substr $m1, $g1, $m2, $g2; undef $m1; substr($m1, $g1) = $g2; undef $m1; # NB global2 substr($m1, $g1, $m2) = $g2; undef $m1; # isn't identified $v = eval {vec ($m1, $g1, $m2)}; eval {vec ($m1, $g1, $m2) = $g2}; undef $m1; # ditto $v = index $m1, $m2; $v = index $m1, $m2, $g1; $v = rindex $m1, $m2; $v = rindex $m1, $m2, $g1; EXPECT Use of uninitialized value $g1 in substr at - line 5. Use of uninitialized value $m1 in substr at - line 5. Use of uninitialized value $m2 in substr at - line 6. Use of uninitialized value $g1 in substr at - line 6. Use of uninitialized value $m1 in substr at - line 6. Use of uninitialized value $g2 in substr at - line 7. Use of uninitialized value $m2 in substr at - line 7. Use of uninitialized value $g1 in substr at - line 7. Use of uninitialized value $m1 in substr at - line 7. Use of uninitialized value $g1 in substr at - line 8. Use of uninitialized value $m1 in substr at - line 8. Use of uninitialized value in scalar assignment at - line 8. Use of uninitialized value $m2 in substr at - line 9. Use of uninitialized value $g1 in substr at - line 9. Use of uninitialized value $m1 in substr at - line 9. Use of uninitialized value in scalar assignment at - line 9. Use of uninitialized value $m2 in vec at - line 11. Use of uninitialized value $g1 in vec at - line 11. Use of uninitialized value $m1 in vec at - line 11. Use of uninitialized value $m2 in vec at - line 12. Use of uninitialized value $g1 in vec at - line 12. Use of uninitialized value $m1 in vec at - line 12. Use of uninitialized value $m1 in index at - line 14. Use of uninitialized value $m2 in index at - line 14. Use of uninitialized value $g1 in index at - line 15. Use of uninitialized value $m1 in index at - line 15. Use of uninitialized value $m2 in index at - line 15. Use of uninitialized value $m1 in rindex at - line 16. Use of uninitialized value $m2 in rindex at - line 16. Use of uninitialized value $g1 in rindex at - line 17. Use of uninitialized value $m1 in rindex at - line 17. Use of uninitialized value $m2 in rindex at - line 17. ######## use warnings 'uninitialized'; my ($m1, $v); our ($g1); $v = sprintf $m1; $v = sprintf '%d%d%d%d', $m1, $m2, $g1, $g2; my $m3; eval {formline $m3 }; formline '@<<@<<@<<@<<', $m1, $m2, $g1, $g2; EXPECT Use of uninitialized value $m1 in sprintf at - line 5. Use of uninitialized value $m1 in sprintf at - line 6. Use of uninitialized value $m2 in sprintf at - line 6. Use of uninitialized value $g1 in sprintf at - line 6. Use of uninitialized value $g2 in sprintf at - line 6. Use of uninitialized value $m3 in formline at - line 7. Use of uninitialized value $m1 in formline at - line 8. Use of uninitialized value $m2 in formline at - line 8. Use of uninitialized value $g1 in formline at - line 8. Use of uninitialized value $g2 in formline at - line 8. ######## use warnings 'uninitialized'; my ($m1, $v); our ($g1); $v = crypt $m1, $g1; $v = ord; $v = ord $m1; $v = chr; $v = chr $m1; $v = ucfirst; $v = ucfirst $m1; $v = lcfirst; $v = lcfirst $m1; $v = uc; $v = uc $m1; $v = lc; $v = lc $m1; $v = quotemeta; $v = quotemeta $m1; EXPECT Use of uninitialized value $m1 in crypt at - line 5. Use of uninitialized value $g1 in crypt at - line 5. Use of uninitialized value $_ in ord at - line 7. Use of uninitialized value $m1 in ord at - line 8. Use of uninitialized value $_ in chr at - line 9. Use of uninitialized value $m1 in chr at - line 10. Use of uninitialized value $_ in ucfirst at - line 12. Use of uninitialized value $m1 in ucfirst at - line 13. Use of uninitialized value $_ in lcfirst at - line 14. Use of uninitialized value $m1 in lcfirst at - line 15. Use of uninitialized value $_ in uc at - line 16. Use of uninitialized value $m1 in uc at - line 17. Use of uninitialized value $_ in lc at - line 18. Use of uninitialized value $m1 in lc at - line 19. Use of uninitialized value $_ in quotemeta at - line 21. Use of uninitialized value $m1 in quotemeta at - line 22. ######## use warnings 'uninitialized'; my ($m1, $v1, $v2, $v3, $v4); our ($g1); ($v1,$v2,$v3,$v4) = split; ($v1,$v2,$v3,$v4) = split $m1; ($v1,$v2,$v3,$v4) = split $m1, $m2; ($v1,$v2,$v3,$v4) = split $m1, $m2, $g1; $v1 = join $m1; $v2 = join $m1, $m2; $v3 = join $m1, $m2, $m3; EXPECT Use of uninitialized value $_ in split at - line 5. Use of uninitialized value $m1 in regexp compilation at - line 6. Use of uninitialized value $_ in split at - line 6. Use of uninitialized value $m1 in regexp compilation at - line 7. Use of uninitialized value $m2 in split at - line 7. Use of uninitialized value $m1 in regexp compilation at - line 8. Use of uninitialized value $g1 in split at - line 8. Use of uninitialized value $m2 in split at - line 8. Use of uninitialized value $m1 in join or string at - line 10. Use of uninitialized value $m1 in join or string at - line 11. Use of uninitialized value $m2 in join or string at - line 11. Use of uninitialized value $m1 in join or string at - line 12. Use of uninitialized value $m2 in join or string at - line 12. Use of uninitialized value $m3 in join or string at - line 12. ######## use warnings 'uninitialized'; my ($m1, $m2, @ma, $v); our @foo1=(1,undef); chomp @foo1; my @foo2=(1,undef); chomp @foo2; our @foo3=(1,undef); chop @foo3; my @foo4=(1,undef); chop @foo4; our @foo5=(1,undef); $v = sprintf "%s%s",@foo5; my @foo6=(1,undef); $v = sprintf "%s%s",@foo6; our %foo7=('foo'=>'bar','baz'=>undef); $v = sprintf "%s%s",%foo7; my %foo8=('foo'=>'bar','baz'=>undef); $v = sprintf "%s%s",%foo8; our @foo9 =(1,undef); $v = sprintf "%s%s%s%s",$m1,@foo9, $ma[2]; my @foo10=(1,undef); $v = sprintf "%s%s%s%s",$m2,@foo10,$ma[2]; our %foo11=('foo'=>'bar','baz'=>undef); $v = join '', %foo11; my %foo12=('foo'=>'bar','baz'=>undef); $v = join '', %foo12; our %foo13=(1..2000,'foo'=>'bar','baz'=>undef); $v = join '', %foo13; my %foo14=(1..2000,'foo'=>'bar','baz'=>undef); $v = join '', %foo14; EXPECT Use of uninitialized value $foo1[1] in chomp at - line 4. Use of uninitialized value $foo2[1] in chomp at - line 5. Use of uninitialized value $foo3[1] in chop at - line 6. Use of uninitialized value $foo4[1] in chop at - line 7. Use of uninitialized value $foo5[1] in sprintf at - line 8. Use of uninitialized value $foo6[1] in sprintf at - line 9. Use of uninitialized value $foo7{"baz"} in sprintf at - line 10. Use of uninitialized value $foo8{"baz"} in sprintf at - line 11. Use of uninitialized value $m1 in sprintf at - line 12. Use of uninitialized value $foo9[1] in sprintf at - line 12. Use of uninitialized value in sprintf at - line 12. Use of uninitialized value $m2 in sprintf at - line 13. Use of uninitialized value $foo10[1] in sprintf at - line 13. Use of uninitialized value in sprintf at - line 13. Use of uninitialized value $foo11{"baz"} in join or string at - line 14. Use of uninitialized value $foo12{"baz"} in join or string at - line 15. Use of uninitialized value within %foo13 in join or string at - line 16. Use of uninitialized value within %foo14 in join or string at - line 17. ######## use warnings 'uninitialized'; my ($v); undef $^A; $v = $^A + ${^FOO}; # should output '^A' not chr(1) *GLOB1 = *GLOB2; $v = $GLOB1 + 1; $v = $GLOB2 + 1; EXPECT Use of uninitialized value $^FOO in addition (+) at - line 4. Use of uninitialized value $^A in addition (+) at - line 4. Use of uninitialized value $GLOB1 in addition (+) at - line 6. Use of uninitialized value $GLOB2 in addition (+) at - line 7. ######## use warnings 'uninitialized'; my ($v); # check hash key is sanitised my %h = ("\0011\002\r\n\t\f\"\\abcdefghijklmnopqrstuvwxyz", undef); $v = join '', %h; EXPECT Use of uninitialized value $h{"\0011\2\r\n\t\f\"\\abcdefghijklm"...} in join or string at - line 6. ######## use warnings 'uninitialized'; my ($m1, $v); our ($g1); $v = eval { \&$m1 }; $v = eval { \&$g1 }; my @a; @a = splice @a, $m1, $g1; $v = 1 + splice @a, $m1, $g1; my $x = bless [], 'Z'; eval { $x->$m1() }; eval { &$m1() }; eval { &$g1() }; warn $m1,$g1,"foo"; eval { die $m1, $g1 }; reset $m1; reset $g1; EXPECT Use of uninitialized value $m1 in subroutine dereference at - line 5. Use of uninitialized value $g1 in subroutine dereference at - line 6. Use of uninitialized value $m1 in splice at - line 9. Use of uninitialized value $g1 in splice at - line 9. Use of uninitialized value $m1 in splice at - line 10. Use of uninitialized value $g1 in splice at - line 10. Use of uninitialized value in addition (+) at - line 10. Use of uninitialized value $m1 in method lookup at - line 13. Use of uninitialized value in subroutine entry at - line 15. Use of uninitialized value in subroutine entry at - line 16. Use of uninitialized value $m1 in warn at - line 18. Use of uninitialized value $g1 in warn at - line 18. foo at - line 18. Use of uninitialized value $m1 in die at - line 20. Use of uninitialized value $g1 in die at - line 20. Use of uninitialized value $m1 in symbol reset at - line 22. Use of uninitialized value $g1 in symbol reset at - line 23. ######## use warnings 'uninitialized'; my ($m1); our ($g1); open FOO; # accesses $FOO my $foo = 'FO'; open($foo."O"); # accesses $FOO open my $x; # accesses ${*$x} open $foobar; # accesses ${*$foobar} my $y; open $y, $m1; eval { open $y, $m1, $g1 }; open $y, '<', $g1; sysopen $y, $m1, $m2; sysopen $y, $m1, $g1, $m2; my $old = umask; umask $m1; umask $g1; umask $old; binmode STDIN, $m1; EXPECT Use of uninitialized value $FOO in open at - line 5. Use of uninitialized value in open at - line 7. Use of uninitialized value in open at - line 8. Use of uninitialized value in open at - line 9. Use of uninitialized value $m1 in open at - line 11. Use of uninitialized value $m1 in open at - line 12. Use of uninitialized value $g1 in open at - line 13. Use of uninitialized value $m2 in sysopen at - line 15. Use of uninitialized value $m1 in sysopen at - line 15. Use of uninitialized value $m2 in sysopen at - line 16. Use of uninitialized value $g1 in sysopen at - line 16. Use of uninitialized value $m1 in sysopen at - line 16. Use of uninitialized value $m1 in umask at - line 19. Use of uninitialized value $g1 in umask at - line 20. Use of uninitialized value $m1 in binmode at - line 23. ######## use warnings 'uninitialized'; my ($m1); our ($g1); eval { my $x; tie $x, $m1 }; eval { my $x; read $m1, $x, $g1 }; eval { my $x; read $m1, $x, $g1, $g2 }; eval { my $x; sysread $m1, $x, $g1 }; eval { my $x; sysread $m1, $x, $g1, $g2 }; EXPECT Use of uninitialized value $m1 in tie at - line 5. Use of uninitialized value $m1 in ref-to-glob cast at - line 7. Use of uninitialized value $g1 in read at - line 7. Use of uninitialized value $m1 in ref-to-glob cast at - line 8. Use of uninitialized value $g1 in read at - line 8. Use of uninitialized value $g2 in read at - line 8. Use of uninitialized value $m1 in ref-to-glob cast at - line 9. Use of uninitialized value $g1 in sysread at - line 9. Use of uninitialized value $m1 in ref-to-glob cast at - line 10. Use of uninitialized value $g1 in sysread at - line 10. Use of uninitialized value $g2 in sysread at - line 10. ######## use warnings 'uninitialized'; my ($m1); our ($g1, @ga); printf $m1; printf STDERR "%d%d%d%d\n", $m1, $m2, $g1, $g2; printf $ga[1000]; printf STDERR "FOO1:%s\n", $ga[1000]; printf STDERR "FOO2:%s%s%s%s\n", $m1, $g1, $ga[1],$m2; printf STDERR "FOO3:%s%s%s\n", "X", $ga[1],"Y"; EXPECT Use of uninitialized value $m1 in printf at - line 5. Use of uninitialized value $m1 in printf at - line 6. Use of uninitialized value $m2 in printf at - line 6. Use of uninitialized value $g1 in printf at - line 6. Use of uninitialized value $g2 in printf at - line 6. 0000 Use of uninitialized value in printf at - line 7. Use of uninitialized value in printf at - line 8. FOO1: Use of uninitialized value $m1 in printf at - line 9. Use of uninitialized value $g1 in printf at - line 9. Use of uninitialized value in printf at - line 9. Use of uninitialized value $m2 in printf at - line 9. FOO2: Use of uninitialized value in printf at - line 10. FOO3:XY ######## use warnings 'uninitialized'; my ($m1); our ($g1); eval { my $x; seek $x,$m1, $g1 }; eval { my $x; sysseek $x,$m1, $g1 }; eval { syswrite $m1, $g1 }; # logic changed - now won't try $g1 if $m1 is bad # eval { syswrite STDERR, $m1 }; # XXX under utf8, can give # eval { syswrite STDERR, $m1, $g1 }; # XXX different warnings # eval { syswrite STDERR, $m1, $g1, $m2 }; eval { my $x; socket $x, $m1, $g1, $m2 }; eval { my ($x,$y); socketpair $x, $y, $m1, $g1, $m2 }; EXPECT Use of uninitialized value $x in ref-to-glob cast at - line 5. Use of uninitialized value $g1 in seek at - line 5. Use of uninitialized value $m1 in seek at - line 5. Use of uninitialized value $x in ref-to-glob cast at - line 6. Use of uninitialized value $g1 in sysseek at - line 6. Use of uninitialized value $m1 in sysseek at - line 6. Use of uninitialized value $m1 in ref-to-glob cast at - line 7. Use of uninitialized value $m2 in socket at - line 11. Use of uninitialized value $g1 in socket at - line 11. Use of uninitialized value $m1 in socket at - line 11. Use of uninitialized value $m2 in socketpair at - line 12. Use of uninitialized value $g1 in socketpair at - line 12. Use of uninitialized value $m1 in socketpair at - line 12. ######## use Config; BEGIN { if ( !$Config{d_flock} && !$Config{d_fcntl_can_lock} && !$Config{d_lockf} ) { print < 0; $e = !($c == 0)) { # a # few # blank # lines --$d; } EXPECT Use of uninitialized value $c in numeric eq (==) at - line 5. Use of uninitialized value $c in numeric eq (==) at - line 5. Use of uninitialized value $c in numeric eq (==) at - line 14. Use of uninitialized value $c in numeric eq (==) at - line 14. ######## # TODO long standing bug - more general variant of the above problem use warnings; my $undef; my $a = $undef + 1; my $b = $undef + 1; EXPECT Use of uninitialized value $undef in addition (+) at - line 4. Use of uninitialized value $undef in addition (+) at - line 7. ######## use warnings 'uninitialized'; my ($r1, $r2); $_ = undef; $v = reverse; $v = reverse $r1; $v = reverse "abc", $r2, "def"; EXPECT Use of uninitialized value in reverse at - line 4. Use of uninitialized value $r1 in reverse at - line 5. Use of uninitialized value $r2 in reverse at - line 6. ######## use warnings 'uninitialized'; # # ops that can return undef for defined args # split into separate tests to diagnose the cause of daily build smoke # # *** `` not tested: Windows produces an error on STDERR # *** ditto qx() # *** pipe() not tested # *** ioctl not tested # *** socket not tested # *** socketpair not tested # *** bind not tested # *** connect not tested # *** listen not tested # *** shutdown not tested # *** setsockopt not tested # *** getpeername not tested # *** readdir not tested # *** telldir not tested # *** seekdir not tested # *** rewinddir not tested # *** closedir not tested # *** gmtime not tested # *** alarm not tested # *** semget not tested # *** getlogin not tested EXPECT ######## use warnings 'uninitialized'; if ($^O eq 'MSWin32') { print <<'EOM'; SKIPPED # `` produces an error on STDERR on Win32 EOM exit; } my $nocmd = '/no/such/command'; my $v; $v = 1 + `$nocmd`; EXPECT Use of uninitialized value in addition (+) at - line 11. ######## use warnings 'uninitialized'; if ($^O eq 'MSWin32') { print <<'EOM'; SKIPPED # qx produces an error on STDERR on Win32 EOM exit; } my $nocmd = '/no/such/command'; my $v; $v = 1 + qx($nocmd); EXPECT Use of uninitialized value in addition (+) at - line 11. ######## use warnings 'uninitialized'; my $nan = "NaN"; if ($nan == $nan) { print <<'EOM'; SKIPPED # NaN not supported here. EOM exit; } my $v; $v = 1 + ($nan <=> 1); EXPECT Use of uninitialized value in addition (+) at - line 11. ######## use warnings 'uninitialized'; if ($^O eq 'MSWin32') { print <<'EOM'; SKIPPED # -k produces no warning on Win32 EOM exit; } my $nofile = '/no/such/file'; my $v; $v = 1 + -k $nofile; EXPECT Use of uninitialized value in addition (+) at - line 11. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; my $f = ""; $v = 1 + open($f, $nofile); EXPECT Use of uninitialized value in addition (+) at - line 5. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + fileno($nofile); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + binmode($nofile); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + tied($nofile); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + getc($nofile); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + sysread($nofile, my $buf,1); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + eval { send($nofile, $buf,0) }; EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; my $fh = ""; $v = 1 + eval { accept($fh, $nofile) }; EXPECT Use of uninitialized value in addition (+) at - line 5. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + (-r $nofile); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + (-w $nofile); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + (-x $nofile); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + (-o $nofile); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + (-R $nofile); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + (-W $nofile); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + (-X $nofile); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + (-O $nofile); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + (-e $nofile); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + (-z $nofile); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + (-s $nofile); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + (-f $nofile); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + (-d $nofile); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + (-l $nofile); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + (-p $nofile); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + (-S $nofile); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + (-b $nofile); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + (-c $nofile); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + (-t $nofile); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + (-u $nofile); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + (-g $nofile); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + (-T $nofile); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + (-B $nofile); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + (-M $nofile); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + (-A $nofile); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + (-C $nofile); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + eval { readlink $nofile }; EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + opendir($f, $nofile); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + undef; EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; my $x = 1; $v = 1 + undef($x); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $v; my $emptys = ""; $v = 1 + substr($emptys,2,1); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $v; my @emptya; $v = 1 + each @emptya; EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $v; my %emptyh; $v = 1 + each %emptyh; EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $v; my @emptya; $v = 1 + sort @emptya; EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $v; my $zero = 0; $v = 1 + caller($zero); EXPECT Use of uninitialized value in addition (+) at - line 3. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; $v = 1 + do $nofile; EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $v; my $fn = sub {}; $v = 1 + prototype $fn; EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $v; my $fn = sub {}; $v = 1 + (1 ~~ $fn); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $v; my $f = ""; $v = 1 + (print STDIN $f); # print to STDIN returns undef EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $v; my $f = ""; $v = 1 + (printf STDIN "%s", $f); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $v; my $f = ""; { use feature 'say'; $v = 1 + (say STDIN "%s", $f); } EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $v; my $f = ""; $v = 1 + (unpack("",$f)); EXPECT Use of uninitialized value in addition (+) at - line 4. ######## use warnings 'uninitialized'; my $nofile = '/no/such/file'; my $v; my $f = ""; $v = 1 + sysopen($f, $nofile, 0); EXPECT Use of uninitialized value in addition (+) at - line 5. ######## use warnings 'uninitialized'; my $v; { my $x = -1; $v = 1 + sysseek(DATA, $x, 0); } __END__ EXPECT Use of uninitialized value in addition (+) at - line 3. perl-5.12.0-RC0/t/lib/warnings/utf80000444000175000017500000001012711325127001015570 0ustar jessejesse utf8.c AOK [utf8_to_uv] Malformed UTF-8 character my $a = ord "\x80" ; Malformed UTF-8 character my $a = ord "\xf080" ; <<<<<< this warning can't be easily triggered from perl anymore [utf16_to_utf8] Malformed UTF-16 surrogate <<<<<< Add a test when somethig actually calls utf16_to_utf8 __END__ # utf8.c [utf8_to_uv] -W BEGIN { if (ord('A') == 193) { print "SKIPPED\n# ebcdic platforms do not generate Malformed UTF-8 warnings."; exit 0; } } use utf8 ; my $a = "snøstorm" ; { no warnings 'utf8' ; my $a = "snøstorm"; use warnings 'utf8' ; my $a = "snøstorm"; } EXPECT Malformed UTF-8 character (unexpected non-continuation byte 0x73, immediately after start byte 0xf8) at - line 9. Malformed UTF-8 character (unexpected non-continuation byte 0x73, immediately after start byte 0xf8) at - line 14. ######## use warnings 'utf8'; my $d7ff = chr(0xD7FF); my $d800 = chr(0xD800); my $dfff = chr(0xDFFF); my $e000 = chr(0xE000); my $feff = chr(0xFEFF); my $fffd = chr(0xFFFD); my $fffe = chr(0xFFFE); my $ffff = chr(0xFFFF); my $hex4 = chr(0x10000); my $hex5 = chr(0x100000); my $maxm1 = chr(0x10FFFE); my $max = chr(0x10FFFF); no warnings 'utf8'; my $d7ff = chr(0xD7FF); my $d800 = chr(0xD800); my $dfff = chr(0xDFFF); my $e000 = chr(0xE000); my $feff = chr(0xFEFF); my $fffd = chr(0xFFFD); my $fffe = chr(0xFFFE); my $ffff = chr(0xFFFF); my $hex4 = chr(0x10000); my $hex5 = chr(0x100000); my $maxm1 = chr(0x10FFFE); my $max = chr(0x10FFFF); EXPECT UTF-16 surrogate 0xd800 at - line 3. UTF-16 surrogate 0xdfff at - line 4. Unicode non-character 0xfffe is illegal for interchange at - line 8. Unicode non-character 0xffff is illegal for interchange at - line 9. Unicode non-character 0x10fffe is illegal for interchange at - line 12. Unicode non-character 0x10ffff is illegal for interchange at - line 13. ######## use warnings 'utf8'; my $d7ff = pack("U", 0xD7FF); my $d800 = pack("U", 0xD800); my $dfff = pack("U", 0xDFFF); my $e000 = pack("U", 0xE000); my $feff = pack("U", 0xFEFF); my $fffd = pack("U", 0xFFFD); my $fffe = pack("U", 0xFFFE); my $ffff = pack("U", 0xFFFF); my $hex4 = pack("U", 0x10000); my $hex5 = pack("U", 0x100000); my $maxm1 = pack("U", 0x10FFFE); my $max = pack("U", 0x10FFFF); no warnings 'utf8'; my $d7ff = pack("U", 0xD7FF); my $d800 = pack("U", 0xD800); my $dfff = pack("U", 0xDFFF); my $e000 = pack("U", 0xE000); my $feff = pack("U", 0xFEFF); my $fffd = pack("U", 0xFFFD); my $fffe = pack("U", 0xFFFE); my $ffff = pack("U", 0xFFFF); my $hex4 = pack("U", 0x10000); my $hex5 = pack("U", 0x100000); my $maxm1 = pack("U", 0x10FFFE); my $max = pack("U", 0x10FFFF); EXPECT UTF-16 surrogate 0xd800 at - line 3. UTF-16 surrogate 0xdfff at - line 4. Unicode non-character 0xfffe is illegal for interchange at - line 8. Unicode non-character 0xffff is illegal for interchange at - line 9. Unicode non-character 0x10fffe is illegal for interchange at - line 12. Unicode non-character 0x10ffff is illegal for interchange at - line 13. ######## use warnings 'utf8'; my $d7ff = "\x{D7FF}"; my $d800 = "\x{D800}"; my $dfff = "\x{DFFF}"; my $e000 = "\x{E000}"; my $feff = "\x{FEFF}"; my $fffd = "\x{FFFD}"; my $fffe = "\x{FFFE}"; my $ffff = "\x{FFFF}"; my $hex4 = "\x{10000}"; my $hex5 = "\x{100000}"; my $maxm1 = "\x{10FFFE}"; my $max = "\x{10FFFF}"; uc($ffff); no warnings 'utf8'; my $d7ff = "\x{D7FF}"; my $d800 = "\x{D800}"; my $dfff = "\x{DFFF}"; my $e000 = "\x{E000}"; my $feff = "\x{FEFF}"; my $fffd = "\x{FFFD}"; my $fffe = "\x{FFFE}"; my $ffff = "\x{FFFF}"; my $hex4 = "\x{10000}"; my $hex5 = "\x{100000}"; my $maxm1 = "\x{10FFFE}"; my $max = "\x{10FFFF}"; uc($ffff); EXPECT UTF-16 surrogate 0xd800 at - line 3. UTF-16 surrogate 0xdfff at - line 4. Unicode non-character 0xfffe is illegal for interchange at - line 8. Unicode non-character 0xffff is illegal for interchange at - line 9. Unicode non-character 0x10fffe is illegal for interchange at - line 12. Unicode non-character 0x10ffff is illegal for interchange at - line 13. Unicode non-character 0xffff is illegal for interchange in uc at - line 14. perl-5.12.0-RC0/t/lib/warnings/doio0000444000175000017500000001415511325127001015641 0ustar jessejesse doio.c Can't open bidirectional pipe [Perl_do_open9] open(F, "| true |"); Missing command in piped open [Perl_do_open9] open(F, "| "); Missing command in piped open [Perl_do_open9] open(F, " |"); warn(warn_nl, "open"); [Perl_do_open9] open(F, "true\ncd") close() on unopened filehandle %s [Perl_do_close] $a = "fred";close("$a") tell() on closed filehandle [Perl_do_tell] $a = "fred";$a = tell($a) seek() on closed filehandle [Perl_do_seek] $a = "fred";$a = seek($a,1,1) sysseek() on closed filehandle [Perl_do_sysseek] $a = "fred";$a = seek($a,1,1) warn(warn_uninit); [Perl_do_print] print $a ; -x on closed filehandle %s [Perl_my_stat] close STDIN ; -x STDIN ; warn(warn_nl, "stat"); [Perl_my_stat] stat "ab\ncd" warn(warn_nl, "lstat"); [Perl_my_lstat] lstat "ab\ncd" Use of -l on filehandle %s [Perl_my_lstat] Can't exec \"%s\": %s [Perl_do_aexec5] Can't exec \"%s\": %s [Perl_do_exec3] Filehandle %s opened only for output [Perl_do_eof] my $a = eof STDOUT Mandatory Warnings ALL TODO ------------------ Can't do inplace edit: %s is not a regular file [Perl_nextargv] edit a directory Can't do inplace edit: %s would not be unique [Perl_nextargv] Can't rename %s to %s: %s, skipping file [Perl_nextargv] Can't rename %s to %s: %s, skipping file [Perl_nextargv] Can't remove %s: %s, skipping file [Perl_nextargv] Can't do inplace edit on %s: %s [Perl_nextargv] __END__ # doio.c [Perl_do_open9] use warnings 'io' ; open(F, '|'."$^X -e 1|"); close(F); no warnings 'io' ; open(G, '|'."$^X -e 1|"); close(G); EXPECT Can't open bidirectional pipe at - line 3. ######## # doio.c [Perl_do_open9] use warnings 'io' ; open(F, "| "); no warnings 'io' ; open(G, "| "); EXPECT Missing command in piped open at - line 3. ######## # doio.c [Perl_do_open9] use warnings 'io' ; open(F, " |"); no warnings 'io' ; open(G, " |"); EXPECT Missing command in piped open at - line 3. ######## # doio.c [Perl_do_open9] use warnings 'io' ; open(F, " ; } { no warnings 'inplace' ; local (@ARGV) = ($filename) ; local ($^I) = "" ; my $x = <> ; } { use warnings 'inplace' ; local (@ARGV) = ($filename) ; local ($^I) = "" ; my $x = <> ; } rmdir $filename ; EXPECT Can't do inplace edit: ./temp.dir is not a regular file at - line 9. Can't do inplace edit: ./temp.dir is not a regular file at - line 21. ######## # doio.c [Perl_do_eof] use warnings 'io' ; my $a = eof STDOUT ; no warnings 'io' ; $a = eof STDOUT ; EXPECT Filehandle STDOUT opened only for output at - line 3. ######## # doio.c [Perl_do_openn] use Config; BEGIN { if ($Config{useperlio}) { print <', \$x; open BAR, '>&', \*STDOUT; # should not warn no warnings 'io'; open FOO, '>', \$x; EXPECT Can't open a reference at - line 14. ######## # doio.c [Perl_do_openn] use Config; BEGIN { if (!$Config{useperlio}) { print <doiowarn.tmp"; close $fh1; no warnings 'io' ; open my $fh2, ">doiowarn.tmp"; close $fh2; unlink "doiowarn.tmp"; EXPECT Filehandle STDIN reopened as $fh1 only for output at - line 14. perl-5.12.0-RC0/t/lib/proxy_constant_subs.t0000555000175000017500000000212411325127001017443 0ustar jessejessemy @symbols; BEGIN { require Config; if (($Config::Config{'extensions'} !~ /\bB\b/) ){ print "1..0 # Skip -- Perl configured without B module\n"; exit 0; } if ($Config::Config{'extensions'} !~ /\bFcntl\b/) { print "1..0 # Skip -- Perl configured without Fcntl\n"; exit 0; } # S_IFMT is a real subroutine, and acts as control # SEEK_SET is a proxy constant subroutine. @symbols = qw(S_IFMT SEEK_SET); require './test.pl'; } use strict; use warnings; plan(4 * @symbols); use B qw(svref_2object GVf_IMPORTED_CV); use Fcntl @symbols; # GVf_IMPORTED_CV should not be set on the original, but should be set on the # imported GV. foreach my $symbol (@symbols) { my ($ps, $ms); { no strict 'refs'; $ps = svref_2object(\*{"Fcntl::$symbol"}); $ms = svref_2object(\*{"::$symbol"}); } isa_ok($ps, 'B::GV'); is($ps->GvFLAGS() & GVf_IMPORTED_CV, 0, "GVf_IMPORTED_CV not set on original"); isa_ok($ms, 'B::GV'); is($ms->GvFLAGS() & GVf_IMPORTED_CV, GVf_IMPORTED_CV, "GVf_IMPORTED_CV set on imported GV"); } perl-5.12.0-RC0/t/lib/commonsense.t0000555000175000017500000000103011325125742015650 0ustar jessejesse#!./perl chdir 't' if -d 't'; @INC = '../lib'; require Config; import Config; if (($Config{'extensions'} !~ /\bFcntl\b/) ){ print "Bail out! Perl configured without Fcntl module\n"; exit 0; } if (($Config{'extensions'} !~ /\bIO\b/) ){ print "Bail out! Perl configured without IO module\n"; exit 0; } # hey, DOS users do not need this kind of common sense ;-) if ($^O ne 'dos' && ($Config{'extensions'} !~ /\bFile\/Glob\b/) ){ print "Bail out! Perl configured without File::Glob module\n"; exit 0; } print "1..1\nok 1\n"; perl-5.12.0-RC0/t/lib/Sans_mypragma.pm0000444000175000017500000000011011325125742016267 0ustar jessejessepackage Sans_mypragma; sub affected { mypragma::in_effect(); } 1; perl-5.12.0-RC0/t/lib/common.pl0000444000175000017500000001206711325127001014761 0ustar jessejesse# This code is used by lib/warnings.t and lib/feature.t BEGIN { require './test.pl'; } use Config; use File::Path; use File::Spec::Functions; use strict; use warnings; our $pragma_name; $| = 1; my $tmpfile = tempfile(); my @prgs = () ; my @w_files = () ; if (@ARGV) { print "ARGV = [@ARGV]\n" ; @w_files = map { s#^#./lib/$pragma_name/#; $_ } @ARGV } else { @w_files = sort glob(catfile(curdir(), "lib", $pragma_name, "*")) } my $files = 0; foreach my $file (@w_files) { next if $file =~ /(~|\.orig|,v)$/; next if $file =~ /perlio$/ && !(find PerlIO::Layer 'perlio'); next if -d $file; open F, "<$file" or die "Cannot open $file: $!\n" ; my $line = 0; while () { $line++; last if /^__END__/ ; } { local $/ = undef; $files++; @prgs = (@prgs, $file, split "\n########\n", ) ; } close F ; } undef $/; plan tests => (scalar(@prgs)-$files); for (@prgs){ unless (/\n/) { print "# From $_\n"; next; } my $switch = ""; my @temps = () ; my @temp_path = () ; if (s/^\s*-\w+//){ $switch = $&; } my($prog,$expected) = split(/\nEXPECT(?:\n|$)/, $_, 2); my %reason; foreach my $what (qw(skip todo)) { $prog =~ s/^#\s*\U$what\E\s*(.*)\n//m and $reason{$what} = $1; # If the SKIP reason starts ? then it's taken as a code snippet to # evaluate. This provides the flexibility to have conditional SKIPs if ($reason{$what} && $reason{$what} =~ s/^\?//) { my $temp = eval $reason{$what}; if ($@) { die "# In \U$what\E code reason:\n# $reason{$what}\n$@"; } $reason{$what} = $temp; } } if ( $prog =~ /--FILE--/) { my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ; shift @files ; die "Internal error: test $_ didn't split into pairs, got " . scalar(@files) . "[" . join("%%%%", @files) ."]\n" if @files % 2 ; while (@files > 2) { my $filename = shift @files ; my $code = shift @files ; push @temps, $filename ; if ($filename =~ m#(.*)/#) { mkpath($1); push(@temp_path, $1); } open F, ">$filename" or die "Cannot open $filename: $!\n" ; print F $code ; close F or die "Cannot close $filename: $!\n"; } shift @files ; $prog = shift @files ; } open TEST, ">$tmpfile" or die "Cannot open >$tmpfile: $!"; print TEST q{ BEGIN { open(STDERR, ">&STDOUT") or die "Can't dup STDOUT->STDERR: $!;"; } }; print TEST "\n#line 1\n"; # So the line numbers don't get messed up. print TEST $prog,"\n"; close TEST or die "Cannot close $tmpfile: $!"; my $results = runperl( switches => [$switch], stderr => 1, progfile => $tmpfile ); my $status = $?; $results =~ s/\n+$//; # allow expected output to be written as if $prog is on STDIN $results =~ s/$::tempfile_regexp/-/g; if ($^O eq 'VMS') { # some tests will trigger VMS messages that won't be expected $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//; # pipes double these sometimes $results =~ s/\n\n/\n/g; } # bison says 'parse error' instead of 'syntax error', # various yaccs may or may not capitalize 'syntax'. $results =~ s/^(syntax|parse) error/syntax error/mig; # allow all tests to run when there are leaks $results =~ s/Scalars leaked: \d+\n//g; $expected =~ s/\n+$//; my $prefix = ($results =~ s#^PREFIX(\n|$)##) ; # any special options? (OPTIONS foo bar zap) my $option_regex = 0; my $option_random = 0; if ($expected =~ s/^OPTIONS? (.+)\n//) { foreach my $option (split(' ', $1)) { if ($option eq 'regex') { # allow regular expressions $option_regex = 1; } elsif ($option eq 'random') { # all lines match, but in any order $option_random = 1; } else { die "$0: Unknown OPTION '$option'\n"; } } } die "$0: can't have OPTION regex and random\n" if $option_regex + $option_random > 1; my $ok = 0; if ($results =~ s/^SKIPPED\n//) { print "$results\n" ; $ok = 1; } elsif ($option_random) { $ok = randomMatch($results, $expected); } elsif ($option_regex) { $ok = $results =~ /^$expected/; } elsif ($prefix) { $ok = $results =~ /^\Q$expected/; } else { $ok = $results eq $expected; } local $::TODO = $reason{todo}; print_err_line( $switch, $prog, $expected, $results, $::TODO ) unless $ok; ok($ok); foreach (@temps) { unlink $_ if $_ } foreach (@temp_path) { rmtree $_ if -d $_ } } sub randomMatch { my $got = shift ; my $expected = shift; my @got = sort split "\n", $got ; my @expected = sort split "\n", $expected ; return "@got" eq "@expected"; } sub print_err_line { my($switch, $prog, $expected, $results, $todo) = @_; my $err_line = "PROG: $switch\n$prog\n" . "EXPECTED:\n$expected\n" . "GOT:\n$results\n"; if ($todo) { $err_line =~ s/^/# /mg; print $err_line; # Harness can't filter it out from STDERR. } else { print STDERR $err_line; } return 1; } 1; perl-5.12.0-RC0/t/lib/feature/0000755000175000017500000000000011351321566014576 5ustar jessejesseperl-5.12.0-RC0/t/lib/feature/implicit0000444000175000017500000000206011325125742016326 0ustar jessejesseCheck implicit loading of features with use VERSION. __END__ # Standard feature bundle use feature ":5.10"; say "Hello", "world"; EXPECT Helloworld ######## # VERSION requirement, dotted notation use 5.9.5; say "Hello", "world"; EXPECT Helloworld ######## # VERSION requirement, v-dotted notation use v5.9.5; say "Hello", "world"; EXPECT Helloworld ######## # VERSION requirement, decimal notation use 5.009005; say defined $INC{"feature.pm"} ? "Helloworld" : "Good bye"; EXPECT Helloworld ######## # VERSION requirement, doesn't load anything for < 5.9.5 use 5.8.8; print "<".$INC{"feature.pm"}.">\n"; EXPECT <> ######## # VERSION requirement, doesn't load anything with require require 5.9.5; print "<".$INC{"feature.pm"}.">\n"; EXPECT <> ######## # VERSION requirement in eval {} eval { use 5.9.5; say "Hello", "world"; } EXPECT Helloworld ######## # VERSION requirement in eval "" eval q{ use 5.9.5; say "Hello", "world"; } EXPECT Helloworld ######## # VERSION requirement in BEGIN BEGIN { use 5.9.5; say "Hello", "world"; } EXPECT Helloworld perl-5.12.0-RC0/t/lib/feature/say0000444000175000017500000000354611325125742015322 0ustar jessejesseCheck the lexical scoping of the say keyword. (The actual behaviour is tested in t/op/say.t) __END__ # No say; should be a syntax error. use warnings; say "Hello", "world"; EXPECT Unquoted string "say" may clash with future reserved word at - line 3. String found where operator expected at - line 3, near "say "Hello"" (Do you need to predeclare say?) syntax error at - line 3, near "say "Hello"" Execution of - aborted due to compilation errors. ######## # With say, should work use warnings; use feature "say"; say "Hello", "world"; EXPECT Helloworld ######## # With say, should work in eval too use warnings; use feature "say"; eval q(say "Hello", "world"); EXPECT Helloworld ######## # feature out of scope; should be a syntax error. use warnings; { use feature 'say'; } say "Hello", "world"; EXPECT Unquoted string "say" may clash with future reserved word at - line 4. String found where operator expected at - line 4, near "say "Hello"" (Do you need to predeclare say?) syntax error at - line 4, near "say "Hello"" Execution of - aborted due to compilation errors. ######## # 'no feature' should work use warnings; use feature 'say'; say "Hello", "world"; no feature; say "Hello", "world"; EXPECT Unquoted string "say" may clash with future reserved word at - line 6. String found where operator expected at - line 6, near "say "Hello"" (Do you need to predeclare say?) syntax error at - line 6, near "say "Hello"" Execution of - aborted due to compilation errors. ######## # 'no feature "say"' should work too use warnings; use feature 'say'; say "Hello", "world"; no feature 'say'; say "Hello", "world"; EXPECT Unquoted string "say" may clash with future reserved word at - line 6. String found where operator expected at - line 6, near "say "Hello"" (Do you need to predeclare say?) syntax error at - line 6, near "say "Hello"" Execution of - aborted due to compilation errors. perl-5.12.0-RC0/t/lib/feature/bundle0000444000175000017500000000234411325127001015760 0ustar jessejesseCheck feature bundles. __END__ # Standard feature bundle use feature ":5.10"; say "Hello", "world"; EXPECT Helloworld ######## # Standard feature bundle, no 5.11 use feature ":5.10"; say ord uc chr 233; EXPECT 233 ######## # Standard feature bundle, 5.11 use feature ":5.11"; say ord uc chr 233; EXPECT 201 ######## # Standard feature bundle, 5.11 use feature ":5.11"; use utf8; say ord "\ué"; # this is utf8 EXPECT 201 ######## # more specific: 5.10.0 maps to 5.10 use feature ":5.10.0"; say "Hello", "world"; EXPECT Helloworld ######## # as does 5.10.1 use feature ":5.10.1"; say "Hello", "world"; EXPECT Helloworld ######## # as does 5.10.99 use feature ":5.10.99"; say "Hello", "world"; EXPECT Helloworld ######## # 5.9.5 also supported use feature ":5.9.5"; say "Hello", "world"; EXPECT Helloworld ######## # 5.9 not supported use feature ":5.9"; EXPECT OPTIONS regex ^Feature bundle "5.9" is not supported by Perl \d+\.\d+\.\d+ at - line \d+ ######## # 5.9.4 not supported use feature ":5.9.4"; EXPECT OPTIONS regex ^Feature bundle "5.9.4" is not supported by Perl \d+\.\d+\.\d+ at - line \d+ ######## # 5.8.8 not supported use feature ":5.8.8"; EXPECT OPTIONS regex ^Feature bundle "5.8.8" is not supported by Perl \d+\.\d+\.\d+ at - line \d+ perl-5.12.0-RC0/t/lib/feature/switch0000444000175000017500000000733511325125742016027 0ustar jessejesseCheck the lexical scoping of the switch keywords. (The actual behaviour is tested in t/op/switch.t) __END__ # No switch; given should be a bareword. use warnings; print STDOUT given; EXPECT Unquoted string "given" may clash with future reserved word at - line 3. given ######## # No switch; when should be a bareword. use warnings; print STDOUT when; EXPECT Unquoted string "when" may clash with future reserved word at - line 3. when ######## # No switch; default should be a bareword. use warnings; print STDOUT default; EXPECT Unquoted string "default" may clash with future reserved word at - line 3. default ######## # No switch; break should be a bareword. use warnings; print STDOUT break; EXPECT Unquoted string "break" may clash with future reserved word at - line 3. break ######## # No switch; but continue is still a keyword print STDOUT continue; EXPECT syntax error at - line 2, near "STDOUT continue" Execution of - aborted due to compilation errors. ######## # Use switch; so given is a keyword use feature 'switch'; given("okay\n") { print } EXPECT okay ######## # Use switch; so when is a keyword use feature 'switch'; given(1) { when(1) { print "okay" } } EXPECT okay ######## # Use switch; so default is a keyword use feature 'switch'; given(1) { default { print "okay" } } EXPECT okay ######## # Use switch; so break is a keyword use feature 'switch'; break; EXPECT Can't "break" outside a given block at - line 3. ######## # Use switch; so continue is a keyword use feature 'switch'; continue; EXPECT Can't "continue" outside a when block at - line 3. ######## # switch out of scope; given should be a bareword. use warnings; { use feature 'switch'; given (1) {print "Okay here\n";} } print STDOUT given; EXPECT Unquoted string "given" may clash with future reserved word at - line 6. Okay here given ######## # switch out of scope; when should be a bareword. use warnings; { use feature 'switch'; given (1) { when(1) {print "Okay here\n";} } } print STDOUT when; EXPECT Unquoted string "when" may clash with future reserved word at - line 6. Okay here when ######## # switch out of scope; default should be a bareword. use warnings; { use feature 'switch'; given (1) { default {print "Okay here\n";} } } print STDOUT default; EXPECT Unquoted string "default" may clash with future reserved word at - line 6. Okay here default ######## # switch out of scope; break should be a bareword. use warnings; { use feature 'switch'; given (1) { break } } print STDOUT break; EXPECT Unquoted string "break" may clash with future reserved word at - line 6. break ######## # switch out of scope; continue should not work { use feature 'switch'; given (1) { default {continue} } } print STDOUT continue; EXPECT syntax error at - line 5, near "STDOUT continue" Execution of - aborted due to compilation errors. ######## # C should work use warnings; use feature 'switch'; given (1) { when(1) {print "Okay here\n";} } no feature 'switch'; print STDOUT when; EXPECT Unquoted string "when" may clash with future reserved word at - line 6. Okay here when ######## # C should work too use warnings; use feature 'switch'; given (1) { when(1) {print "Okay here\n";} } no feature; print STDOUT when; EXPECT Unquoted string "when" may clash with future reserved word at - line 6. Okay here when ######## # Without the feature, no 'Unambiguous use of' warning: use warnings; @break = ($break = "break"); print ${break}, ${break[0]}; EXPECT breakbreak ######## # With the feature, we get an 'Unambiguous use of' warning: use warnings; use feature 'switch'; @break = ($break = "break"); print ${break}, ${break[0]}; EXPECT Ambiguous use of ${break} resolved to $break at - line 5. Ambiguous use of ${break[...]} resolved to $break[...] at - line 5. breakbreak perl-5.12.0-RC0/t/lib/feature/nonesuch0000444000175000017500000000104011325125742016333 0ustar jessejesseTest that non-existent features fail as expected. __END__ use feature "nonesuch"; EXPECT OPTIONS regex ^Feature "nonesuch" is not supported by Perl [v0-9.]+ at - line 1 ######## no feature "nonesuch"; EXPECT OPTIONS regex ^Feature "nonesuch" is not supported by Perl [v0-9.]+ at - line 1 ######## use feature ":nonesuch"; EXPECT OPTIONS regex ^Feature bundle "nonesuch" is not supported by Perl [v0-9.]+ at - line 1 ######## no feature ":nonesuch"; EXPECT OPTIONS regex ^Feature bundle "nonesuch" is not supported by Perl [v0-9.]+ at - line 1 perl-5.12.0-RC0/t/lib/croak.t0000555000175000017500000000117711325125742014435 0ustar jessejesse#!./perl # So far, it seems, there is no place to test all the Perl_croak() calls in the # C code. So this is a start. It's likely that it needs refactoring to be data # driven. Data driven code exists in various other tests - best plan would be to # investigate whether any common code library already exists, and if not, # refactor the "donor" test code into a common code library. BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; plan( tests => 1 ); } use strict; fresh_perl_is(<<'EOF', 'No such hook: _HUNGRY at - line 1.', {}, 'Perl_magic_setsig'); $SIG{_HUNGRY} = \&mmm_pie; warn "Mmm, pie"; EOF perl-5.12.0-RC0/t/lib/strict/0000755000175000017500000000000011351321566014453 5ustar jessejesseperl-5.12.0-RC0/t/lib/strict/subs0000444000175000017500000002074111325127001015341 0ustar jessejesseCheck strict subs functionality __END__ # no strict, should build & run ok. Fred ; my $fred ; $b = "fred" ; $a = $$b ; EXPECT ######## use strict qw(refs vars); Fred ; EXPECT ######## use strict ; no strict 'subs' ; Fred ; EXPECT ######## # strict subs - error use strict 'subs' ; my @a = (1..2); my $b = xyz; EXPECT Bareword "xyz" not allowed while "strict subs" in use at - line 5. Execution of - aborted due to compilation errors. ######## # strict subs - error use strict 'subs' ; Fred ; EXPECT Bareword "Fred" not allowed while "strict subs" in use at - line 4. Execution of - aborted due to compilation errors. ######## # strict subs - error use strict 'subs' ; my @a = (A..Z); EXPECT Bareword "Z" not allowed while "strict subs" in use at - line 4. Bareword "A" not allowed while "strict subs" in use at - line 4. Execution of - aborted due to compilation errors. ######## # strict subs - error use strict 'subs' ; my $a = (B..Y); EXPECT Bareword "Y" not allowed while "strict subs" in use at - line 4. Bareword "B" not allowed while "strict subs" in use at - line 4. Execution of - aborted due to compilation errors. ######## # strict subs - error use strict ; Fred ; EXPECT Bareword "Fred" not allowed while "strict subs" in use at - line 4. Execution of - aborted due to compilation errors. ######## # strict subs - no error use strict 'subs' ; sub Fred {} Fred ; EXPECT ######## # Check compile time scope of strict subs pragma use strict 'subs' ; { no strict ; my $a = Fred ; } my $a = Fred ; EXPECT Bareword "Fred" not allowed while "strict subs" in use at - line 8. Execution of - aborted due to compilation errors. ######## # Check compile time scope of strict subs pragma no strict; { use strict 'subs' ; my $a = Fred ; } my $a = Fred ; EXPECT Bareword "Fred" not allowed while "strict subs" in use at - line 6. Execution of - aborted due to compilation errors. ######## # Check compile time scope of strict vars pragma use strict 'vars' ; { no strict ; $joe = 1 ; } $joe = 1 ; EXPECT Variable "$joe" is not imported at - line 8. Global symbol "$joe" requires explicit package name at - line 8. Execution of - aborted due to compilation errors. ######## # Check compile time scope of strict vars pragma no strict; { use strict 'vars' ; $joe = 1 ; } $joe = 1 ; EXPECT Global symbol "$joe" requires explicit package name at - line 6. Execution of - aborted due to compilation errors. ######## # Check runtime scope of strict refs pragma use strict 'refs'; my $fred ; my $b = "fred" ; { no strict ; my $a = $$b ; } my $a = $$b ; EXPECT Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 10. ######## # Check runtime scope of strict refs pragma no strict ; my $fred ; my $b = "fred" ; { use strict 'refs' ; my $a = $$b ; } my $a = $$b ; EXPECT Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8. ######## # Check runtime scope of strict refs pragma no strict ; my $fred ; my $b = "fred" ; { use strict 'refs' ; $a = sub { my $c = $$b ; } } &$a ; EXPECT Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8. ######## use strict 'subs' ; my $a = Fred ; EXPECT Bareword "Fred" not allowed while "strict subs" in use at - line 3. Execution of - aborted due to compilation errors. ######## --FILE-- abc my $a = Fred ; 1; --FILE-- use strict 'subs' ; require "./abc"; EXPECT ######## --FILE-- abc use strict 'subs' ; 1; --FILE-- require "./abc"; my $a = Fred ; EXPECT ######## --FILE-- abc use strict 'subs' ; my $a = Fred ; 1; --FILE-- Fred ; require "./abc"; EXPECT Bareword "Fred" not allowed while "strict subs" in use at ./abc line 2. Compilation failed in require at - line 2. ######## --FILE-- abc.pm use strict 'subs' ; my $a = Fred ; 1; --FILE-- Fred ; use abc; EXPECT Bareword "Fred" not allowed while "strict subs" in use at abc.pm line 2. Compilation failed in require at - line 2. BEGIN failed--compilation aborted at - line 2. ######## # Check scope of pragma with eval no strict ; eval { my $a = Fred ; }; print STDERR $@; my $a = Fred ; EXPECT ######## # Check scope of pragma with eval no strict ; eval { use strict 'subs' ; my $a = Fred ; }; print STDERR $@; my $a = Fred ; EXPECT Bareword "Fred" not allowed while "strict subs" in use at - line 6. Execution of - aborted due to compilation errors. ######## # Check scope of pragma with eval use strict 'subs' ; eval { my $a = Fred ; }; print STDERR $@; my $a = Fred ; EXPECT Bareword "Fred" not allowed while "strict subs" in use at - line 5. Bareword "Fred" not allowed while "strict subs" in use at - line 8. Execution of - aborted due to compilation errors. ######## # Check scope of pragma with eval use strict 'subs' ; eval { no strict ; my $a = Fred ; }; print STDERR $@; my $a = Fred ; EXPECT Bareword "Fred" not allowed while "strict subs" in use at - line 9. Execution of - aborted due to compilation errors. ######## # Check scope of pragma with eval no strict ; eval ' Fred ; '; print STDERR $@ ; Fred ; EXPECT ######## # Check scope of pragma with eval no strict ; eval q[ use strict 'subs' ; Fred ; ]; print STDERR $@; EXPECT Bareword "Fred" not allowed while "strict subs" in use at (eval 1) line 3. ######## # Check scope of pragma with eval use strict 'subs' ; eval ' Fred ; '; print STDERR $@ ; EXPECT Bareword "Fred" not allowed while "strict subs" in use at (eval 1) line 2. ######## # Check scope of pragma with eval use strict 'subs' ; eval ' no strict ; my $a = Fred ; '; print STDERR $@; my $a = Fred ; EXPECT Bareword "Fred" not allowed while "strict subs" in use at - line 8. Execution of - aborted due to compilation errors. ######## # see if Foo->Bar(...) etc work under strictures use strict; package Foo; sub Bar { print "@_\n" } Foo->Bar('a',1); Bar Foo ('b',2); Foo->Bar(qw/c 3/); Bar Foo (qw/d 4/); Foo::->Bar('A',1); Bar Foo:: ('B',2); Foo::->Bar(qw/C 3/); Bar Foo:: (qw/D 4/); EXPECT Foo a 1 Foo b 2 Foo c 3 Foo d 4 Foo A 1 Foo B 2 Foo C 3 Foo D 4 ######## # Check that barewords on the RHS of a regex match are caught use strict; "" =~ foo; EXPECT Bareword "foo" not allowed while "strict subs" in use at - line 4. Execution of - aborted due to compilation errors. ######## # ID 20020703.002 use strict; use warnings; my $abc = XYZ ? 1 : 0; print "$abc\n"; EXPECT Bareword "XYZ" not allowed while "strict subs" in use at - line 5. Execution of - aborted due to compilation errors. ######## # [perl #10021] use strict; use warnings; print "" if BAREWORD; EXPECT Bareword "BAREWORD" not allowed while "strict subs" in use at - line 5. Execution of - aborted due to compilation errors. ######## # Ticket: 18927 use strict 'subs'; print 1..1, bad; EXPECT Bareword "bad" not allowed while "strict subs" in use at - line 3. Execution of - aborted due to compilation errors. ######## eval q{ use strict; no strict refs; }; print $@; EXPECT Bareword "refs" not allowed while "strict subs" in use at (eval 1) line 1. ######## # [perl #25147] use strict; print "" if BAREWORD; EXPECT Bareword "BAREWORD" not allowed while "strict subs" in use at - line 3. Execution of - aborted due to compilation errors. ######## # [perl #26910] hints not propagated into (?{...}) use strict 'subs'; qr/(?{my $x=foo})/; EXPECT Bareword "foo" not allowed while "strict subs" in use at (re_eval 1) line 1. Compilation failed in regexp at - line 3. ######## # [perl #27628] strict 'subs' didn't warn on bareword array index use strict 'subs'; my $x=$a[FOO]; EXPECT Bareword "FOO" not allowed while "strict subs" in use at - line 3. Execution of - aborted due to compilation errors. ######## use strict 'subs'; my @a;my $x=$a[FOO]; EXPECT Bareword "FOO" not allowed while "strict subs" in use at - line 2. Execution of - aborted due to compilation errors. ######## # [perl #53806] No complain about bareword use strict 'subs'; print FOO . "\n"; EXPECT Bareword "FOO" not allowed while "strict subs" in use at - line 3. Execution of - aborted due to compilation errors. ######## # [perl #53806] No complain about bareword use strict 'subs'; $ENV{PATH} = ""; system(FOO . "\n"); EXPECT Bareword "FOO" not allowed while "strict subs" in use at - line 4. Execution of - aborted due to compilation errors. ######## use strict 'subs'; my @players; eval { @players = sort(_rankCompare @players) }; sub _rankCompare2 { } @players = sort(_rankCompare2 @players); EXPECT ######## use strict; readline(FOO); EXPECT ######## use strict 'subs'; sub sayfoo { print "foo:@_\n" ; "ret\n" } print sayfoo "bar"; print sayfoo . "bar\n"; EXPECT foo:bar ret foo: ret bar perl-5.12.0-RC0/t/lib/strict/vars0000444000175000017500000002114311143650501015341 0ustar jessejesseCheck strict vars functionality __END__ # no strict, should build & run ok. Fred ; my $fred ; $b = "fred" ; $a = $$b ; EXPECT ######## use strict qw(subs refs) ; $fred ; EXPECT ######## use strict ; no strict 'vars' ; $fred ; EXPECT ######## # strict vars - no error use strict 'vars' ; use vars qw( $freddy) ; BEGIN { *freddy = \$joe::shmoe; } $freddy = 2 ; EXPECT ######## # strict vars - no error use strict 'vars' ; use vars qw( $freddy) ; local $abc::joe ; my $fred ; my $b = \$fred ; $Fred::ABC = 1 ; $freddy = 2 ; EXPECT ######## # strict vars - error use strict ; $fred ; EXPECT Global symbol "$fred" requires explicit package name at - line 4. Execution of - aborted due to compilation errors. ######## # strict vars - error use strict 'vars' ; <$fred> ; EXPECT Global symbol "$fred" requires explicit package name at - line 4. Execution of - aborted due to compilation errors. ######## # strict vars - error use strict 'vars' ; local $fred ; EXPECT Global symbol "$fred" requires explicit package name at - line 4. Execution of - aborted due to compilation errors. ######## # Check compile time scope of strict vars pragma use strict 'vars' ; { no strict ; $joe = 1 ; } $joe = 1 ; EXPECT Variable "$joe" is not imported at - line 8. Global symbol "$joe" requires explicit package name at - line 8. Execution of - aborted due to compilation errors. ######## # Check compile time scope of strict vars pragma no strict; { use strict 'vars' ; $joe = 1 ; } $joe = 1 ; EXPECT Global symbol "$joe" requires explicit package name at - line 6. Execution of - aborted due to compilation errors. ######## --FILE-- abc $joe = 1 ; 1; --FILE-- use strict 'vars' ; require "./abc"; EXPECT ######## --FILE-- abc use strict 'vars' ; 1; --FILE-- require "./abc"; $joe = 1 ; EXPECT ######## --FILE-- abc use strict 'vars' ; $joe = 1 ; 1; --FILE-- $joe = 1 ; require "./abc"; EXPECT Variable "$joe" is not imported at ./abc line 2. Global symbol "$joe" requires explicit package name at ./abc line 2. Compilation failed in require at - line 2. ######## --FILE-- abc.pm use strict 'vars' ; $joe = 1 ; 1; --FILE-- $joe = 1 ; use abc; EXPECT Variable "$joe" is not imported at abc.pm line 2. Global symbol "$joe" requires explicit package name at abc.pm line 2. Compilation failed in require at - line 2. BEGIN failed--compilation aborted at - line 2. ######## --FILE-- abc.pm package Burp; use strict; $a = 1;$f = 1;$k = 1; # just to get beyond the limit... $b = 1;$g = 1;$l = 1; $c = 1;$h = 1;$m = 1; $d = 1;$i = 1;$n = 1; $e = 1;$j = 1;$o = 1; $p = 0b12; --FILE-- use abc; EXPECT Global symbol "$f" requires explicit package name at abc.pm line 3. Global symbol "$k" requires explicit package name at abc.pm line 3. Global symbol "$g" requires explicit package name at abc.pm line 4. Global symbol "$l" requires explicit package name at abc.pm line 4. Global symbol "$c" requires explicit package name at abc.pm line 5. Global symbol "$h" requires explicit package name at abc.pm line 5. Global symbol "$m" requires explicit package name at abc.pm line 5. Global symbol "$d" requires explicit package name at abc.pm line 6. Global symbol "$i" requires explicit package name at abc.pm line 6. Global symbol "$n" requires explicit package name at abc.pm line 6. Global symbol "$e" requires explicit package name at abc.pm line 7. Global symbol "$j" requires explicit package name at abc.pm line 7. Global symbol "$o" requires explicit package name at abc.pm line 7. Global symbol "$p" requires explicit package name at abc.pm line 8. Illegal binary digit '2' at abc.pm line 8, at end of line abc.pm has too many errors. Compilation failed in require at - line 1. BEGIN failed--compilation aborted at - line 1. ######## # Check scope of pragma with eval no strict ; eval { $joe = 1 ; }; print STDERR $@; $joe = 1 ; EXPECT ######## # Check scope of pragma with eval no strict ; eval { use strict 'vars' ; $joe = 1 ; }; print STDERR $@; $joe = 1 ; EXPECT Global symbol "$joe" requires explicit package name at - line 6. Execution of - aborted due to compilation errors. ######## # Check scope of pragma with eval use strict 'vars' ; eval { $joe = 1 ; }; print STDERR $@; $joe = 1 ; EXPECT Global symbol "$joe" requires explicit package name at - line 5. Global symbol "$joe" requires explicit package name at - line 8. Execution of - aborted due to compilation errors. ######## # Check scope of pragma with eval use strict 'vars' ; eval { no strict ; $joe = 1 ; }; print STDERR $@; $joe = 1 ; EXPECT Variable "$joe" is not imported at - line 9. Global symbol "$joe" requires explicit package name at - line 9. Execution of - aborted due to compilation errors. ######## # Check scope of pragma with eval no strict ; eval ' $joe = 1 ; '; print STDERR $@ ; $joe = 1 ; EXPECT ######## # Check scope of pragma with eval no strict ; eval q[ use strict 'vars' ; $joe = 1 ; ]; print STDERR $@; EXPECT Global symbol "$joe" requires explicit package name at (eval 1) line 3. ######## # Check scope of pragma with eval use strict 'vars' ; eval ' $joe = 1 ; '; print STDERR $@ ; EXPECT Global symbol "$joe" requires explicit package name at (eval 1) line 2. ######## # Check scope of pragma with eval use strict 'vars' ; eval ' no strict ; $joe = 1 ; '; print STDERR $@; $joe = 1 ; EXPECT Global symbol "$joe" requires explicit package name at - line 8. Execution of - aborted due to compilation errors. ######## # Check if multiple evals produce same errors use strict 'vars'; my $ret = eval q{ print $x; }; print $@; print "ok 1\n" unless defined $ret; $ret = eval q{ print $x; }; print $@; print "ok 2\n" unless defined $ret; EXPECT Global symbol "$x" requires explicit package name at (eval 1) line 1. ok 1 Global symbol "$x" requires explicit package name at (eval 2) line 1. ok 2 ######## # strict vars with outer our - no error use strict 'vars' ; our $freddy; local $abc::joe ; my $fred ; my $b = \$fred ; $Fred::ABC = 1 ; $freddy = 2 ; EXPECT ######## # strict vars with inner our - no error use strict 'vars' ; sub foo { our $fred; $fred; } EXPECT ######## # strict vars with outer our, inner use - no error use strict 'vars' ; our $fred; sub foo { $fred; } EXPECT ######## # strict vars with nested our - no error use strict 'vars' ; our $fred; sub foo { our $fred; $fred; } $fred ; EXPECT ######## # strict vars with elapsed our - error use strict 'vars' ; sub foo { our $fred; $fred; } $fred ; EXPECT Variable "$fred" is not imported at - line 8. Global symbol "$fred" requires explicit package name at - line 8. Execution of - aborted due to compilation errors. ######## # nested our with local - no error $fred = 1; use strict 'vars'; { local our $fred = 2; print $fred,"\n"; } print our $fred,"\n"; EXPECT 2 1 ######## # "nailed" our declaration visibility across package boundaries use strict 'vars'; our $foo; $foo = 20; package Foo; print $foo, "\n"; EXPECT 20 ######## # multiple our declarations in same scope, different packages, no warning use strict 'vars'; use warnings; our $foo; ${foo} = 10; package Foo; our $foo = 20; print $foo, "\n"; EXPECT 20 ######## # multiple our declarations in same scope, same package, warning use strict 'vars'; use warnings; our $foo; ${foo} = 10; our $foo; EXPECT "our" variable $foo redeclared at - line 7. ######## # multiple our declarations in same scope, same package, warning use strict 'vars'; use warnings; { our $x = 1 } { our $x = 0 } our $foo; { our $foo; our $foo; package Foo; our $foo; } EXPECT "our" variable $foo redeclared at - line 9. (Did you mean "local" instead of "our"?) "our" variable $foo redeclared at - line 10. ######## --FILE-- abc ok --FILE-- # check if our variables are introduced correctly in readline() package Foo; use strict 'vars'; our $FH; open $FH, "abc" or die "Can't open 'abc': $!"; print <$FH>; close $FH; EXPECT ok ######## # Make sure the strict vars failure still occurs # now that the `@i should be written as \@i' failure does not occur # 20000522 mjd@plover.com (MJD) use strict 'vars'; no warnings; "@i_like_crackers"; EXPECT Global symbol "@i_like_crackers" requires explicit package name at - line 7. Execution of - aborted due to compilation errors. ######## # [perl #21914] New bug > 5.8.0. Used to dump core. use strict 'vars'; @k = <$k>; EXPECT Global symbol "@k" requires explicit package name at - line 4. Global symbol "$k" requires explicit package name at - line 4. Execution of - aborted due to compilation errors. ######## # [perl #26910] hints not propagated into (?{...}) use strict 'vars'; qr/(?{$foo++})/; EXPECT Global symbol "$foo" requires explicit package name at (re_eval 1) line 1. Compilation failed in regexp at - line 3. perl-5.12.0-RC0/t/lib/strict/refs0000444000175000017500000001434311325127001015325 0ustar jessejesseCheck strict refs functionality __END__ # no strict, should build & run ok. my $fred ; $b = "fred" ; $a = $$b ; $c = ${"def"} ; $c = @{"def"} ; $c = %{"def"} ; $c = *{"def"} ; $c = \&{"def"} ; $c = def->[0]; $c = def->{xyz}; EXPECT ######## # strict refs - error use strict ; my $str="A::Really::Big::Package::Name::To::Use"; $str->{foo}= 1; EXPECT Can't use string ("A::Really::Big::Package::Name::T"...) as a HASH ref while "strict refs" in use at - line 5. ######## # strict refs - error use strict ; my $fred ; my $a = ${"fred"} ; EXPECT Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 5. ######## # strict refs - error use strict 'refs' ; my $fred ; my $a = ${"fred"} ; EXPECT Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 5. ######## # strict refs - error use strict 'refs' ; my $fred ; my $b = "fred" ; my $a = $$b ; EXPECT Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 6. ######## # strict refs - error use strict 'refs' ; my $b ; my $a = $$b ; EXPECT Can't use an undefined value as a SCALAR reference at - line 5. ######## # strict refs - error use strict 'refs' ; my $b ; my $a = @$b ; EXPECT Can't use an undefined value as an ARRAY reference at - line 5. ######## # strict refs - error use strict 'refs' ; my $b ; my $a = %$b ; EXPECT Can't use an undefined value as a HASH reference at - line 5. ######## # strict refs - error use strict 'refs' ; my $b ; my $a = *$b ; EXPECT Can't use an undefined value as a symbol reference at - line 5. ######## # strict refs - error use strict 'refs' ; my $a = fred->[0] ; EXPECT Can't use bareword ("fred") as an ARRAY ref while "strict refs" in use at - line 4. ######## # strict refs - error use strict 'refs' ; my $a = fred->{barney} ; EXPECT Can't use bareword ("fred") as a HASH ref while "strict refs" in use at - line 4. ######## # strict refs - no error use strict ; no strict 'refs' ; my $fred ; my $b = "fred" ; my $a = $$b ; use strict 'refs' ; EXPECT ######## # strict refs - no error use strict qw(subs vars) ; my $fred ; my $b = "fred" ; my $a = $$b ; use strict 'refs' ; EXPECT ######## # strict refs - no error my $fred ; my $b = "fred" ; my $a = $$b ; use strict 'refs' ; EXPECT ######## # strict refs - no error use strict 'refs' ; my $fred ; my $b = \$fred ; my $a = $$b ; EXPECT ######## # Check runtime scope of strict refs pragma use strict 'refs'; my $fred ; my $b = "fred" ; { no strict ; my $a = $$b ; } my $a = $$b ; EXPECT Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 10. ######## # Check runtime scope of strict refs pragma no strict ; my $fred ; my $b = "fred" ; { use strict 'refs' ; my $a = $$b ; } my $a = $$b ; EXPECT Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8. ######## # Check runtime scope of strict refs pragma no strict ; my $fred ; my $b = "fred" ; { use strict 'refs' ; $a = sub { my $c = $$b ; } } &$a ; EXPECT Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8. ######## --FILE-- abc my $a = ${"Fred"} ; 1; --FILE-- use strict 'refs' ; require "./abc"; EXPECT ######## --FILE-- abc use strict 'refs' ; 1; --FILE-- require "./abc"; my $a = ${"Fred"} ; EXPECT ######## --FILE-- abc use strict 'refs' ; my $a = ${"Fred"} ; 1; --FILE-- ${"Fred"} ; require "./abc"; EXPECT Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at ./abc line 2. Compilation failed in require at - line 2. ######## --FILE-- abc.pm use strict 'refs' ; my $a = ${"Fred"} ; 1; --FILE-- my $a = ${"Fred"} ; use abc; EXPECT Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at abc.pm line 2. Compilation failed in require at - line 2. BEGIN failed--compilation aborted at - line 2. ######## # Check scope of pragma with eval no strict ; eval { my $a = ${"Fred"} ; }; print STDERR $@ ; my $a = ${"Fred"} ; EXPECT ######## # Check scope of pragma with eval no strict ; eval { use strict 'refs' ; my $a = ${"Fred"} ; }; print STDERR $@ ; my $a = ${"Fred"} ; EXPECT Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 6. ######## # Check scope of pragma with eval use strict 'refs' ; eval { my $a = ${"Fred"} ; }; print STDERR $@ ; EXPECT Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 5. ######## # Check scope of pragma with eval use strict 'refs' ; eval { no strict ; my $a = ${"Fred"} ; }; print STDERR $@ ; my $a = ${"Fred"} ; EXPECT Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 9. ######## # Check scope of pragma with eval no strict ; eval ' my $a = ${"Fred"} ; '; print STDERR $@ ; my $a = ${"Fred"} ; EXPECT ######## # Check scope of pragma with eval no strict ; eval q[ use strict 'refs' ; my $a = ${"Fred"} ; ]; print STDERR $@; EXPECT Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at (eval 1) line 3. ######## # Check scope of pragma with eval use strict 'refs' ; eval ' my $a = ${"Fred"} ; '; print STDERR $@ ; EXPECT Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at (eval 1) line 2. ######## # Check scope of pragma with eval use strict 'refs' ; eval ' no strict ; my $a = ${"Fred"} ; '; print STDERR $@; my $a = ${"Fred"} ; EXPECT Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 8. ######## # [perl #26910] hints not propagated into (?{...}) use strict 'refs'; /(?{${"foo"}++})/; EXPECT Can't use string ("foo") as a SCALAR ref while "strict refs" in use at (re_eval 1) line 1. ######## # [perl #37886] strict 'refs' doesn't apply inside defined use strict 'refs'; my $x = "foo"; defined $$x; EXPECT Can't use string ("foo") as a SCALAR ref while "strict refs" in use at - line 4. ######## # [perl #37886] strict 'refs' doesn't apply inside defined use strict 'refs'; my $x = "foo"; defined @$x; EXPECT Can't use string ("foo") as an ARRAY ref while "strict refs" in use at - line 4. ######## # [perl #37886] strict 'refs' doesn't apply inside defined use strict 'refs'; my $x = "foo"; defined %$x; EXPECT defined(%hash) is deprecated at - line 4. (Maybe you should just omit the defined()?) Can't use string ("foo") as a HASH ref while "strict refs" in use at - line 4. perl-5.12.0-RC0/t/lib/locale/0000755000175000017500000000000011351321566014402 5ustar jessejesseperl-5.12.0-RC0/t/lib/locale/utf80000444000175000017500000000051411143650501015202 0ustar jessejesseuse utf8; $locales .= <; chomp @Core_Modules; if (eval { require Socket }) { # Two Net:: modules need the Convert::EBCDIC if in EBDCIC. if (ord("A") != 193 || eval { require Convert::EBCDIC }) { push @Core_Modules, qw(Net::Cmd Net::POP3); } } @Core_Modules = sort @Core_Modules; print "1..".(1+@Core_Modules)."\n"; my $message = "ok 1 - All modules should have tests # TODO Make Schwern Poorer\n"; if (@Core_Modules) { print "not $message"; } else { print $message; } print <<'EOREWARD'; # http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2001-04/msg01223.html # 20010421230349.P2946@blackrider.blackstar.co.uk EOREWARD my $test_num = 2; foreach my $module (@Core_Modules) { my $todo = ''; $todo = "# TODO $module needs porting on $^O" if $module eq 'ByteLoader' && $^O eq 'VMS'; print "# $module compile failed\nnot " unless compile_module($module); print "ok $test_num $todo\n"; $test_num++; } # We do this as a separate process else we'll blow the hell # out of our namespace. sub compile_module { my ($module) = $_[0]; my $compmod = catfile(curdir(), 'lib', 'compmod.pl'); my $lib = '-I' . catdir(updir(), 'lib'); my $out = scalar `$^X $lib $compmod $module`; print "# $out"; return $out =~ /^ok/; } # These modules have no tests of their own. # Keep up to date with # http://perl-qa.hexten.net/wiki/index.php/Untested_Core_Modules # and vice-versa. The list should only shrink. __DATA__ perl-5.12.0-RC0/t/lib/h2ph.pht0000444000175000017500000000747211325125742014530 0ustar jessejesserequire '_h2ph_pre.ph'; no warnings qw(redefine misc); unless(defined(&SQUARE)) { sub SQUARE { my($x) = @_; eval q((($x)*($x))); } } unless(defined(&ERROR)) { eval 'sub ERROR { my($x) = @_; eval q( &fprintf( &stderr, \\"%s\\\\n\\", $x->[2][3][0])); }' unless defined(&ERROR); } unless(defined(&_H2PH_H_)) { eval 'sub _H2PH_H_ () {1;}' unless defined(&_H2PH_H_); # "$Revision h2ph.h,v 1.0 98/05/04 20:42:14 billy $" undef(&MAX) if defined(&MAX); eval 'sub MAX { my($a,$b) = @_; eval q((($a) > ($b) ? ($a) : ($b))); }' unless defined(&MAX); eval 'sub NOTTRUE () {0;}' unless defined(&NOTTRUE); undef(&NOTTRUE) if defined(&NOTTRUE); if(defined(&__SOME_UNIMPORTANT_PROPERTY)) { eval 'sub MIN { my($a,$b) = @_; eval q((($a) < ($b) ? ($a) : ($b))); }' unless defined(&MIN); } if(!(defined (&__SOMETHING_MORE_IMPORTANT))) { } elsif(!(defined (&__SOMETHING_REALLY_REALLY_IMPORTANT))) { die("Nup, can't go on"); } else { eval 'sub EVERYTHING_IS_OK () {1;}' unless defined(&EVERYTHING_IS_OK); } undef(&WHATEVER) if defined(&WHATEVER); if((!((defined (&__SOMETHING_TRIVIAL) && defined (&__SOMETHING_LESS_SO))) || defined (&__SOMETHING_OVERPOWERING))) { eval 'sub WHATEVER () {6;}' unless defined(&WHATEVER); } elsif(!(defined (&__SOMETHING_TRIVIAL)) ) { eval 'sub WHATEVER () {7;}' unless defined(&WHATEVER); } elsif(!(defined (&__SOMETHING_LESS_SO)) ) { eval 'sub WHATEVER () {8;}' unless defined(&WHATEVER); } else { eval 'sub WHATEVER () {1000;}' unless defined(&WHATEVER); } if(0) { require 'sys/socket.ph'; require 'sys/ioctl.ph'; eval { my(@REM); my(%INCD) = map { $INC{$_} => 1 } (grep { $_ eq "sys/fcntl.ph" } keys(%INC)); @REM = map { "$_/sys/fcntl.ph" } (grep { not exists($INCD{"$_/sys/fcntl.ph"}) and -f "$_/sys/fcntl.ph" } @INC); require "$REM[0]" if @REM; }; warn($@) if $@; } eval("sub sun () { 0; }") unless defined(&sun); eval("sub mon () { 1; }") unless defined(&mon); eval("sub tue () { 2; }") unless defined(&tue); eval("sub wed () { 3; }") unless defined(&wed); eval("sub thu () { 4; }") unless defined(&thu); eval("sub fri () { 5; }") unless defined(&fri); eval("sub sat () { 6; }") unless defined(&sat); eval("sub Sun () { 0; }") unless defined(&Sun); eval("sub Mon () { 1; }") unless defined(&Mon); eval("sub Tue () { 2; }") unless defined(&Tue); eval("sub Wed () { 3; }") unless defined(&Wed); eval("sub Thu () { 4; }") unless defined(&Thu); eval("sub Fri () { 5; }") unless defined(&Fri); eval("sub Sat () { 6; }") unless defined(&Sat); unless(defined(&_SOMETHING_TRIGRAPHIC)) { eval 'sub _SOMETHING_TRIGRAPHIC () {1;}' unless defined(&_SOMETHING_TRIGRAPHIC); eval 'sub SOMETHING_ELSE_TRIGRAPHIC_0 () {"|";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_0); eval 'sub SOMETHING_ELSE_TRIGRAPHIC_1 () {"^";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_1); eval 'sub SOMETHING_ELSE_TRIGRAPHIC_2 () {"[";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_2); eval 'sub SOMETHING_ELSE_TRIGRAPHIC_3 () {"]";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_3); eval 'sub SOMETHING_ELSE_TRIGRAPHIC_4 () {"~0";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_4); eval 'sub SOMETHING_ELSE_TRIGRAPHIC_5 () {"\\ ";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_5); eval 'sub SOMETHING_ELSE_TRIGRAPHIC_6 () {"{";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_6); eval 'sub SOMETHING_ELSE_TRIGRAPHIC_7 () {"#";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_7); eval 'sub SOMETHING_ELSE_TRIGRAPHIC_8 () {"}";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_8); } if(1) { } eval("sub flim () { 0; }") unless defined(&flim); eval("sub flam () { 1; }") unless defined(&flam); eval 'sub multiline () {"multilinestring";}' unless defined(&multiline); } 1; perl-5.12.0-RC0/t/lib/deprecate.t0000555000175000017500000000415211325127001015254 0ustar jessejesse#!perl -w use strict; BEGIN { require './test.pl'; } use File::Copy (); use File::Path (); use File::Spec (); plan(tests => 10); my $test_dir = File::Spec->catdir(qw(lib deprecate)); chdir $test_dir or die "Can't chdir $test_dir"; @INC = ( File::Spec->catdir( (File::Spec->updir)x3, qw(lib)) ); my %libdir = ( privlibexp => File::Spec->catdir(qw(lib perl)), sitelibexp => File::Spec->catdir(qw(lib site)), archlibexp => File::Spec->catdir(qw(lib perl arch)), sitearchexp => File::Spec->catdir(qw(lib site arch)), ); File::Path::make_path(values %libdir); push @INC, @libdir{qw(archlibexp privlibexp sitearchexp sitelibexp)}; our %tests = ( privlibexp => 1, sitelibexp => 0, archlibexp => 1, sitearchexp => 0, ); no warnings 'once'; local %deprecate::Config = (%libdir); my $module = 'Deprecated.pm'; for my $lib (sort keys %tests) { my $dir = $libdir{$lib}; my $pm = File::Spec->catfile($dir, $module); File::Copy::copy($module, $pm); my $warn = ''; { local $SIG{__WARN__} = sub { $warn .= $_[0]; }; use warnings qw(deprecated); #line 1001 require Deprecated; #line } if( $tests{$lib} ) { like($warn, qr/^Deprecated\s+will\s+be\s+removed\b/, "$lib - message"); my $me = quotemeta($0); like($warn, qr/$me,?\s+line\s+1001\.?\n*$/, "$lib - location"); } else { ok( !$warn, "$lib - no message" ); } delete $INC{$module}; unlink $pm; } my $sub_dir = 'Optionally'; my $opt_mod = $sub_dir .'.pm'; for my $lib (sort keys %tests) { my $dir = File::Spec->catdir($libdir{$lib}, $sub_dir); File::Path::make_path($dir); my $pm = File::Spec->catfile($dir, $module); File::Copy::copy($opt_mod, $pm); my $warn = ''; { local $SIG{__WARN__} = sub { $warn .= $_[0]; }; use warnings qw(deprecated); require Optionally::Deprecated; } if( $tests{$lib} ) { like($warn, qr/^Optionally::Deprecated\s+will\s+be\s+removed\b/, "$lib - use if - message"); } else { ok( !$warn, "$lib - use if - no message" ); } delete $INC{"$sub_dir/$module"}; unlink $pm; } END { File::Path::remove_tree('lib') } perl-5.12.0-RC0/t/lib/no_load.t0000555000175000017500000000132311325125742014742 0ustar jessejesse#!./perl # # Check that certain modules don't get loaded when other modules are used. # BEGIN { chdir 't' if -d 't'; @INC = qw(. ../lib); } use strict; use warnings; require "test.pl"; # # Format: [Module-that-should-not-be-loaded => modules to test] # my @TESTS = ( [Carp => qw [warnings Exporter]], ); my $count = 0; $count += @$_ - 1 for @TESTS; print "1..$count\n"; foreach my $test (@TESTS) { my ($exclude, @modules) = @$test; foreach my $module (@modules) { my $prog = <<" --"; use $module; print exists \$INC {'$exclude.pm'} ? "not ok" : "ok"; -- fresh_perl_is ($prog, "ok", "", "$module does not load $exclude"); } } __END__ perl-5.12.0-RC0/t/op/0000755000175000017500000000000011351321566013013 5ustar jessejesseperl-5.12.0-RC0/t/op/chars.t0000555000175000017500000000420111325125742014275 0ustar jessejesse#!./perl print "1..33\n"; # because of ebcdic.c these should be the same on asciiish # and ebcdic machines. # Peter Prymmer . my $c = "\c@"; print +((ord($c) == 0) ? "" : "not "),"ok 1\n"; $c = "\cA"; print +((ord($c) == 1) ? "" : "not "),"ok 2\n"; $c = "\cB"; print +((ord($c) == 2) ? "" : "not "),"ok 3\n"; $c = "\cC"; print +((ord($c) == 3) ? "" : "not "),"ok 4\n"; $c = "\cD"; print +((ord($c) == 4) ? "" : "not "),"ok 5\n"; $c = "\cE"; print +((ord($c) == 5) ? "" : "not "),"ok 6\n"; $c = "\cF"; print +((ord($c) == 6) ? "" : "not "),"ok 7\n"; $c = "\cG"; print +((ord($c) == 7) ? "" : "not "),"ok 8\n"; $c = "\cH"; print +((ord($c) == 8) ? "" : "not "),"ok 9\n"; $c = "\cI"; print +((ord($c) == 9) ? "" : "not "),"ok 10\n"; $c = "\cJ"; print +((ord($c) == 10) ? "" : "not "),"ok 11\n"; $c = "\cK"; print +((ord($c) == 11) ? "" : "not "),"ok 12\n"; $c = "\cL"; print +((ord($c) == 12) ? "" : "not "),"ok 13\n"; $c = "\cM"; print +((ord($c) == 13) ? "" : "not "),"ok 14\n"; $c = "\cN"; print +((ord($c) == 14) ? "" : "not "),"ok 15\n"; $c = "\cO"; print +((ord($c) == 15) ? "" : "not "),"ok 16\n"; $c = "\cP"; print +((ord($c) == 16) ? "" : "not "),"ok 17\n"; $c = "\cQ"; print +((ord($c) == 17) ? "" : "not "),"ok 18\n"; $c = "\cR"; print +((ord($c) == 18) ? "" : "not "),"ok 19\n"; $c = "\cS"; print +((ord($c) == 19) ? "" : "not "),"ok 20\n"; $c = "\cT"; print +((ord($c) == 20) ? "" : "not "),"ok 21\n"; $c = "\cU"; print +((ord($c) == 21) ? "" : "not "),"ok 22\n"; $c = "\cV"; print +((ord($c) == 22) ? "" : "not "),"ok 23\n"; $c = "\cW"; print +((ord($c) == 23) ? "" : "not "),"ok 24\n"; $c = "\cX"; print +((ord($c) == 24) ? "" : "not "),"ok 25\n"; $c = "\cY"; print +((ord($c) == 25) ? "" : "not "),"ok 26\n"; $c = "\cZ"; print +((ord($c) == 26) ? "" : "not "),"ok 27\n"; $c = "\c["; print +((ord($c) == 27) ? "" : "not "),"ok 28\n"; $c = "\c\\"; print +((ord($c) == 28) ? "" : "not "),"ok 29\n"; $c = "\c]"; print +((ord($c) == 29) ? "" : "not "),"ok 30\n"; $c = "\c^"; print +((ord($c) == 30) ? "" : "not "),"ok 31\n"; $c = "\c_"; print +((ord($c) == 31) ? "" : "not "),"ok 32\n"; $c = "\c?"; print +((ord($c) == 127) ? "" : "not "),"ok 33\n"; perl-5.12.0-RC0/t/op/array_base.t0000555000175000017500000000501711325127001015301 0ustar jessejesse#!perl -w use strict; require './test.pl'; plan (tests => 24); no warnings 'deprecated'; # Bug #27024 { # this used to segfault (because $[=1 is optimized away to a null block) my $x; $[ = 1 while $x; pass('#27204'); $[ = 0; # restore the original value for less side-effects } # [perl #36313] perl -e "1for$[=0" crash { my $x; $x = 1 for ($[) = 0; pass('optimized assignment to $[ used to segfault in list context'); if ($[ = 0) { $x = 1 } pass('optimized assignment to $[ used to segfault in scalar context'); $x = ($[=2.4); is($x, 2, 'scalar assignment to $[ behaves like other variables'); $x = (($[) = 0); is($x, 1, 'list assignment to $[ behaves like other variables'); $x = eval q{ ($[, $x) = (0) }; like($@, qr/That use of \$\[ is unsupported/, 'cannot assign to $[ in a list'); eval q{ ($[) = (0, 1) }; like($@, qr/That use of \$\[ is unsupported/, 'cannot assign list of >1 elements to $['); eval q{ ($[) = () }; like($@, qr/That use of \$\[ is unsupported/, 'cannot assign list of <1 elements to $['); } { $[ = 11; cmp_ok($[ + 0, '==', 11, 'setting $[ affects $['); our $t11; BEGIN { $t11 = $^H{'$['} } cmp_ok($t11, '==', 11, 'setting $[ affects $^H{\'$[\'}'); BEGIN { $^H{'$['} = 22 } cmp_ok($[ + 0, '==', 22, 'setting $^H{\'$\'} affects $['); our $t22; BEGIN { $t22 = $^H{'$['} } cmp_ok($t22, '==', 22, 'setting $^H{\'$[\'} affects $^H{\'$[\'}'); BEGIN { %^H = () } my $val = do { no warnings 'uninitialized'; $[; }; cmp_ok($val, '==', 0, 'clearing %^H affects $['); our $t0; BEGIN { $t0 = $^H{'$['} } cmp_ok($t0, '==', 0, 'clearing %^H affects $^H{\'$[\'}'); } { $[ = 13; BEGIN { $^H |= 0x04000000; $^H{foo} = "z"; } our($ri0, $rf0); BEGIN { $ri0 = $^H; $rf0 = $^H{foo}; } cmp_ok($[ + 0, '==', 13, '$[ correct before require'); ok($ri0 & 0x04000000, '$^H correct before require'); is($rf0, "z", '$^H{foo} correct before require'); our($ra1, $ri1, $rf1, $rfe1); BEGIN { require "op/array_base.aux"; } cmp_ok($ra1, '==', 0, '$[ cleared for require'); ok(!($ri1 & 0x04000000), '$^H cleared for require'); is($rf1, undef, '$^H{foo} cleared for require'); ok(!$rfe1, '$^H{foo} cleared for require'); our($ri2, $rf2); BEGIN { $ri2 = $^H; $rf2 = $^H{foo}; } cmp_ok($[ + 0, '==', 13, '$[ correct after require'); ok($ri2 & 0x04000000, '$^H correct after require'); is($rf2, "z", '$^H{foo} correct after require'); } perl-5.12.0-RC0/t/op/concat.t0000555000175000017500000000756511143650501014456 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } # This ok() function is specially written to avoid any concatenation. my $test = 1; sub ok { my($ok, $name) = @_; printf "%sok %d - %s\n", ($ok ? "" : "not "), $test, $name; printf "# Failed test at line %d\n", (caller)[2] unless $ok; $test++; return $ok; } print "1..29\n"; ($a, $b, $c) = qw(foo bar); ok("$a" eq "foo", "verifying assign"); ok("$a$b" eq "foobar", "basic concatenation"); ok("$c$a$c" eq "foo", "concatenate undef, fore and aft"); # Okay, so that wasn't very challenging. Let's go Unicode. { # bug id 20000819.004 $_ = $dx = "\x{10f2}"; s/($dx)/$dx$1/; { ok($_ eq "$dx$dx","bug id 20000819.004, back"); } $_ = $dx = "\x{10f2}"; s/($dx)/$1$dx/; { ok($_ eq "$dx$dx","bug id 20000819.004, front"); } $dx = "\x{10f2}"; $_ = "\x{10f2}\x{10f2}"; s/($dx)($dx)/$1$2/; { ok($_ eq "$dx$dx","bug id 20000819.004, front and back"); } } { # bug id 20000901.092 # test that undef left and right of utf8 results in a valid string my $a; $a .= "\x{1ff}"; ok($a eq "\x{1ff}", "bug id 20000901.092, undef left"); $a .= undef; ok($a eq "\x{1ff}", "bug id 20000901.092, undef right"); } { # ID 20001020.006 "x" =~ /(.)/; # unset $2 # Without the fix this 5.7.0 would croak: # Modification of a read-only value attempted at ... eval {"$2\x{1234}"}; ok(!$@, "bug id 20001020.006, left"); # For symmetry with the above. eval {"\x{1234}$2"}; ok(!$@, "bug id 20001020.006, right"); *pi = \undef; # This bug existed earlier than the $2 bug, but is fixed with the same # patch. Without the fix this 5.7.0 would also croak: # Modification of a read-only value attempted at ... eval{"$pi\x{1234}"}; ok(!$@, "bug id 20001020.006, constant left"); # For symmetry with the above. eval{"\x{1234}$pi"}; ok(!$@, "bug id 20001020.006, constant right"); } sub beq { use bytes; $_[0] eq $_[1]; } { # concat should not upgrade its arguments. my($l, $r, $c); ($l, $r, $c) = ("\x{101}", "\x{fe}", "\x{101}\x{fe}"); ok(beq($l.$r, $c), "concat utf8 and byte"); ok(beq($l, "\x{101}"), "right not changed after concat u+b"); ok(beq($r, "\x{fe}"), "left not changed after concat u+b"); ($l, $r, $c) = ("\x{fe}", "\x{101}", "\x{fe}\x{101}"); ok(beq($l.$r, $c), "concat byte and utf8"); ok(beq($l, "\x{fe}"), "right not changed after concat b+u"); ok(beq($r, "\x{101}"), "left not changed after concat b+u"); } { my $a; ($a .= 5) . 6; ok($a == 5, '($a .= 5) . 6 - present since 5.000'); } { # [perl #24508] optree construction bug sub strfoo { "x" } my ($x, $y); $y = ($x = '' . strfoo()) . "y"; ok( "$x,$y" eq "x,xy", 'figures out correct target' ); } { # [perl #26905] "use bytes" doesn't apply byte semantics to concatenation my $p = "\xB6"; # PILCROW SIGN (ASCII/EBCDIC), 2bytes in UTF-X my $u = "\x{100}"; my $b = pack 'a*', "\x{100}"; my $pu = "\xB6\x{100}"; my $up = "\x{100}\xB6"; my $x1 = $p; my $y1 = $u; use bytes; ok(beq($p.$u, $p.$b), "perl #26905, left eq bytes"); ok(beq($u.$p, $b.$p), "perl #26905, right eq bytes"); ok(!beq($p.$u, $pu), "perl #26905, left ne unicode"); ok(!beq($u.$p, $up), "perl #26905, right ne unicode"); $x1 .= $u; $x2 = $p . $u; $y1 .= $p; $y2 = $u . $p; no bytes; ok(beq($x1, $x2), "perl #26905, left, .= vs = . in bytes"); ok(beq($y1, $y2), "perl #26905, right, .= vs = . in bytes"); ok(($x1 eq $x2), "perl #26905, left, .= vs = . in chars"); ok(($y1 eq $y2), "perl #26905, right, .= vs = . in chars"); } { # Concatenation needs to preserve UTF8ness of left oper. my $x = eval"qr/\x{fff}/"; ok( ord chop($x .= "\303\277") == 191, "UTF8ness preserved" ); } perl-5.12.0-RC0/t/op/smartmatch.t0000555000175000017500000002370611325127001015341 0ustar jessejesse#!./perl BEGIN { chdir 't'; @INC = '../lib'; require './test.pl'; } use strict; use warnings; no warnings 'uninitialized'; use Tie::Array; use Tie::Hash; use if !$ENV{PERL_CORE_MINITEST}, "Tie::RefHash"; # Predeclare vars used in the tests: my @empty; my %empty; my @sparse; $sparse[2] = 2; my $deep1 = []; push @$deep1, $deep1; my $deep2 = []; push @$deep2, $deep2; my @nums = (1..10); tie my @tied_nums, 'Tie::StdArray'; @tied_nums = (1..10); my %hash = (foo => 17, bar => 23); tie my %tied_hash, 'Tie::StdHash'; %tied_hash = %hash; { package Test::Object::NoOverload; sub new { bless { key => 1 } } } { package Test::Object::StringOverload; use overload '""' => sub { "object" }, fallback => 1; sub new { bless { key => 1 } } } { package Test::Object::WithOverload; sub new { bless { key => ($_[1] // 'magic') } } use overload '~~' => sub { my %hash = %{ $_[0] }; if ($_[2]) { # arguments reversed ? return $_[1] eq reverse $hash{key}; } else { return $_[1] eq $hash{key}; } }; use overload '""' => sub { "stringified" }; use overload 'eq' => sub {"$_[0]" eq "$_[1]"}; } our $ov_obj = Test::Object::WithOverload->new; our $ov_obj_2 = Test::Object::WithOverload->new("object"); our $obj = Test::Object::NoOverload->new; our $str_obj = Test::Object::StringOverload->new; my %refh; if (!$ENV{PERL_CORE_MINITEST}) { tie %refh, 'Tie::RefHash'; $refh{$ov_obj} = 1; } my @keyandmore = qw(key and more); my @fooormore = qw(foo or more); my %keyandmore = map { $_ => 0 } @keyandmore; my %fooormore = map { $_ => 0 } @fooormore; # Load and run the tests plan tests => 335; while () { SKIP: { next if /^#/ || !/\S/; chomp; my ($yn, $left, $right, $note) = split /\t+/; local $::TODO = $note =~ /TODO/; die "Bad test spec: ($yn, $left, $right)" if $yn =~ /[^!@=]/; my $tstr = "$left ~~ $right"; test_again: my $res; if ($note =~ /NOWARNINGS/) { $res = eval "no warnings; $tstr"; } elsif ($note =~ /MINISKIP/ && $ENV{PERL_CORE_MINITEST}) { skip("Doesn't work with miniperl", $yn =~ /=/ ? 2 : 1); } else { $res = eval $tstr; } chomp $@; if ( $yn =~ /@/ ) { ok( $@ ne '', "$tstr dies" ) and print "# \$\@ was: $@\n"; } else { my $test_name = $tstr . ($yn =~ /!/ ? " does not match" : " matches"); if ( $@ ne '' ) { fail($test_name); print "# \$\@ was: $@\n"; } else { ok( ($yn =~ /!/ xor $res), $test_name ); } } if ( $yn =~ s/=// ) { $tstr = "$right ~~ $left"; goto test_again; } } } sub foo {} sub bar {42} sub gorch {42} sub fatal {die "fatal sub\n"} # to test constant folding sub FALSE() { 0 } sub TRUE() { 1 } sub NOT_DEF() { undef } # Prefix character : # - expected to match # ! - expected to not match # @ - expected to be a compilation failure # = - expected to match symmetrically (runs test twice) # Data types to test : # undef # Object-overloaded # Object # Coderef # Hash # Hashref # Array # Arrayref # Tied arrays and hashes # Arrays that reference themselves # Regex (// and qr//) # Range # Num # Str # Other syntactic items of interest: # Constants # Values returned by a sub call __DATA__ # Any ~~ undef ! $ov_obj undef ! $obj undef ! sub {} undef ! %hash undef ! \%hash undef ! {} undef ! @nums undef ! \@nums undef ! [] undef ! %tied_hash undef ! @tied_nums undef ! $deep1 undef ! /foo/ undef ! qr/foo/ undef ! 21..30 undef ! 189 undef ! "foo" undef ! "" undef ! !1 undef undef undef (my $u) undef NOT_DEF undef &NOT_DEF undef # Any ~~ object overloaded ! \&fatal $ov_obj 'cigam' $ov_obj ! 'cigam on' $ov_obj ! ['cigam'] $ov_obj ! ['stringified'] $ov_obj ! { cigam => 1 } $ov_obj ! { stringified => 1 } $ov_obj ! $obj $ov_obj ! undef $ov_obj # regular object @ $obj $obj @ $ov_obj $obj =@ \&fatal $obj @ \&FALSE $obj @ \&foo $obj @ sub { 1 } $obj @ sub { 0 } $obj @ %keyandmore $obj @ {"key" => 1} $obj @ @fooormore $obj @ ["key" => 1] $obj @ /key/ $obj @ qr/key/ $obj @ "key" $obj @ FALSE $obj # regular object with "" overload @ $obj $str_obj =@ \&fatal $str_obj @ \&FALSE $str_obj @ \&foo $str_obj @ sub { 1 } $str_obj @ sub { 0 } $str_obj @ %keyandmore $str_obj @ {"object" => 1} $str_obj @ @fooormore $str_obj @ ["object" => 1] $str_obj @ /object/ $str_obj @ qr/object/ $str_obj @ "object" $str_obj @ FALSE $str_obj # Those will treat the $str_obj as a string because of fallback: ! $ov_obj $str_obj $ov_obj_2 $str_obj # object (overloaded or not) ~~ Any $obj qr/NoOverload/ $ov_obj qr/^stringified$/ = "$ov_obj" "stringified" = "$str_obj" "object" != $ov_obj "stringified" $str_obj "object" $ov_obj 'magic' ! $ov_obj 'not magic' # ~~ Coderef sub{0} sub { ref $_[0] eq "CODE" } %fooormore sub { $_[0] =~ /^(foo|or|more)$/ } ! %fooormore sub { $_[0] =~ /^(foo|or|less)$/ } \%fooormore sub { $_[0] =~ /^(foo|or|more)$/ } ! \%fooormore sub { $_[0] =~ /^(foo|or|less)$/ } +{%fooormore} sub { $_[0] =~ /^(foo|or|more)$/ } ! +{%fooormore} sub { $_[0] =~ /^(foo|or|less)$/ } @fooormore sub { $_[0] =~ /^(foo|or|more)$/ } ! @fooormore sub { $_[0] =~ /^(foo|or|less)$/ } \@fooormore sub { $_[0] =~ /^(foo|or|more)$/ } ! \@fooormore sub { $_[0] =~ /^(foo|or|less)$/ } [@fooormore] sub { $_[0] =~ /^(foo|or|more)$/ } ! [@fooormore] sub { $_[0] =~ /^(foo|or|less)$/ } %fooormore sub{@_==1} @fooormore sub{@_==1} "foo" sub { $_[0] =~ /^(foo|or|more)$/ } ! "more" sub { $_[0] =~ /^(foo|or|less)$/ } /fooormore/ sub{ref $_[0] eq 'Regexp'} qr/fooormore/ sub{ref $_[0] eq 'Regexp'} 1 sub{shift} ! 0 sub{shift} ! undef sub{shift} undef sub{not shift} NOT_DEF sub{not shift} &NOT_DEF sub{not shift} FALSE sub{not shift} [1] \&bar {a=>1} \&bar qr// \&bar ! [1] \&foo ! {a=>1} \&foo $obj sub { ref($_[0]) =~ /NoOverload/ } $ov_obj sub { ref($_[0]) =~ /WithOverload/ } # empty stuff matches, because the sub is never called: [] \&foo {} \&foo @empty \&foo %empty \&foo ! qr// \&foo ! undef \&foo undef \&bar @ undef \&fatal @ 1 \&fatal @ [1] \&fatal @ {a=>1} \&fatal @ "foo" \&fatal @ qr// \&fatal # sub is not called on empty hashes / arrays [] \&fatal +{} \&fatal @empty \&fatal %empty \&fatal # sub is not special on the left sub {0} qr/^CODE/ sub {0} sub { ref shift eq "CODE" } # HASH ref against: # - another hash ref {} {} =! {} {1 => 2} {1 => 2} {1 => 2} {1 => 2} {1 => 3} =! {1 => 2} {2 => 3} = \%main:: {map {$_ => 'x'} keys %main::} # - tied hash ref = \%hash \%tied_hash \%tied_hash \%tied_hash != {"a"=>"b"} \%tied_hash = %hash %tied_hash %tied_hash %tied_hash != {"a"=>"b"} %tied_hash $ov_obj %refh MINISKIP ! "$ov_obj" %refh MINISKIP [$ov_obj] %refh MINISKIP ! ["$ov_obj"] %refh MINISKIP %refh %refh MINISKIP # - an array ref # (since this is symmetrical, tests as well hash~~array) = [keys %main::] \%:: = [qw[STDIN STDOUT]] \%:: =! [] \%:: =! [""] {} =! [] {} =! @empty {} = [undef] {"" => 1} = [""] {"" => 1} = ["foo"] { foo => 1 } = ["foo", "bar"] { foo => 1 } = ["foo", "bar"] \%hash = ["foo"] \%hash =! ["quux"] \%hash = [qw(foo quux)] \%hash = @fooormore { foo => 1, or => 2, more => 3 } = @fooormore %fooormore = @fooormore \%fooormore = \@fooormore %fooormore # - a regex = qr/^(fo[ox])$/ {foo => 1} = /^(fo[ox])$/ %fooormore =! qr/[13579]$/ +{0..99} =! qr/a*/ {} = qr/a*/ {b=>2} = qr/B/i {b=>2} = /B/i {b=>2} =! qr/a+/ {b=>2} = qr/^à/ {"à"=>2} # - a scalar "foo" +{foo => 1, bar => 2} "foo" %fooormore ! "baz" +{foo => 1, bar => 2} ! "boz" %fooormore ! 1 +{foo => 1, bar => 2} ! 1 %fooormore 1 { 1 => 3 } 1.0 { 1 => 3 } ! "1.0" { 1 => 3 } ! "1.0" { 1.0 => 3 } "1.0" { "1.0" => 3 } "à" { "à" => "À" } # - undef ! undef { hop => 'zouu' } ! undef %hash ! undef +{"" => "empty key"} ! undef {} # ARRAY ref against: # - another array ref [] [] =! [] [1] [["foo"], ["bar"]] [qr/o/, qr/a/] ! [["foo"], ["bar"]] [qr/ARRAY/, qr/ARRAY/] ["foo", "bar"] [qr/o/, qr/a/] ! [qr/o/, qr/a/] ["foo", "bar"] ["foo", "bar"] [["foo"], ["bar"]] ! ["foo", "bar"] [qr/o/, "foo"] ["foo", undef, "bar"] [qr/o/, undef, "bar"] ! ["foo", undef, "bar"] [qr/o/, "", "bar"] ! ["foo", "", "bar"] [qr/o/, undef, "bar"] $deep1 $deep1 @$deep1 @$deep1 ! $deep1 $deep2 = \@nums \@tied_nums = @nums \@tied_nums = \@nums @tied_nums = @nums @tied_nums # - an object ! $obj @fooormore $obj [sub{ref shift}] # - a regex = qr/x/ [qw(foo bar baz quux)] =! qr/y/ [qw(foo bar baz quux)] = /x/ [qw(foo bar baz quux)] =! /y/ [qw(foo bar baz quux)] = /FOO/i @fooormore =! /bar/ @fooormore # - a number 2 [qw(1.00 2.00)] 2 [qw(foo 2)] 2.0_0e+0 [qw(foo 2)] ! 2 [qw(1foo bar2)] # - a string ! "2" [qw(1foo 2bar)] "2bar" [qw(1foo 2bar)] # - undef undef [1, 2, undef, 4] ! undef [1, 2, [undef], 4] ! undef @fooormore undef @sparse undef [undef] ! 0 [undef] ! "" [undef] ! undef [0] ! undef [""] # - nested arrays and ~~ distributivity 11 [[11]] ! 11 [[12]] "foo" [{foo => "bar"}] ! "bar" [{foo => "bar"}] # Number against number 2 2 20 2_0 ! 2 3 0 FALSE 3-2 TRUE ! undef 0 ! (my $u) 0 # Number against string = 2 "2" = 2 "2.0" ! 2 "2bananas" != 2_3 "2_3" NOWARNINGS FALSE "0" ! undef "0" ! undef "" # Regex against string "x" qr/x/ ! "x" qr/y/ # Regex against number 12345 qr/3/ ! 12345 qr/7/ # array/hash against string @fooormore "".\@fooormore ! @keyandmore "".\@fooormore %fooormore "".\%fooormore ! %keyandmore "".\%fooormore # Test the implicit referencing 7 @nums @nums \@nums ! @nums \\@nums @nums [1..10] ! @nums [0..9] "foo" %hash /bar/ %hash [qw(bar)] %hash ! [qw(a b c)] %hash %hash %hash %hash +{%hash} %hash \%hash %hash %tied_hash %tied_hash %tied_hash %hash { foo => 5, bar => 10 } ! %hash { foo => 5, bar => 10, quux => 15 } @nums { 1, '', 2, '' } @nums { 1, '', 12, '' } ! @nums { 11, '', 12, '' } # UNDEF ! 3 undef ! 1 undef ! [] undef ! {} undef ! \%::main undef ! [1,2] undef ! %hash undef ! @nums undef ! "foo" undef ! "" undef ! !1 undef ! \&foo undef ! sub { } undef perl-5.12.0-RC0/t/op/splice.t0000555000175000017500000000403311325125742014457 0ustar jessejesse#!./perl print "1..18\n"; @a = (1..10); sub j { join(":",@_) } print "not " unless j(splice(@a,@a,0,11,12)) eq "" && j(@a) eq j(1..12); print "ok 1\n"; print "not " unless j(splice(@a,-1)) eq "12" && j(@a) eq j(1..11); print "ok 2\n"; print "not " unless j(splice(@a,0,1)) eq "1" && j(@a) eq j(2..11); print "ok 3\n"; print "not " unless j(splice(@a,0,0,0,1)) eq "" && j(@a) eq j(0..11); print "ok 4\n"; print "not " unless j(splice(@a,5,1,5)) eq "5" && j(@a) eq j(0..11); print "ok 5\n"; print "not " unless j(splice(@a, @a, 0, 12, 13)) eq "" && j(@a) eq j(0..13); print "ok 6\n"; print "not " unless j(splice(@a, -@a, @a, 1, 2, 3)) eq j(0..13) && j(@a) eq j(1..3); print "ok 7\n"; print "not " unless j(splice(@a, 1, -1, 7, 7)) eq "2" && j(@a) eq j(1,7,7,3); print "ok 8\n"; print "not " unless j(splice(@a,-3,-2,2)) eq j(7) && j(@a) eq j(1,2,7,3); print "ok 9\n"; # Bug 20000223.001 - no test for splice(@array). Destructive test! print "not " unless j(splice(@a)) eq j(1,2,7,3) && j(@a) eq ''; print "ok 10\n"; # Tests 11 and 12: # [ID 20010711.005] in Tie::Array, SPLICE ignores context, breaking SHIFT my $foo; @a = ('red', 'green', 'blue'); $foo = splice @a, 1, 2; print "not " unless $foo eq 'blue'; print "ok 11\n"; @a = ('red', 'green', 'blue'); $foo = shift @a; print "not " unless $foo eq 'red'; print "ok 12\n"; # Bug [perl #30568] - insertions of deleted elements @a = (1, 2, 3); splice( @a, 0, 3, $a[1], $a[0] ); print "not " unless j(@a) eq j(2,1); print "ok 13\n"; @a = (1, 2, 3); splice( @a, 0, 3 ,$a[0], $a[1] ); print "not " unless j(@a) eq j(1,2); print "ok 14\n"; @a = (1, 2, 3); splice( @a, 0, 3 ,$a[2], $a[1], $a[0] ); print "not " unless j(@a) eq j(3,2,1); print "ok 15\n"; @a = (1, 2, 3); splice( @a, 0, 3, $a[0], $a[1], $a[2], $a[0], $a[1], $a[2] ); print "not " unless j(@a) eq j(1,2,3,1,2,3); print "ok 16\n"; @a = (1, 2, 3); splice( @a, 1, 2, $a[2], $a[1] ); print "not " unless j(@a) eq j(1,3,2); print "ok 17\n"; @a = (1, 2, 3); splice( @a, 1, 2, $a[1], $a[1] ); print "not " unless j(@a) eq j(1,2,2); print "ok 18\n"; perl-5.12.0-RC0/t/op/join.t0000555000175000017500000000551611325125742014146 0ustar jessejesse#!./perl print "1..22\n"; @x = (1, 2, 3); if (join(':',@x) eq '1:2:3') {print "ok 1\n";} else {print "not ok 1\n";} if (join('',1,2,3) eq '123') {print "ok 2\n";} else {print "not ok 2\n";} if (join(':',split(/ /,"1 2 3")) eq '1:2:3') {print "ok 3\n";} else {print "not ok 3\n";} my $f = 'a'; $f = join ',', 'b', $f, 'e'; if ($f eq 'b,a,e') {print "ok 4\n";} else {print "# '$f'\nnot ok 4\n";} $f = 'a'; $f = join ',', $f, 'b', 'e'; if ($f eq 'a,b,e') {print "ok 5\n";} else {print "not ok 5\n";} $f = 'a'; $f = join $f, 'b', 'e', 'k'; if ($f eq 'baeak') {print "ok 6\n";} else {print "# '$f'\nnot ok 6\n";} # 7,8 check for multiple read of tied objects { package X; sub TIESCALAR { my $x = 7; bless \$x }; sub FETCH { my $y = shift; $$y += 5 }; tie my $t, 'X'; my $r = join ':', $t, 99, $t, 99; print "# expected '12:99:17:99' got '$r'\nnot " if $r ne '12:99:17:99'; print "ok 7\n"; $r = join '', $t, 99, $t, 99; print "# expected '22992799' got '$r'\nnot " if $r ne '22992799'; print "ok 8\n"; }; # 9,10 and for multiple read of undef { my $s = 5; local ($^W, $SIG{__WARN__}) = ( 1, sub { $s+=4 } ); my $r = join ':', 'a', undef, $s, 'b', undef, $s, 'c'; print "# expected 'a::9:b::13:c' got '$r'\nnot " if $r ne 'a::9:b::13:c'; print "ok 9\n"; my $r = join '', 'a', undef, $s, 'b', undef, $s, 'c'; print "# expected 'a17b21c' got '$r'\nnot " if $r ne 'a17b21c'; print "ok 10\n"; }; { my $s = join("", chr(0x1234), chr(0xff)); print "not " unless length($s) == 2 && $s eq "\x{1234}\x{ff}"; print "ok 11\n"; } { my $s = join(chr(0xff), chr(0x1234), ""); print "not " unless length($s) == 2 && $s eq "\x{1234}\x{ff}"; print "ok 12\n"; } { my $s = join(chr(0x1234), chr(0xff), chr(0x2345)); print "not " unless length($s) == 3 && $s eq "\x{ff}\x{1234}\x{2345}"; print "ok 13\n"; } { my $s = join(chr(0xff), chr(0x1234), chr(0xfe)); print "not " unless length($s) == 3 && $s eq "\x{1234}\x{ff}\x{fe}"; print "ok 14\n"; } { # [perl #24846] $jb2 should be in bytes, not in utf8. my $b = "abc\304"; my $u = "abc\x{0100}"; sub join_into_my_variable { my $r = join("", @_); return $r; } my $jb1 = join_into_my_variable("", $b); my $ju1 = join_into_my_variable("", $u); my $jb2 = join_into_my_variable("", $b); my $ju2 = join_into_my_variable("", $u); { use bytes; print "not " unless $jb1 eq $b; print "ok 15\n"; } print "not " unless $jb1 eq $b; print "ok 16\n"; { use bytes; print "not " unless $ju1 eq $u; print "ok 17\n"; } print "not " unless $ju1 eq $u; print "ok 18\n"; { use bytes; print "not " unless $jb2 eq $b; print "ok 19\n"; } print "not " unless $jb2 eq $b; print "ok 20\n"; { use bytes; print "not " unless $ju2 eq $u; print "ok 21\n"; } print "not " unless $ju2 eq $u; print "ok 22\n"; } perl-5.12.0-RC0/t/op/avhv.t0000555000175000017500000001005511325125742014145 0ustar jessejesse#!./perl # This test was originally for pseudo-hashes. It now exists to ensure # they were properly removed in 5.9. BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } require Tie::Array; package Tie::BasicArray; @ISA = 'Tie::Array'; sub TIEARRAY { bless [], $_[0] } sub STORE { $_[0]->[$_[1]] = $_[2] } sub FETCH { $_[0]->[$_[1]] } sub FETCHSIZE { scalar(@{$_[0]})} sub STORESIZE { $#{$_[0]} = $_[1]+1 } package main; require './test.pl'; plan(tests => 40); # Helper function to check the typical error message. sub not_hash { my($err) = shift; like( $err, qr/^Not a HASH reference / ) || printf STDERR "# at %s line %d.\n", (caller)[1,2]; } # Something to place inside if blocks and while loops that won't get # compiled out. my $foo = 42; sub no_op { $foo++ } $sch = { 'abc' => 1, 'def' => 2, 'jkl' => 3, }; # basic normal array $a = []; $a->[0] = $sch; eval { $a->{'abc'} = 'ABC'; }; not_hash($@); eval { $a->{'def'} = 'DEF'; }; not_hash($@); eval { $a->{'jkl'} = 'JKL'; }; not_hash($@); eval { @keys = keys %$a; }; not_hash($@); eval { @values = values %$a; }; not_hash($@); eval { while( my($k,$v) = each %$a ) { no_op; } }; not_hash($@); # quick check with tied array tie @fake, 'Tie::StdArray'; $a = \@fake; $a->[0] = $sch; eval { $a->{'abc'} = 'ABC'; }; not_hash($@); eval { if ($a->{'abc'} eq 'ABC') { no_op(23) } else { no_op(42) } }; not_hash($@); # quick check with tied array tie @fake, 'Tie::BasicArray'; $a = \@fake; $a->[0] = $sch; eval { $a->{'abc'} = 'ABC'; }; not_hash($@); eval { if ($a->{'abc'} eq 'ABC') { no_op(23) } else { no_op(42) } }; not_hash($@); # quick check with tied array & tied hash require Tie::Hash; tie %fake, Tie::StdHash; %fake = %$sch; $a->[0] = \%fake; eval { $a->{'abc'} = 'ABC'; }; not_hash($@); eval { if ($a->{'abc'} eq 'ABC') { no_op(23) } else { no_op(42) } }; not_hash($@); # hash slice eval { my $slice = join('', 'x',@$a{'abc','def'},'x'); }; not_hash($@); # evaluation in scalar context my $avhv = [{}]; eval { () = %$avhv; }; not_hash($@); push @$avhv, "a"; eval { () = %$avhv; }; not_hash($@); $avhv = []; eval { $a = %$avhv }; not_hash($@); $avhv = [{foo=>1, bar=>2}]; eval { %$avhv =~ m,^\d+/\d+,; }; not_hash($@); # check if defelem magic works sub f { print "not " unless $_[0] eq 'a'; $_[0] = 'b'; print "ok 11\n"; } $a = [{key => 1}, 'a']; eval { f($a->{key}); }; not_hash($@); # check if exists() is behaving properly $avhv = [{foo=>1,bar=>2,pants=>3}]; eval { no_op if exists $avhv->{bar}; }; not_hash($@); eval { $avhv->{pants} = undef; }; not_hash($@); eval { no_op if exists $avhv->{pants}; }; not_hash($@); eval { no_op if exists $avhv->{bar}; }; not_hash($@); eval { $avhv->{bar} = 10; }; not_hash($@); eval { no_op unless exists $avhv->{bar} and $avhv->{bar} == 10; }; not_hash($@); eval { $v = delete $avhv->{bar}; }; not_hash($@); eval { no_op if exists $avhv->{bar}; }; not_hash($@); eval { $avhv->{foo} = 'xxx'; }; not_hash($@); eval { $avhv->{bar} = 'yyy'; }; not_hash($@); eval { $avhv->{pants} = 'zzz'; }; not_hash($@); eval { @x = delete @{$avhv}{'foo','pants'}; }; not_hash($@); eval { no_op unless "$avhv->{bar}" eq "yyy"; }; not_hash($@); # hash assignment eval { %$avhv = (); }; not_hash($@); eval { %hv = %$avhv; }; not_hash($@); eval { %$avhv = (foo => 29, pants => 2, bar => 0); }; not_hash($@); my $extra; my @extra; eval { ($extra, %$avhv) = ("moo", foo => 42, pants => 53, bar => "HIKE!"); }; not_hash($@); eval { %$avhv = (); (%$avhv, $extra) = (foo => 42, pants => 53, bar => "HIKE!"); }; not_hash($@); eval { @extra = qw(whatever and stuff); %$avhv = (); }; not_hash($@); eval { (%$avhv, @extra) = (foo => 42, pants => 53, bar => "HIKE!"); }; not_hash($@); eval { (@extra, %$avhv) = (foo => 42, pants => 53, bar => "HIKE!"); }; not_hash($@); # Check hash slices (BUG ID 20010423.002) $avhv = [{foo=>1, bar=>2}]; eval { @$avhv{"foo", "bar"} = (42, 53); }; not_hash($@); perl-5.12.0-RC0/t/op/read.t0000555000175000017500000000443711325125742014123 0ustar jessejesse#!./perl BEGIN { chdir 't'; @INC = '../lib'; require './test.pl'; } use strict; plan tests => 2564; open(FOO,'op/read.t') || open(FOO,'t/op/read.t') || open(FOO,':op:read.t') || die "Can't open op.read"; seek(FOO,4,0) or die "Seek failed: $!"; my $buf; my $got = read(FOO,$buf,4); is ($got, 4); is ($buf, "perl"); seek (FOO,0,2) || seek(FOO,20000,0); $got = read(FOO,$buf,4); is ($got, 0); is ($buf, ""); # This is true if Config is not built, or if PerlIO is enabled # ie assume that PerlIO is present, unless we know for sure otherwise. my $has_perlio = !eval { no warnings; require Config; !$Config::Config{useperlio} }; my $tmpfile = tempfile(); my (@values, @buffers) = ('', ''); foreach (65, 161, 253, 9786) { push @values, join "", map {chr $_} $_ .. $_ + 4; push @buffers, join "", map {chr $_} $_ + 5 .. $_ + 20; } my @offsets = (0, 3, 7, 22, -1, -3, -5, -7); my @lengths = (0, 2, 5, 10); foreach my $value (@values) { foreach my $initial_buffer (@buffers) { my @utf8 = 1; if ($value !~ tr/\0-\377//c) { # It's all 8 bit unshift @utf8, 0; } SKIP: foreach my $utf8 (@utf8) { skip "Needs :utf8 layer but no perlio", 2 * @offsets * @lengths if $utf8 and !$has_perlio; open FH, ">$tmpfile" or die "Can't open $tmpfile: $!"; binmode FH, "utf8" if $utf8; print FH $value; close FH; foreach my $offset (@offsets) { foreach my $length (@lengths) { # Will read the lesser of the length of the file and the # read length my $will_read = $value; if ($length < length $will_read) { substr ($will_read, $length) = ''; } # Going to trash this so need a copy my $buffer = $initial_buffer; my $expect = $buffer; if ($offset > 0) { # Right pad with NUL bytes $expect .= "\0" x $offset; substr ($expect, $offset) = ''; } substr ($expect, $offset) = $will_read; open FH, $tmpfile or die "Can't open $tmpfile: $!"; binmode FH, "utf8" if $utf8; my $what = sprintf "%d into %d l $length o $offset", ord $value, ord $buffer; $what .= ' u' if $utf8; $got = read (FH, $buffer, $length, $offset); is ($got, length $will_read, "got $what"); is ($buffer, $expect, "buffer $what"); close FH; } } } } } perl-5.12.0-RC0/t/op/runlevel.t0000555000175000017500000001466311325127001015034 0ustar jessejesse#!./perl ## ## Many of these tests are originally from Michael Schroeder ## ## Adapted and expanded by Gurusamy Sarathy ## chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; $Is_VMS = $^O eq 'VMS'; $Is_MSWin32 = $^O eq 'MSWin32'; $Is_NetWare = $^O eq 'NetWare'; $ENV{PERL5LIB} = "../lib" unless $Is_VMS; $|=1; undef $/; @prgs = split "\n########\n", ; print "1..", scalar @prgs, "\n"; $tmpfile = tempfile(); for (@prgs){ my $switch = ""; if (s/^\s*(-\w+)//){ $switch = $1; } my($prog,$expected) = split(/\nEXPECT\n/, $_); open TEST, ">$tmpfile"; print TEST "$prog\n"; close TEST or die "Could not close: $!"; my $results = $Is_VMS ? `$^X "-I[-.lib]" $switch $tmpfile 2>&1` : $Is_MSWin32 ? `.\\perl -I../lib $switch $tmpfile 2>&1` : $Is_NetWare ? `perl -I../lib $switch $tmpfile 2>&1` : `./perl $switch $tmpfile 2>&1`; my $status = $?; $results =~ s/\n+$//; # allow expected output to be written as if $prog is on STDIN $results =~ s/$::tempfile_regexp/-/ig; $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg $expected =~ s/\n+$//; if ($results ne $expected) { print STDERR "PROG: $switch\n$prog\n"; print STDERR "EXPECTED:\n$expected\n"; print STDERR "GOT:\n$results\n"; print "not "; } print "ok ", ++$i, "\n"; } __END__ @a = (1, 2, 3); { @a = sort { last ; } @a; } EXPECT Can't "last" outside a loop block at - line 3. ######## package TEST; sub TIESCALAR { my $foo; return bless \$foo; } sub FETCH { eval 'die("test")'; print "still in fetch\n"; return ">$@<"; } package main; tie $bar, TEST; print "- $bar\n"; EXPECT still in fetch - >test at (eval 1) line 1. < ######## package TEST; sub TIESCALAR { my $foo; eval('die("foo\n")'); print "after eval\n"; return bless \$foo; } sub FETCH { return "ZZZ"; } package main; tie $bar, TEST; print "- $bar\n"; print "OK\n"; EXPECT after eval - ZZZ OK ######## package TEST; sub TIEHANDLE { my $foo; return bless \$foo; } sub PRINT { print STDERR "PRINT CALLED\n"; (split(/./, 'x'x10000))[0]; eval('die("test\n")'); } package main; open FH, ">&STDOUT"; tie *FH, TEST; print FH "OK\n"; print STDERR "DONE\n"; EXPECT PRINT CALLED DONE ######## sub warnhook { print "WARNHOOK\n"; eval('die("foooo\n")'); } $SIG{'__WARN__'} = 'warnhook'; warn("dfsds\n"); print "END\n"; EXPECT WARNHOOK END ######## package TEST; use overload "\"\"" => \&str ; sub str { eval('die("test\n")'); return "STR"; } package main; $bar = bless {}, TEST; print "$bar\n"; print "OK\n"; EXPECT STR OK ######## sub foo { $a <=> $b unless eval('$a == 0 ? bless undef : ($a <=> $b)'); } @a = (3, 2, 0, 1); @a = sort foo @a; print join(', ', @a)."\n"; EXPECT 0, 1, 2, 3 ######## sub foo { goto bar if $a == 0 || $b == 0; $a <=> $b; } @a = (3, 2, 0, 1); @a = sort foo @a; print join(', ', @a)."\n"; exit; bar: print "bar reached\n"; EXPECT Can't "goto" out of a pseudo block at - line 2. ######## %seen = (); sub sortfn { (split(/./, 'x'x10000))[0]; my (@y) = ( 4, 6, 5); @y = sort { $a <=> $b } @y; my $t = "sortfn ".join(', ', @y)."\n"; print $t if ($seen{$t}++ == 0); return $_[0] <=> $_[1]; } @x = ( 3, 2, 1 ); @x = sort { &sortfn($a, $b) } @x; print "---- ".join(', ', @x)."\n"; EXPECT sortfn 4, 5, 6 ---- 1, 2, 3 ######## @a = (3, 2, 1); @a = sort { eval('die("no way")') , $a <=> $b} @a; print join(", ", @a)."\n"; EXPECT 1, 2, 3 ######## @a = (1, 2, 3); foo: { @a = sort { last foo; } @a; } EXPECT Label not found for "last foo" at - line 2. ######## package TEST; sub TIESCALAR { my $foo; return bless \$foo; } sub FETCH { next; return "ZZZ"; } sub STORE { } package main; tie $bar, TEST; { print "- $bar\n"; } print "OK\n"; EXPECT Can't "next" outside a loop block at - line 8. ######## package TEST; sub TIESCALAR { my $foo; return bless \$foo; } sub FETCH { goto bbb; return "ZZZ"; } package main; tie $bar, TEST; print "- $bar\n"; exit; bbb: print "bbb\n"; EXPECT Can't find label bbb at - line 8. ######## sub foo { $a <=> $b unless eval('$a == 0 ? die("foo\n") : ($a <=> $b)'); } @a = (3, 2, 0, 1); @a = sort foo @a; print join(', ', @a)."\n"; EXPECT 0, 1, 2, 3 ######## package TEST; sub TIESCALAR { my $foo; return bless \$foo; } sub FETCH { return "fetch"; } sub STORE { (split(/./, 'x'x10000))[0]; } package main; tie $bar, TEST; $bar = "x"; ######## package TEST; sub TIESCALAR { my $foo; next; return bless \$foo; } package main; { tie $bar, TEST; } EXPECT Can't "next" outside a loop block at - line 4. ######## @a = (1, 2, 3); foo: { @a = sort { exit(0) } @a; } END { print "foobar\n" } EXPECT foobar ######## $SIG{__DIE__} = sub { print "In DIE\n"; $i = 0; while (($p,$f,$l,$s) = caller(++$i)) { print "$p|$f|$l|$s\n"; } }; eval { die }; &{sub { eval 'die' }}(); sub foo { eval { die } } foo(); {package rmb; sub{ eval{die} } ->() }; # check __ANON__ knows package EXPECT In DIE main|-|8|(eval) In DIE main|-|9|(eval) main|-|9|main::__ANON__ In DIE main|-|10|(eval) main|-|10|main::foo In DIE rmb|-|11|(eval) rmb|-|11|rmb::__ANON__ ######## package TEST; sub TIEARRAY { return bless [qw(foo fee fie foe)], $_[0]; } sub FETCH { my ($s,$i) = @_; if ($i) { goto bbb; } bbb: return $s->[$i]; } package main; tie my @bar, 'TEST'; print join('|', @bar[0..3]), "\n"; EXPECT foo|fee|fie|foe ######## package TH; sub TIEHASH { bless {}, TH } sub STORE { eval { print "@_[1,2]\n" }; die "bar\n" } tie %h, TH; eval { $h{A} = 1; print "never\n"; }; print $@; eval { $h{B} = 2; }; print $@; EXPECT A 1 bar B 2 bar ######## sub n { 0 } sub f { my $x = shift; d(); } f(n()); f(); sub d { my $i = 0; my @a; while (do { { package DB; @a = caller($i++) } } ) { @a = @DB::args; for (@a) { print "$_\n"; $_ = '' } } } EXPECT 0 ######## sub TIEHANDLE { bless {} } sub PRINT { next } tie *STDERR, ''; { map ++$_, 1 } EXPECT Can't "next" outside a loop block at - line 2. ######## sub TIEHANDLE { bless {} } sub PRINT { print "[TIE] $_[1]" } tie *STDERR, ''; die "DIE\n"; EXPECT [TIE] DIE ######## sub TIEHANDLE { bless {} } sub PRINT { (split(/./, 'x'x10000))[0]; eval('die("test\n")'); warn "[TIE] $_[1]"; } open OLDERR, '>&STDERR'; tie *STDERR, ''; use warnings FATAL => qw(uninitialized); print undef; EXPECT [TIE] Use of uninitialized value in print at - line 11. perl-5.12.0-RC0/t/op/vec.t0000555000175000017500000000407411325125742013762 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = qw(. ../lib); } require "test.pl"; plan( tests => 31 ); my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0; is(vec($foo,0,1), 0); is(length($foo), undef); vec($foo,0,1) = 1; is(length($foo), 1); is(unpack('C',$foo), 1); is(vec($foo,0,1), 1); is(vec($foo,20,1), 0); vec($foo,20,1) = 1; is(vec($foo,20,1), 1); is(length($foo), 3); is(vec($foo,1,8), 0); vec($foo,1,8) = 0xf1; is(vec($foo,1,8), 0xf1); is((unpack('C',substr($foo,1,1)) & 255), 0xf1); is(vec($foo,2,4), 1);; is(vec($foo,3,4), 15); vec($Vec, 0, 32) = 0xbaddacab; is($Vec, "\xba\xdd\xac\xab"); is(vec($Vec, 0, 32), 3135089835); # ensure vec() handles numericalness correctly $foo = $bar = $baz = 0; vec($foo = 0,0,1) = 1; vec($bar = 0,1,1) = 1; $baz = $foo | $bar; ok($foo eq "1" && $foo == 1); ok($bar eq "2" && $bar == 2); ok("$foo $bar $baz" eq "1 2 3"); # error cases $x = eval { vec $foo, 0, 3 }; like($@, qr/^Illegal number of bits in vec/); $@ = undef; $x = eval { vec $foo, 0, 0 }; like($@, qr/^Illegal number of bits in vec/); $@ = undef; $x = eval { vec $foo, 0, -13 }; like($@, qr/^Illegal number of bits in vec/); $@ = undef; $x = eval { vec($foo, -1, 4) = 2 }; like($@, qr/^Negative offset to vec in lvalue context/); $@ = undef; ok(! vec('abcd', 7, 8)); # UTF8 # N.B. currently curiously coded to circumvent bugs elswhere in UTF8 handling $foo = "\x{100}" . "\xff\xfe"; $x = substr $foo, 1; is(vec($x, 0, 8), 255); $@ = undef; eval { vec($foo, 1, 8) }; ok(! $@); $@ = undef; eval { vec($foo, 1, 8) = 13 }; ok(! $@); if ($Is_EBCDIC) { is($foo, "\x8c\x0d\xff\x8a\x69"); } else { is($foo, "\xc4\x0d\xc3\xbf\xc3\xbe"); } $foo = "\x{100}" . "\xff\xfe"; $x = substr $foo, 1; vec($x, 2, 4) = 7; is($x, "\xff\xf7"); # mixed magic $foo = "\x61\x62\x63\x64\x65\x66"; is(vec(substr($foo, 2, 2), 0, 16), 25444); vec(substr($foo, 1,3), 5, 4) = 3; is($foo, "\x61\x62\x63\x34\x65\x66"); # A variation of [perl #20933] { my $s = ""; vec($s, 0, 1) = 0; vec($s, 1, 1) = 1; my @r; $r[$_] = \ vec $s, $_, 1 for (0, 1); ok(!(${ $r[0] } != 0 || ${ $r[1] } != 1)); } perl-5.12.0-RC0/t/op/pack.t0000555000175000017500000020141511325125742014121 0ustar jessejesse#!./perl -w BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } # This is truth in an if statement, and could be a skip message my $no_endianness = $] > 5.009 ? '' : "Endianness pack modifiers not available on this perl"; my $no_signedness = $] > 5.009 ? '' : "Signed/unsigned pack modifiers not available on this perl"; plan tests => 14697; use strict; use warnings qw(FATAL all); use Config; my $Is_EBCDIC = (defined $Config{ebcdic} && $Config{ebcdic} eq 'define'); my $Perl = which_perl(); my @valid_errors = (qr/^Invalid type '\w'/); my $ByteOrder = 'unknown'; my $maybe_not_avail = '(?:hto[bl]e|[bl]etoh)'; if ($no_endianness) { push @valid_errors, qr/^Invalid type '[<>]'/; } elsif ($Config{byteorder} =~ /^1234(?:5678)?$/) { $ByteOrder = 'little'; $maybe_not_avail = '(?:htobe|betoh)'; } elsif ($Config{byteorder} =~ /^(?:8765)?4321$/) { $ByteOrder = 'big'; $maybe_not_avail = '(?:htole|letoh)'; } else { push @valid_errors, qr/^Can't (?:un)?pack (?:big|little)-endian .*? on this platform/; } if ($no_signedness) { push @valid_errors, qr/^'!' allowed only after types sSiIlLxX in (?:un)?pack/; } for my $size ( 16, 32, 64 ) { if (defined $Config{"u${size}size"} and ($Config{"u${size}size"}||0) != ($size >> 3)) { push @valid_errors, qr/^Perl_my_$maybe_not_avail$size\(\) not available/; } } my $IsTwosComplement = pack('i', -1) eq "\xFF" x $Config{intsize}; print "# \$IsTwosComplement = $IsTwosComplement\n"; sub is_valid_error { my $err = shift; for my $e (@valid_errors) { $err =~ $e and return 1; } return 0; } sub encode_list { my @result = map {_qq($_)} @_; if (@result == 1) { return @result; } return '(' . join (', ', @result) . ')'; } sub list_eq ($$) { my ($l, $r) = @_; return 0 unless @$l == @$r; for my $i (0..$#$l) { if (defined $l->[$i]) { return 0 unless defined ($r->[$i]) && $l->[$i] eq $r->[$i]; } else { return 0 if defined $r->[$i] } } return 1; } ############################################################################## # # Here starteth the tests # { my $format = "c2 x5 C C x s d i l a6"; # Need the expression in here to force ary[5] to be numeric. This avoids # test2 failing because ary2 goes str->numeric->str and ary doesn't. my @ary = (1,-100,127,128,32767,987.654321098 / 100.0,12345,123456, "abcdef"); my $foo = pack($format,@ary); my @ary2 = unpack($format,$foo); is($#ary, $#ary2); my $out1=join(':',@ary); my $out2=join(':',@ary2); # Using long double NVs may introduce greater accuracy than wanted. $out1 =~ s/:9\.87654321097999\d*:/:9.87654321098:/; $out2 =~ s/:9\.87654321097999\d*:/:9.87654321098:/; is($out1, $out2); like($foo, qr/def/); } # How about counting bits? { my $x; is( ($x = unpack("%32B*", "\001\002\004\010\020\040\100\200\377")), 16 ); is( ($x = unpack("%32b69", "\001\002\004\010\020\040\100\200\017")), 12 ); is( ($x = unpack("%32B69", "\001\002\004\010\020\040\100\200\017")), 9 ); } { my $sum = 129; # ASCII $sum = 103 if $Is_EBCDIC; my $x; is( ($x = unpack("%32B*", "Now is the time for all good blurfl")), $sum ); my $foo; open(BIN, $Perl) || die "Can't open $Perl: $!\n"; binmode BIN; sysread BIN, $foo, 8192; close BIN; $sum = unpack("%32b*", $foo); my $longway = unpack("b*", $foo); is( $sum, $longway =~ tr/1/1/ ); } { my $x; is( ($x = unpack("I",pack("I", 0xFFFFFFFF))), 0xFFFFFFFF ); } { # check 'w' my @x = (5,130,256,560,32000,3097152,268435455,1073741844, 2**33, '4503599627365785','23728385234614992549757750638446'); my $x = pack('w*', @x); my $y = pack 'H*', '0581028200843081fa0081bd8440ffffff7f8480808014A0808'. '0800087ffffffffffdb19caefe8e1eeeea0c2e1e3e8ede1ee6e'; is($x, $y); my @y = unpack('w*', $y); my $a; while ($a = pop @x) { my $b = pop @y; is($a, $b); } @y = unpack('w2', $x); is(scalar(@y), 2); is($y[1], 130); $x = pack('w*', 5000000000); $y = ''; eval { use Math::BigInt; $y = pack('w*', Math::BigInt::->new(5000000000)); }; is($x, $y); $x = pack 'w', ~0; $y = pack 'w', (~0).''; is($x, $y); is(unpack ('w',$x), ~0); is(unpack ('w',$y), ~0); $x = pack 'w', ~0 - 1; $y = pack 'w', (~0) - 2; if (~0 - 1 == (~0) - 2) { is($x, $y, "NV arithmetic"); } else { isnt($x, $y, "IV/NV arithmetic"); } cmp_ok(unpack ('w',$x), '==', ~0 - 1); cmp_ok(unpack ('w',$y), '==', ~0 - 2); # These should spot that pack 'w' is using NV, not double, on platforms # where IVs are smaller than doubles, and harmlessly pass elsewhere. # (tests for change 16861) my $x0 = 2**54+3; my $y0 = 2**54-2; $x = pack 'w', $x0; $y = pack 'w', $y0; if ($x0 == $y0) { is($x, $y, "NV arithmetic"); } else { isnt($x, $y, "IV/NV arithmetic"); } cmp_ok(unpack ('w',$x), '==', $x0); cmp_ok(unpack ('w',$y), '==', $y0); } { print "# test exceptions\n"; my $x; eval { $x = unpack 'w', pack 'C*', 0xff, 0xff}; like($@, qr/^Unterminated compressed integer/); eval { $x = unpack 'w', pack 'C*', 0xff, 0xff, 0xff, 0xff}; like($@, qr/^Unterminated compressed integer/); eval { $x = unpack 'w', pack 'C*', 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff}; like($@, qr/^Unterminated compressed integer/); eval { $x = pack 'w', -1 }; like ($@, qr/^Cannot compress negative numbers/); eval { $x = pack 'w', '1'x(1 + length ~0) . 'e0' }; like ($@, qr/^Can only compress unsigned integers/); # Check that the warning behaviour on the modifiers !, < and > is as we # expect it for this perl. my $can_endian = $no_endianness ? '' : 'sSiIlLqQjJfFdDpP'; my $can_shriek = 'sSiIlL'; $can_shriek .= 'nNvV' unless $no_signedness; # h and H can't do either, so act as sanity checks in blead foreach my $base (split '', 'hHsSiIlLqQjJfFdDpPnNvV') { foreach my $mod ('', '<', '>', '!', '!', '!<', '!>') { SKIP: { # Avoid void context warnings. my $a = eval {pack "$base$mod"}; skip "pack can't $base", 1 if $@ =~ /^Invalid type '\w'/; # Which error you get when 2 would be possible seems to be emergent # behaviour of pack's format parser. my $fails_shriek = $mod =~ /!/ && index ($can_shriek, $base) == -1; my $fails_endian = $mod =~ /[<>]/ && index ($can_endian, $base) == -1; my $shriek_first = $mod =~ /^!/; if ($no_endianness and ($mod eq '!')) { # The ! isn't seem as part of $base. Instead it's seen as a modifier # on > or < $fails_shriek = 1; undef $fails_endian; } elsif ($fails_shriek and $fails_endian) { if ($shriek_first) { undef $fails_endian; } } if ($fails_endian) { if ($no_endianness) { # < and > are seen as pattern letters, not modifiers like ($@, qr/^Invalid type '[<>]'/, "pack can't $base$mod"); } else { like ($@, qr/^'[<>]' allowed only after types/, "pack can't $base$mod"); } } elsif ($fails_shriek) { like ($@, qr/^'!' allowed only after types/, "pack can't $base$mod"); } else { is ($@, '', "pack can $base$mod"); } } } } SKIP: { skip $no_endianness, 2*3 + 2*8 if $no_endianness; for my $mod (qw( ! < > )) { eval { $x = pack "a$mod", 42 }; like ($@, qr/^'$mod' allowed only after types \S+ in pack/); eval { $x = unpack "a$mod", 'x'x8 }; like ($@, qr/^'$mod' allowed only after types \S+ in unpack/); } for my $mod (qw( <> >< !<> !>< >!< <>! >' after type 'I' in pack/); eval { $x = unpack "sI${mod}s", 'x'x16 }; like ($@, qr/^Can't use both '<' and '>' after type 'I' in unpack/); } } SKIP: { # Is this a stupid thing to do on VMS, VOS and other unusual platforms? skip("-- the IEEE infinity model is unavailable in this configuration.", 1) if (($^O eq 'VMS') && !defined($Config{useieee})); skip("-- $^O has serious fp indigestion on w-packed infinities", 1) if ( ($^O eq 'mpeix') || ($^O eq 'ultrix') || ($^O =~ /^svr4/ && -f "/etc/issue" && -f "/etc/.relid") # NCR MP-RAS ); my $inf = eval '2**1000000'; skip("Couldn't generate infinity - got error '$@'", 1) unless defined $inf and $inf == $inf / 2 and $inf + 1 == $inf; local our $TODO; $TODO = "VOS needs a fix for posix-1022 to pass this test." if ($^O eq 'vos'); eval { $x = pack 'w', $inf }; like ($@, qr/^Cannot compress integer/, "Cannot compress integer"); } SKIP: { skip("-- the full range of an IEEE double may not be available in this configuration.", 3) if (($^O eq 'VMS') && !defined($Config{useieee})); skip("-- $^O does not like 2**1023", 3) if (($^O eq 'ultrix')); # This should be about the biggest thing possible on an IEEE double my $big = eval '2**1023'; skip("Couldn't generate 2**1023 - got error '$@'", 3) unless defined $big and $big != $big / 2; eval { $x = pack 'w', $big }; is ($@, '', "Should be able to pack 'w', $big # 2**1023"); my $y = eval {unpack 'w', $x}; is ($@, '', "Should be able to unpack 'w' the result of pack 'w', $big # 2**1023"); # I'm getting about 1e-16 on FreeBSD my $quotient = int (100 * ($y - $big) / $big); ok($quotient < 2 && $quotient > -2, "Round trip pack, unpack 'w' of $big is within 1% ($quotient%)"); } } print "# test the 'p' template\n"; # literals is(unpack("p",pack("p","foo")), "foo"); SKIP: { skip $no_endianness, 2 if $no_endianness; is(unpack("p<",pack("p<","foo")), "foo"); is(unpack("p>",pack("p>","foo")), "foo"); } # scalars is(unpack("p",pack("p",239)), 239); SKIP: { skip $no_endianness, 2 if $no_endianness; is(unpack("p<",pack("p<",239)), 239); is(unpack("p>",pack("p>",239)), 239); } # temps sub foo { my $a = "a"; return $a . $a++ . $a++ } { use warnings qw(NONFATAL all);; my $warning; local $SIG{__WARN__} = sub { $warning = $_[0]; }; my $junk = pack("p", &foo); like($warning, qr/temporary val/); } # undef should give null pointer like(pack("p", undef), qr/^\0+$/); SKIP: { skip $no_endianness, 2 if $no_endianness; like(pack("p<", undef), qr/^\0+$/); like(pack("p>", undef), qr/^\0+$/); } # Check for optimizer bug (e.g. Digital Unix GEM cc with -O4 on DU V4.0B gives # 4294967295 instead of -1) # see #ifdef __osf__ in pp.c pp_unpack is((unpack("i",pack("i",-1))), -1); print "# test the pack lengths of s S i I l L n N v V + modifiers\n"; my @lengths = ( qw(s 2 S 2 i -4 I -4 l 4 L 4 n 2 N 4 v 2 V 4 n! 2 N! 4 v! 2 V! 4), 's!' => $Config{shortsize}, 'S!' => $Config{shortsize}, 'i!' => $Config{intsize}, 'I!' => $Config{intsize}, 'l!' => $Config{longsize}, 'L!' => $Config{longsize}, ); while (my ($base, $expect) = splice @lengths, 0, 2) { my @formats = ($base); $base =~ /^[nv]/i or push @formats, "$base>", "$base<"; for my $format (@formats) { SKIP: { skip $no_endianness, 1 if $no_endianness && $format =~ m/[<>]/; skip $no_signedness, 1 if $no_signedness && $format =~ /[nNvV]!/; my $len = length(pack($format, 0)); if ($expect > 0) { is($expect, $len, "format '$format'"); } else { $expect = -$expect; ok ($len >= $expect, "format '$format'") || print "# format '$format' has length $len, expected >= $expect\n"; } } } } print "# test unpack-pack lengths\n"; my @templates = qw(c C W i I s S l L n N v V f d q Q); foreach my $base (@templates) { my @tmpl = ($base); $base =~ /^[cwnv]/i or push @tmpl, "$base>", "$base<"; foreach my $t (@tmpl) { SKIP: { my @t = eval { unpack("$t*", pack("$t*", 12, 34)) }; skip "cannot pack '$t' on this perl", 4 if is_valid_error($@); is( $@, '', "Template $t works"); is(scalar @t, 2); is($t[0], 12); is($t[1], 34); } } } { # uuencode/decode # Note that first uuencoding known 'text' data and then checking the # binary values of the uuencoded version would not be portable between # character sets. Uuencoding is meant for encoding binary data, not # text data. my $in = pack 'C*', 0 .. 255; # just to be anal, we do some random tr/`/ / my $uu = <<'EOUU'; M` $"`P0%!@<("0H+# T.#Q`1$A,4%187&!D:&QP='A\@(2(C)"4F)R@I*BLL M+2XO,#$R,S0U-C'EZ>WQ]?G^`@8*#A(6& MAXB)BHN,C8Z/D)&2DY25EI>8F9J;G)V>GZ"AHJ.DI::GJ*FJJZRMKJ^PL;*S MM+6VM[BYNKN\O;Z_P,'"P\3%QL?(R+CY.7FY^CIZNOL[>[O\/'R\_3U]O?X^?K[_/W^_P ` EOUU $_ = $uu; tr/ /`/; is(pack('u', $in), $_); is(unpack('u', $uu), $in); $in = "\x1f\x8b\x08\x08\x58\xdc\xc4\x35\x02\x03\x4a\x41\x50\x55\x00\xf3\x2a\x2d\x2e\x51\x48\xcc\xcb\x2f\xc9\x48\x2d\x52\x08\x48\x2d\xca\x51\x28\x2d\x4d\xce\x4f\x49\x2d\xe2\x02\x00\x64\x66\x60\x5c\x1a\x00\x00\x00"; $uu = <<'EOUU'; M'XL("%C("`&1F &8%P:```` EOUU is(unpack('u', $uu), $in); # This is identical to the above except that backquotes have been # changed to spaces $uu = <<'EOUU'; M'XL("%C(" &1F &8%P: EOUU # ' # Grr is(unpack('u', $uu), $in); } # test the ascii template types (A, a, Z) foreach ( ['p', 'A*', "foo\0bar\0 ", "foo\0bar\0 "], ['p', 'A11', "foo\0bar\0 ", "foo\0bar\0 "], ['u', 'A*', "foo\0bar \0", "foo\0bar"], ['u', 'A8', "foo\0bar \0", "foo\0bar"], ['p', 'a*', "foo\0bar\0 ", "foo\0bar\0 "], ['p', 'a11', "foo\0bar\0 ", "foo\0bar\0 \0\0"], ['u', 'a*', "foo\0bar \0", "foo\0bar \0"], ['u', 'a8', "foo\0bar \0", "foo\0bar "], ['p', 'Z*', "foo\0bar\0 ", "foo\0bar\0 \0"], ['p', 'Z11', "foo\0bar\0 ", "foo\0bar\0 \0\0"], ['p', 'Z3', "foo", "fo\0"], ['u', 'Z*', "foo\0bar \0", "foo"], ['u', 'Z8', "foo\0bar \0", "foo"], ) { my ($what, $template, $in, $out) = @$_; my $got = $what eq 'u' ? (unpack $template, $in) : (pack $template, $in); unless (is($got, $out)) { my $un = $what eq 'u' ? 'un' : ''; print "# ${un}pack ('$template', "._qq($in).') gave '._qq($out). ' not '._qq($got)."\n"; } } print "# packing native shorts/ints/longs\n"; is(length(pack("s!", 0)), $Config{shortsize}); is(length(pack("i!", 0)), $Config{intsize}); is(length(pack("l!", 0)), $Config{longsize}); ok(length(pack("s!", 0)) <= length(pack("i!", 0))); ok(length(pack("i!", 0)) <= length(pack("l!", 0))); is(length(pack("i!", 0)), length(pack("i", 0))); sub numbers { my $base = shift; my @formats = ($base); $base =~ /^[silqjfdp]/i and push @formats, "$base>", "$base<"; for my $format (@formats) { numbers_with_total ($format, undef, @_); } } sub numbers_with_total { my $format = shift; my $total = shift; if (!defined $total) { foreach (@_) { $total += $_; } } print "# numbers test for $format\n"; foreach (@_) { SKIP: { my $out = eval {unpack($format, pack($format, $_))}; skip "cannot pack '$format' on this perl", 2 if is_valid_error($@); is($@, '', "no error"); is($out, $_, "unpack pack $format $_"); } } my $skip_if_longer_than = ~0; # "Infinity" if (~0 - 1 == ~0) { # If we're running with -DNO_PERLPRESERVE_IVUV and NVs don't preserve all # UVs (in which case ~0 is NV, ~0-1 will be the same NV) then we can't # correctly in perl calculate UV totals for long checksums, as pp_unpack # is using UV maths, and we've only got NVs. $skip_if_longer_than = $Config{nv_preserves_uv_bits}; } foreach ('', 1, 2, 3, 15, 16, 17, 31, 32, 33, 53, 54, 63, 64, 65) { SKIP: { my $sum = eval {unpack "%$_$format*", pack "$format*", @_}; skip "cannot pack '$format' on this perl", 3 if is_valid_error($@); is($@, '', "no error"); ok(defined $sum, "sum bits $_, format $format defined"); my $len = $_; # Copy, so that we can reassign '' $len = 16 unless length $len; SKIP: { skip "cannot test checksums over $skip_if_longer_than bits", 1 if $len > $skip_if_longer_than; # Our problem with testing this portably is that the checksum code in # pp_unpack is able to cast signed to unsigned, and do modulo 2**n # arithmetic in unsigned ints, which perl has no operators to do. # (use integer; does signed ints, which won't wrap on UTS, which is just # fine with ANSI, but not with most people's assumptions. # This is why we need to supply the totals for 'Q' as there's no way in # perl to calculate them, short of unpack '%0Q' (is that documented?) # ** returns NVs; make sure it's IV. my $max = 1 + 2 * (int (2 ** ($len-1))-1); # The max possible checksum my $max_p1 = $max + 1; my ($max_is_integer, $max_p1_is_integer); $max_p1_is_integer = 1 unless $max_p1 + 1 == $max_p1; $max_is_integer = 1 if $max - 1 < ~0; my $calc_sum; if (ref $total) { $calc_sum = &$total($len); } else { $calc_sum = $total; # Shift into range by some multiple of the total my $mult = $max_p1 ? int ($total / $max_p1) : undef; # Need this to make sure that -1 + (~0+1) is ~0 (ie still integer) $calc_sum = $total - $mult; $calc_sum -= $mult * $max; if ($calc_sum < 0) { $calc_sum += 1; $calc_sum += $max; } } if ($calc_sum == $calc_sum - 1 && $calc_sum == $max_p1) { # we're into floating point (either by getting out of the range of # UV arithmetic, or because we're doing a floating point checksum) # and our calculation of the checksum has become rounded up to # max_checksum + 1 $calc_sum = 0; } if ($calc_sum == $sum) { # HAS to be ==, not eq (so no is()). pass ("unpack '%$_$format' gave $sum"); } else { my $delta = 1.000001; if ($format =~ tr /dDfF// && ($calc_sum <= $sum * $delta && $calc_sum >= $sum / $delta)) { pass ("unpack '%$_$format' gave $sum, expected $calc_sum"); } else { my $text = ref $total ? &$total($len) : $total; fail; print "# For list (" . join (", ", @_) . ") (total $text)" . " packed with $format unpack '%$_$format' gave $sum," . " expected $calc_sum\n"; } } } } } } numbers ('c', -128, -1, 0, 1, 127); numbers ('C', 0, 1, 127, 128, 255); numbers ('W', 0, 1, 127, 128, 255, 256, 0x7ff, 0x800, 0xfffd); numbers ('s', -32768, -1, 0, 1, 32767); numbers ('S', 0, 1, 32767, 32768, 65535); numbers ('i', -2147483648, -1, 0, 1, 2147483647); numbers ('I', 0, 1, 2147483647, 2147483648, 4294967295); numbers ('l', -2147483648, -1, 0, 1, 2147483647); numbers ('L', 0, 1, 2147483647, 2147483648, 4294967295); numbers ('s!', -32768, -1, 0, 1, 32767); numbers ('S!', 0, 1, 32767, 32768, 65535); numbers ('i!', -2147483648, -1, 0, 1, 2147483647); numbers ('I!', 0, 1, 2147483647, 2147483648, 4294967295); numbers ('l!', -2147483648, -1, 0, 1, 2147483647); numbers ('L!', 0, 1, 2147483647, 2147483648, 4294967295); numbers ('n', 0, 1, 32767, 32768, 65535); numbers ('v', 0, 1, 32767, 32768, 65535); numbers ('N', 0, 1, 2147483647, 2147483648, 4294967295); numbers ('V', 0, 1, 2147483647, 2147483648, 4294967295); numbers ('n!', -32768, -1, 0, 1, 32767); numbers ('v!', -32768, -1, 0, 1, 32767); numbers ('N!', -2147483648, -1, 0, 1, 2147483647); numbers ('V!', -2147483648, -1, 0, 1, 2147483647); # All these should have exact binary representations: numbers ('f', -1, 0, 0.5, 42, 2**34); numbers ('d', -(2**34), -1, 0, 1, 2**34); ## These don't, but 'd' is NV. XXX wrong, it's double #numbers ('d', -1, 0, 1, 1-exp(-1), -exp(1)); numbers_with_total ('q', -1, -9223372036854775808, -1, 0, 1,9223372036854775807); # This total is icky, but the true total is 2**65-1, and need a way to generate # the epxected checksum on any system including those where NVs can preserve # 65 bits. (long double is 128 bits on sparc, so they certainly can) # or where rounding is down not up on binary conversion (crays) numbers_with_total ('Q', sub { my $len = shift; $len = 65 if $len > 65; # unmasked total is 2**65-1 here my $total = 1 + 2 * (int (2**($len - 1)) - 1); return 0 if $total == $total - 1; # Overflowed integers return $total; # NVs still accurate to nearest integer }, 0, 1,9223372036854775807, 9223372036854775808, 18446744073709551615); print "# pack nvNV byteorders\n"; is(pack("n", 0xdead), "\xde\xad"); is(pack("v", 0xdead), "\xad\xde"); is(pack("N", 0xdeadbeef), "\xde\xad\xbe\xef"); is(pack("V", 0xdeadbeef), "\xef\xbe\xad\xde"); SKIP: { skip $no_signedness, 4 if $no_signedness; is(pack("n!", 0xdead), "\xde\xad"); is(pack("v!", 0xdead), "\xad\xde"); is(pack("N!", 0xdeadbeef), "\xde\xad\xbe\xef"); is(pack("V!", 0xdeadbeef), "\xef\xbe\xad\xde"); } print "# test big-/little-endian conversion\n"; sub byteorder { my $format = shift; print "# byteorder test for $format\n"; for my $value (@_) { SKIP: { my($nat,$be,$le) = eval { map { pack $format.$_, $value } '', '>', '<' }; skip "cannot pack '$format' on this perl", 5 if is_valid_error($@); { use warnings qw(NONFATAL utf8); print "# [$value][$nat][$be][$le][$@]\n"; } SKIP: { skip "cannot compare native byteorder with big-/little-endian", 1 if $ByteOrder eq 'unknown'; is($nat, $ByteOrder eq 'big' ? $be : $le); } is($be, reverse($le)); my @x = eval { unpack "$format$format>$format<", $nat.$be.$le }; print "# [$value][", join('][', @x), "][$@]\n"; is($@, ''); is($x[0], $x[1]); is($x[0], $x[2]); } } } byteorder('s', -32768, -1, 0, 1, 32767); byteorder('S', 0, 1, 32767, 32768, 65535); byteorder('i', -2147483648, -1, 0, 1, 2147483647); byteorder('I', 0, 1, 2147483647, 2147483648, 4294967295); byteorder('l', -2147483648, -1, 0, 1, 2147483647); byteorder('L', 0, 1, 2147483647, 2147483648, 4294967295); byteorder('j', -2147483648, -1, 0, 1, 2147483647); byteorder('J', 0, 1, 2147483647, 2147483648, 4294967295); byteorder('s!', -32768, -1, 0, 1, 32767); byteorder('S!', 0, 1, 32767, 32768, 65535); byteorder('i!', -2147483648, -1, 0, 1, 2147483647); byteorder('I!', 0, 1, 2147483647, 2147483648, 4294967295); byteorder('l!', -2147483648, -1, 0, 1, 2147483647); byteorder('L!', 0, 1, 2147483647, 2147483648, 4294967295); byteorder('q', -9223372036854775808, -1, 0, 1, 9223372036854775807); byteorder('Q', 0, 1, 9223372036854775807, 9223372036854775808, 18446744073709551615); byteorder('f', -1, 0, 0.5, 42, 2**34); byteorder('F', -1, 0, 0.5, 42, 2**34); byteorder('d', -(2**34), -1, 0, 1, 2**34); byteorder('D', -(2**34), -1, 0, 1, 2**34); print "# test negative numbers\n"; SKIP: { skip "platform is not using two's complement for negative integers", 120 unless $IsTwosComplement; for my $format (qw(s i l j s! i! l! q)) { SKIP: { my($nat,$be,$le) = eval { map { pack $format.$_, -1 } '', '>', '<' }; skip "cannot pack '$format' on this perl", 15 if is_valid_error($@); my $len = length $nat; is($_, "\xFF"x$len) for $nat, $be, $le; my(@val,@ref); if ($len >= 8) { @val = (-2, -81985529216486896, -9223372036854775808); @ref = ("\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFE", "\xFE\xDC\xBA\x98\x76\x54\x32\x10", "\x80\x00\x00\x00\x00\x00\x00\x00"); } elsif ($len >= 4) { @val = (-2, -19088744, -2147483648); @ref = ("\xFF\xFF\xFF\xFE", "\xFE\xDC\xBA\x98", "\x80\x00\x00\x00"); } else { @val = (-2, -292, -32768); @ref = ("\xFF\xFE", "\xFE\xDC", "\x80\x00"); } for my $x (@ref) { if ($len > length $x) { $x = $x . "\xFF" x ($len - length $x); } } for my $i (0 .. $#val) { my($nat,$be,$le) = eval { map { pack $format.$_, $val[$i] } '', '>', '<' }; is($@, ''); SKIP: { skip "cannot compare native byteorder with big-/little-endian", 1 if $ByteOrder eq 'unknown'; is($nat, $ByteOrder eq 'big' ? $be : $le); } is($be, $ref[$i]); is($be, reverse($le)); } } } } { # / my ($x, $y, $z); eval { ($x) = unpack '/a*','hello' }; like($@, qr!'/' must follow a numeric type!); undef $x; eval { $x = unpack '/a*','hello' }; like($@, qr!'/' must follow a numeric type!); undef $x; eval { ($z,$x,$y) = unpack 'a3/A C/a* C/Z', "003ok \003yes\004z\000abc" }; is($@, ''); is($z, 'ok'); is($x, 'yes'); is($y, 'z'); undef $z; eval { $z = unpack 'a3/A C/a* C/Z', "003ok \003yes\004z\000abc" }; is($@, ''); is($z, 'ok'); undef $x; eval { ($x) = pack '/a*','hello' }; like($@, qr!Invalid type '/'!); undef $x; eval { $x = pack '/a*','hello' }; like($@, qr!Invalid type '/'!); $z = pack 'n/a* N/Z* w/A*','string','hi there ','etc'; my $expect = "\000\006string\0\0\0\012hi there \000\003etc"; is($z, $expect); undef $x; $expect = 'hello world'; eval { ($x) = unpack ("w/a", chr (11) . "hello world!")}; is($x, $expect); is($@, ''); undef $x; # Doing this in scalar context used to fail. eval { $x = unpack ("w/a", chr (11) . "hello world!")}; is($@, ''); is($x, $expect); foreach ( ['a/a*/a*', '212ab345678901234567','ab3456789012'], ['a/a*/a*', '3012ab345678901234567', 'ab3456789012'], ['a/a*/b*', '212ab', $Is_EBCDIC ? '100000010100' : '100001100100'], ) { my ($pat, $in, $expect) = @$_; undef $x; eval { ($x) = unpack $pat, $in }; is($@, ''); is($x, $expect) || printf "# list unpack ('$pat', '$in') gave %s, expected '$expect'\n", encode_list ($x); undef $x; eval { $x = unpack $pat, $in }; is($@, ''); is($x, $expect) || printf "# scalar unpack ('$pat', '$in') gave %s, expected '$expect'\n", encode_list ($x); } # / with # my $pattern = <<'EOU'; a3/A # Count in ASCII C/a* # Count in a C char C/Z # Count in a C char but skip after \0 EOU $x = $y = $z =undef; eval { ($z,$x,$y) = unpack $pattern, "003ok \003yes\004z\000abc" }; is($@, ''); is($z, 'ok'); is($x, 'yes'); is($y, 'z'); undef $x; eval { $z = unpack $pattern, "003ok \003yes\004z\000abc" }; is($@, ''); is($z, 'ok'); $pattern = <<'EOP'; n/a* # Count as network short w/A* # Count a BER integer EOP $expect = "\000\006string\003etc"; $z = pack $pattern,'string','etc'; is($z, $expect); } SKIP: { skip("(EBCDIC and) version strings are bad idea", 2) if $Is_EBCDIC; is("1.20.300.4000", sprintf "%vd", pack("U*",1,20,300,4000)); is("1.20.300.4000", sprintf "%vd", pack(" U*",1,20,300,4000)); } isnt(v1.20.300.4000, sprintf "%vd", pack("C0U*",1,20,300,4000)); my $rslt = $Is_EBCDIC ? "156 67" : "199 162"; is(join(" ", unpack("U0 C*", chr(0x1e2))), $rslt); # does pack U create Unicode? is(ord(pack('U', 300)), 300); # does unpack U deref Unicode? is((unpack('U', chr(300)))[0], 300); # is unpack U the reverse of pack U for Unicode string? is("@{[unpack('U*', pack('U*', 100, 200, 300))]}", "100 200 300"); # is unpack U the reverse of pack U for byte string? is("@{[unpack('U*', pack('U*', 100, 200))]}", "100 200"); SKIP: { skip "Not for EBCDIC", 4 if $Is_EBCDIC; # does pack U0C create Unicode? is("@{[pack('U0C*', 100, 195, 136)]}", v100.v200); # does pack C0U create characters? is("@{[pack('C0U*', 100, 200)]}", pack("C*", 100, 195, 136)); # does unpack U0U on byte data warn? { use warnings qw(NONFATAL all);; my $bad = pack("U0C", 255); local $SIG{__WARN__} = sub { $@ = "@_" }; my @null = unpack('U0U', $bad); like($@, qr/^Malformed UTF-8 character /); } } { my $p = pack 'i*', -2147483648, ~0, 0, 1, 2147483647; my (@a); # bug - % had to be at the start of the pattern, no leading whitespace or # comments. %i! didn't work at all. foreach my $pat ('%32i*', ' %32i*', "# Muhahahaha\n%32i*", '%32i* ', '%32i!*', ' %32i!*', "\n#\n#\n\r \t\f%32i!*", '%32i!*#') { @a = unpack $pat, $p; is($a[0], 0xFFFFFFFF) || print "# $pat\n"; @a = scalar unpack $pat, $p; is($a[0], 0xFFFFFFFF) || print "# $pat\n"; } $p = pack 'I*', 42, 12; # Multiline patterns in scalar context failed. foreach my $pat ('I', < 32 bits with floating # point, so a pathologically long pattern would wrap at 32 bits. my $pat = "\xff\xff"x65538; # Start with it long, to save any copying. foreach (4,3,2,1,0) { my $len = 65534 + $_; is(unpack ("%33n$len", $pat), 65535 * $len); } } # pack x X @ foreach ( ['x', "N", "\0"], ['x4', "N", "\0"x4], ['xX', "N", ""], ['xXa*', "Nick", "Nick"], ['a5Xa5', "cameL", "llama", "camellama"], ['@4', 'N', "\0"x4], ['a*@8a*', 'Camel', 'Dromedary', "Camel\0\0\0Dromedary"], ['a*@4a', 'Perl rules', '!', 'Perl!'], ) { my ($template, @in) = @$_; my $out = pop @in; my $got = eval {pack $template, @in}; is($@, ''); is($out, $got) || printf "# pack ('$template', %s) gave %s expected %s\n", encode_list (@in), encode_list ($got), encode_list ($out); } # unpack x X @ foreach ( ['x', "N"], ['xX', "N"], ['xXa*', "Nick", "Nick"], ['a5Xa5', "camellama", "camel", "llama"], ['@3', "ice"], ['@2a2', "water", "te"], ['a*@1a3', "steam", "steam", "tea"], ) { my ($template, $in, @out) = @$_; my @got = eval {unpack $template, $in}; is($@, ''); ok (list_eq (\@got, \@out)) || printf "# list unpack ('$template', %s) gave %s expected %s\n", _qq($in), encode_list (@got), encode_list (@out); my $got = eval {unpack $template, $in}; is($@, ''); @out ? is( $got, $out[0] ) # 1 or more items; should get first : ok( !defined $got ) # 0 items; should get undef or printf "# scalar unpack ('$template', %s) gave %s expected %s\n", _qq($in), encode_list ($got), encode_list ($out[0]); } { my $t = 'Z*Z*'; my ($u, $v) = qw(foo xyzzy); my $p = pack($t, $u, $v); my @u = unpack($t, $p); is(scalar @u, 2); is($u[0], $u); is($u[1], $v); } { is((unpack("w/a*", "\x02abc"))[0], "ab"); # "w/a*" should be seen as one unit is(scalar unpack("w/a*", "\x02abc"), "ab"); } SKIP: { print "# group modifiers\n"; skip $no_endianness, 3 * 2 + 3 * 2 + 1 if $no_endianness; for my $t (qw{ (s<)< (sl>s)> (s(l(sl) (sl>s)< (s(l(sl) }) { print "# testing pattern '$t'\n"; eval { ($_) = unpack($t, 'x'x18); }; like($@, qr/Can't use '[<>]' in a group with different byte-order in unpack/); eval { $_ = pack($t, (0)x6); }; like($@, qr/Can't use '[<>]' in a group with different byte-order in pack/); } is(pack('L', (0x12345678)x2), pack('(((L1)1)<)(((L)1)1)>1', (0x12345678)x2)); } { sub compress_template { my $t = shift; for my $mod (qw( < > )) { $t =~ s/((?:(?:[SILQJFDP]!?$mod|[^SILQJFDP\W]!?)(?:\d+|\*|\[(?:[^]]+)\])?\/?){2,})/ my $x = $1; $x =~ s!$mod!!g ? "($x)$mod" : $x /ieg; } return $t; } my %templates = ( 's<' => [-42], 's [-42, -11, 12, 4711], '(i [-11, -22, -33, 1000000, 1100, 2201, 3302, -1000000, 32767, -32768, 1, -123456789 ], '(I!<4(J<2L<)3)5' => [1 .. 65], 'q [-50000000005, 60000000006], 'f [3.14159, 111.11, 2222.22], 'D [1e42, -128, 255, 1e-42], 'n/a*' => ['/usr/bin/perl'], 'C/a*S [qw(Just another Perl hacker)], ); for my $tle (sort keys %templates) { my @d = @{$templates{$tle}}; my $tbe = $tle; $tbe =~ y//; for my $t ($tbe, $tle) { my $c = compress_template($t); print "# '$t' -> '$c'\n"; SKIP: { my $p1 = eval { pack $t, @d }; skip "cannot pack '$t' on this perl", 5 if is_valid_error($@); my $p2 = eval { pack $c, @d }; is($@, ''); is($p1, $p2); s!(/[aAZ])\*!$1!g for $t, $c; my @u1 = eval { unpack $t, $p1 }; is($@, ''); my @u2 = eval { unpack $c, $p2 }; is($@, ''); is(join('!', @u1), join('!', @u2)); } } } } { # from Wolfgang Laun: fix in change #13163 my $s = 'ABC' x 10; my $t = '*'; my $x = ord($t); my $buf = pack( 'Z*/A* C', $s, $x ); my $y; my $h = $buf; $h =~ s/[^[:print:]]/./g; ( $s, $y ) = unpack( "Z*/A* C", $buf ); is($h, "30.ABCABCABCABCABCABCABCABCABCABC$t"); is(length $buf, 34); is($s, "ABCABCABCABCABCABCABCABCABCABC"); is($y, $x); } { # from Wolfgang Laun: fix in change #13288 eval { my $t=unpack("P*", "abc") }; like($@, qr/'P' must have an explicit size/); } { # Grouping constructs my (@a, @b); @a = unpack '(SL)', pack 'SLSLSL', 67..90; is("@a", "67 68"); @a = unpack '(SL)3', pack 'SLSLSL', 67..90; @b = (67..72); is("@a", "@b"); @a = unpack '(SL)3', pack 'SLSLSLSL', 67..90; is("@a", "@b"); @a = unpack '(SL)[3]', pack 'SLSLSLSL', 67..90; is("@a", "@b"); @a = unpack '(SL)[2] SL', pack 'SLSLSLSL', 67..90; is("@a", "@b"); @a = unpack 'A/(SL)', pack 'ASLSLSLSL', 3, 67..90; is("@a", "@b"); @a = unpack 'A/(SL)SL', pack 'ASLSLSLSL', 2, 67..90; is("@a", "@b"); @a = unpack '(SL)*', pack 'SLSLSLSL', 67..90; @b = (67..74); is("@a", "@b"); @a = unpack '(SL)*SL', pack 'SLSLSLSL', 67..90; is("@a", "@b"); eval { @a = unpack '(*SL)', '' }; like($@, qr/\(\)-group starts with a count/); eval { @a = unpack '(3SL)', '' }; like($@, qr/\(\)-group starts with a count/); eval { @a = unpack '([3]SL)', '' }; like($@, qr/\(\)-group starts with a count/); eval { @a = pack '(*SL)' }; like($@, qr/\(\)-group starts with a count/); @a = unpack '(SL)3 SL', pack '(SL)4', 67..74; is("@a", "@b"); @a = unpack '(SL)3 SL', pack '(SL)[4]', 67..74; is("@a", "@b"); @a = unpack '(SL)3 SL', pack '(SL)*', 67..74; is("@a", "@b"); } { # more on grouping (W.Laun) # @ absolute within ()-group my $badc = pack( '(a)*', unpack( '(@1a @0a @2)*', 'abcd' ) ); is( $badc, 'badc' ); my @b = ( 1, 2, 3 ); my $buf = pack( '(@1c)((@2C)@3c)', @b ); is( $buf, "\0\1\0\0\2\3" ); my @a = unpack( '(@1c)((@2c)@3c)', $buf ); is( "@a", "@b" ); # various unpack count/code scenarios my @Env = ( a => 'AAA', b => 'BBB' ); my $env = pack( 'S(S/A*S/A*)*', @Env/2, @Env ); # unpack full length - ok my @pup = unpack( 'S/(S/A* S/A*)', $env ); is( "@pup", "@Env" ); # warn when count/code goes beyond end of string # \0002 \0001 a \0003 AAA \0001 b \0003 BBB # 2 4 5 7 10 1213 eval { @pup = unpack( 'S/(S/A* S/A*)', substr( $env, 0, 13 ) ) }; like( $@, qr{length/code after end of string} ); # postfix repeat count $env = pack( '(S/A* S/A*)' . @Env/2, @Env ); # warn when count/code goes beyond end of string # \0001 a \0003 AAA \0001 b \0003 BBB # 2 3c 5 8 10 11 13 16 eval { @pup = unpack( '(S/A* S/A*)' . @Env/2, substr( $env, 0, 11 ) ) }; like( $@, qr{length/code after end of string} ); # catch stack overflow/segfault eval { $_ = pack( ('(' x 105) . 'A' . (')' x 105) ); }; like( $@, qr{Too deeply nested \(\)-groups} ); } { # syntax checks (W.Laun) use warnings qw(NONFATAL all);; my @warning; local $SIG{__WARN__} = sub { push( @warning, $_[0] ); }; eval { my $s = pack( 'Ax![4c]A', 1..5 ); }; like( $@, qr{Malformed integer in \[\]} ); eval { my $buf = pack( '(c/*a*)', 'AAA', 'BB' ); }; like( $@, qr{'/' does not take a repeat count} ); eval { my @inf = unpack( 'c/1a', "\x03AAA\x02BB" ); }; like( $@, qr{'/' does not take a repeat count} ); eval { my @inf = unpack( 'c/*a', "\x03AAA\x02BB" ); }; like( $@, qr{'/' does not take a repeat count} ); # white space where possible my @Env = ( a => 'AAA', b => 'BBB' ); my $env = pack( ' S ( S / A* S / A* )* ', @Env/2, @Env ); my @pup = unpack( ' S / ( S / A* S / A* ) ', $env ); is( "@pup", "@Env" ); # white space in 4 wrong places for my $temp ( 'A ![4]', 'A [4]', 'A *', 'A 4' ){ eval { my $s = pack( $temp, 'B' ); }; like( $@, qr{Invalid type } ); } # warning for commas @warning = (); my $x = pack( 'I,A', 4, 'X' ); like( $warning[0], qr{Invalid type ','} ); # comma warning only once @warning = (); $x = pack( 'C(C,C)C,C', 65..71 ); like( scalar @warning, 1 ); # forbidden code in [] eval { my $x = pack( 'A[@4]', 'XXXX' ); }; like( $@, qr{Within \[\]-length '\@' not allowed} ); # @ repeat default 1 my $s = pack( 'AA@A', 'A', 'B', 'C' ); my @c = unpack( 'AA@A', $s ); is( $s, 'AC' ); is( "@c", "A C C" ); # no unpack code after / eval { my @a = unpack( "C/", "\3" ); }; like( $@, qr{Code missing after '/'} ); SKIP: { skip $no_endianness, 6 if $no_endianness; # modifier warnings @warning = (); $x = pack "I>>s!!", 47, 11; ($x) = unpack "I<!>", 'x'x20; is(scalar @warning, 5); like($warning[0], qr/Duplicate modifier '>' after 'I' in pack/); like($warning[1], qr/Duplicate modifier '!' after 's' in pack/); like($warning[2], qr/Duplicate modifier '<' after 'I' in unpack/); like($warning[3], qr/Duplicate modifier '!' after 'l' in unpack/); like($warning[4], qr/Duplicate modifier '>' after 'l' in unpack/); } } { # Repeat count [SUBEXPR] my @codes = qw( x A Z a c C W B b H h s v n S i I l V N L p P f F d s! S! i! I! l! L! j J); my $G; if (eval { pack 'q', 1 } ) { push @codes, qw(q Q); } else { push @codes, qw(s S); # Keep the count the same } if (eval { pack 'D', 1 } ) { push @codes, 'D'; } else { push @codes, 'd'; # Keep the count the same } push @codes, map { /^[silqjfdp]/i ? ("$_<", "$_>") : () } @codes; my %val; @val{@codes} = map { / [Xx] (?{ undef }) | [AZa] (?{ 'something' }) | C (?{ 214 }) | W (?{ 8188 }) | c (?{ 114 }) | [Bb] (?{ '101' }) | [Hh] (?{ 'b8' }) | [svnSiIlVNLqQjJ] (?{ 10111 }) | [FfDd] (?{ 1.36514538e67 }) | [pP] (?{ "try this buffer" }) /x; $^R } @codes; my @end = (0x12345678, 0x23456781, 0x35465768, 0x15263748); my $end = "N4"; for my $type (@codes) { my @list = $val{$type}; @list = () unless defined $list[0]; for my $count ('', '3', '[11]') { my $c = 1; $c = $1 if $count =~ /(\d+)/; my @list1 = @list; @list1 = (@list1) x $c unless $type =~ /[XxAaZBbHhP]/; for my $groupend ('', ')2', ')[8]') { my $groupbegin = ($groupend ? '(' : ''); $c = 1; $c = $1 if $groupend =~ /(\d+)/; my @list2 = (@list1) x $c; SKIP: { my $junk1 = "$groupbegin $type$count $groupend"; # print "# junk1=$junk1\n"; my $p = eval { pack $junk1, @list2 }; skip "cannot pack '$type' on this perl", 12 if is_valid_error($@); die "pack $junk1 failed: $@" if $@; my $half = int( (length $p)/2 ); for my $move ('', "X$half", "X!$half", 'x1', 'x!8', "x$half") { my $junk = "$junk1 $move"; # print "# junk='$junk', list=(@list2)\n"; $p = pack "$junk $end", @list2, @end; my @l = unpack "x[$junk] $end", $p; is(scalar @l, scalar @end); is("@l", "@end", "skipping x[$junk]"); } } } } } } # / is recognized after spaces in scalar context # XXXX no spaces are allowed in pack... In pack only before the slash... is(scalar unpack('A /A Z20', pack 'A/A* Z20', 'bcde', 'xxxxx'), 'bcde'); is(scalar unpack('A /A /A Z20', '3004bcde'), 'bcde'); { # X! and x! my $t = 'C[3] x!8 C[2]'; my @a = (0x73..0x77); my $p = pack($t, @a); is($p, "\x73\x74\x75\0\0\0\0\0\x76\x77"); my @b = unpack $t, $p; is(scalar @b, scalar @a); is("@b", "@a", 'x!8'); $t = 'x[5] C[6] X!8 C[2]'; @a = (0x73..0x7a); $p = pack($t, @a); is($p, "\0\0\0\0\0\x73\x74\x75\x79\x7a"); @b = unpack $t, $p; @a = (0x73..0x75, 0x79, 0x7a, 0x79, 0x7a); is(scalar @b, scalar @a); is("@b", "@a"); } { # struct {char c1; double d; char cc[2];} my $t = 'C x![d] d C[2]'; my @a = (173, 1.283476517e-45, 42, 215); my $p = pack $t, @a; ok( length $p); my @b = unpack "$t X[$t] $t", $p; # Extract, step back, extract again is(scalar @b, 2 * scalar @a); $b = "@b"; $b =~ s/(?:17000+|16999+)\d+(e-45) /17$1 /gi; # stringification is gamble is($b, "@a @a"); use warnings qw(NONFATAL all);; my $warning; local $SIG{__WARN__} = sub { $warning = $_[0]; }; @b = unpack "x[C] x[$t] X[$t] X[C] $t", "$p\0"; is($warning, undef); is(scalar @b, scalar @a); $b = "@b"; $b =~ s/(?:17000+|16999+)\d+(e-45) /17$1 /gi; # stringification is gamble is($b, "@a"); } is(length(pack("j", 0)), $Config{ivsize}); is(length(pack("J", 0)), $Config{uvsize}); is(length(pack("F", 0)), $Config{nvsize}); numbers ('j', -2147483648, -1, 0, 1, 2147483647); numbers ('J', 0, 1, 2147483647, 2147483648, 4294967295); numbers ('F', -(2**34), -1, 0, 1, 2**34); SKIP: { my $t = eval { unpack("D*", pack("D", 12.34)) }; skip "Long doubles not in use", 166 if $@ =~ /Invalid type/; is(length(pack("D", 0)), $Config{longdblsize}); numbers ('D', -(2**34), -1, 0, 1, 2**34); } # Maybe this knowledge needs to be "global" for all of pack.t # Or a "can checksum" which would effectively be all the number types" my %cant_checksum = map {$_=> 1} qw(A Z u w); # not a b B h H foreach my $template (qw(A Z c C s S i I l L n N v V q Q j J f d F D u U w)) { SKIP: { my $packed = eval {pack "${template}4", 1, 4, 9, 16}; if ($@) { die unless $@ =~ /Invalid type '$template'/; skip ("$template not supported on this perl", $cant_checksum{$template} ? 4 : 8); } my @unpack4 = unpack "${template}4", $packed; my @unpack = unpack "${template}*", $packed; my @unpack1 = unpack "${template}", $packed; my @unpack1s = scalar unpack "${template}", $packed; my @unpack4s = scalar unpack "${template}4", $packed; my @unpacks = scalar unpack "${template}*", $packed; my @tests = ( ["${template}4 vs ${template}*", \@unpack4, \@unpack], ["scalar ${template} ${template}", \@unpack1s, \@unpack1], ["scalar ${template}4 vs ${template}", \@unpack4s, \@unpack1], ["scalar ${template}* vs ${template}", \@unpacks, \@unpack1], ); unless ($cant_checksum{$template}) { my @unpack4_c = unpack "\%${template}4", $packed; my @unpack_c = unpack "\%${template}*", $packed; my @unpack1_c = unpack "\%${template}", $packed; my @unpack1s_c = scalar unpack "\%${template}", $packed; my @unpack4s_c = scalar unpack "\%${template}4", $packed; my @unpacks_c = scalar unpack "\%${template}*", $packed; push @tests, ( ["% ${template}4 vs ${template}*", \@unpack4_c, \@unpack_c], ["% scalar ${template} ${template}", \@unpack1s_c, \@unpack1_c], ["% scalar ${template}4 vs ${template}*", \@unpack4s_c, \@unpack_c], ["% scalar ${template}* vs ${template}*", \@unpacks_c, \@unpack_c], ); } foreach my $test (@tests) { ok (list_eq ($test->[1], $test->[2]), $test->[0]) || printf "# unpack gave %s expected %s\n", encode_list (@{$test->[1]}), encode_list (@{$test->[2]}); } } } ok(pack('u2', 'AA'), "[perl #8026]"); # used to hang and eat RAM in perl 5.7.2 $_ = pack('c', 65); # 'A' would not be EBCDIC-friendly is(unpack('c'), 65, "one-arg unpack (change #18751)"); # defaulting to $_ { my $a = "X\x0901234567\n" x 100; # \t would not be EBCDIC TAB my @a = unpack("(a1 c/a)*", $a); is(scalar @a, 200, "[perl #15288]"); is($a[-1], "01234567\n", "[perl #15288]"); is($a[-2], "X", "[perl #15288]"); } { use warnings qw(NONFATAL all);; my $warning; local $SIG{__WARN__} = sub { $warning = $_[0]; }; my $out = pack("u99", "foo" x 99); like($warning, qr/Field too wide in 'u' format in pack at /, "Warn about too wide uuencode"); is($out, ("_" . "9F]O" x 21 . "\n") x 4 . "M" . "9F]O" x 15 . "\n", "Use max width in case of too wide uuencode"); } # checksums { # verify that unpack advances correctly wrt a checksum my (@x) = unpack("b10a", "abcd"); my (@y) = unpack("%b10a", "abcd"); is($x[1], $y[1], "checksum advance ok"); # verify that the checksum is not overflowed with C0 if (ord('A') == 193) { is(unpack("C0%128U", "/bcd"), unpack("U0%128U", "abcd"), "checksum not overflowed"); } else { is(unpack("C0%128U", "abcd"), unpack("U0%128U", "abcd"), "checksum not overflowed"); } } { # U0 and C0 must be scoped my (@x) = unpack("a(U0)U", "b\341\277\274"); is($x[0], 'b', 'before scope'); is($x[1], 8188, 'after scope'); is(pack("a(U0)U", "b", 8188), "b\341\277\274"); } { # counted length prefixes shouldn't change C0/U0 mode # (note the length is actually 0 in this test) if (ord('A') == 193) { is(join(',', unpack("aU0C/UU", "b\0\341\277\274")), 'b,0'); is(join(',', unpack("aU0C/CU", "b\0\341\277\274")), 'b,0'); } else { is(join(',', unpack("aC/UU", "b\0\341\277\274")), 'b,8188'); is(join(',', unpack("aC/CU", "b\0\341\277\274")), 'b,8188'); is(join(',', unpack("aU0C/UU", "b\0\341\277\274")), 'b,225'); is(join(',', unpack("aU0C/CU", "b\0\341\277\274")), 'b,225'); } } { # "Z0" (bug #34062) my (@x) = unpack("C*", pack("CZ0", 1, "b")); is(join(',', @x), '1', 'pack Z0 doesn\'t destroy the character before'); } { # Encoding neutrality # String we will pull apart and rebuild in several ways: my $down = "\xf8\xf9\xfa\xfb\xfc\xfd\xfe\xff\x05\x06"; my $up = $down; utf8::upgrade($up); my %expect = # [expected result, # how many chars it should progress, # (optional) expected result of pack] (a5 => ["\xf8\xf9\xfa\xfb\xfc", 5], A5 => ["\xf8\xf9\xfa\xfb\xfc", 5], Z5 => ["\xf8\xf9\xfa\xfb\xfc", 5, "\xf8\xf9\xfa\xfb\x00\xfd"], b21 => ["000111111001111101011", 3, "\xf8\xf9\x1a\xfb"], B21 => ["111110001111100111111", 3, "\xf8\xf9\xf8\xfb"], H5 => ["f8f9f", 3, "\xf8\xf9\xf0\xfb"], h5 => ["8f9fa", 3, "\xf8\xf9\x0a\xfb"], "s<" => [-1544, 2], "s>" => [-1799, 2], "S<" => [0xf9f8, 2], "S>" => [0xf8f9, 2], "l<" => [-67438088, 4], "l>" => [-117835013, 4], "L>" => [0xf8f9fafb, 4], "L<" => [0xfbfaf9f8, 4], n => [0xf8f9, 2], N => [0xf8f9fafb, 4], v => [63992, 2], V => [0xfbfaf9f8, 4], c => [-8, 1], U0U => [0xf8, 1], w => ["8715569050387726213", 9], q => ["-283686952306184", 8], Q => ["18446460386757245432", 8], ); for my $string ($down, $up) { for my $format (sort {lc($a) cmp lc($b) || $a cmp $b } keys %expect) { SKIP: { my $expect = $expect{$format}; # unpack upgraded and downgraded string my @result = eval { unpack("$format C0 W", $string) }; skip "cannot pack/unpack '$format C0 W' on this perl", 5 if $@ && is_valid_error($@); is(@result, 2, "Two results from unpack $format C0 W"); # pack to downgraded my $new = pack("$format C0 W", @result); is(length($new), $expect->[1]+1, "pack $format C0 W should give $expect->[1]+1 chars"); is($new, $expect->[2] || substr($string, 0, length $new), "pack $format C0 W returns expected value"); # pack to upgraded $new = pack("a0 $format C0 W", chr(256), @result); is(length($new), $expect->[1]+1, "pack a0 $format C0 W should give $expect->[1]+1 chars"); is($new, $expect->[2] || substr($string, 0, length $new), "pack a0 $format C0 W returns expected value"); } } } } { # Encoding neutrality, numbers my $val = -2.68; for my $format (qw(s S i I l L j J f d F D q Q s! S! i! I! l! L! n! N! v! V!)) { SKIP: { my $down = eval { pack($format, $val) }; skip "cannot pack/unpack $format on this perl", 9 if $@ && is_valid_error($@); ok(!utf8::is_utf8($down), "Simple $format pack doesn't get upgraded"); my $up = pack("a0 $format", chr(256), $val); ok(utf8::is_utf8($up), "a0 $format with high char leads to upgrade"); is($down, $up, "$format generated strings are equal though"); my @down_expanded = unpack("$format W", $down . chr(0xce)); is(@down_expanded, 2, "Expand to two values"); is($down_expanded[1], 0xce, "unpack $format left us at the expected position"); my @up_expanded = unpack("$format W", $up . chr(0xce)); is(@up_expanded, 2, "Expand to two values"); is($up_expanded[1], 0xce, "unpack $format left us at the expected position"); is($down_expanded[0], $up_expanded[0], "$format unpack was neutral"); is(pack($format, $down_expanded[0]), $down, "Pack $format undoes unpack $format"); } } } { # C *is* neutral my $down = "\xf8\xf9\xfa\xfb\xfc\xfd\xfe\xff\x05\x06"; my $up = $down; utf8::upgrade($up); my @down = unpack("C*", $down); my @expect_down = (0xf8, 0xf9, 0xfa, 0xfb, 0xfc, 0xfd, 0xfe, 0xff, 0x05, 0x06); is("@down", "@expect_down", "byte expand"); is(pack("C*", @down), $down, "byte join"); my @up = unpack("C*", $up); my @expect_up = (0xf8, 0xf9, 0xfa, 0xfb, 0xfc, 0xfd, 0xfe, 0xff, 0x05, 0x06); is("@up", "@expect_up", "UTF-8 expand"); is(pack("U0C0C*", @up), $up, "UTF-8 join"); } { # Harder cases for the neutrality test # u format my $down = "\xf8\xf9\xfa\xfb\xfc\xfd\xfe\xff\x05\x06"; my $up = $down; utf8::upgrade($up); is(pack("u", $down), pack("u", $up), "u pack is neutral"); is(unpack("u", pack("u", $down)), $down, "u unpack to downgraded works"); is(unpack("U0C0u", pack("u", $down)), $up, "u unpack to upgraded works"); # p/P format # This actually only tests something if the address contains a byte >= 0x80 my $str = "abc\xa5\x00\xfede"; $down = pack("p", $str); is(pack("P", $str), $down); is(pack("U0C0p", $str), $down); is(pack("U0C0P", $str), $down); is(unpack("p", $down), "abc\xa5", "unpack p downgraded"); $up = $down; utf8::upgrade($up); is(unpack("p", $up), "abc\xa5", "unpack p upgraded"); is(unpack("P7", $down), "abc\xa5\x00\xfed", "unpack P downgraded"); is(unpack("P7", $up), "abc\xa5\x00\xfed", "unpack P upgraded"); # x, X and @ $down = "\xf8\xf9\xfa\xfb\xfc\xfd\xfe\xff\x05\x06"; $up = $down; utf8::upgrade($up); is(unpack('@4W', $down), 0xfc, "\@positioning on downgraded string"); is(unpack('@4W', $up), 0xfc, "\@positioning on upgraded string"); is(unpack('@4x2W', $down), 0xfe, "x moving on downgraded string"); is(unpack('@4x2W', $up), 0xfe, "x moving on upgraded string"); is(unpack('@4x!4W', $down), 0xfc, "x! moving on downgraded string"); is(unpack('@4x!4W', $up), 0xfc, "x! moving on upgraded string"); is(unpack('@5x!4W', $down), 0x05, "x! moving on downgraded string"); is(unpack('@5x!4W', $up), 0x05, "x! moving on upgraded string"); is(unpack('@4X2W', $down), 0xfa, "X moving on downgraded string"); is(unpack('@4X2W', $up), 0xfa, "X moving on upgraded string"); is(unpack('@4X!4W', $down), 0xfc, "X! moving on downgraded string"); is(unpack('@4X!4W', $up), 0xfc, "X! moving on upgraded string"); is(unpack('@5X!4W', $down), 0xfc, "X! moving on downgraded string"); is(unpack('@5X!4W', $up), 0xfc, "X! moving on upgraded string"); is(unpack('@5X!8W', $down), 0xf8, "X! moving on downgraded string"); is(unpack('@5X!8W', $up), 0xf8, "X! moving on upgraded string"); is(pack("W2x", 0xfa, 0xe3), "\xfa\xe3\x00", "x on downgraded string"); is(pack("W2x!4", 0xfa, 0xe3), "\xfa\xe3\x00\x00", "x! on downgraded string"); is(pack("W2x!2", 0xfa, 0xe3), "\xfa\xe3", "x! on downgraded string"); is(pack("U0C0W2x", 0xfa, 0xe3), "\xfa\xe3\x00", "x on upgraded string"); is(pack("U0C0W2x!4", 0xfa, 0xe3), "\xfa\xe3\x00\x00", "x! on upgraded string"); is(pack("U0C0W2x!2", 0xfa, 0xe3), "\xfa\xe3", "x! on upgraded string"); is(pack("W2X", 0xfa, 0xe3), "\xfa", "X on downgraded string"); is(pack("U0C0W2X", 0xfa, 0xe3), "\xfa", "X on upgraded string"); is(pack("W2X!2", 0xfa, 0xe3), "\xfa\xe3", "X! on downgraded string"); is(pack("U0C0W2X!2", 0xfa, 0xe3), "\xfa\xe3", "X! on upgraded string"); is(pack("W3X!2", 0xfa, 0xe3, 0xa6), "\xfa\xe3", "X! on downgraded string"); is(pack("U0C0W3X!2", 0xfa, 0xe3, 0xa6), "\xfa\xe3", "X! on upgraded string"); # backward eating through a ( moves the group starting point backwards is(pack("a*(Xa)", "abc", "q"), "abq", "eating before strbeg moves it back"); is(pack("a*(Xa)", "ab" . chr(512), "q"), "abq", "eating before strbeg moves it back"); # Check marked_upgrade is(pack('W(W(Wa@3W)@6W)@9W', 0xa1, 0xa2, 0xa3, "a", 0xa4, 0xa5, 0xa6), "\xa1\xa2\xa3a\x00\xa4\x00\xa5\x00\xa6"); $up = "a"; utf8::upgrade($up); is(pack('W(W(Wa@3W)@6W)@9W', 0xa1, 0xa2, 0xa3, $up, 0xa4, 0xa5, 0xa6), "\xa1\xa2\xa3a\x00\xa4\x00\xa5\x00\xa6", "marked upgrade caused by a"); is(pack('W(W(WW@3W)@6W)@9W', 0xa1, 0xa2, 0xa3, 256, 0xa4, 0xa5, 0xa6), "\xa1\xa2\xa3\x{100}\x00\xa4\x00\xa5\x00\xa6", "marked upgrade caused by W"); is(pack('W(W(WU0aC0@3W)@6W)@9W', 0xa1, 0xa2, 0xa3, "a", 0xa4, 0xa5, 0xa6), "\xa1\xa2\xa3a\x00\xa4\x00\xa5\x00\xa6", "marked upgrade caused by U0"); # a, A and Z $down = "\xa4\xa6\xa7"; $up = $down; utf8::upgrade($up); utf8::upgrade(my $high = "\xfeb"); for my $format ("a0", "A0", "Z0", "U0a0C0", "U0A0C0", "U0Z0C0") { is(pack("a* $format a*", "ab", $down, "cd"), "abcd", "$format format on plain string"); is(pack("a* $format a*", "ab", $up, "cd"), "abcd", "$format format on upgraded string"); is(pack("a* $format a*", $high, $down, "cd"), "\xfebcd", "$format format on plain string"); is(pack("a* $format a*", $high, $up, "cd"), "\xfebcd", "$format format on upgraded string"); my @down = unpack("a1 $format a*", "\xfeb"); is("@down", "\xfe b", "unpack $format"); my @up = unpack("a1 $format a*", $high); is("@up", "\xfe b", "unpack $format"); } is(pack("a1", $high), "\xfe"); is(pack("A1", $high), "\xfe"); is(pack("Z1", $high), "\x00"); is(pack("a2", $high), "\xfeb"); is(pack("A2", $high), "\xfeb"); is(pack("Z2", $high), "\xfe\x00"); is(pack("a5", $high), "\xfeb\x00\x00\x00"); is(pack("A5", $high), "\xfeb "); is(pack("Z5", $high), "\xfeb\x00\x00\x00"); is(pack("a*", $high), "\xfeb"); is(pack("A*", $high), "\xfeb"); is(pack("Z*", $high), "\xfeb\x00"); utf8::upgrade($high = "\xc3\xbeb"); is(pack("U0a2", $high), "\xfe"); is(pack("U0A2", $high), "\xfe"); is(pack("U0Z1", $high), "\x00"); is(pack("U0a3", $high), "\xfeb"); is(pack("U0A3", $high), "\xfeb"); is(pack("U0Z3", $high), "\xfe\x00"); is(pack("U0a6", $high), "\xfeb\x00\x00\x00"); is(pack("U0A6", $high), "\xfeb "); is(pack("U0Z6", $high), "\xfeb\x00\x00\x00"); is(pack("U0a*", $high), "\xfeb"); is(pack("U0A*", $high), "\xfeb"); is(pack("U0Z*", $high), "\xfeb\x00"); } { # pack / my @array = 1..14; my @out = unpack("N/S", pack("N/S", @array) . "abcd"); is("@out", "@array", "pack N/S works"); @out = unpack("N/S*", pack("N/S*", @array) . "abcd"); is("@out", "@array", "pack N/S* works"); @out = unpack("N/S*", pack("N/S14", @array) . "abcd"); is("@out", "@array", "pack N/S14 works"); @out = unpack("N/S*", pack("N/S15", @array) . "abcd"); is("@out", "@array", "pack N/S15 works"); @out = unpack("N/S*", pack("N/S13", @array) . "abcd"); is("@out", "@array[0..12]", "pack N/S13 works"); @out = unpack("N/S*", pack("N/S0", @array) . "abcd"); is("@out", "", "pack N/S0 works"); is(pack("Z*/a0", "abc"), "0\0", "pack Z*/a0 makes a short string"); is(pack("Z*/Z0", "abc"), "0\0", "pack Z*/Z0 makes a short string"); is(pack("Z*/a3", "abc"), "3\0abc", "pack Z*/a3 makes a full string"); is(pack("Z*/Z3", "abc"), "3\0ab\0", "pack Z*/Z3 makes a short string"); is(pack("Z*/a5", "abc"), "5\0abc\0\0", "pack Z*/a5 makes a long string"); is(pack("Z*/Z5", "abc"), "5\0abc\0\0", "pack Z*/Z5 makes a long string"); is(pack("Z*/Z"), "1\0\0", "pack Z*/Z makes an extended string"); is(pack("Z*/Z", ""), "1\0\0", "pack Z*/Z makes an extended string"); is(pack("Z*/a", ""), "0\0", "pack Z*/a makes an extended string"); } { # unpack("A*", $unicode) strips general unicode spaces is(unpack("A*", "ab \n\xa0 \0"), "ab \n\xa0", 'normal A* strip leaves \xa0'); is(unpack("U0C0A*", "ab \n\xa0 \0"), "ab \n\xa0", 'normal A* strip leaves \xa0 even if it got upgraded for technical reasons'); is(unpack("A*", pack("a*(U0U)a*", "ab \n", 0xa0, " \0")), "ab", 'upgraded strings A* removes \xa0'); is(unpack("A*", pack("a*(U0UU)a*", "ab \n", 0xa0, 0x1680, " \0")), "ab", 'upgraded strings A* removes all unicode whitespace'); is(unpack("A5", pack("a*(U0U)a*", "ab \n", 0x1680, "def", "ab")), "ab", 'upgraded strings A5 removes all unicode whitespace'); is(unpack("A*", pack("U", 0x1680)), "", 'upgraded strings A* with nothing left'); } { # Testing unpack . and .! is(unpack(".", "ABCD"), 0, "offset at start of string is 0"); is(unpack(".", ""), 0, "offset at start of empty string is 0"); is(unpack("x3.", "ABCDEF"), 3, "simple offset works"); is(unpack("x3.", "ABC"), 3, "simple offset at end of string works"); is(unpack("x3.0", "ABC"), 0, "self offset is 0"); is(unpack("x3(x2.)", "ABCDEF"), 2, "offset is relative to inner group"); is(unpack("x3(X2.)", "ABCDEF"), -2, "negative offset relative to inner group"); is(unpack("x3(X2.2)", "ABCDEF"), 1, "offset is relative to inner group"); is(unpack("x3(x2.0)", "ABCDEF"), 0, "self offset in group is still 0"); is(unpack("x3(x2.2)", "ABCDEF"), 5, "offset counts groups"); is(unpack("x3(x2.*)", "ABCDEF"), 5, "star offset is relative to start"); my $high = chr(8188) x 6; is(unpack("x3(x2.)", $high), 2, "utf8 offset is relative to inner group"); is(unpack("x3(X2.)", $high), -2, "utf8 negative offset relative to inner group"); is(unpack("x3(X2.2)", $high), 1, "utf8 offset counts groups"); is(unpack("x3(x2.0)", $high), 0, "utf8 self offset in group is still 0"); is(unpack("x3(x2.2)", $high), 5, "utf8 offset counts groups"); is(unpack("x3(x2.*)", $high), 5, "utf8 star offset is relative to start"); is(unpack("U0x3(x2.)", $high), 2, "U0 mode utf8 offset is relative to inner group"); is(unpack("U0x3(X2.)", $high), -2, "U0 mode utf8 negative offset relative to inner group"); is(unpack("U0x3(X2.2)", $high), 1, "U0 mode utf8 offset counts groups"); is(unpack("U0x3(x2.0)", $high), 0, "U0 mode utf8 self offset in group is still 0"); is(unpack("U0x3(x2.2)", $high), 5, "U0 mode utf8 offset counts groups"); is(unpack("U0x3(x2.*)", $high), 5, "U0 mode utf8 star offset is relative to start"); is(unpack("x3(x2.!)", $high), 2*3, "utf8 offset is relative to inner group"); is(unpack("x3(X2.!)", $high), -2*3, "utf8 negative offset relative to inner group"); is(unpack("x3(X2.!2)", $high), 1*3, "utf8 offset counts groups"); is(unpack("x3(x2.!0)", $high), 0, "utf8 self offset in group is still 0"); is(unpack("x3(x2.!2)", $high), 5*3, "utf8 offset counts groups"); is(unpack("x3(x2.!*)", $high), 5*3, "utf8 star offset is relative to start"); is(unpack("U0x3(x2.!)", $high), 2, "U0 mode utf8 offset is relative to inner group"); is(unpack("U0x3(X2.!)", $high), -2, "U0 mode utf8 negative offset relative to inner group"); is(unpack("U0x3(X2.!2)", $high), 1, "U0 mode utf8 offset counts groups"); is(unpack("U0x3(x2.!0)", $high), 0, "U0 mode utf8 self offset in group is still 0"); is(unpack("U0x3(x2.!2)", $high), 5, "U0 mode utf8 offset counts groups"); is(unpack("U0x3(x2.!*)", $high), 5, "U0 mode utf8 star offset is relative to start"); } { # Testing pack . and .! is(pack("(a)5 .", 1..5, 3), "123", ". relative to string start, shorten"); eval { () = pack("(a)5 .", 1..5, -3) }; like($@, qr{'\.' outside of string in pack}, "Proper error message"); is(pack("(a)5 .", 1..5, 8), "12345\x00\x00\x00", ". relative to string start, extend"); is(pack("(a)5 .", 1..5, 5), "12345", ". relative to string start, keep"); is(pack("(a)5 .0", 1..5, -3), "12", ". relative to string current, shorten"); is(pack("(a)5 .0", 1..5, 2), "12345\x00\x00", ". relative to string current, extend"); is(pack("(a)5 .0", 1..5, 0), "12345", ". relative to string current, keep"); is(pack("(a)5 (.)", 1..5, -3), "12", ". relative to group, shorten"); is(pack("(a)5 (.)", 1..5, 2), "12345\x00\x00", ". relative to group, extend"); is(pack("(a)5 (.)", 1..5, 0), "12345", ". relative to group, keep"); is(pack("(a)3 ((a)2 .)", 1..5, -2), "1", ". relative to group, shorten"); is(pack("(a)3 ((a)2 .)", 1..5, 2), "12345", ". relative to group, keep"); is(pack("(a)3 ((a)2 .)", 1..5, 4), "12345\x00\x00", ". relative to group, extend"); is(pack("(a)3 ((a)2 .2)", 1..5, 2), "12", ". relative to counted group, shorten"); is(pack("(a)3 ((a)2 .2)", 1..5, 7), "12345\x00\x00", ". relative to counted group, extend"); is(pack("(a)3 ((a)2 .2)", 1..5, 5), "12345", ". relative to counted group, keep"); is(pack("(a)3 ((a)2 .*)", 1..5, 2), "12", ". relative to start, shorten"); is(pack("(a)3 ((a)2 .*)", 1..5, 7), "12345\x00\x00", ". relative to start, extend"); is(pack("(a)3 ((a)2 .*)", 1..5, 5), "12345", ". relative to start, keep"); is(pack('(a)5 (. @2 a)', 1..5, -3, "a"), "12\x00\x00a", ". based shrink properly updates group starts"); is(pack("(W)3 ((W)2 .)", 0x301..0x305, -2), "\x{301}", "utf8 . relative to group, shorten"); is(pack("(W)3 ((W)2 .)", 0x301..0x305, 2), "\x{301}\x{302}\x{303}\x{304}\x{305}", "utf8 . relative to group, keep"); is(pack("(W)3 ((W)2 .)", 0x301..0x305, 4), "\x{301}\x{302}\x{303}\x{304}\x{305}\x00\x00", "utf8 . relative to group, extend"); is(pack("(W)3 ((W)2 .!)", 0x301..0x305, -2), "\x{301}\x{302}", "utf8 . relative to group, shorten"); is(pack("(W)3 ((W)2 .!)", 0x301..0x305, 4), "\x{301}\x{302}\x{303}\x{304}\x{305}", "utf8 . relative to group, keep"); is(pack("(W)3 ((W)2 .!)", 0x301..0x305, 6), "\x{301}\x{302}\x{303}\x{304}\x{305}\x00\x00", "utf8 . relative to group, extend"); is(pack('(W)5 (. @2 a)', 0x301..0x305, -3, "a"), "\x{301}\x{302}\x00\x00a", "utf8 . based shrink properly updates group starts"); } { # Testing @! is(pack('a* @3', "abcde"), "abc", 'Test basic @'); is(pack('a* @!3', "abcde"), "abc", 'Test basic @!'); is(pack('a* @2', "\x{301}\x{302}\x{303}\x{304}\x{305}"), "\x{301}\x{302}", 'Test basic utf8 @'); is(pack('a* @!2', "\x{301}\x{302}\x{303}\x{304}\x{305}"), "\x{301}", 'Test basic utf8 @!'); is(unpack('@4 a*', "abcde"), "e", 'Test basic @'); is(unpack('@!4 a*', "abcde"), "e", 'Test basic @!'); is(unpack('@4 a*', "\x{301}\x{302}\x{303}\x{304}\x{305}"), "\x{305}", 'Test basic utf8 @'); is(unpack('@!4 a*', "\x{301}\x{302}\x{303}\x{304}\x{305}"), "\x{303}\x{304}\x{305}", 'Test basic utf8 @!'); } { #50256 my ($v) = split //, unpack ('(B)*', 'ab'); is($v, 0); # Doesn't SEGV :-) } perl-5.12.0-RC0/t/op/attrhand.t0000555000175000017500000000206711325125742015012 0ustar jessejesse#!/usr/bin/perl -w BEGIN { if ($ENV{PERL_CORE_MINITEST}) { print "1..0 # skip: miniperl can't load attributes\n"; exit 0; } chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } plan tests => 4; # test for bug #38475: parsing errors with multiline attributes package Antler; use Attribute::Handlers; sub TypeCheck :ATTR(CODE,RAWDATA) { ::ok(1); } sub WrongAttr :ATTR(CODE,RAWDATA) { ::ok(0); } sub CheckData :ATTR(RAWDATA) { # check that the $data element contains the given attribute parameters. if ($_[4] eq "12, 14") { ::ok(1) } else { ::ok(0) } } sub CheckEmptyValue :ATTR() { if (not defined $_[4]) { ::ok(1) } else { ::ok(0) } } package Deer; use base 'Antler'; sub something : TypeCheck( QNET::Util::Object, QNET::Util::Object, QNET::Util::Object ) { # WrongAttr (perl tokenizer bug) # keep this ^ lined up ! return 42; } something(); sub c :CheckData(12, 14) {}; sub d1 :CheckEmptyValue() {}; sub d2 :CheckEmptyValue {}; perl-5.12.0-RC0/t/op/getppid.t0000555000175000017500000000372011325125742014636 0ustar jessejesse#!./perl # Test that getppid() follows UNIX semantics: when the parent process # dies, the child is reparented to the init process # The init process is usually 1, but doesn't have to be, and there's no # standard way to find out what it is, so the only portable way to go it so # attempt 2 reparentings and see if the PID both orphaned grandchildren get is # the same. (and not ours) BEGIN { chdir 't' if -d 't'; @INC = qw(../lib); } use strict; use Config; BEGIN { for my $syscall (qw(pipe fork waitpid getppid)) { if (!$Config{"d_$syscall"}) { print "1..0 # Skip: no $syscall\n"; exit; } } require './test.pl'; plan (8); } sub fork_and_retrieve { my $which = shift; pipe my ($r, $w) or die "pipe: $!\n"; my $pid = fork; defined $pid or die "fork: $!\n"; if ($pid) { # parent close $w; $_ = <$r>; chomp; die "Garbled output '$_'" unless my ($first, $second) = /^(\d+),(\d+)\z/; cmp_ok ($first, '>=', 1, "Parent of $which grandchild"); cmp_ok ($second, '>=', 1, "New parent of orphaned $which grandchild"); SKIP: { skip("Orphan processes are not reparented on QNX", 1) if $^O eq 'nto'; isnt($first, $second, "Orphaned $which grandchild got a new parent"); } return $second; } else { # child # Prevent test.pl from thinking that we failed to run any tests. $::NO_ENDING = 1; close $r; my $pid2 = fork; defined $pid2 or die "fork: $!\n"; if ($pid2) { close $w; sleep 1; } else { # grandchild my $ppid1 = getppid(); # Wait for immediate parent to exit sleep 2; my $ppid2 = getppid(); print $w "$ppid1,$ppid2\n"; } exit 0; } } my $first = fork_and_retrieve("first"); my $second = fork_and_retrieve("second"); SKIP: { skip ("Orphan processes are not reparented on QNX", 1) if $^O eq 'nto'; is ($first, $second, "Both orphaned grandchildren get the same new parent"); } isnt ($first, $$, "And that new parent isn't this process"); perl-5.12.0-RC0/t/op/unshift.t0000555000175000017500000000315411325127002014652 0ustar jessejesse#!./perl BEGIN { require "test.pl"; } plan(18); @array = (1, 2, 3); { no warnings 'syntax'; $count3 = unshift (@array); } is(join(' ',@array), '1 2 3', 'unshift null'); cmp_ok($count3, '==', 3, 'unshift count == 3'); $count3_2 = unshift (@array, ()); is(join(' ',@array), '1 2 3', 'unshift null empty'); cmp_ok($count3_2, '==', 3, 'unshift count == 3 again'); $count4 = unshift (@array, 0); is(join(' ',@array), '0 1 2 3', 'unshift singleton list'); cmp_ok($count4, '==', 4, 'unshift count == 4'); $count7 = unshift (@array, 3, 2, 1); is(join(' ',@array), '3 2 1 0 1 2 3', 'unshift list'); cmp_ok($count7, '==', 7, 'unshift count == 7'); @list = (5, 4); $count9 = unshift (@array, @list); is(join(' ',@array), '5 4 3 2 1 0 1 2 3', 'unshift array'); cmp_ok($count9, '==', 9, 'unshift count == 9'); @list = (7); @list2 = (6); $count11 = unshift (@array, @list, @list2); is(join(' ',@array), '7 6 5 4 3 2 1 0 1 2 3', 'unshift arrays'); cmp_ok($count11, '==', 11, 'unshift count == 11'); # ignoring counts @alpha = ('y', 'z'); { no warnings 'syntax'; unshift (@alpha); } is(join(' ',@alpha), 'y z', 'void unshift null'); unshift (@alpha, ()); is(join(' ',@alpha), 'y z', 'void unshift null empty'); unshift (@alpha, 'x'); is(join(' ',@alpha), 'x y z', 'void unshift singleton list'); unshift (@alpha, 'u', 'v', 'w'); is(join(' ',@alpha), 'u v w x y z', 'void unshift list'); @bet = ('s', 't'); unshift (@alpha, @bet); is(join(' ',@alpha), 's t u v w x y z', 'void unshift array'); @bet = ('q'); @gimel = ('r'); unshift (@alpha, @bet, @gimel); is(join(' ',@alpha), 'q r s t u v w x y z', 'void unshift arrays'); perl-5.12.0-RC0/t/op/rand.t0000555000175000017500000002016311325125742014126 0ustar jessejesse#!./perl # From Tom Phoenix 22 Feb 1997 # Based upon a test script by kgb@ast.cam.ac.uk (Karl Glazebrook) # Looking for the hints? You're in the right place. # The hints are near each test, so search for "TEST #", where # the pound sign is replaced by the number of the test. # I'd like to include some more robust tests, but anything # too subtle to be detected here would require a time-consuming # test. Also, of course, we're here to detect only flaws in Perl; # if there are flaws in the underlying system rand, that's not # our responsibility. But if you want better tests, see # The Art of Computer Programming, Donald E. Knuth, volume 2, # chapter 3. ISBN 0-201-03822-6 (v. 2) BEGIN { chdir "t" if -d "t"; @INC = qw(. ../lib); } use strict; use Config; require "test.pl"; plan(tests => 8); my $reps = 15000; # How many times to try rand each time. # May be changed, but should be over 500. # The more the better! (But slower.) sub bits ($) { # Takes a small integer and returns the number of one-bits in it. my $total; my $bits = sprintf "%o", $_[0]; while (length $bits) { $total += (0,1,1,2,1,2,2,3)[chop $bits]; # Oct to bits } $total; } # First, let's see whether randbits is set right { my($max, $min, $sum); # Characteristics of rand my($off, $shouldbe); # Problems with randbits my($dev, $bits); # Number of one bits my $randbits = $Config{randbits}; $max = $min = rand(1); for (1..$reps) { my $n = rand(1); if ($n < 0.0 or $n >= 1.0) { print <= 1.0. # Make sure \$Config{drand01} is a valid expression in the # C-language, and produces values in the range [0.0,1.0). # # I give up. EOM exit; } $sum += $n; $bits += bits($n * 256); # Don't be greedy; 8 is enough # It's too many if randbits is less than 8! # But that should never be the case... I hope. # Note: If you change this, you must adapt the # formula for absolute standard deviation, below. $max = $n if $n > $max; $min = $n if $n < $min; } # This test checks for one of Perl's most frequent # mis-configurations. Your system's documentation # for rand(2) should tell you what value you need # for randbits. Usually the diagnostic message # has the right value as well. Just fix it and # recompile, and you'll usually be fine. (The main # reason that the diagnostic message might get the # wrong value is that Config.pm is incorrect.) # unless (ok( !$max <= 0 or $max >= (2 ** $randbits))) {# Just in case... print < 0); # Next more positive int unless (is( $off, 0 )) { $shouldbe = $Config{randbits} + $off; print "# max=[$max] min=[$min]\n"; print "# This perl was compiled with randbits=$randbits on $^O.\n"; print "# Consider using randbits=$shouldbe instead.\n"; # And skip the remaining tests; they would be pointless now. print "# Skipping remaining tests until randbits is fixed.\n"; exit; } # This should always be true: 0 <= rand(1) < 1 # If this test is failing, something is seriously wrong, # either in perl or your system's rand function. # unless (ok( !($min < 0 or $max >= 1) )) { # Slightly redundant... print "# min too low\n" if $min < 0; print "# max too high\n" if $max >= 1; } # This is just a crude test. The average number produced # by rand should be about one-half. But once in a while # it will be relatively far away. Note: This test will # occasionally fail on a perfectly good system! # See the hints for test 4 to see why. # $sum /= $reps; unless (ok( !($sum < 0.4 or $sum > 0.6) )) { print "# Average random number is far from 0.5\n"; } # NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE # This test will fail .1% of the time on a normal system. # also # This test asks you to see these hints 100% of the time! # NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE # # There is probably no reason to be alarmed that # something is wrong with your rand function. But, # if you're curious or if you can't help being # alarmed, keep reading. # # This is a less-crude test than test 3. But it has # the same basic flaw: Unusually distributed random # values should occasionally appear in every good # random number sequence. (If you flip a fair coin # twenty times every day, you'll see it land all # heads about one time in a million days, on the # average. That might alarm you if you saw it happen # on the first day!) # # So, if this test failed on you once, run it a dozen # times. If it keeps failing, it's likely that your # rand is bogus. If it keeps passing, it's likely # that the one failure was bogus. If it's a mix, # read on to see about how to interpret the tests. # # The number printed in square brackets is the # standard deviation, a statistical measure # of how unusual rand's behavior seemed. It should # fall in these ranges with these *approximate* # probabilities: # # under 1 68.26% of the time # 1-2 27.18% of the time # 2-3 4.30% of the time # over 3 0.26% of the time # # If the numbers you see are not scattered approximately # (not exactly!) like that table, check with your vendor # to find out what's wrong with your rand. Or with this # algorithm. :-) # # Calculating absoulute standard deviation for number of bits set # (eight bits per rep) $dev = abs ($bits - $reps * 4) / sqrt($reps * 2); ok( $dev < 3.3 ); if ($dev < 1.96) { print "# Your rand seems fine. If this test failed\n"; print "# previously, you may want to run it again.\n"; } elsif ($dev < 2.575) { print "# This is ok, but suspicious. But it will happen\n"; print "# one time out of 25, more or less.\n"; print "# You should run this test again to be sure.\n"; } elsif ($dev < 3.3) { print "# This is very suspicious. It will happen only\n"; print "# about one time out of 100, more or less.\n"; print "# You should run this test again to be sure.\n"; } elsif ($dev < 3.9) { print "# This is VERY suspicious. It will happen only\n"; print "# about one time out of 1000, more or less.\n"; print "# You should run this test again to be sure.\n"; } else { print "# This is VERY VERY suspicious.\n"; print "# Your rand seems to be bogus.\n"; } print "#\n# If you are having random number troubles,\n"; print "# see the hints within the test script for more\n"; printf "# information on why this might fail. [ %.3f ]\n", $dev; } # Now, let's see whether rand accepts its argument { my($max, $min); $max = $min = rand(100); for (1..$reps) { my $n = rand(100); $max = $n if $n > $max; $min = $n if $n < $min; } # This test checks to see that rand(100) really falls # within the range 0 - 100, and that the numbers produced # have a reasonably-large range among them. # unless ( ok( !($min < 0 or $max >= 100 or ($max - $min) < 65) ) ) { print "# min too low\n" if $min < 0; print "# max too high\n" if $max >= 100; print "# range too narrow\n" if ($max - $min) < 65; } # This test checks that rand without an argument # is equivalent to rand(1). # $_ = 12345; # Just for fun. srand 12345; my $r = rand; srand 12345; is(rand(1), $r, 'rand() without args is rand(1)'); # This checks that rand without an argument is not # rand($_). (In case somebody got overzealous.) # ok($r < 1, 'rand() without args is under 1'); } perl-5.12.0-RC0/t/op/64bitint.t0000555000175000017500000002477111325125742014656 0ustar jessejesse#./perl BEGIN { eval { my $q = pack "q", 0 }; if ($@) { print "1..0 # Skip: no 64-bit types\n"; exit(0); } chdir 't' if -d 't'; @INC = '../lib'; } # This could use many more tests. # so that using > 0xfffffff constants and # 32+ bit integers don't cause noise use warnings; no warnings qw(overflow portable); print "1..67\n"; # as 6 * 6 = 36, the last digit of 6**n will always be six. Hence the last # digit of 16**n will always be six. Hence 16**n - 1 will always end in 5. # Assumption is that UVs will always be a multiple of 4 bits long. my $UV_max = ~0; die "UV_max eq '$UV_max', doesn't end in 5; your UV isn't 4n bits long :-(." unless $UV_max =~ /5$/; my $UV_max_less3 = $UV_max - 3; my $maths_preserves_UVs = $UV_max_less3 =~ /^\d+2$/; # 5 - 3 is 2. if ($maths_preserves_UVs) { print "# This perl's maths preserves all bits of a UV.\n"; } else { print "# This perl's maths does not preserve all bits of a UV.\n"; } my $q = 12345678901; my $r = 23456789012; my $f = 0xffffffff; my $x; my $y; $x = unpack "q", pack "q", $q; print "not " unless $x == $q && $x > $f; print "ok 1\n"; $x = sprintf("%lld", 12345678901); print "not " unless $x eq $q && $x > $f; print "ok 2\n"; $x = sprintf("%lld", $q); print "not " unless $x == $q && $x eq $q && $x > $f; print "ok 3\n"; $x = sprintf("%Ld", $q); print "not " unless $x == $q && $x eq $q && $x > $f; print "ok 4\n"; $x = sprintf("%qd", $q); print "not " unless $x == $q && $x eq $q && $x > $f; print "ok 5\n"; $x = sprintf("%llx", $q); print "not " unless hex($x) == 0x2dfdc1c35 && hex($x) > $f; print "ok 6\n"; $x = sprintf("%Lx", $q); print "not " unless hex($x) == 0x2dfdc1c35 && hex($x) > $f; print "ok 7\n"; $x = sprintf("%qx", $q); print "not " unless hex($x) == 0x2dfdc1c35 && hex($x) > $f; print "ok 8\n"; $x = sprintf("%llo", $q); print "not " unless oct("0$x") == 0133767016065 && oct($x) > $f; print "ok 9\n"; $x = sprintf("%Lo", $q); print "not " unless oct("0$x") == 0133767016065 && oct($x) > $f; print "ok 10\n"; $x = sprintf("%qo", $q); print "not " unless oct("0$x") == 0133767016065 && oct($x) > $f; print "ok 11\n"; $x = sprintf("%llb", $q); print "not " unless oct("0b$x") == 0b1011011111110111000001110000110101 && oct("0b$x") > $f; print "ok 12\n"; $x = sprintf("%Lb", $q); print "not " unless oct("0b$x") == 0b1011011111110111000001110000110101 && oct("0b$x") > $f; print "ok 13\n"; $x = sprintf("%qb", $q); print "not " unless oct("0b$x") == 0b1011011111110111000001110000110101 && oct("0b$x") > $f; print "ok 14\n"; $x = sprintf("%llu", $q); print "not " unless $x eq $q && $x > $f; print "ok 15\n"; $x = sprintf("%Lu", $q); print "not " unless $x == $q && $x eq $q && $x > $f; print "ok 16\n"; $x = sprintf("%qu", $q); print "not " unless $x == $q && $x eq $q && $x > $f; print "ok 17\n"; $x = sprintf("%D", $q); print "not " unless $x == $q && $x eq $q && $x > $f; print "ok 18\n"; $x = sprintf("%U", $q); print "not " unless $x == $q && $x eq $q && $x > $f; print "ok 19\n"; $x = sprintf("%O", $q); print "not " unless oct($x) == $q && oct($x) > $f; print "ok 20\n"; $x = $q + $r; print "not " unless $x == 35802467913 && $x > $f; print "ok 21\n"; $x = $q - $r; print "not " unless $x == -11111110111 && -$x > $f; print "ok 22\n"; if ($^O ne 'unicos') { $x = $q * 1234567; print "not " unless $x == 15241567763770867 && $x > $f; print "ok 23\n"; $x /= 1234567; print "not " unless $x == $q && $x > $f; print "ok 24\n"; $x = 98765432109 % 12345678901; print "not " unless $x == 901; print "ok 25\n"; # The following 12 tests adapted from op/inc. $a = 9223372036854775807; $c = $a++; print "not " unless $a == 9223372036854775808; print "ok 26\n"; $a = 9223372036854775807; $c = ++$a; print "not " unless $a == 9223372036854775808 && $c == $a; print "ok 27\n"; $a = 9223372036854775807; $c = $a + 1; print "not " unless $a == 9223372036854775807 && $c == 9223372036854775808; print "ok 28\n"; $a = -9223372036854775808; { no warnings 'imprecision'; $c = $a--; } print "not " unless $a == -9223372036854775809 && $c == -9223372036854775808; print "ok 29\n"; $a = -9223372036854775808; { no warnings 'imprecision'; $c = --$a; } print "not " unless $a == -9223372036854775809 && $c == $a; print "ok 30\n"; $a = -9223372036854775808; $c = $a - 1; print "not " unless $a == -9223372036854775808 && $c == -9223372036854775809; print "ok 31\n"; $a = 9223372036854775808; $a = -$a; { no warnings 'imprecision'; $c = $a--; } print "not " unless $a == -9223372036854775809 && $c == -9223372036854775808; print "ok 32\n"; $a = 9223372036854775808; $a = -$a; { no warnings 'imprecision'; $c = --$a; } print "not " unless $a == -9223372036854775809 && $c == $a; print "ok 33\n"; $a = 9223372036854775808; $a = -$a; $c = $a - 1; print "not " unless $a == -9223372036854775808 && $c == -9223372036854775809; print "ok 34\n"; $a = 9223372036854775808; $b = -$a; { no warnings 'imprecision'; $c = $b--; } print "not " unless $b == -$a-1 && $c == -$a; print "ok 35\n"; $a = 9223372036854775808; $b = -$a; { no warnings 'imprecision'; $c = --$b; } print "not " unless $b == -$a-1 && $c == $b; print "ok 36\n"; $a = 9223372036854775808; $b = -$a; $b = $b - 1; print "not " unless $b == -(++$a); print "ok 37\n"; } else { # Unicos has imprecise doubles (14 decimal digits or so), # especially if operating near the UV/IV limits the low-order bits # become mangled even by simple arithmetic operations. for (23..37) { print "ok $_ # skipped: too imprecise numbers\n"; } } $x = ''; print "not " unless (vec($x, 1, 64) = $q) == $q; print "ok 38\n"; print "not " unless vec($x, 1, 64) == $q && vec($x, 1, 64) > $f; print "ok 39\n"; print "not " unless vec($x, 0, 64) == 0 && vec($x, 2, 64) == 0; print "ok 40\n"; print "not " unless ~0 == 0xffffffffffffffff; print "ok 41\n"; print "not " unless (0xffffffff<<32) == 0xffffffff00000000; print "ok 42\n"; print "not " unless ((0xffffffff)<<32)>>32 == 0xffffffff; print "ok 43\n"; print "not " unless 1<<63 == 0x8000000000000000; print "ok 44\n"; print "not " unless (sprintf "%#Vx", 1<<63) eq '0x8000000000000000'; print "ok 45\n"; print "not " unless (0x8000000000000000 | 1) == 0x8000000000000001; print "ok 46\n"; print "not " unless (0xf000000000000000 & 0x8000000000000000) == 0x8000000000000000; print "ok 47\n"; print "not " unless (0xf000000000000000 ^ 0xfffffffffffffff0) == 0x0ffffffffffffff0; print "ok 48\n"; print "not " unless (sprintf "%b", ~0) eq '1111111111111111111111111111111111111111111111111111111111111111'; print "ok 49\n"; print "not " unless (sprintf "%64b", ~0) eq '1111111111111111111111111111111111111111111111111111111111111111'; print "ok 50\n"; print "not " unless (sprintf "%d", ~0>>1) eq '9223372036854775807'; print "ok 51\n"; print "not " unless (sprintf "%u", ~0) eq '18446744073709551615'; print "ok 52\n"; # If the 53..55 fail you have problems in the parser's string->int conversion, # see toke.c:scan_num(). $q = -9223372036854775808; print "# $q ne\n# -9223372036854775808\nnot " unless "$q" eq "-9223372036854775808"; print "ok 53\n"; $q = 9223372036854775807; print "# $q ne\n# 9223372036854775807\nnot " unless "$q" eq "9223372036854775807"; print "ok 54\n"; $q = 18446744073709551615; print "# $q ne\n# 18446744073709551615\nnot " unless "$q" eq "18446744073709551615"; print "ok 55\n"; # Test that sv_2nv then sv_2iv is the same as sv_2iv direct # fails if whatever Atol is defined as can't actually cope with >32 bits. my $num = 4294967297; my $string = "4294967297"; { use integer; $num += 0; $string += 0; } if ($num eq $string) { print "ok 56\n"; } else { print "not ok 56 # \"$num\" ne \"$string\"\n"; } # Test that sv_2nv then sv_2uv is the same as sv_2uv direct $num = 4294967297; $string = "4294967297"; $num &= 0; $string &= 0; if ($num eq $string) { print "ok 57\n"; } else { print "not ok 57 # \"$num\" ne \"$string\"\n"; } $q = "18446744073709551616e0"; $q += 0; print "# \"18446744073709551616e0\" += 0 gives $q\nnot " if "$q" eq "18446744073709551615"; print "ok 58\n"; # 0xFFFFFFFFFFFFFFFF == 1 * 3 * 5 * 17 * 257 * 641 * 65537 * 6700417' $q = 0xFFFFFFFFFFFFFFFF / 3; if ($q == 0x5555555555555555 and ($q != 0x5555555555555556 or !$maths_preserves_UVs)) { print "ok 59\n"; } else { print "not ok 59 # 0xFFFFFFFFFFFFFFFF / 3 = $q\n"; print "# Should not be floating point\n" if $q =~ tr/e.//; } $q = 0xFFFFFFFFFFFFFFFF % 0x5555555555555555; if ($q == 0) { print "ok 60\n"; } else { print "not ok 60 # 0xFFFFFFFFFFFFFFFF % 0x5555555555555555 => $q\n"; } $q = 0xFFFFFFFFFFFFFFFF % 0xFFFFFFFFFFFFFFF0; if ($q == 0xF) { print "ok 61\n"; } else { print "not ok 61 # 0xFFFFFFFFFFFFFFFF % 0xFFFFFFFFFFFFFFF0 => $q\n"; } $q = 0x8000000000000000 % 9223372036854775807; if ($q == 1) { print "ok 62\n"; } else { print "not ok 62 # 0x8000000000000000 % 9223372036854775807 => $q\n"; } $q = 0x8000000000000000 % -9223372036854775807; if ($q == -9223372036854775806) { print "ok 63\n"; } else { print "not ok 63 # 0x8000000000000000 % -9223372036854775807 => $q\n"; } { use integer; $q = hex "0x123456789abcdef0"; if ($q == 0x123456789abcdef0 and $q != 0x123456789abcdef1) { print "ok 64\n"; } else { printf "not ok 64 # hex \"0x123456789abcdef0\" = $q (%X)\n", $q; print "# Should not be floating point\n" if $q =~ tr/e.//; } $q = oct "0x123456789abcdef0"; if ($q == 0x123456789abcdef0 and $q != 0x123456789abcdef1) { print "ok 65\n"; } else { printf "not ok 65 # oct \"0x123456789abcdef0\" = $q (%X)\n", $q; print "# Should not be floating point\n" if $q =~ tr/e.//; } $q = oct "765432176543217654321"; if ($q == 0765432176543217654321 and $q != 0765432176543217654322) { print "ok 66\n"; } else { printf "not ok 66 # oct \"765432176543217654321\" = $q (%o)\n", $q; print "# Should not be floating point\n" if $q =~ tr/e.//; } $q = oct "0b0101010101010101010101010101010101010101010101010101010101010101"; if ($q == 0x5555555555555555 and $q != 0x5555555555555556) { print "ok 67\n"; } else { printf "not ok 67 # oct \"0b0101010101010101010101010101010101010101010101010101010101010101\" = $q (%b)\n", $q; print "# Should not be floating point\n" if $q =~ tr/e.//; } } # eof perl-5.12.0-RC0/t/op/pow.t0000555000175000017500000000417711143650501014010 0ustar jessejesse#!./perl -w # Now they'll be wanting biff! and zap! tests too. BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } # This calcualtion ought to be within 0.001 of the right answer. my $bits_in_uv = int (0.001 + log (~0+1) / log 2); # 3**30 < 2**48, don't trust things outside that range on a Cray # Likewise other 3 should not overflow 48 bits if I did my sums right. my @pow = ([ 3, 30, 1e-14], [ 4, 32, 0], [ 5, 20, 1e-14], [2.5, 10, 1e-14], [ -2, 69, 0], [ -3, 30, 1e-14], ); my $tests; $tests += $_->[1] foreach @pow; plan tests => 13 + $bits_in_uv + $tests; # (-3)**3 gave 27 instead of -27 before change #20167. # Let's test the other similar edge cases, too. is((-3)**0, 1, "negative ** 0 = 1"); is((-3)**1, -3, "negative ** 1 = self"); is((-3)**2, 9, "negative ** 2 = positive"); is((-3)**3, -27, "(negative int) ** (odd power) is negative"); # Positives shouldn't be a problem is(3**0, 1, "positive ** 0 = 1"); is(3**1, 3, "positive ** 1 = self"); is(3**2, 9, "positive ** 2 = positive"); is(3**3, 27, "(positive int) ** (odd power) is positive"); # And test order of operations while we're at it is(-3**0, -1); is(-3**1, -3); is(-3**2, -9); is(-3**3, -27); # Ought to be 32, 64, 36 or something like that. my $remainder = $bits_in_uv & 3; cmp_ok ($remainder, '==', 0, 'Sanity check bits in UV calculation') or printf "# ~0 is %d (0x%d) which gives $bits_in_uv bits\n", ~0, ~0; # These are a lot of brute force tests to see how accurate $m ** $n is. # Unfortunately rather a lot of perl programs expect 2 ** $n to be integer # perfect, forgetting that it's a call to floating point pow() which never # claims to deliver perfection. foreach my $n (0..$bits_in_uv - 1) { my $pow = 2 ** $n; my $int = 1 << $n; cmp_ok ($pow, '==', $int, "2 ** $n vs 1 << $n"); } foreach my $pow (@pow) { my ($base, $max, $range) = @$pow; my $expect = 1; foreach my $n (0..$max-1) { my $got = $base ** $n; within ($got, $expect, $range, "$base ** $n got[$got] expect[$expect]"); $expect *= $base; } } perl-5.12.0-RC0/t/op/incfilter.t0000555000175000017500000001172611325125742015166 0ustar jessejesse#!./perl -w # Tests for the source filters in coderef-in-@INC BEGIN { chdir 't' if -d 't'; @INC = qw(. ../lib); if ($ENV{PERL_CORE_MINITEST}) { print "1..0 # Skip: no dynamic loading on miniperl\n"; exit 0; } unless (find PerlIO::Layer 'perlio') { print "1..0 # Skip: not perlio\n"; exit 0; } require "test.pl"; } use strict; use Config; use Filter::Util::Call; plan(tests => 141); unshift @INC, sub { no warnings 'uninitialized'; ref $_[1] eq 'ARRAY' ? @{$_[1]} : $_[1]; }; my $fh; open $fh, "<", \'pass("Can return file handles from \@INC");'; do $fh or die; my @origlines = ("# This is a blank line\n", "pass('Can return generators from \@INC');\n", "pass('Which return multiple lines');\n", "1", ); my @lines = @origlines; sub generator { $_ = shift @lines; # Return of 0 marks EOF return defined $_ ? 1 : 0; }; do \&generator or die; @lines = @origlines; # Check that the array dereferencing works ready for the more complex tests: do [\&generator] or die; sub generator_with_state { my $param = $_[1]; is (ref $param, 'ARRAY', "Got our parameter"); $_ = shift @$param; return defined $_ ? 1 : 0; } do [\&generator_with_state, ["pass('Can return generators which take state');\n", "pass('And return multiple lines');\n", ]] or die; open $fh, "<", \'fail("File handles and filters work from \@INC");'; do [$fh, sub {s/fail/pass/; return;}] or die; open $fh, "<", \'fail("File handles and filters with state work from \@INC");'; do [$fh, sub {s/$_[1]/pass/; return;}, 'fail'] or die; print "# 2 tests with pipes from subprocesses.\n"; my ($echo_command, $pass_arg, $fail_arg); if ($^O eq 'VMS') { $echo_command = 'write sys$output'; $pass_arg = '"pass"'; $fail_arg = '"fail"'; } else { $echo_command = 'echo'; $pass_arg = 'pass'; $fail_arg = 'fail'; } open $fh, "$echo_command $pass_arg|" or die $!; do $fh or die; open $fh, "$echo_command $fail_arg|" or die $!; do [$fh, sub {s/$_[1]/pass/; return;}, 'fail'] or die; sub rot13_filter { filter_add(sub { my $status = filter_read(); tr/A-Za-z/N-ZA-Mn-za-m/; $status; }) } open $fh, "<", \<<'EOC'; BEGIN {rot13_filter}; cnff("This will rot13'ed prepend"); EOC do $fh or die; open $fh, "<", \<<'EOC'; ORTVA {ebg13_svygre}; pass("This will rot13'ed twice"); EOC do [$fh, sub {tr/A-Za-z/N-ZA-Mn-za-m/; return;}] or die; my $count = 32; sub prepend_rot13_filter { filter_add(sub { my $previous = $_; # Filters should append to any existing data in $_ # But (logically) shouldn't filter it twice. my $test = "fzrt!"; $_ = $test; my $status = filter_read(); my $got = substr $_, 0, length $test, ''; is $got, $test, "Upstream didn't alter existing data"; tr/A-Za-z/N-ZA-Mn-za-m/; $_ = $previous . $_; die "Looping infinitely" unless $count--; $status; }) } open $fh, "<", \<<'EOC'; ORTVA {cercraq_ebg13_svygre}; pass("This will rot13'ed twice"); EOC do [$fh, sub {tr/A-Za-z/N-ZA-Mn-za-m/; return;}] or die; # This generates a heck of a lot of oks, but I think it's necessary. my $amount = 1; sub prepend_block_counting_filter { filter_add(sub { my $output = $_; my $count = 256; while (--$count) { $_ = ''; my $status = filter_read($amount); cmp_ok (length $_, '<=', $amount, "block mode works?"); $output .= $_; if ($status <= 0 or /\n/s) { $_ = $output; return $status; } } die "Looping infinitely"; }) } open $fh, "<", \<<'EOC'; BEGIN {prepend_block_counting_filter}; pass("one by one"); pass("and again"); EOC do [$fh, sub {return;}] or die; open $fh, "<", \<<'EOC'; BEGIN {prepend_block_counting_filter}; pas("SSS make s fast SSS"); EOC TODO: { todo_skip "disabled under -Dmad", 50 if $Config{mad}; do [$fh, sub {s/s/ss/gs; s/([\nS])/$1$1$1/gs; return;}] or die; } sub prepend_line_counting_filter { filter_add(sub { my $output = $_; $_ = ''; my $status = filter_read(); my $newlines = tr/\n//; cmp_ok ($newlines, '<=', 1, "1 line at most?"); $_ = $output . $_ if defined $output; return $status; }) } open $fh, "<", \<<'EOC'; BEGIN {prepend_line_counting_filter}; pass("You should see this line thrice"); EOC do [$fh, sub {$_ .= $_ . $_; return;}] or die; do \"pass\n(\n'Scalar references are treated as initial file contents'\n)\n" or die; open $fh, "<", \"ss('The file is concatentated');"; do [\'pa', $fh] or die; open $fh, "<", \"ff('Gur svygre vf bayl eha ba gur svyr');"; do [\'pa', $fh, sub {tr/A-Za-z/N-ZA-Mn-za-m/; return;}] or die; open $fh, "<", \"SS('State also works');"; do [\'pa', $fh, sub {s/($_[1])/lc $1/ge; return;}, "S"] or die; @lines = ('ss', '(', "'you can use a generator'", ')'); do [\'pa', \&generator] or die; do [\'pa', \&generator_with_state, ["ss('And generators which take state');\n", "pass('And return multiple lines');\n", ]] or die; perl-5.12.0-RC0/t/op/undef.t0000555000175000017500000000376611325127002014304 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } use strict; use vars qw(@ary %ary %hash); plan 40; ok !defined($a); $a = 1+1; ok defined($a); undef $a; ok !defined($a); $a = "hi"; ok defined($a); $a = $b; ok !defined($a); @ary = ("1arg"); $a = pop(@ary); ok defined($a); $a = pop(@ary); ok !defined($a); @ary = ("1arg"); $a = shift(@ary); ok defined($a); $a = shift(@ary); ok !defined($a); $ary{'foo'} = 'hi'; ok defined($ary{'foo'}); ok !defined($ary{'bar'}); undef $ary{'foo'}; ok !defined($ary{'foo'}); ok defined(@ary); { no warnings 'deprecated'; ok defined(%ary); } ok %ary; undef @ary; ok !defined(@ary); undef %ary; { no warnings 'deprecated'; ok !defined(%ary); } ok !%ary; @ary = (1); ok defined @ary; %ary = (1,1); { no warnings 'deprecated'; ok defined %ary; } ok %ary; sub foo { pass; 1 } &foo || fail; ok defined &foo; undef &foo; ok !defined(&foo); eval { undef $1 }; like $@, qr/^Modification of a read/; eval { $1 = undef }; like $@, qr/^Modification of a read/; { require Tie::Hash; tie my %foo, 'Tie::StdHash'; no warnings 'deprecated'; ok defined %foo; %foo = ( a => 1 ); ok defined %foo; } { require Tie::Array; tie my @foo, 'Tie::StdArray'; no warnings 'deprecated'; ok defined @foo; @foo = ( a => 1 ); ok defined @foo; } { # [perl #17753] segfault when undef'ing unquoted string constant eval 'undef tcp'; like $@, qr/^Can't modify constant item/; } # bugid 3096 # undefing a hash may free objects with destructors that then try to # modify the hash. To them, the hash should appear empty. %hash = ( key1 => bless({}, 'X'), key2 => bless({}, 'X'), ); undef %hash; sub X::DESTROY { is scalar keys %hash, 0; is scalar values %hash, 0; my @l = each %hash; is @l, 0; is delete $hash{'key2'}, undef; } # this will segfault if it fails sub PVBM () { 'foo' } { my $dummy = index 'foo', PVBM } my $pvbm = PVBM; undef $pvbm; ok !defined $pvbm; perl-5.12.0-RC0/t/op/cond.t0000555000175000017500000000031511325125742014122 0ustar jessejesse#!./perl print "1..4\n"; print 1 ? "ok 1\n" : "not ok 1\n"; # compile time print 0 ? "not ok 2\n" : "ok 2\n"; $x = 1; print $x ? "ok 3\n" : "not ok 3\n"; # run time print !$x ? "not ok 4\n" : "ok 4\n"; perl-5.12.0-RC0/t/op/utf8decode.t0000555000175000017500000002155511143650501015234 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } { my $wide = v256; use bytes; my $ordwide = ord($wide); printf "# under use bytes ord(v256) = 0x%02x\n", $ordwide; if ($ordwide == 140) { print "1..0 # Skip: UTF-EBCDIC (not UTF-8) used here\n"; exit 0; } elsif ($ordwide != 196) { printf "# v256 starts with 0x%02x\n", $ordwide; } } no utf8; print "1..78\n"; my $test = 1; # This table is based on Markus Kuhn's UTF-8 Decode Stress Tester, # http://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt, # version dated 2000-09-02. # We use the \x notation instead of raw binary bytes for \x00-\x1f\x7f-\xff # because e.g. many patch programs have issues with binary data. my @MK = split(/\n/, <<__EOMK__); 1 Correct UTF-8 1.1.1 y "\xce\xba\xe1\xbd\xb9\xcf\x83\xce\xbc\xce\xb5" - 11 ce:ba:e1:bd:b9:cf:83:ce:bc:ce:b5 5 2 Boundary conditions 2.1 First possible sequence of certain length 2.1.1 y "\x00" 0 1 00 1 2.1.2 y "\xc2\x80" 80 2 c2:80 1 2.1.3 y "\xe0\xa0\x80" 800 3 e0:a0:80 1 2.1.4 y "\xf0\x90\x80\x80" 10000 4 f0:90:80:80 1 2.1.5 y "\xf8\x88\x80\x80\x80" 200000 5 f8:88:80:80:80 1 2.1.6 y "\xfc\x84\x80\x80\x80\x80" 4000000 6 fc:84:80:80:80:80 1 2.2 Last possible sequence of certain length 2.2.1 y "\x7f" 7f 1 7f 1 2.2.2 y "\xdf\xbf" 7ff 2 df:bf 1 # The ffff is illegal unless UTF8_ALLOW_FFFF 2.2.3 n "\xef\xbf\xbf" ffff 3 ef:bf:bf 1 character 0xffff 2.2.4 y "\xf7\xbf\xbf\xbf" 1fffff 4 f7:bf:bf:bf 1 2.2.5 y "\xfb\xbf\xbf\xbf\xbf" 3ffffff 5 fb:bf:bf:bf:bf 1 2.2.6 y "\xfd\xbf\xbf\xbf\xbf\xbf" 7fffffff 6 fd:bf:bf:bf:bf:bf 1 2.3 Other boundary conditions 2.3.1 y "\xed\x9f\xbf" d7ff 3 ed:9f:bf 1 2.3.2 y "\xee\x80\x80" e000 3 ee:80:80 1 2.3.3 y "\xef\xbf\xbd" fffd 3 ef:bf:bd 1 2.3.4 y "\xf4\x8f\xbf\xbf" 10ffff 4 f4:8f:bf:bf 1 2.3.5 y "\xf4\x90\x80\x80" 110000 4 f4:90:80:80 1 3 Malformed sequences 3.1 Unexpected continuation bytes 3.1.1 n "\x80" - 1 80 - unexpected continuation byte 0x80 3.1.2 n "\xbf" - 1 bf - unexpected continuation byte 0xbf 3.1.3 n "\x80\xbf" - 2 80:bf - unexpected continuation byte 0x80 3.1.4 n "\x80\xbf\x80" - 3 80:bf:80 - unexpected continuation byte 0x80 3.1.5 n "\x80\xbf\x80\xbf" - 4 80:bf:80:bf - unexpected continuation byte 0x80 3.1.6 n "\x80\xbf\x80\xbf\x80" - 5 80:bf:80:bf:80 - unexpected continuation byte 0x80 3.1.7 n "\x80\xbf\x80\xbf\x80\xbf" - 6 80:bf:80:bf:80:bf - unexpected continuation byte 0x80 3.1.8 n "\x80\xbf\x80\xbf\x80\xbf\x80" - 7 80:bf:80:bf:80:bf:80 - unexpected continuation byte 0x80 3.1.9 n "\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8a\x8b\x8c\x8d\x8e\x8f\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9a\x9b\x9c\x9d\x9e\x9f\xa0\xa1\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\xaa\xab\xac\xad\xae\xaf\xb0\xb1\xb2\xb3\xb4\xb5\xb6\xb7\xb8\xb9\xba\xbb\xbc\xbd\xbe\xbf" - 64 80:81:82:83:84:85:86:87:88:89:8a:8b:8c:8d:8e:8f:90:91:92:93:94:95:96:97:98:99:9a:9b:9c:9d:9e:9f:a0:a1:a2:a3:a4:a5:a6:a7:a8:a9:aa:ab:ac:ad:ae:af:b0:b1:b2:b3:b4:b5:b6:b7:b8:b9:ba:bb:bc:bd:be:bf - unexpected continuation byte 0x80 3.2 Lonely start characters 3.2.1 n "\xc0 \xc1 \xc2 \xc3 \xc4 \xc5 \xc6 \xc7 \xc8 \xc9 \xca \xcb \xcc \xcd \xce \xcf \xd0 \xd1 \xd2 \xd3 \xd4 \xd5 \xd6 \xd7 \xd8 \xd9 \xda \xdb \xdc \xdd \xde \xdf " - 64 c0:20:c1:20:c2:20:c3:20:c4:20:c5:20:c6:20:c7:20:c8:20:c9:20:ca:20:cb:20:cc:20:cd:20:ce:20:cf:20:d0:20:d1:20:d2:20:d3:20:d4:20:d5:20:d6:20:d7:20:d8:20:d9:20:da:20:db:20:dc:20:dd:20:de:20:df:20 - unexpected non-continuation byte 0x20 after start byte 0xc0 3.2.2 n "\xe0 \xe1 \xe2 \xe3 \xe4 \xe5 \xe6 \xe7 \xe8 \xe9 \xea \xeb \xec \xed \xee \xef " - 32 e0:20:e1:20:e2:20:e3:20:e4:20:e5:20:e6:20:e7:20:e8:20:e9:20:ea:20:eb:20:ec:20:ed:20:ee:20:ef:20 - unexpected non-continuation byte 0x20 after start byte 0xe0 3.2.3 n "\xf0 \xf1 \xf2 \xf3 \xf4 \xf5 \xf6 \xf7 " - 16 f0:20:f1:20:f2:20:f3:20:f4:20:f5:20:f6:20:f7:20 - unexpected non-continuation byte 0x20 after start byte 0xf0 3.2.4 n "\xf8 \xf9 \xfa \xfb " - 8 f8:20:f9:20:fa:20:fb:20 - unexpected non-continuation byte 0x20 after start byte 0xf8 3.2.5 n "\xfc \xfd " - 4 fc:20:fd:20 - unexpected non-continuation byte 0x20 after start byte 0xfc 3.3 Sequences with last continuation byte missing 3.3.1 n "\xc0" - 1 c0 - 1 byte, need 2 3.3.2 n "\xe0\x80" - 2 e0:80 - 2 bytes, need 3 3.3.3 n "\xf0\x80\x80" - 3 f0:80:80 - 3 bytes, need 4 3.3.4 n "\xf8\x80\x80\x80" - 4 f8:80:80:80 - 4 bytes, need 5 3.3.5 n "\xfc\x80\x80\x80\x80" - 5 fc:80:80:80:80 - 5 bytes, need 6 3.3.6 n "\xdf" - 1 df - 1 byte, need 2 3.3.7 n "\xef\xbf" - 2 ef:bf - 2 bytes, need 3 3.3.8 n "\xf7\xbf\xbf" - 3 f7:bf:bf - 3 bytes, need 4 3.3.9 n "\xfb\xbf\xbf\xbf" - 4 fb:bf:bf:bf - 4 bytes, need 5 3.3.10 n "\xfd\xbf\xbf\xbf\xbf" - 5 fd:bf:bf:bf:bf - 5 bytes, need 6 3.4 Concatenation of incomplete sequences 3.4.1 n "\xc0\xe0\x80\xf0\x80\x80\xf8\x80\x80\x80\xfc\x80\x80\x80\x80\xdf\xef\xbf\xf7\xbf\xbf\xfb\xbf\xbf\xbf\xfd\xbf\xbf\xbf\xbf" - 30 c0:e0:80:f0:80:80:f8:80:80:80:fc:80:80:80:80:df:ef:bf:f7:bf:bf:fb:bf:bf:bf:fd:bf:bf:bf:bf - unexpected non-continuation byte 0xe0 after start byte 0xc0 3.5 Impossible bytes 3.5.1 n "\xfe" - 1 fe - byte 0xfe 3.5.2 n "\xff" - 1 ff - byte 0xff 3.5.3 n "\xfe\xfe\xff\xff" - 4 fe:fe:ff:ff - byte 0xfe 4 Overlong sequences 4.1 Examples of an overlong ASCII character 4.1.1 n "\xc0\xaf" - 2 c0:af - 2 bytes, need 1 4.1.2 n "\xe0\x80\xaf" - 3 e0:80:af - 3 bytes, need 1 4.1.3 n "\xf0\x80\x80\xaf" - 4 f0:80:80:af - 4 bytes, need 1 4.1.4 n "\xf8\x80\x80\x80\xaf" - 5 f8:80:80:80:af - 5 bytes, need 1 4.1.5 n "\xfc\x80\x80\x80\x80\xaf" - 6 fc:80:80:80:80:af - 6 bytes, need 1 4.2 Maximum overlong sequences 4.2.1 n "\xc1\xbf" - 2 c1:bf - 2 bytes, need 1 4.2.2 n "\xe0\x9f\xbf" - 3 e0:9f:bf - 3 bytes, need 2 4.2.3 n "\xf0\x8f\xbf\xbf" - 4 f0:8f:bf:bf - 4 bytes, need 3 4.2.4 n "\xf8\x87\xbf\xbf\xbf" - 5 f8:87:bf:bf:bf - 5 bytes, need 4 4.2.5 n "\xfc\x83\xbf\xbf\xbf\xbf" - 6 fc:83:bf:bf:bf:bf - 6 bytes, need 5 4.3 Overlong representation of the NUL character 4.3.1 n "\xc0\x80" - 2 c0:80 - 2 bytes, need 1 4.3.2 n "\xe0\x80\x80" - 3 e0:80:80 - 3 bytes, need 1 4.3.3 n "\xf0\x80\x80\x80" - 4 f0:80:80:80 - 4 bytes, need 1 4.3.4 n "\xf8\x80\x80\x80\x80" - 5 f8:80:80:80:80 - 5 bytes, need 1 4.3.5 n "\xfc\x80\x80\x80\x80\x80" - 6 fc:80:80:80:80:80 - 6 bytes, need 1 5 Illegal code positions 5.1 Single UTF-16 surrogates 5.1.1 n "\xed\xa0\x80" - 3 ed:a0:80 - UTF-16 surrogate 0xd800 5.1.2 n "\xed\xad\xbf" - 3 ed:ad:bf - UTF-16 surrogate 0xdb7f 5.1.3 n "\xed\xae\x80" - 3 ed:ae:80 - UTF-16 surrogate 0xdb80 5.1.4 n "\xed\xaf\xbf" - 3 ed:af:bf - UTF-16 surrogate 0xdbff 5.1.5 n "\xed\xb0\x80" - 3 ed:b0:80 - UTF-16 surrogate 0xdc00 5.1.6 n "\xed\xbe\x80" - 3 ed:be:80 - UTF-16 surrogate 0xdf80 5.1.7 n "\xed\xbf\xbf" - 3 ed:bf:bf - UTF-16 surrogate 0xdfff 5.2 Paired UTF-16 surrogates 5.2.1 n "\xed\xa0\x80\xed\xb0\x80" - 6 ed:a0:80:ed:b0:80 - UTF-16 surrogate 0xd800 5.2.2 n "\xed\xa0\x80\xed\xbf\xbf" - 6 ed:a0:80:ed:bf:bf - UTF-16 surrogate 0xd800 5.2.3 n "\xed\xad\xbf\xed\xb0\x80" - 6 ed:ad:bf:ed:b0:80 - UTF-16 surrogate 0xdb7f 5.2.4 n "\xed\xad\xbf\xed\xbf\xbf" - 6 ed:ad:bf:ed:bf:bf - UTF-16 surrogate 0xdb7f 5.2.5 n "\xed\xae\x80\xed\xb0\x80" - 6 ed:ae:80:ed:b0:80 - UTF-16 surrogate 0xdb80 5.2.6 n "\xed\xae\x80\xed\xbf\xbf" - 6 ed:ae:80:ed:bf:bf - UTF-16 surrogate 0xdb80 5.2.7 n "\xed\xaf\xbf\xed\xb0\x80" - 6 ed:af:bf:ed:b0:80 - UTF-16 surrogate 0xdbff 5.2.8 n "\xed\xaf\xbf\xed\xbf\xbf" - 6 ed:af:bf:ed:bf:bf - UTF-16 surrogate 0xdbff 5.3 Other illegal code positions 5.3.1 n "\xef\xbf\xbe" - 3 ef:bf:be - byte order mark 0xfffe # The ffff is illegal unless UTF8_ALLOW_FFFF 5.3.2 n "\xef\xbf\xbf" - 3 ef:bf:bf - character 0xffff __EOMK__ # 104..181 { my $id; local $SIG{__WARN__} = sub { print "# $id: @_"; $@ = "@_"; }; sub moan { print "$id: @_"; } sub warn_unpack_U { $@ = ''; my @null = unpack('U0U*', $_[0]); return $@; } for (@MK) { if (/^(?:\d+(?:\.\d+)?)\s/ || /^#/) { # print "# $_\n"; } elsif (/^(\d+\.\d+\.\d+[bu]?)\s+([yn])\s+"(.+)"\s+([0-9a-f]{1,8}|-)\s+(\d+)\s+([0-9a-f]{2}(?::[0-9a-f]{2})*)(?:\s+((?:\d+|-)(?:\s+(.+))?))?$/) { $id = $1; my ($okay, $bytes, $Unicode, $byteslen, $hex, $charslen, $experr) = ($2, $3, $4, $5, $6, $7, $8); my @hex = split(/:/, $hex); unless (@hex == $byteslen) { my $nhex = @hex; moan "amount of hex ($nhex) not equal to byteslen ($byteslen)\n"; } { use bytes; my $bytesbyteslen = length($bytes); unless ($bytesbyteslen == $byteslen) { moan "bytes length() ($bytesbyteslen) not equal to $byteslen\n"; } } my $warn = warn_unpack_U($bytes); if ($okay eq 'y') { if ($warn) { moan "unpack('U0U*') false negative\n"; print "not "; } } elsif ($okay eq 'n') { if (not $warn || ($experr ne '' && $warn !~ /$experr/)) { moan "unpack('U0U*') false positive\n"; print "not "; } } print "ok $test # $id $okay\n"; $test++; } else { moan "unknown format\n"; } } } perl-5.12.0-RC0/t/op/chr.t0000555000175000017500000000354511325125742013763 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = qw(. ../lib); # ../lib needed for test.deparse require "test.pl"; } plan tests => 34; # Note that t/op/ord.t already tests for chr() <-> ord() rountripping. # Don't assume ASCII. is(chr(ord("A")), "A"); is(chr( 0), "\x00"); is(chr(127), "\x7F"); is(chr(128), "\x80"); is(chr(255), "\xFF"); is(chr(-0.1), "\x{FFFD}"); # The U+FFFD Unicode replacement character. is(chr(-1 ), "\x{FFFD}"); is(chr(-2 ), "\x{FFFD}"); is(chr(-3.0), "\x{FFFD}"); { use bytes; # Backward compatibility. is(chr(-0.1), "\x00"); is(chr(-1 ), "\xFF"); is(chr(-2 ), "\xFE"); is(chr(-3.0), "\xFD"); } # Check UTF-8 (not UTF-EBCDIC). SKIP: { skip "no UTF-8 on EBCDIC", 21 if chr(193) eq 'A'; sub hexes { no warnings 'utf8'; # avoid surrogate and beyond Unicode warnings join(" ",unpack "U0 (H2)*", chr $_[0]); } # The following code points are some interesting steps in UTF-8. is(hexes( 0x100), "c4 80"); is(hexes( 0x7FF), "df bf"); is(hexes( 0x800), "e0 a0 80"); is(hexes( 0xFFF), "e0 bf bf"); is(hexes( 0x1000), "e1 80 80"); is(hexes( 0xCFFF), "ec bf bf"); is(hexes( 0xD000), "ed 80 80"); is(hexes( 0xD7FF), "ed 9f bf"); is(hexes( 0xD800), "ed a0 80"); # not strict utf-8 (surrogate area begin) is(hexes( 0xDFFF), "ed bf bf"); # not strict utf-8 (surrogate area end) is(hexes( 0xE000), "ee 80 80"); is(hexes( 0xFFFF), "ef bf bf"); is(hexes( 0x10000), "f0 90 80 80"); is(hexes( 0x3FFFF), "f0 bf bf bf"); is(hexes( 0x40000), "f1 80 80 80"); is(hexes( 0xFFFFF), "f3 bf bf bf"); is(hexes(0x100000), "f4 80 80 80"); is(hexes(0x10FFFF), "f4 8f bf bf"); # Unicode (4.1) last code point is(hexes(0x110000), "f4 90 80 80"); is(hexes(0x1FFFFF), "f7 bf bf bf"); # last four byte encoding is(hexes(0x200000), "f8 88 80 80 80"); } perl-5.12.0-RC0/t/op/ver.t0000555000175000017500000001773611325125742014012 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = qw(. ../lib); $SIG{'__WARN__'} = sub { warn $_[0] if $DOWARN }; } $DOWARN = 1; # enable run-time warnings now use Config; require "test.pl"; plan( tests => 54 ); eval 'use v5.5.640'; is( $@, '', "use v5.5.640; $@"); require_ok('v5.5.640'); # printing characters should work if (ord("\t") == 9) { # ASCII is('ok ',v111.107.32,'ASCII printing characters'); # hash keys too $h{v111.107} = "ok"; is('ok',$h{v111.107},'ASCII hash keys'); } else { # EBCDIC is('ok ',v150.146.64,'EBCDIC printing characters'); # hash keys too $h{v150.146} = "ok"; is('ok',$h{v150.146},'EBCDIC hash keys'); } # poetry optimization should also sub v77 { "ok" } $x = v77; is('ok',$x,'poetry optimization'); # but not when dots are involved if (ord("\t") == 9) { # ASCII $x = v77.78.79; } else { $x = v212.213.214; } is($x, 'MNO','poetry optimization with dots'); is(v1.20.300.4000, "\x{1}\x{14}\x{12c}\x{fa0}",'compare embedded \x{} string'); # # now do the same without the "v" eval 'use 5.5.640'; is( $@, '', "use 5.5.640; $@"); require_ok('5.5.640'); # hash keys too if (ord("\t") == 9) { # ASCII $h{111.107.32} = "ok"; } else { $h{150.146.64} = "ok"; } is('ok',$h{ok },'hash keys w/o v'); if (ord("\t") == 9) { # ASCII $x = 77.78.79; } else { $x = 212.213.214; } is($x, 'MNO','poetry optimization with dots w/o v'); is(1.20.300.4000, "\x{1}\x{14}\x{12c}\x{fa0}",'compare embedded \x{} string w/o v'); # test sprintf("%vd"...) etc if (ord("\t") == 9) { # ASCII is(sprintf("%vd", "Perl"), '80.101.114.108', 'ASCII sprintf("%vd", "Perl")'); } else { is(sprintf("%vd", "Perl"), '215.133.153.147', 'EBCDIC sprintf("%vd", "Perl")'); } is(sprintf("%vd", v1.22.333.4444), '1.22.333.4444', 'sprintf("%vd", v1.22.333.4444)'); if (ord("\t") == 9) { # ASCII is(sprintf("%vx", "Perl"), '50.65.72.6c', 'ASCII sprintf("%vx", "Perl")'); } else { is(sprintf("%vx", "Perl"), 'd7.85.99.93', 'EBCDIC sprintf("%vx", "Perl")'); } is(sprintf("%vX", 1.22.333.4444), '1.16.14D.115C','ASCII sprintf("%vX", 1.22.333.4444)'); if (ord("\t") == 9) { # ASCII is(sprintf("%#*vo", ":", "Perl"), '0120:0145:0162:0154', 'ASCII sprintf("%vo", "Perl")'); } else { is(sprintf("%#*vo", ":", "Perl"), '0327:0205:0231:0223', 'EBCDIC sprintf("%vo", "Perl")'); } is(sprintf("%*vb", "##", v1.22.333.4444), '1##10110##101001101##1000101011100', 'sprintf("%vb", 1.22.333.4444)'); is(sprintf("%vd", join("", map { chr } unpack 'U*', pack('U*',2001,2002,2003))), '2001.2002.2003','unpack/pack U*'); { use bytes; if (ord("\t") == 9) { # ASCII is(sprintf("%vd", "Perl"), '80.101.114.108', 'ASCII sprintf("%vd", "Perl") w/use bytes'); } else { is(sprintf("%vd", "Perl"), '215.133.153.147', 'EBCDIC sprintf("%vd", "Perl") w/use bytes'); } if (ord("\t") == 9) { # ASCII is(sprintf("%vd", 1.22.333.4444), '1.22.197.141.225.133.156', 'ASCII sprintf("%vd", v1.22.333.4444 w/use bytes'); } else { is(sprintf("%vd", 1.22.333.4444), '1.22.142.84.187.81.112', 'EBCDIC sprintf("%vd", v1.22.333.4444 w/use bytes'); } if (ord("\t") == 9) { # ASCII is(sprintf("%vx", "Perl"), '50.65.72.6c', 'ASCII sprintf("%vx", "Perl")'); } else { is(sprintf("%vx", "Perl"), 'd7.85.99.93', 'EBCDIC sprintf("%vx", "Perl")'); } if (ord("\t") == 9) { # ASCII is(sprintf("%vX", v1.22.333.4444), '1.16.C5.8D.E1.85.9C', 'ASCII sprintf("%vX", v1.22.333.4444)'); } else { is(sprintf("%vX", v1.22.333.4444), '1.16.8E.54.BB.51.70', 'EBCDIC sprintf("%vX", v1.22.333.4444)'); } if (ord("\t") == 9) { # ASCII is(sprintf("%#*vo", ":", "Perl"), '0120:0145:0162:0154', 'ASCII sprintf("%#*vo", ":", "Perl")'); } else { is(sprintf("%#*vo", ":", "Perl"), '0327:0205:0231:0223', 'EBCDIC sprintf("%#*vo", ":", "Perl")'); } if (ord("\t") == 9) { # ASCII is(sprintf("%*vb", "##", v1.22.333.4444), '1##10110##11000101##10001101##11100001##10000101##10011100', 'ASCII sprintf("%*vb", "##", v1.22.333.4444)'); } else { is(sprintf("%*vb", "##", v1.22.333.4444), '1##10110##10001110##1010100##10111011##1010001##1110000', 'EBCDIC sprintf("%*vb", "##", v1.22.333.4444)'); } } { # bug id 20000323.056 is( "\x{41}", +v65, 'bug id 20000323.056'); is( "\x41", +v65, 'bug id 20000323.056'); is( "\x{c8}", +v200, 'bug id 20000323.056'); is( "\xc8", +v200, 'bug id 20000323.056'); is( "\x{221b}", +v8731, 'bug id 20000323.056'); } # See if the things Camel-III says are true: 29..33 # Chapter 2 pp67/68 my $vs = v1.20.300.4000; is($vs,"\x{1}\x{14}\x{12c}\x{fa0}","v-string ne \\x{}"); is($vs,chr(1).chr(20).chr(300).chr(4000),"v-string ne chr()"); is('foo',((chr(193) eq 'A') ? v134.150.150 : v102.111.111),"v-string ne ''"); # Chapter 15, pp403 # See if sane addr and gethostbyaddr() work eval { require Socket; gethostbyaddr(v127.0.0.1, &Socket::AF_INET) }; if ($@) { # No - so do not test insane fails. $@ =~ s/\n/\n# /g; } SKIP: { skip("No Socket::AF_INET # $@") if $@; my $ip = v2004.148.0.1; my $host; eval { $host = gethostbyaddr($ip,&Socket::AF_INET) }; like($@, qr/Wide character/, "Non-bytes leak to gethostbyaddr"); } # Chapter 28, pp671 ok(v5.6.0 lt v5.7.0, "v5.6.0 lt v5.7.0"); # part of 20000323.059 is(v200, chr(200), "v200 eq chr(200)" ); is(v200, +v200, "v200 eq +v200" ); is(v200, eval( "v200"), 'v200 eq "v200"' ); is(v200, eval("+v200"), 'v200 eq eval("+v200")' ); # Tests for string/numeric value of $] itself my ($revision,$version,$subversion) = split /\./, sprintf("%vd",$^V); # $^V always displays the leading 'v' but we don't want that here $revision =~ s/^v//; print "# revision = '$revision'\n"; print "# version = '$version'\n"; print "# subversion = '$subversion'\n"; my $v = sprintf("%d.%.3d%.3d",$revision,$version,$subversion); print "# v = '$v'\n"; print "# ] = '$]'\n"; is( $v, "$]", qq{\$^V eq "\$]"}); $v = $revision + $version/1000 + $subversion/1000000; ok( abs($v - $]) < 10**-8 , "\$^V == \$] (numeric)" ); SKIP: { skip("In EBCDIC the v-string components cannot exceed 2147483647", 6) if ord "A" == 193; # [ID 20010902.001] check if v-strings handle full UV range or not if ( $Config{'uvsize'} >= 4 ) { is( sprintf("%vd", eval 'v2147483647.2147483648'), '2147483647.2147483648', 'v-string > IV_MAX[32-bit]' ); is( sprintf("%vd", eval 'v3141592653'), '3141592653', 'IV_MAX < v-string < UV_MAX[32-bit]'); is( sprintf("%vd", eval 'v4294967295'), '4294967295', 'v-string == UV_MAX[32-bit] - 1'); } SKIP: { skip("No quads", 3) if $Config{uvsize} < 8; if ( $Config{'uvsize'} >= 8 ) { is( sprintf("%vd", eval 'v9223372036854775807.9223372036854775808'), '9223372036854775807.9223372036854775808', 'v-string > IV_MAX[64-bit]' ); is( sprintf("%vd", eval 'v17446744073709551615'), '17446744073709551615', 'IV_MAX < v-string < UV_MAX[64-bit]'); is( sprintf("%vd", eval 'v18446744073709551615'), '18446744073709551615', 'v-string == UV_MAX[64-bit] - 1'); } } } # Tests for magic v-strings $v = 1.2.3; is( ref(\$v), 'VSTRING', 'v-string objects' ); $v = v1.2_3; is( ref(\$v), 'VSTRING', 'v-string objects with v' ); is( sprintf("%vd", $v), '1.23', 'v-string ignores underscores' ); # [perl #16010] %h = (v65 => 42); ok( exists $h{v65}, "v-stringness is not engaged for vX" ); %h = (v65.66 => 42); ok( exists $h{chr(65).chr(66)}, "v-stringness is engaged for vX.Y" ); %h = (65.66.67 => 42); ok( exists $h{chr(65).chr(66).chr(67)}, "v-stringness is engaged for X.Y.Z" ); # The following tests whether v-strings are correctly # interpreted by the tokeniser when it's in a XTERMORDORDOR # state (fittingly, the only tokeniser state to contain the # word MORDOR). *{"\3"} = *DATA; is( (readline v3), "This is what we expect to see!\n", "v-strings even work in Mordor" ); __DATA__ This is what we expect to see! perl-5.12.0-RC0/t/op/override.t0000555000175000017500000000462711325125742015030 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } plan tests => 26; # # This file tries to test builtin override using CORE::GLOBAL # my $dirsep = "/"; BEGIN { package Foo; *main::getlogin = sub { "kilroy"; } } is( getlogin, "kilroy" ); my $t = 42; BEGIN { *CORE::GLOBAL::time = sub () { $t; } } is( 45, time + 3 ); # # require has special behaviour # my $r; BEGIN { *CORE::GLOBAL::require = sub { $r = shift; 1; } } require Foo; is( $r, "Foo.pm" ); require Foo::Bar; is( $r, join($dirsep, "Foo", "Bar.pm") ); require 'Foo'; is( $r, "Foo" ); require 5.6; is( $r, "5.6" ); require v5.6; ok( abs($r - 5.006) < 0.001 && $r eq "\x05\x06" ); eval "use Foo"; is( $r, "Foo.pm" ); eval "use Foo::Bar"; is( $r, join($dirsep, "Foo", "Bar.pm") ); eval "use 5.6"; is( $r, "5.6" ); # localizing *CORE::GLOBAL::foo should revert to finding CORE::foo { local(*CORE::GLOBAL::require); $r = ''; eval "require NoNeXiSt;"; ok( ! ( $r or $@ !~ /^Can't locate NoNeXiSt/i ) ); } # # readline() has special behaviour too # $r = 11; BEGIN { *CORE::GLOBAL::readline = sub (;*) { ++$r }; } is( , 12 ); is( <$fh> , 13 ); my $pad_fh; is( <$pad_fh> , 14 ); # Non-global readline() override BEGIN { *Rgs::readline = sub (;*) { --$r }; } { package Rgs; ::is( , 13 ); ::is( <$fh> , 12 ); ::is( <$pad_fh> , 11 ); } # Global readpipe() override BEGIN { *CORE::GLOBAL::readpipe = sub ($) { "$_[0] " . --$r }; } is( `rm`, "rm 10", '``' ); is( qx/cp/, "cp 9", 'qx' ); # Non-global readpipe() override BEGIN { *Rgs::readpipe = sub ($) { ++$r . " $_[0]" }; } { package Rgs; ::is( `rm`, "10 rm", '``' ); ::is( qx/cp/, "11 cp", 'qx' ); } # Verify that the parsing of overriden keywords isn't messed up # by the indirect object notation { local $SIG{__WARN__} = sub { ::like( $_[0], qr/^ok overriden at/ ); }; BEGIN { *OverridenWarn::warn = sub { CORE::warn "@_ overriden"; }; } package OverridenWarn; sub foo { "ok" } warn( OverridenWarn->foo() ); warn OverridenWarn->foo(); } BEGIN { *OverridenPop::pop = sub { ::is( $_[0][0], "ok" ) }; } { package OverridenPop; sub foo { [ "ok" ] } pop( OverridenPop->foo() ); pop OverridenPop->foo(); } { eval { local *CORE::GLOBAL::require = sub { CORE::require($_[0]); }; require 5; require Text::ParseWords; }; is $@, ''; } perl-5.12.0-RC0/t/op/sort.t0000555000175000017500000005641611325127001014171 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = qw(. ../lib); require 'test.pl'; } use warnings; plan( tests => 148 ); # these shouldn't hang { no warnings; sort { for ($_ = 0;; $_++) {} } @a; sort { while(1) {} } @a; sort { while(1) { last; } } @a; sort { while(0) { last; } } @a; # Change 26011: Re: A surprising segfault map scalar(sort(+())), ('')x68; } sub Backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 } sub Backwards_stacked($$) { my($a,$b) = @_; $a lt $b ? 1 : $a gt $b ? -1 : 0 } sub Backwards_other { $a lt $b ? 1 : $a gt $b ? -1 : 0 } my $upperfirst = 'A' lt 'a'; # Beware: in future this may become hairier because of possible # collation complications: qw(A a B b) can be sorted at least as # any of the following # # A a B b # A B a b # a b A B # a A b B # # All the above orders make sense. # # That said, EBCDIC sorts all small letters first, as opposed # to ASCII which sorts all big letters first. @harry = ('dog','cat','x','Cain','Abel'); @george = ('gone','chased','yz','punished','Axed'); $x = join('', sort @harry); $expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain'; cmp_ok($x,'eq',$expected,'upper first 1'); $x = join('', sort( Backwards @harry)); $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; cmp_ok($x,'eq',$expected,'upper first 2'); $x = join('', sort( Backwards_stacked @harry)); $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; cmp_ok($x,'eq',$expected,'upper first 3'); $x = join('', sort @george, 'to', @harry); $expected = $upperfirst ? 'AbelAxedCaincatchaseddoggonepunishedtoxyz' : 'catchaseddoggonepunishedtoxyzAbelAxedCain' ; cmp_ok($x,'eq',$expected,'upper first 4'); $" = ' '; @a = (); @b = reverse @a; cmp_ok("@b",'eq',"",'reverse 1'); @a = (1); @b = reverse @a; cmp_ok("@b",'eq',"1",'reverse 2'); @a = (1,2); @b = reverse @a; cmp_ok("@b",'eq',"2 1",'reverse 3'); @a = (1,2,3); @b = reverse @a; cmp_ok("@b",'eq',"3 2 1",'reverse 4'); @a = (1,2,3,4); @b = reverse @a; cmp_ok("@b",'eq',"4 3 2 1",'reverse 5'); @a = (10,2,3,4); @b = sort {$a <=> $b;} @a; cmp_ok("@b",'eq',"2 3 4 10",'sort numeric'); $sub = 'Backwards'; $x = join('', sort $sub @harry); $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; cmp_ok($x,'eq',$expected,'sorter sub name in var 1'); $sub = 'Backwards_stacked'; $x = join('', sort $sub @harry); $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; cmp_ok($x,'eq',$expected,'sorter sub name in var 2'); # literals, combinations @b = sort (4,1,3,2); cmp_ok("@b",'eq','1 2 3 4','just sort'); @b = sort grep { $_ } (4,1,3,2); cmp_ok("@b",'eq','1 2 3 4','grep then sort'); @b = sort map { $_ } (4,1,3,2); cmp_ok("@b",'eq','1 2 3 4','map then sort'); @b = sort reverse (4,1,3,2); cmp_ok("@b",'eq','1 2 3 4','reverse then sort'); sub twoface { no warnings 'redefine'; *twoface = sub { $a <=> $b }; &twoface } eval { @b = sort twoface 4,1,3,2 }; cmp_ok("@b",'eq','1 2 3 4','redefine sort sub inside the sort sub'); eval { no warnings 'redefine'; *twoface = sub { &Backwards } }; ok(!$@,"redefining sort subs outside the sort \$@=[$@]"); eval { @b = sort twoface 4,1,3,2 }; cmp_ok("@b",'eq','4 3 2 1','twoface redefinition'); { no warnings 'redefine'; *twoface = sub { *twoface = *Backwards_other; $a <=> $b }; } eval { @b = sort twoface 4,1,9,5 }; ok(($@ eq "" && "@b" eq "1 4 5 9"),'redefinition should not take effect during the sort'); { no warnings 'redefine'; *twoface = sub { eval 'sub twoface { $a <=> $b }'; die($@ eq "" ? "good\n" : "bad\n"); $a <=> $b; }; } eval { @b = sort twoface 4,1 }; cmp_ok(substr($@,0,4), 'eq', 'good', 'twoface eval'); eval <<'CODE'; my @result = sort main'Backwards 'one', 'two'; CODE cmp_ok($@,'eq','',q(old skool package)); eval <<'CODE'; # "sort 'one', 'two'" should not try to parse "'one" as a sort sub my @result = sort 'one', 'two'; CODE cmp_ok($@,'eq','',q(one is not a sub)); { my $sortsub = \&Backwards; my $sortglob = *Backwards; my $sortglobr = \*Backwards; my $sortname = 'Backwards'; @b = sort $sortsub 4,1,3,2; cmp_ok("@b",'eq','4 3 2 1','sortname 1'); @b = sort $sortglob 4,1,3,2; cmp_ok("@b",'eq','4 3 2 1','sortname 2'); @b = sort $sortname 4,1,3,2; cmp_ok("@b",'eq','4 3 2 1','sortname 3'); @b = sort $sortglobr 4,1,3,2; cmp_ok("@b",'eq','4 3 2 1','sortname 4'); } { my $sortsub = \&Backwards_stacked; my $sortglob = *Backwards_stacked; my $sortglobr = \*Backwards_stacked; my $sortname = 'Backwards_stacked'; @b = sort $sortsub 4,1,3,2; cmp_ok("@b",'eq','4 3 2 1','sortname 5'); @b = sort $sortglob 4,1,3,2; cmp_ok("@b",'eq','4 3 2 1','sortname 6'); @b = sort $sortname 4,1,3,2; cmp_ok("@b",'eq','4 3 2 1','sortname 7'); @b = sort $sortglobr 4,1,3,2; cmp_ok("@b",'eq','4 3 2 1','sortname 8'); } { local $sortsub = \&Backwards; local $sortglob = *Backwards; local $sortglobr = \*Backwards; local $sortname = 'Backwards'; @b = sort $sortsub 4,1,3,2; cmp_ok("@b",'eq','4 3 2 1','sortname local 1'); @b = sort $sortglob 4,1,3,2; cmp_ok("@b",'eq','4 3 2 1','sortname local 2'); @b = sort $sortname 4,1,3,2; cmp_ok("@b",'eq','4 3 2 1','sortname local 3'); @b = sort $sortglobr 4,1,3,2; cmp_ok("@b",'eq','4 3 2 1','sortname local 4'); } { local $sortsub = \&Backwards_stacked; local $sortglob = *Backwards_stacked; local $sortglobr = \*Backwards_stacked; local $sortname = 'Backwards_stacked'; @b = sort $sortsub 4,1,3,2; cmp_ok("@b",'eq','4 3 2 1','sortname local 5'); @b = sort $sortglob 4,1,3,2; cmp_ok("@b",'eq','4 3 2 1','sortname local 6'); @b = sort $sortname 4,1,3,2; cmp_ok("@b",'eq','4 3 2 1','sortname local 7'); @b = sort $sortglobr 4,1,3,2; cmp_ok("@b",'eq','4 3 2 1','sortname local 8'); } ## exercise sort builtins... ($a <=> $b already tested) @a = ( 5, 19, 1996, 255, 90 ); @b = sort { my $dummy; # force blockness return $b <=> $a } @a; cmp_ok("@b",'eq','1996 255 90 19 5','force blockness'); $x = join('', sort { $a cmp $b } @harry); $expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain'; cmp_ok($x,'eq',$expected,'a cmp b'); $x = join('', sort { $b cmp $a } @harry); $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; cmp_ok($x,'eq',$expected,'b cmp a'); { use integer; @b = sort { $a <=> $b } @a; cmp_ok("@b",'eq','5 19 90 255 1996','integer a <=> b'); @b = sort { $b <=> $a } @a; cmp_ok("@b",'eq','1996 255 90 19 5','integer b <=> a'); $x = join('', sort { $a cmp $b } @harry); $expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain'; cmp_ok($x,'eq',$expected,'integer a cmp b'); $x = join('', sort { $b cmp $a } @harry); $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; cmp_ok($x,'eq',$expected,'integer b cmp a'); } $x = join('', sort { $a <=> $b } 3, 1, 2); cmp_ok($x,'eq','123',q(optimized-away comparison block doesn't take any other arguments away with it)); # test sorting in non-main package { package Foo; @a = ( 5, 19, 1996, 255, 90 ); @b = sort { $b <=> $a } @a; ::cmp_ok("@b",'eq','1996 255 90 19 5','not in main:: 1'); @b = sort ::Backwards_stacked @a; ::cmp_ok("@b",'eq','90 5 255 1996 19','not in main:: 2'); # check if context for sort arguments is handled right sub test_if_list { my $gimme = wantarray; ::is($gimme,1,'wantarray 1'); } my $m = sub { $a <=> $b }; sub cxt_one { sort $m test_if_list() } cxt_one(); sub cxt_two { sort { $a <=> $b } test_if_list() } cxt_two(); sub cxt_three { sort &test_if_list() } cxt_three(); sub test_if_scalar { my $gimme = wantarray; ::is(!($gimme or !defined($gimme)),1,'wantarray 2'); } $m = \&test_if_scalar; sub cxt_four { sort $m 1,2 } @x = cxt_four(); sub cxt_five { sort { test_if_scalar($a,$b); } 1,2 } @x = cxt_five(); sub cxt_six { sort test_if_scalar 1,2 } @x = cxt_six(); } # test against a reentrancy bug { package Bar; sub compare { $a cmp $b } sub reenter { my @force = sort compare qw/a b/ } } { my($def, $init) = (0, 0); @b = sort { $def = 1 if defined $Bar::a; Bar::reenter() unless $init++; $a <=> $b } qw/4 3 1 2/; cmp_ok("@b",'eq','1 2 3 4','reenter 1'); ok(!$def,'reenter 2'); } { sub routine { "one", "two" }; @a = sort(routine(1)); cmp_ok("@a",'eq',"one two",'bug id 19991001.003'); } # check for in-place optimisation of @a = sort @a { my ($r1,$r2,@a); our @g; @g = (3,2,1); $r1 = \$g[2]; @g = sort @g; $r2 = \$g[0]; is "$r1-@g", "$r2-1 2 3", "inplace sort of global"; @a = qw(b a c); $r1 = \$a[1]; @a = sort @a; $r2 = \$a[0]; is "$r1-@a", "$r2-a b c", "inplace sort of lexical"; @g = (2,3,1); $r1 = \$g[1]; @g = sort { $b <=> $a } @g; $r2 = \$g[0]; is "$r1-@g", "$r2-3 2 1", "inplace reversed sort of global"; @g = (2,3,1); $r1 = \$g[1]; @g = sort { $a<$b?1:$a>$b?-1:0 } @g; $r2 = \$g[0]; is "$r1-@g", "$r2-3 2 1", "inplace custom sort of global"; sub mysort { $b cmp $a }; @a = qw(b c a); $r1 = \$a[1]; @a = sort mysort @a; $r2 = \$a[0]; is "$r1-@a", "$r2-c b a", "inplace sort with function of lexical"; use Tie::Array; my @t; tie @t, 'Tie::StdArray'; @t = qw(b c a); @t = sort @t; is "@t", "a b c", "inplace sort of tied array"; @t = qw(b c a); @t = sort mysort @t; is "@t", "c b a", "inplace sort of tied array with function"; # [perl #29790] don't optimise @a = ('a', sort @a) ! @g = (3,2,1); @g = ('0', sort @g); is "@g", "0 1 2 3", "un-inplace sort of global"; @g = (3,2,1); @g = (sort(@g),'4'); is "@g", "1 2 3 4", "un-inplace sort of global 2"; @a = qw(b a c); @a = ('x', sort @a); is "@a", "x a b c", "un-inplace sort of lexical"; @a = qw(b a c); @a = ((sort @a), 'x'); is "@a", "a b c x", "un-inplace sort of lexical 2"; @g = (2,3,1); @g = ('0', sort { $b <=> $a } @g); is "@g", "0 3 2 1", "un-inplace reversed sort of global"; @g = (2,3,1); @g = ((sort { $b <=> $a } @g),'4'); is "@g", "3 2 1 4", "un-inplace reversed sort of global 2"; @g = (2,3,1); @g = ('0', sort { $a<$b?1:$a>$b?-1:0 } @g); is "@g", "0 3 2 1", "un-inplace custom sort of global"; @g = (2,3,1); @g = ((sort { $a<$b?1:$a>$b?-1:0 } @g),'4'); is "@g", "3 2 1 4", "un-inplace custom sort of global 2"; @a = qw(b c a); @a = ('x', sort mysort @a); is "@a", "x c b a", "un-inplace sort with function of lexical"; @a = qw(b c a); @a = ((sort mysort @a),'x'); is "@a", "c b a x", "un-inplace sort with function of lexical 2"; # RT#54758. Git 62b40d2474e7487e6909e1872b6bccdf812c6818 no warnings 'void'; my @m; push @m, 0 for 1 .. 1024; $#m; @m = sort @m; ::pass("in-place sorting segfault"); } # Test optimisations of reversed sorts. As we now guarantee stability by # default, # optimisations which do not provide this are bogus. { package Oscalar; use overload (qw("" stringify 0+ numify fallback 1)); sub new { bless [$_[1], $_[2]], $_[0]; } sub stringify { $_[0]->[0] } sub numify { $_[0]->[1] } } sub generate { my $count = 0; map {new Oscalar $_, $count++} qw(A A A B B B C C C); } my @input = &generate; my @output = sort @input; is join(" ", map {0+$_} @output), "0 1 2 3 4 5 6 7 8", "Simple stable sort"; @input = &generate; @input = sort @input; is join(" ", map {0+$_} @input), "0 1 2 3 4 5 6 7 8", "Simple stable in place sort"; # This won't be very interesting @input = &generate; @output = sort {$a <=> $b} @input; is "@output", "A A A B B B C C C", 'stable $a <=> $b sort'; @input = &generate; @output = sort {$a cmp $b} @input; is join(" ", map {0+$_} @output), "0 1 2 3 4 5 6 7 8", 'stable $a cmp $b sort'; @input = &generate; @input = sort {$a cmp $b} @input; is join(" ", map {0+$_} @input), "0 1 2 3 4 5 6 7 8", 'stable $a cmp $b in place sort'; @input = &generate; @output = sort {$b cmp $a} @input; is join(" ", map {0+$_} @output), "6 7 8 3 4 5 0 1 2", 'stable $b cmp $a sort'; @input = &generate; @input = sort {$b cmp $a} @input; is join(" ", map {0+$_} @input), "6 7 8 3 4 5 0 1 2", 'stable $b cmp $a in place sort'; @input = &generate; @output = reverse sort @input; is join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0", "Reversed stable sort"; @input = &generate; @input = reverse sort @input; is join(" ", map {0+$_} @input), "8 7 6 5 4 3 2 1 0", "Reversed stable in place sort"; @input = &generate; my $output = reverse sort @input; is $output, "CCCBBBAAA", "Reversed stable sort in scalar context"; @input = &generate; @output = reverse sort {$a cmp $b} @input; is join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0", 'reversed stable $a cmp $b sort'; @input = &generate; @input = reverse sort {$a cmp $b} @input; is join(" ", map {0+$_} @input), "8 7 6 5 4 3 2 1 0", 'revesed stable $a cmp $b in place sort'; @input = &generate; $output = reverse sort {$a cmp $b} @input; is $output, "CCCBBBAAA", 'Reversed stable $a cmp $b sort in scalar context'; @input = &generate; @output = reverse sort {$b cmp $a} @input; is join(" ", map {0+$_} @output), "2 1 0 5 4 3 8 7 6", 'reversed stable $b cmp $a sort'; @input = &generate; @input = reverse sort {$b cmp $a} @input; is join(" ", map {0+$_} @input), "2 1 0 5 4 3 8 7 6", 'revesed stable $b cmp $a in place sort'; @input = &generate; $output = reverse sort {$b cmp $a} @input; is $output, "AAABBBCCC", 'Reversed stable $b cmp $a sort in scalar context'; sub stuff { # Something complex enough to defeat any constant folding optimiser $$ - $$; } @input = &generate; @output = reverse sort {stuff || $a cmp $b} @input; is join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0", 'reversed stable complex sort'; @input = &generate; @input = reverse sort {stuff || $a cmp $b} @input; is join(" ", map {0+$_} @input), "8 7 6 5 4 3 2 1 0", 'revesed stable complex in place sort'; @input = &generate; $output = reverse sort {stuff || $a cmp $b } @input; is $output, "CCCBBBAAA", 'Reversed stable complex sort in scalar context'; sub sortr { reverse sort @_; } @output = sortr &generate; is join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0", 'reversed stable sort return list context'; $output = sortr &generate; is $output, "CCCBBBAAA", 'reversed stable sort return scalar context'; sub sortcmpr { reverse sort {$a cmp $b} @_; } @output = sortcmpr &generate; is join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0", 'reversed stable $a cmp $b sort return list context'; $output = sortcmpr &generate; is $output, "CCCBBBAAA", 'reversed stable $a cmp $b sort return scalar context'; sub sortcmprba { reverse sort {$b cmp $a} @_; } @output = sortcmprba &generate; is join(" ", map {0+$_} @output), "2 1 0 5 4 3 8 7 6", 'reversed stable $b cmp $a sort return list context'; $output = sortcmprba &generate; is $output, "AAABBBCCC", 'reversed stable $b cmp $a sort return scalar context'; sub sortcmprq { reverse sort {stuff || $a cmp $b} @_; } @output = sortcmpr &generate; is join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0", 'reversed stable complex sort return list context'; $output = sortcmpr &generate; is $output, "CCCBBBAAA", 'reversed stable complex sort return scalar context'; # And now with numbers sub generate1 { my $count = 'A'; map {new Oscalar $count++, $_} 0, 0, 0, 1, 1, 1, 2, 2, 2; } # This won't be very interesting @input = &generate1; @output = sort {$a cmp $b} @input; is "@output", "A B C D E F G H I", 'stable $a cmp $b sort'; @input = &generate1; @output = sort {$a <=> $b} @input; is "@output", "A B C D E F G H I", 'stable $a <=> $b sort'; @input = &generate1; @input = sort {$a <=> $b} @input; is "@input", "A B C D E F G H I", 'stable $a <=> $b in place sort'; @input = &generate1; @output = sort {$b <=> $a} @input; is "@output", "G H I D E F A B C", 'stable $b <=> $a sort'; @input = &generate1; @input = sort {$b <=> $a} @input; is "@input", "G H I D E F A B C", 'stable $b <=> $a in place sort'; # test that optimized {$b cmp $a} and {$b <=> $a} remain stable # (new in 5.9) without overloading { no warnings; @b = sort { $b <=> $a } @input = qw/5first 6first 5second 6second/; is "@b" , "6first 6second 5first 5second", "optimized {$b <=> $a} without overloading" ; @input = sort {$b <=> $a} @input; is "@input" , "6first 6second 5first 5second","inline optimized {$b <=> $a} without overloading" ; }; # These two are actually doing string cmp on 0 1 and 2 @input = &generate1; @output = reverse sort @input; is "@output", "I H G F E D C B A", "Reversed stable sort"; @input = &generate1; @input = reverse sort @input; is "@input", "I H G F E D C B A", "Reversed stable in place sort"; @input = &generate1; $output = reverse sort @input; is $output, "IHGFEDCBA", "Reversed stable sort in scalar context"; @input = &generate1; @output = reverse sort {$a <=> $b} @input; is "@output", "I H G F E D C B A", 'reversed stable $a <=> $b sort'; @input = &generate1; @input = reverse sort {$a <=> $b} @input; is "@input", "I H G F E D C B A", 'revesed stable $a <=> $b in place sort'; @input = &generate1; $output = reverse sort {$a <=> $b} @input; is $output, "IHGFEDCBA", 'reversed stable $a <=> $b sort in scalar context'; @input = &generate1; @output = reverse sort {$b <=> $a} @input; is "@output", "C B A F E D I H G", 'reversed stable $b <=> $a sort'; @input = &generate1; @input = reverse sort {$b <=> $a} @input; is "@input", "C B A F E D I H G", 'revesed stable $b <=> $a in place sort'; @input = &generate1; $output = reverse sort {$b <=> $a} @input; is $output, "CBAFEDIHG", 'reversed stable $b <=> $a sort in scalar context'; @input = &generate1; @output = reverse sort {stuff || $a <=> $b} @input; is "@output", "I H G F E D C B A", 'reversed stable complex sort'; @input = &generate1; @input = reverse sort {stuff || $a <=> $b} @input; is "@input", "I H G F E D C B A", 'revesed stable complex in place sort'; @input = &generate1; $output = reverse sort {stuff || $a <=> $b} @input; is $output, "IHGFEDCBA", 'reversed stable complex sort in scalar context'; sub sortnumr { reverse sort {$a <=> $b} @_; } @output = sortnumr &generate1; is "@output", "I H G F E D C B A", 'reversed stable $a <=> $b sort return list context'; $output = sortnumr &generate1; is $output, "IHGFEDCBA", 'reversed stable $a <=> $b sort return scalar context'; sub sortnumrba { reverse sort {$b <=> $a} @_; } @output = sortnumrba &generate1; is "@output", "C B A F E D I H G", 'reversed stable $b <=> $a sort return list context'; $output = sortnumrba &generate1; is $output, "CBAFEDIHG", 'reversed stable $b <=> $a sort return scalar context'; sub sortnumrq { reverse sort {stuff || $a <=> $b} @_; } @output = sortnumrq &generate1; is "@output", "I H G F E D C B A", 'reversed stable complex sort return list context'; $output = sortnumrq &generate1; is $output, "IHGFEDCBA", 'reversed stable complex sort return scalar context'; @output = reverse (sort(qw(C A B)), 0); is "@output", "0 C B A", 'reversed sort with trailing argument'; @output = reverse (0, sort(qw(C A B))); is "@output", "C B A 0", 'reversed sort with leading argument'; eval { @output = sort {goto sub {}} 1,2; }; $fail_msg = q(Can't goto subroutine outside a subroutine); cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'goto subr outside subr'); sub goto_sub {goto sub{}} eval { @output = sort goto_sub 1,2; }; $fail_msg = q(Can't goto subroutine from a sort sub); cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'goto subr from a sort sub'); eval { @output = sort {goto label} 1,2; }; $fail_msg = q(Can't "goto" out of a pseudo block); cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'goto out of a pseudo block 1'); sub goto_label {goto label} label: eval { @output = sort goto_label 1,2; }; $fail_msg = q(Can't "goto" out of a pseudo block); cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'goto out of a pseudo block 2'); sub self_immolate {undef &self_immolate; $a<=>$b} eval { @output = sort self_immolate 1,2,3 }; $fail_msg = q(Can't undef active subroutine); cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'undef active subr'); for(1,2) # We run this twice, to make sure sort does not lower the ref { # count. See bug 71076. my $failed = 0; sub rec { my $n = shift; if (!defined($n)) { # No arg means we're being called by sort() return 1; } if ($n<5) { rec($n+1); } else { () = sort rec 1,2; } $failed = 1 if !defined $n; } rec(1); ok(!$failed, "sort from active sub"); } # $a and $b are set in the package the sort() is called from, # *not* the package the sort sub is in. This is longstanding # de facto behaviour that shouldn't be broken. my $answer = "good"; () = sort OtherPack::foo 1,2,3,4; { package OtherPack; no warnings 'once'; sub foo { $answer = "something was unexpectedly defined or undefined" if defined($a) || defined($b) || !defined($main::a) || !defined($main::b); $main::a <=> $main::b; } } cmp_ok($answer,'eq','good','sort subr called from other package'); # Bug 36430 - sort called in package2 while a # sort in package1 is active should set $package2::a/b. { my $answer = "good"; my @list = sort { A::min(@$a) <=> A::min(@$b) } [3, 1, 5], [2, 4], [0]; cmp_ok($answer,'eq','good','bug 36430'); package A; sub min { my @list = sort { $answer = '$a and/or $b are not defined ' if !defined($a) || !defined($b); $a <=> $b; } @_; $list[0]; } } # Bug 7567 - an array shouldn't be modifiable while it's being # sorted in-place. { eval { @a=(1..8); @a = sort { @a = (0) } @a; }; $fail_msg = q(Modification of a read-only value attempted); cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'bug 7567'); } { local $TODO = "sort should make sure elements are not freed in the sort block"; eval { @nomodify_x=(1..8); our @copy = sort { @nomodify_x = (0) } (@nomodify_x, 3); }; is($@, ""); } # Sorting shouldn't increase the refcount of a sub { sub sportello {(1+$a) <=> (1+$b)} my $refcnt = &Internals::SvREFCNT(\&sportello); @output = sort sportello 3,7,9; { package Doc; ::is($refcnt, &Internals::SvREFCNT(\&::sportello), "sort sub refcnt"); $fail_msg = q(Modification of a read-only value attempted); # Sorting a read-only array in-place shouldn't be allowed my @readonly = (1..10); Internals::SvREADONLY(@readonly, 1); eval { @readonly = sort @readonly; }; ::cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'in-place sort of read-only array'); } } # Using return() should be okay even in a deeper context @b = sort {while (1) {return ($a <=> $b)} } 1..10; is("@b", "1 2 3 4 5 6 7 8 9 10", "return within loop"); # Using return() should be okay even if there are other items # on the stack at the time. @b = sort {$_ = ($a<=>$b) + do{return $b<=> $a}} 1..10; is("@b", "10 9 8 7 6 5 4 3 2 1", "return with SVs on stack"); # As above, but with a sort sub rather than a sort block. sub ret_with_stacked { $_ = ($a<=>$b) + do {return $b <=> $a} } @b = sort ret_with_stacked 1..10; is("@b", "10 9 8 7 6 5 4 3 2 1", "return with SVs on stack"); # Comparison code should be able to give result in non-integer representation. sub cmp_as_string($$) { $_[0] < $_[1] ? "-1" : $_[0] == $_[1] ? "0" : "+1" } @b = sort { cmp_as_string($a, $b) } (1,5,4,7,3,2,3); is("@b", "1 2 3 3 4 5 7", "comparison result as string"); @b = sort cmp_as_string (1,5,4,7,3,2,3); is("@b", "1 2 3 3 4 5 7", "comparison result as string"); perl-5.12.0-RC0/t/op/caller.t0000555000175000017500000001030111325125742014435 0ustar jessejesse#!./perl # Tests for caller() BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; plan( tests => 78 ); } my @c; print "# Tests with caller(0)\n"; @c = caller(0); ok( (!@c), "caller(0) in main program" ); eval { @c = caller(0) }; is( $c[3], "(eval)", "subroutine name in an eval {}" ); ok( !$c[4], "hasargs false in an eval {}" ); eval q{ @c = (Caller(0))[3] }; is( $c[3], "(eval)", "subroutine name in an eval ''" ); ok( !$c[4], "hasargs false in an eval ''" ); sub { @c = caller(0) } -> (); is( $c[3], "main::__ANON__", "anonymous subroutine name" ); ok( $c[4], "hasargs true with anon sub" ); # Bug 20020517.003, used to dump core sub foo { @c = caller(0) } my $fooref = delete $::{foo}; $fooref -> (); is( $c[3], "(unknown)", "unknown subroutine name" ); ok( $c[4], "hasargs true with unknown sub" ); print "# Tests with caller(1)\n"; sub f { @c = caller(1) } sub callf { f(); } callf(); is( $c[3], "main::callf", "subroutine name" ); ok( $c[4], "hasargs true with callf()" ); &callf; ok( !$c[4], "hasargs false with &callf" ); eval { f() }; is( $c[3], "(eval)", "subroutine name in an eval {}" ); ok( !$c[4], "hasargs false in an eval {}" ); eval q{ f() }; is( $c[3], "(eval)", "subroutine name in an eval ''" ); ok( !$c[4], "hasargs false in an eval ''" ); sub { f() } -> (); is( $c[3], "main::__ANON__", "anonymous subroutine name" ); ok( $c[4], "hasargs true with anon sub" ); sub foo2 { f() } my $fooref2 = delete $::{foo2}; $fooref2 -> (); is( $c[3], "(unknown)", "unknown subroutine name" ); ok( $c[4], "hasargs true with unknown sub" ); # See if caller() returns the correct warning mask sub show_bits { my $in = shift; my $out = ''; foreach (unpack('W*', $in)) { $out .= sprintf('\x%02x', $_); } return $out; } sub check_bits { local $Level = $Level + 2; my ($got, $exp, $desc) = @_; if (! ok($got eq $exp, $desc)) { diag(' got: ' . show_bits($got)); diag('expected: ' . show_bits($exp)); } } sub testwarn { my $w = shift; my $id = shift; check_bits( (caller(0))[9], $w, "warnings match caller ($id)"); } { no warnings; # Build the warnings mask dynamically my ($default, $registered); BEGIN { for my $i (0..$warnings::LAST_BIT/2 - 1) { vec($default, $i, 2) = 1; } $registered = $default; vec($registered, $warnings::LAST_BIT/2, 2) = 1; } BEGIN { check_bits( ${^WARNING_BITS}, "\0" x 12, 'all bits off via "no warnings"' ) } testwarn("\0" x 12, 'no bits'); use warnings; BEGIN { check_bits( ${^WARNING_BITS}, $default, 'default bits on via "use warnings"' ); } BEGIN { testwarn($default, 'all'); } # run-time : # the warning mask has been extended by warnings::register testwarn($registered, 'ahead of w::r'); use warnings::register; BEGIN { check_bits( ${^WARNING_BITS}, $registered, 'warning bits on via "use warnings::register"' ) } testwarn($registered, 'following w::r'); } # The next two cases test for a bug where caller ignored evals if # the DB::sub glob existed but &DB::sub did not (for example, if # $^P had been set but no debugger has been loaded). The tests # thus assume that there is no &DB::sub: if there is one, they # should both pass no matter whether or not this bug has been # fixed. my $debugger_test = q< my @stackinfo = caller(0); return scalar @stackinfo; >; sub pb { return (caller(0))[3] } my $i = eval $debugger_test; is( $i, 11, "do not skip over eval (and caller returns 10 elements)" ); is( eval 'pb()', 'main::pb', "actually return the right function name" ); my $saved_perldb = $^P; $^P = 16; $^P = $saved_perldb; $i = eval $debugger_test; is( $i, 11, 'do not skip over eval even if $^P had been on at some point' ); is( eval 'pb()', 'main::pb', 'actually return the right function name even if $^P had been on at some point' ); print "# caller can now return the compile time state of %^H\n"; sub hint_exists { my $key = shift; my $level = shift; my @results = caller($level||0); exists $results[10]->{$key}; } sub hint_fetch { my $key = shift; my $level = shift; my @results = caller($level||0); $results[10]->{$key}; } $::testing_caller = 1; do './op/caller.pl' or die $@; perl-5.12.0-RC0/t/op/array_base.aux0000444000175000017500000000015611325127001015627 0ustar jessejesseour($ra1, $ri1, $rf1, $rfe1); $ra1 = $[; BEGIN { $ri1 = $^H; $rf1 = $^H{foo}; $rfe1 = exists($^H{foo}); } 1; perl-5.12.0-RC0/t/op/loopctl.t0000555000175000017500000003512611325125742014663 0ustar jessejesse#!./perl # We have the following types of loop: # # 1a) while(A) {B} # 1b) B while A; # # 2a) until(A) {B} # 2b) B until A; # # 3a) for(@A) {B} # 3b) B for A; # # 4a) for (A;B;C) {D} # # 5a) { A } # a bare block is a loop which runs once # # Loops of type (b) don't allow for next/last/redo style # control, so we ignore them here. Type (a) loops can # all be labelled, so there are ten possibilities (each # of 5 types, labelled/unlabelled). We therefore need # thirty tests to try the three control statements against # the ten types of loop. For the first four types it's useful # to distinguish the case where next re-iterates from the case # where it leaves the loop. That makes 38. # All these tests rely on "last LABEL" # so if they've *all* failed, maybe you broke that... # # These tests are followed by an extra test of nested loops. # Feel free to add more here. # # -- .robin. 2001-03-13 BEGIN { chdir 't' if -d 't'; @INC = qw(. ../lib); } require "test.pl"; plan( tests => 47 ); my $ok; TEST1: { $ok = 0; my $x = 1; my $first_time = 1; while($x--) { if (!$first_time) { $ok = 1; last TEST1; } $ok = 0; $first_time = 0; redo; last TEST1; } continue { $ok = 0; last TEST1; } $ok = 0; } cmp_ok($ok,'==',1,'no label on while()'); TEST2: { $ok = 0; my $x = 2; my $first_time = 1; my $been_in_continue = 0; while($x--) { if (!$first_time) { $ok = $been_in_continue; last TEST2; } $ok = 0; $first_time = 0; next; last TEST2; } continue { $been_in_continue = 1; } $ok = 0; } cmp_ok($ok,'==',1,'no label on while() successful next'); TEST3: { $ok = 0; my $x = 1; my $first_time = 1; my $been_in_loop = 0; my $been_in_continue = 0; while($x--) { $been_in_loop = 1; if (!$first_time) { $ok = 0; last TEST3; } $ok = 0; $first_time = 0; next; last TEST3; } continue { $been_in_continue = 1; } $ok = $been_in_loop && $been_in_continue; } cmp_ok($ok,'==',1,'no label on while() unsuccessful next'); TEST4: { $ok = 0; my $x = 1; my $first_time = 1; while($x++) { if (!$first_time) { $ok = 0; last TEST4; } $ok = 0; $first_time = 0; last; last TEST4; } continue { $ok = 0; last TEST4; } $ok = 1; } cmp_ok($ok,'==',1,'no label on while() last'); TEST5: { $ok = 0; my $x = 0; my $first_time = 1; until($x++) { if (!$first_time) { $ok = 1; last TEST5; } $ok = 0; $first_time = 0; redo; last TEST5; } continue { $ok = 0; last TEST5; } $ok = 0; } cmp_ok($ok,'==',1,'no label on until()'); TEST6: { $ok = 0; my $x = 0; my $first_time = 1; my $been_in_continue = 0; until($x++ >= 2) { if (!$first_time) { $ok = $been_in_continue; last TEST6; } $ok = 0; $first_time = 0; next; last TEST6; } continue { $been_in_continue = 1; } $ok = 0; } cmp_ok($ok,'==',1,'no label on until() successful next'); TEST7: { $ok = 0; my $x = 0; my $first_time = 1; my $been_in_loop = 0; my $been_in_continue = 0; until($x++) { $been_in_loop = 1; if (!$first_time) { $ok = 0; last TEST7; } $ok = 0; $first_time = 0; next; last TEST7; } continue { $been_in_continue = 1; } $ok = $been_in_loop && $been_in_continue; } cmp_ok($ok,'==',1,'no label on until() unsuccessful next'); TEST8: { $ok = 0; my $x = 0; my $first_time = 1; until($x++ == 10) { if (!$first_time) { $ok = 0; last TEST8; } $ok = 0; $first_time = 0; last; last TEST8; } continue { $ok = 0; last TEST8; } $ok = 1; } cmp_ok($ok,'==',1,'no label on until() last'); TEST9: { $ok = 0; my $first_time = 1; for(1) { if (!$first_time) { $ok = 1; last TEST9; } $ok = 0; $first_time = 0; redo; last TEST9; } continue { $ok = 0; last TEST9; } $ok = 0; } cmp_ok($ok,'==',1,'no label on for(@array)'); TEST10: { $ok = 0; my $first_time = 1; my $been_in_continue = 0; for(1,2) { if (!$first_time) { $ok = $been_in_continue; last TEST10; } $ok = 0; $first_time = 0; next; last TEST10; } continue { $been_in_continue = 1; } $ok = 0; } cmp_ok($ok,'==',1,'no label on for(@array) successful next'); TEST11: { $ok = 0; my $first_time = 1; my $been_in_loop = 0; my $been_in_continue = 0; for(1) { $been_in_loop = 1; if (!$first_time) { $ok = 0; last TEST11; } $ok = 0; $first_time = 0; next; last TEST11; } continue { $been_in_continue = 1; } $ok = $been_in_loop && $been_in_continue; } cmp_ok($ok,'==',1,'no label on for(@array) unsuccessful next'); TEST12: { $ok = 0; my $first_time = 1; for(1..10) { if (!$first_time) { $ok = 0; last TEST12; } $ok = 0; $first_time = 0; last; last TEST12; } continue { $ok=0; last TEST12; } $ok = 1; } cmp_ok($ok,'==',1,'no label on for(@array) last'); TEST13: { $ok = 0; for(my $first_time = 1; 1;) { if (!$first_time) { $ok = 1; last TEST13; } $ok = 0; $first_time=0; redo; last TEST13; } $ok = 0; } cmp_ok($ok,'==',1,'no label on for(;;)'); TEST14: { $ok = 0; for(my $first_time = 1; 1; $first_time=0) { if (!$first_time) { $ok = 1; last TEST14; } $ok = 0; next; last TEST14; } $ok = 0; } cmp_ok($ok,'==',1,'no label on for(;;) successful next'); TEST15: { $ok = 0; my $x=1; my $been_in_loop = 0; for(my $first_time = 1; $x--;) { $been_in_loop = 1; if (!$first_time) { $ok = 0; last TEST15; } $ok = 0; $first_time = 0; next; last TEST15; } $ok = $been_in_loop; } cmp_ok($ok,'==',1,'no label on for(;;) unsuccessful next'); TEST16: { $ok = 0; for(my $first_time = 1; 1; last TEST16) { if (!$first_time) { $ok = 0; last TEST16; } $ok = 0; $first_time = 0; last; last TEST16; } $ok = 1; } cmp_ok($ok,'==',1,'no label on for(;;) last'); TEST17: { $ok = 0; my $first_time = 1; { if (!$first_time) { $ok = 1; last TEST17; } $ok = 0; $first_time=0; redo; last TEST17; } continue { $ok = 0; last TEST17; } $ok = 0; } cmp_ok($ok,'==',1,'no label on bare block'); TEST18: { $ok = 0; { next; last TEST18; } continue { $ok = 1; last TEST18; } $ok = 0; } cmp_ok($ok,'==',1,'no label on bare block next'); TEST19: { $ok = 0; { last; last TEST19; } continue { $ok = 0; last TEST19; } $ok = 1; } cmp_ok($ok,'==',1,'no label on bare block last'); ### Now do it all again with labels TEST20: { $ok = 0; my $x = 1; my $first_time = 1; LABEL20: while($x--) { if (!$first_time) { $ok = 1; last TEST20; } $ok = 0; $first_time = 0; redo LABEL20; last TEST20; } continue { $ok = 0; last TEST20; } $ok = 0; } cmp_ok($ok,'==',1,'label on while()'); TEST21: { $ok = 0; my $x = 2; my $first_time = 1; my $been_in_continue = 0; LABEL21: while($x--) { if (!$first_time) { $ok = $been_in_continue; last TEST21; } $ok = 0; $first_time = 0; next LABEL21; last TEST21; } continue { $been_in_continue = 1; } $ok = 0; } cmp_ok($ok,'==',1,'label on while() successful next'); TEST22: { $ok = 0; my $x = 1; my $first_time = 1; my $been_in_loop = 0; my $been_in_continue = 0; LABEL22: while($x--) { $been_in_loop = 1; if (!$first_time) { $ok = 0; last TEST22; } $ok = 0; $first_time = 0; next LABEL22; last TEST22; } continue { $been_in_continue = 1; } $ok = $been_in_loop && $been_in_continue; } cmp_ok($ok,'==',1,'label on while() unsuccessful next'); TEST23: { $ok = 0; my $x = 1; my $first_time = 1; LABEL23: while($x++) { if (!$first_time) { $ok = 0; last TEST23; } $ok = 0; $first_time = 0; last LABEL23; last TEST23; } continue { $ok = 0; last TEST23; } $ok = 1; } cmp_ok($ok,'==',1,'label on while() last'); TEST24: { $ok = 0; my $x = 0; my $first_time = 1; LABEL24: until($x++) { if (!$first_time) { $ok = 1; last TEST24; } $ok = 0; $first_time = 0; redo LABEL24; last TEST24; } continue { $ok = 0; last TEST24; } $ok = 0; } cmp_ok($ok,'==',1,'label on until()'); TEST25: { $ok = 0; my $x = 0; my $first_time = 1; my $been_in_continue = 0; LABEL25: until($x++ >= 2) { if (!$first_time) { $ok = $been_in_continue; last TEST25; } $ok = 0; $first_time = 0; next LABEL25; last TEST25; } continue { $been_in_continue = 1; } $ok = 0; } cmp_ok($ok,'==',1,'label on until() successful next'); TEST26: { $ok = 0; my $x = 0; my $first_time = 1; my $been_in_loop = 0; my $been_in_continue = 0; LABEL26: until($x++) { $been_in_loop = 1; if (!$first_time) { $ok = 0; last TEST26; } $ok = 0; $first_time = 0; next LABEL26; last TEST26; } continue { $been_in_continue = 1; } $ok = $been_in_loop && $been_in_continue; } cmp_ok($ok,'==',1,'label on until() unsuccessful next'); TEST27: { $ok = 0; my $x = 0; my $first_time = 1; LABEL27: until($x++ == 10) { if (!$first_time) { $ok = 0; last TEST27; } $ok = 0; $first_time = 0; last LABEL27; last TEST27; } continue { $ok = 0; last TEST8; } $ok = 1; } cmp_ok($ok,'==',1,'label on until() last'); TEST28: { $ok = 0; my $first_time = 1; LABEL28: for(1) { if (!$first_time) { $ok = 1; last TEST28; } $ok = 0; $first_time = 0; redo LABEL28; last TEST28; } continue { $ok = 0; last TEST28; } $ok = 0; } cmp_ok($ok,'==',1,'label on for(@array)'); TEST29: { $ok = 0; my $first_time = 1; my $been_in_continue = 0; LABEL29: for(1,2) { if (!$first_time) { $ok = $been_in_continue; last TEST29; } $ok = 0; $first_time = 0; next LABEL29; last TEST29; } continue { $been_in_continue = 1; } $ok = 0; } cmp_ok($ok,'==',1,'label on for(@array) successful next'); TEST30: { $ok = 0; my $first_time = 1; my $been_in_loop = 0; my $been_in_continue = 0; LABEL30: for(1) { $been_in_loop = 1; if (!$first_time) { $ok = 0; last TEST30; } $ok = 0; $first_time = 0; next LABEL30; last TEST30; } continue { $been_in_continue = 1; } $ok = $been_in_loop && $been_in_continue; } cmp_ok($ok,'==',1,'label on for(@array) unsuccessful next'); TEST31: { $ok = 0; my $first_time = 1; LABEL31: for(1..10) { if (!$first_time) { $ok = 0; last TEST31; } $ok = 0; $first_time = 0; last LABEL31; last TEST31; } continue { $ok=0; last TEST31; } $ok = 1; } cmp_ok($ok,'==',1,'label on for(@array) last'); TEST32: { $ok = 0; LABEL32: for(my $first_time = 1; 1;) { if (!$first_time) { $ok = 1; last TEST32; } $ok = 0; $first_time=0; redo LABEL32; last TEST32; } $ok = 0; } cmp_ok($ok,'==',1,'label on for(;;)'); TEST33: { $ok = 0; LABEL33: for(my $first_time = 1; 1; $first_time=0) { if (!$first_time) { $ok = 1; last TEST33; } $ok = 0; next LABEL33; last TEST33; } $ok = 0; } cmp_ok($ok,'==',1,'label on for(;;) successful next'); TEST34: { $ok = 0; my $x=1; my $been_in_loop = 0; LABEL34: for(my $first_time = 1; $x--;) { $been_in_loop = 1; if (!$first_time) { $ok = 0; last TEST34; } $ok = 0; $first_time = 0; next LABEL34; last TEST34; } $ok = $been_in_loop; } cmp_ok($ok,'==',1,'label on for(;;) unsuccessful next'); TEST35: { $ok = 0; LABEL35: for(my $first_time = 1; 1; last TEST16) { if (!$first_time) { $ok = 0; last TEST35; } $ok = 0; $first_time = 0; last LABEL35; last TEST35; } $ok = 1; } cmp_ok($ok,'==',1,'label on for(;;) last'); TEST36: { $ok = 0; my $first_time = 1; LABEL36: { if (!$first_time) { $ok = 1; last TEST36; } $ok = 0; $first_time=0; redo LABEL36; last TEST36; } continue { $ok = 0; last TEST36; } $ok = 0; } cmp_ok($ok,'==',1,'label on bare block'); TEST37: { $ok = 0; LABEL37: { next LABEL37; last TEST37; } continue { $ok = 1; last TEST37; } $ok = 0; } cmp_ok($ok,'==',1,'label on bare block next'); TEST38: { $ok = 0; LABEL38: { last LABEL38; last TEST38; } continue { $ok = 0; last TEST38; } $ok = 1; } cmp_ok($ok,'==',1,'label on bare block last'); TEST39: { $ok = 0; my ($x, $y, $z) = (1,1,1); one39: while ($x--) { $ok = 0; two39: while ($y--) { $ok = 0; three39: while ($z--) { next two39; } continue { $ok = 0; last TEST39; } } continue { $ok = 1; last TEST39; } $ok = 0; } } cmp_ok($ok,'==',1,'nested constructs'); sub test_last_label { last TEST40 } TEST40: { $ok = 1; test_last_label(); $ok = 0; } cmp_ok($ok,'==',1,'dynamically scoped label'); sub test_last { last } TEST41: { $ok = 1; test_last(); $ok = 0; } cmp_ok($ok,'==',1,'dynamically scoped'); # [perl #27206] Memory leak in continue loop # Ensure that the temporary object is freed each time round the loop, # rather then all 10 of them all being freed right at the end { my $n=10; my $late_free = 0; sub X::DESTROY { $late_free++ if $n < 0 }; { ($n-- && bless {}, 'X') && redo; } cmp_ok($late_free,'==',0,"bug 27206: redo memory leak"); $n = 10; $late_free = 0; { ($n-- && bless {}, 'X') && redo; } continue { } cmp_ok($late_free,'==',0,"bug 27206: redo with continue memory leak"); } # ensure that redo doesn't clear a lexical declared in the condition { my $i = 1; while (my $x = $i) { $i++; redo if $i == 2; cmp_ok($x,'==',1,"while/redo lexical life"); last; } $i = 1; until (! (my $x = $i)) { $i++; redo if $i == 2; cmp_ok($x,'==',1,"until/redo lexical life"); last; } for ($i = 1; my $x = $i; ) { $i++; redo if $i == 2; cmp_ok($x,'==',1,"for/redo lexical life"); last; } } { $a37725[3] = 1; # use package var $i = 2; for my $x (reverse @a37725) { $x = $i++; } cmp_ok("@a37725",'eq',"5 4 3 2",'bug 27725: reverse with empty slots bug'); } perl-5.12.0-RC0/t/op/inccode-tie.t0000555000175000017500000000052211325125742015362 0ustar jessejesse#!./perl # Calls all tests in op/inccode.t after tying @INC first. use Tie::Array; my @orig_INC = @INC; tie @INC, 'Tie::StdArray'; @INC = @orig_INC; for my $file ('./op/inccode.t', './t/op/inccode.t', ':op:inccode.t') { if (-r $file) { do $file; die $@ if $@; exit; } } die "Cannot find ./op/inccode.t or ./t/op/inccode.t\n"; perl-5.12.0-RC0/t/op/index_thr.t0000555000175000017500000000015311325125742015163 0ustar jessejesse#!./perl chdir 't' if -d 't'; @INC = ('../lib', '.'); require 'thread_it.pl'; thread_it(qw(op index.t)); perl-5.12.0-RC0/t/op/hashassign.t0000555000175000017500000002371311325125742015336 0ustar jessejesse#!./perl -w BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } # use strict; plan tests => 215; my @comma = ("key", "value"); # The peephole optimiser already knows that it should convert the string in # $foo{string} into a shared hash key scalar. It might be worth making the # tokeniser build the LHS of => as a shared hash key scalar too. # And so there's the possiblility of it going wrong # And going right on 8 bit but wrong on utf8 keys. # And really we should also try utf8 literals in {} and => in utf8.t # Some of these tests are (effectively) duplicated in each.t my %comma = @comma; ok (keys %comma == 1, 'keys on comma hash'); ok (values %comma == 1, 'values on comma hash'); # defeat any tokeniser or optimiser cunning my $key = 'ey'; is ($comma{"k" . $key}, "value", 'is key present? (unoptimised)'); # now with cunning: is ($comma{key}, "value", 'is key present? (maybe optimised)'); #tokeniser may treat => differently. my @temp = (key=>undef); is ($comma{$temp[0]}, "value", 'is key present? (using LHS of =>)'); @temp = %comma; ok (eq_array (\@comma, \@temp), 'list from comma hash'); @temp = each %comma; ok (eq_array (\@comma, \@temp), 'first each from comma hash'); @temp = each %comma; ok (eq_array ([], \@temp), 'last each from comma hash'); my %temp = %comma; ok (keys %temp == 1, 'keys on copy of comma hash'); ok (values %temp == 1, 'values on copy of comma hash'); is ($temp{'k' . $key}, "value", 'is key present? (unoptimised)'); # now with cunning: is ($temp{key}, "value", 'is key present? (maybe optimised)'); @temp = (key=>undef); is ($comma{$temp[0]}, "value", 'is key present? (using LHS of =>)'); @temp = %temp; ok (eq_array (\@temp, \@temp), 'list from copy of comma hash'); @temp = each %temp; ok (eq_array (\@temp, \@temp), 'first each from copy of comma hash'); @temp = each %temp; ok (eq_array ([], \@temp), 'last each from copy of comma hash'); my @arrow = (Key =>"Value"); my %arrow = @arrow; ok (keys %arrow == 1, 'keys on arrow hash'); ok (values %arrow == 1, 'values on arrow hash'); # defeat any tokeniser or optimiser cunning $key = 'ey'; is ($arrow{"K" . $key}, "Value", 'is key present? (unoptimised)'); # now with cunning: is ($arrow{Key}, "Value", 'is key present? (maybe optimised)'); #tokeniser may treat => differently. @temp = ('Key', undef); is ($arrow{$temp[0]}, "Value", 'is key present? (using LHS of =>)'); @temp = %arrow; ok (eq_array (\@arrow, \@temp), 'list from arrow hash'); @temp = each %arrow; ok (eq_array (\@arrow, \@temp), 'first each from arrow hash'); @temp = each %arrow; ok (eq_array ([], \@temp), 'last each from arrow hash'); %temp = %arrow; ok (keys %temp == 1, 'keys on copy of arrow hash'); ok (values %temp == 1, 'values on copy of arrow hash'); is ($temp{'K' . $key}, "Value", 'is key present? (unoptimised)'); # now with cunning: is ($temp{Key}, "Value", 'is key present? (maybe optimised)'); @temp = ('Key', undef); is ($arrow{$temp[0]}, "Value", 'is key present? (using LHS of =>)'); @temp = %temp; ok (eq_array (\@temp, \@temp), 'list from copy of arrow hash'); @temp = each %temp; ok (eq_array (\@temp, \@temp), 'first each from copy of arrow hash'); @temp = each %temp; ok (eq_array ([], \@temp), 'last each from copy of arrow hash'); my %direct = ('Camel', 2, 'Dromedary', 1); my %slow; $slow{Dromedary} = 1; $slow{Camel} = 2; ok (eq_hash (\%slow, \%direct), "direct list assignment to hash"); %direct = (Camel => 2, 'Dromedary' => 1); ok (eq_hash (\%slow, \%direct), "direct list assignment to hash using =>"); $slow{Llama} = 0; # A llama is not a camel :-) ok (!eq_hash (\%direct, \%slow), "different hashes should not be equal!"); my (%names, %names_copy); %names = ('$' => 'Scalar', '@' => 'Array', # Grr ' '%', 'Hash', '&', 'Code'); %names_copy = %names; ok (eq_hash (\%names, \%names_copy), "check we can copy our hash"); sub in { my %args = @_; return eq_hash (\%names, \%args); } ok (in (%names), "pass hash into a method"); sub in_method { my $self = shift; my %args = @_; return eq_hash (\%names, \%args); } ok (main->in_method (%names), "pass hash into a method"); sub out { return %names; } %names_copy = out (); ok (eq_hash (\%names, \%names_copy), "pass hash from a subroutine"); sub out_method { my $self = shift; return %names; } %names_copy = main->out_method (); ok (eq_hash (\%names, \%names_copy), "pass hash from a method"); sub in_out { my %args = @_; return %args; } %names_copy = in_out (%names); ok (eq_hash (\%names, \%names_copy), "pass hash to and from a subroutine"); sub in_out_method { my $self = shift; my %args = @_; return %args; } %names_copy = main->in_out_method (%names); ok (eq_hash (\%names, \%names_copy), "pass hash to and from a method"); my %names_copy2 = %names; ok (eq_hash (\%names, \%names_copy2), "check copy worked"); # This should get ignored. %names_copy = ('%', 'Associative Array', %names); ok (eq_hash (\%names, \%names_copy), "duplicates at the start of a list"); # This should not %names_copy = ('*', 'Typeglob', %names); $names_copy2{'*'} = 'Typeglob'; ok (eq_hash (\%names_copy, \%names_copy2), "duplicates at the end of a list"); %names_copy = ('%', 'Associative Array', '*', 'Endangered species', %names, '*', 'Typeglob',); ok (eq_hash (\%names_copy, \%names_copy2), "duplicates at both ends"); # And now UTF8 foreach my $chr (60, 200, 600, 6000, 60000) { # This little game may set a UTF8 flag internally. Or it may not. :-) my ($key, $value) = (chr ($chr) . "\x{ABCD}", "$chr\x{ABCD}"); chop ($key, $value); my @utf8c = ($key, $value); my %utf8c = @utf8c; ok (keys %utf8c == 1, 'keys on utf8 comma hash'); ok (values %utf8c == 1, 'values on utf8 comma hash'); # defeat any tokeniser or optimiser cunning is ($utf8c{"" . $key}, $value, 'is key present? (unoptimised)'); my $tempval = sprintf '$utf8c{"\x{%x}"}', $chr; is (eval $tempval, $value, "is key present? (maybe $tempval is optimised)"); $tempval = sprintf '@temp = ("\x{%x}" => undef)', $chr; eval $tempval or die "'$tempval' gave $@"; is ($utf8c{$temp[0]}, $value, 'is key present? (using LHS of $tempval)'); @temp = %utf8c; ok (eq_array (\@utf8c, \@temp), 'list from utf8 comma hash'); @temp = each %utf8c; ok (eq_array (\@utf8c, \@temp), 'first each from utf8 comma hash'); @temp = each %utf8c; ok (eq_array ([], \@temp), 'last each from utf8 comma hash'); %temp = %utf8c; ok (keys %temp == 1, 'keys on copy of utf8 comma hash'); ok (values %temp == 1, 'values on copy of utf8 comma hash'); is ($temp{"" . $key}, $value, 'is key present? (unoptimised)'); $tempval = sprintf '$temp{"\x{%x}"}', $chr; is (eval $tempval, $value, "is key present? (maybe $tempval is optimised)"); $tempval = sprintf '@temp = ("\x{%x}" => undef)', $chr; eval $tempval or die "'$tempval' gave $@"; is ($temp{$temp[0]}, $value, "is key present? (using LHS of $tempval)"); @temp = %temp; ok (eq_array (\@temp, \@temp), 'list from copy of utf8 comma hash'); @temp = each %temp; ok (eq_array (\@temp, \@temp), 'first each from copy of utf8 comma hash'); @temp = each %temp; ok (eq_array ([], \@temp), 'last each from copy of utf8 comma hash'); my $assign = sprintf '("\x{%x}" => "%d")', $chr, $chr; print "# $assign\n"; my (@utf8a) = eval $assign; my %utf8a = @utf8a; ok (keys %utf8a == 1, 'keys on utf8 arrow hash'); ok (values %utf8a == 1, 'values on utf8 arrow hash'); # defeat any tokeniser or optimiser cunning is ($utf8a{$key . ""}, $value, 'is key present? (unoptimised)'); $tempval = sprintf '$utf8a{"\x{%x}"}', $chr; is (eval $tempval, $value, "is key present? (maybe $tempval is optimised)"); $tempval = sprintf '@temp = ("\x{%x}" => undef)', $chr; eval $tempval or die "'$tempval' gave $@"; is ($utf8a{$temp[0]}, $value, "is key present? (using LHS of $tempval)"); @temp = %utf8a; ok (eq_array (\@utf8a, \@temp), 'list from utf8 arrow hash'); @temp = each %utf8a; ok (eq_array (\@utf8a, \@temp), 'first each from utf8 arrow hash'); @temp = each %utf8a; ok (eq_array ([], \@temp), 'last each from utf8 arrow hash'); %temp = %utf8a; ok (keys %temp == 1, 'keys on copy of utf8 arrow hash'); ok (values %temp == 1, 'values on copy of utf8 arrow hash'); is ($temp{'' . $key}, $value, 'is key present? (unoptimised)'); $tempval = sprintf '$temp{"\x{%x}"}', $chr; is (eval $tempval, $value, "is key present? (maybe $tempval is optimised)"); $tempval = sprintf '@temp = ("\x{%x}" => undef)', $chr; eval $tempval or die "'$tempval' gave $@"; is ($temp{$temp[0]}, $value, "is key present? (using LHS of $tempval)"); @temp = %temp; ok (eq_array (\@temp, \@temp), 'list from copy of utf8 arrow hash'); @temp = each %temp; ok (eq_array (\@temp, \@temp), 'first each from copy of utf8 arrow hash'); @temp = each %temp; ok (eq_array ([], \@temp), 'last each from copy of utf8 arrow hash'); } # now some tests for hash assignment in scalar and list context with # duplicate keys [perl #24380] { my %h; my $x; my $ar; is( (join ':', %h = (1) x 8), '1:1', 'hash assignment in list context removes duplicates' ); is( scalar( %h = (1,2,1,3,1,4,1,5) ), 2, 'hash assignment in scalar context' ); is( scalar( ($x,%h) = (0,1,2,1,3,1,4,1,5) ), 3, 'scalar + hash assignment in scalar context' ); $ar = [ %h = (1,2,1,3,1,4,1,5) ]; is( $#$ar, 1, 'hash assignment in list context' ); is( "@$ar", "1 5", '...gets the last values' ); $ar = [ ($x,%h) = (0,1,2,1,3,1,4,1,5) ]; is( $#$ar, 2, 'scalar + hash assignment in list context' ); is( "@$ar", "0 1 5", '...gets the last values' ); } # test stringification of keys { no warnings 'once'; my @types = qw( SCALAR ARRAY HASH CODE GLOB); my @refs = ( \ do { my $x }, [], {}, sub {}, \ *x); my(%h, %expect); @h{@refs} = @types; @expect{map "$_", @refs} = @types; ok (eq_hash(\%h, \%expect), 'unblessed ref stringification'); bless $_ for @refs; %h = (); %expect = (); @h{@refs} = @types; @expect{map "$_", @refs} = @types; ok (eq_hash(\%h, \%expect), 'blessed ref stringification'); } perl-5.12.0-RC0/t/op/goto_xs.t0000555000175000017500000000676311325125742014676 0ustar jessejesse#!./perl # tests for "goto &sub"-ing into XSUBs # Note: This only tests things that should *work*. At some point, it may # be worth while to write some failure tests for things that should # *break* (such as calls with wrong number of args). For now, I'm # guessing that if all of these work correctly, the bad ones will # break correctly as well. BEGIN { $| = 1; } BEGIN { chdir 't' if -d 't'; @INC = '../lib'; $ENV{PERL5LIB} = "../lib"; # turn warnings into fatal errors $SIG{__WARN__} = sub { die "WARNING: @_" } ; foreach (qw(Fcntl XS::APItest)) { eval "require $_" or do { print "1..0\n# $_ unavailable, can't test XS goto.\n"; exit 0 } } } print "1..11\n"; # We don't know what symbols are defined in platform X's system headers. # We don't even want to guess, because some platform out there will # likely do the unthinkable. However, Fcntl::constant("LOCK_SH",0) # should always return a value, even on platforms which don't define the # cpp symbol; Fcntl.xs says: # /* We support flock() on systems which don't have it, so # always supply the constants. */ # If this ceases to be the case, we're in trouble. =) $VALID = 'LOCK_SH'; ### First, we check whether Fcntl::constant returns sane answers. # Fcntl::constant("LOCK_SH",0) should always succeed. $value = Fcntl::constant($VALID); print((!defined $value) ? "not ok 1\n# Sanity check broke, remaining tests will fail.\n" : "ok 1\n"); ### OK, we're ready to do real tests. # test "goto &function_constant" sub goto_const { goto &Fcntl::constant; } $ret = goto_const($VALID); print(($ret == $value) ? "ok 2\n" : "not ok 2\n# ($ret != $value)\n"); # test "goto &$function_package_and_name" $FNAME1 = 'Fcntl::constant'; sub goto_name1 { goto &$FNAME1; } $ret = goto_name1($VALID); print(($ret == $value) ? "ok 3\n" : "not ok 3\n# ($ret != $value)\n"); # test "goto &$function_package_and_name" again, with dirtier stack $ret = goto_name1($VALID); print(($ret == $value) ? "ok 4\n" : "not ok 4\n# ($ret != $value)\n"); $ret = goto_name1($VALID); print(($ret == $value) ? "ok 5\n" : "not ok 5\n# ($ret != $value)\n"); # test "goto &$function_name" from local package package Fcntl; $FNAME2 = 'constant'; sub goto_name2 { goto &$FNAME2; } package main; $ret = Fcntl::goto_name2($VALID); print(($ret == $value) ? "ok 6\n" : "not ok 6\n# ($ret != $value)\n"); # test "goto &$function_ref" $FREF = \&Fcntl::constant; sub goto_ref { goto &$FREF; } $ret = goto_ref($VALID); print(($ret == $value) ? "ok 7\n" : "not ok 7\n# ($ret != $value)\n"); ### tests where the args are not on stack but in GvAV(defgv) (ie, @_) # test "goto &function_constant" from a sub called without arglist sub call_goto_const { &goto_const; } $ret = call_goto_const($VALID); print(($ret == $value) ? "ok 8\n" : "not ok 8\n# ($ret != $value)\n"); # test "goto &$function_package_and_name" from a sub called without arglist sub call_goto_name1 { &goto_name1; } $ret = call_goto_name1($VALID); print(($ret == $value) ? "ok 9\n" : "not ok 9\n# ($ret != $value)\n"); # test "goto &$function_ref" from a sub called without arglist sub call_goto_ref { &goto_ref; } $ret = call_goto_ref($VALID); print(($ret == $value) ? "ok 10\n" : "not ok 10\n# ($ret != $value)\n"); # [perl #35878] croak in XS after goto segfaulted use XS::APItest qw(mycroak); sub goto_croak { goto &mycroak } { my $e; for (1..4) { eval { goto_croak("boo$_\n") }; $e .= $@; } print $e eq "boo1\nboo2\nboo3\nboo4\n" ? "ok 11\n" : "not ok 11\n"; } perl-5.12.0-RC0/t/op/wantarray.t0000555000175000017500000000155211325125742015213 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } use strict; plan 13; sub context { local $::Level = $::Level + 1; my ( $cona, $testnum ) = @_; my $conb = (defined wantarray) ? ( wantarray ? 'A' : 'S' ) : 'V'; is $cona, $conb; } context('V'); my $a = context('S'); my @a = context('A'); scalar context('S'); $a = scalar context('S'); ($a) = context('A'); ($a) = scalar context('S'); { # [ID 20020626.011] incorrect wantarray optimisation sub simple { wantarray ? 1 : 2 } sub inline { my $a = wantarray ? simple() : simple(); $a; } my @b = inline(); my $c = inline(); is @b, 1; is "@b", "2"; is $c, 2; } my $q; my $qcontext = q{ $q = (defined wantarray) ? ( wantarray ? 'A' : 'S' ) : 'V'; }; eval $qcontext; is $q, 'V'; $a = eval $qcontext; is $q, 'S'; @a = eval $qcontext; is $q, 'A'; 1; perl-5.12.0-RC0/t/op/exec.t0000555000175000017500000001006511325127001014114 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = ('../lib'); require './test.pl'; } my $vms_exit_mode = 0; if ($^O eq 'VMS') { if (eval 'require VMS::Feature') { $vms_exit_mode = !(VMS::Feature::current("posix_exit")); } else { my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; my $env_posix_ex = $ENV{'PERL_VMS_POSIX_EXIT'} || ''; my $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; my $posix_ex = $env_posix_ex =~ /^[ET1]/i; if (($unix_rpt || $posix_ex) ) { $vms_exit_mode = 0; } else { $vms_exit_mode = 1; } } } # supress VMS whinging about bad execs. use vmsish qw(hushed); $| = 1; # flush stdout $ENV{LC_ALL} = 'C'; # Forge English error messages. $ENV{LANGUAGE} = 'C'; # Ditto in GNU. my $Is_VMS = $^O eq 'VMS'; my $Is_Win32 = $^O eq 'MSWin32'; plan(tests => 22); my $Perl = which_perl(); my $exit; SKIP: { skip("bug/feature of pdksh", 2) if $^O eq 'os2'; my $tnum = curr_test(); $exit = system qq{$Perl -le "print q{ok $tnum - interp system(EXPR)"}}; next_test(); is( $exit, 0, ' exited 0' ); } my $tnum = curr_test(); $exit = system qq{$Perl -le "print q{ok $tnum - split & direct system(EXPR)"}}; next_test(); is( $exit, 0, ' exited 0' ); # On VMS and Win32 you need the quotes around the program or it won't work. # On Unix its the opposite. my $quote = $Is_VMS || $Is_Win32 ? '"' : ''; $tnum = curr_test(); $exit = system $Perl, '-le', "${quote}print q{ok $tnum - system(PROG, LIST)}${quote}"; next_test(); is( $exit, 0, ' exited 0' ); # Some basic piped commands. Some OS's have trouble with "helpfully" # putting newlines on the end of piped output. So we split this into # newline insensitive and newline sensitive tests. my $echo_out = `$Perl -e "print 'ok'" | $Perl -le "print "`; $echo_out =~ s/\n\n/\n/g; is( $echo_out, "ok\n", 'piped echo emulation'); { # here we check if extra newlines are going to be slapped on # piped output. local $TODO = 'VMS sticks newlines on everything' if $Is_VMS; is( scalar `$Perl -e "print 'ok'"`, "ok", 'no extra newlines on ``' ); is( scalar `$Perl -e "print 'ok'" | $Perl -e "print "`, "ok", 'no extra newlines on pipes'); is( scalar `$Perl -le "print 'ok'" | $Perl -le "print "`, "ok\n\n", 'doubled up newlines'); is( scalar `$Perl -e "print 'ok'" | $Perl -le "print "`, "ok\n", 'extra newlines on inside pipes'); is( scalar `$Perl -le "print 'ok'" | $Perl -e "print "`, "ok\n", 'extra newlines on outgoing pipes'); { local($/) = \2; $out = runperl(prog => 'print q{1234}'); is($out, "1234", 'ignore $/ when capturing output in scalar context'); } } is( system(qq{$Perl -e "exit 0"}), 0, 'Explicit exit of 0' ); my $exit_one = $vms_exit_mode ? 4 << 8 : 1 << 8; is( system(qq{$Perl "-I../lib" -e "use vmsish qw(hushed); exit 1"}), $exit_one, 'Explicit exit of 1' ); $rc = system { "lskdfj" } "lskdfj"; unless( ok($rc == 255 << 8 or $rc == -1 or $rc == 256 or $rc == 512) ) { print "# \$rc == $rc\n"; } unless ( ok( $! == 2 or $! =~ /\bno\b.*\bfile/i or $! == 13 or $! =~ /permission denied/i or $! == 22 or $! =~ /invalid argument/i ) ) { printf "# \$! eq %d, '%s'\n", $!, $!; } is( `$Perl -le "print 'ok'"`, "ok\n", 'basic ``' ); is( <<`END`, "ok\n", '<<`HEREDOC`' ); $Perl -le "print 'ok'" END { my $_ = qq($Perl -le "print 'ok'"); is( readpipe, "ok\n", 'readpipe default argument' ); } TODO: { my $tnum = curr_test(); if( $^O =~ /Win32/ ) { print "not ok $tnum - exec failure doesn't terminate process " . "# TODO Win32 exec failure waits for user input\n"; next_test(); last TODO; } ok( !exec("lskdjfalksdjfdjfkls"), "exec failure doesn't terminate process"); } my $test = curr_test(); exec $Perl, '-le', qq{${quote}print 'ok $test - exec PROG, LIST'${quote}}; fail("This should never be reached if the exec() worked"); perl-5.12.0-RC0/t/op/negate.t0000555000175000017500000000276211325125742014452 0ustar jessejesse#!./perl -w BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } plan tests => 16; # Some of these will cause warnings if left on. Here we're checking the # functionality, not the warnings. no warnings "numeric"; # test cases based on [perl #36675] -'-10' eq '+10' is(- 10, -10, "Simple numeric negation to negative"); is(- -10, 10, "Simple numeric negation to positive"); is(-"10", -10, "Negation of a positive string to negative"); is(-"10.0", -10, "Negation of a positive decimal sting to negative"); is(-"10foo", -10, "Negation of a numeric-lead string returns negation of numeric"); is(-"-10", "+10", 'Negation of string starting with "-" returns a string starting with "+" - numeric'); is(-"-10.0", "+10.0", 'Negation of string starting with "-" returns a string starting with "+" - decimal'); is(-"-10foo", "+10foo", 'Negation of string starting with "-" returns a string starting with "+" - non-numeric'); is(-"xyz", "-xyz", 'Negation of a negative string adds "-" to the front'); is(-"-xyz", "+xyz", "Negation of a negative string to positive"); is(-"+xyz", "-xyz", "Negation of a positive string to negative"); is(-bareword, "-bareword", "Negation of bareword treated like a string"); is(- -bareword, "+bareword", "Negation of -bareword returns string +bareword"); is(-" -10", 10, "Negation of a whitespace-lead numeric string"); is(-" -10.0", 10, "Negation of a whitespace-lead decimal string"); is(-" -10foo", 10, "Negation of a whitespace-lead sting starting with a numeric") perl-5.12.0-RC0/t/op/chdir.t0000555000175000017500000001466511325127001014273 0ustar jessejesse#!./perl -w BEGIN { # We're not going to chdir() into 't' because we don't know if # chdir() works! Instead, we'll hedge our bets and put both # possibilities into @INC. @INC = qw(t . lib ../lib); } use Config; require "test.pl"; plan(tests => 48); my $IsVMS = $^O eq 'VMS'; my $vms_unix_rpt = 0; my $vms_efs = 0; if ($IsVMS) { if (eval 'require VMS::Feature') { $vms_unix_rpt = VMS::Feature::current("filename_unix_report"); $vms_efs = VMS::Feature::current("efs_charset"); } else { my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || ''; $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i; $vms_efs = $efs_charset =~ /^[ET1]/i; } } # For an op regression test, I don't want to rely on "use constant" working. my $has_fchdir = ($Config{d_fchdir} || "") eq "define"; # Might be a little early in the testing process to start using these, # but I can't think of a way to write this test without them. use File::Spec::Functions qw(:DEFAULT splitdir rel2abs splitpath); # Can't use Cwd::abs_path() because it has different ideas about # path separators than File::Spec. sub abs_path { my $d = rel2abs(curdir); $d = lc($d) if $^O =~ /^uwin/; $d; } my $Cwd = abs_path; # Let's get to a known position SKIP: { my ($vol,$dir) = splitpath(abs_path,1); my $test_dir = 't'; my $compare_dir = (splitdir($dir))[-1]; # VMS is case insensitive but will preserve case in EFS mode. # So we must normalize the case for the compare. $compare_dir = lc($compare_dir) if $IsVMS; skip("Already in t/", 2) if $compare_dir eq $test_dir; ok( chdir($test_dir), 'chdir($test_dir)'); is( abs_path, catdir($Cwd, $test_dir), ' abs_path() agrees' ); } $Cwd = abs_path; SKIP: { skip("no fchdir", 16) unless $has_fchdir; my $has_dirfd = ($Config{d_dirfd} || $Config{d_dir_dd_fd} || "") eq "define"; ok(opendir(my $dh, "."), "opendir ."); ok(open(my $fh, "<", "op"), "open op"); ok(chdir($fh), "fchdir op"); ok(-f "chdir.t", "verify that we are in op"); if ($has_dirfd) { ok(chdir($dh), "fchdir back"); } else { eval { chdir($dh); }; like($@, qr/^The dirfd function is unimplemented at/, "dirfd is unimplemented"); chdir ".." or die $!; } # same with bareword file handles no warnings 'once'; *DH = $dh; *FH = $fh; ok(chdir FH, "fchdir op bareword"); ok(-f "chdir.t", "verify that we are in op"); if ($has_dirfd) { ok(chdir DH, "fchdir back bareword"); } else { eval { chdir(DH); }; like($@, qr/^The dirfd function is unimplemented at/, "dirfd is unimplemented"); chdir ".." or die $!; } ok(-d "op", "verify that we are back"); # And now the ambiguous case { no warnings qw; ok(opendir(H, "op"), "opendir op") or diag $!; ok(open(H, "<", "base"), "open base") or diag $!; } if ($has_dirfd) { ok(chdir(H), "fchdir to op"); ok(-f "chdir.t", "verify that we are in 'op'"); chdir ".." or die $!; } else { eval { chdir(H); }; like($@, qr/^The dirfd function is unimplemented at/, "dirfd is unimplemented"); SKIP: { skip("dirfd is unimplemented"); } } ok(closedir(H), "closedir"); ok(chdir(H), "fchdir to base"); ok(-f "cond.t", "verify that we are in 'base'"); chdir ".." or die $!; } SKIP: { skip("has fchdir", 1) if $has_fchdir; opendir(my $dh, "op"); eval { chdir($dh); }; like($@, qr/^The fchdir function is unimplemented at/, "fchdir is unimplemented"); } # The environment variables chdir() pays attention to. my @magic_envs = qw(HOME LOGDIR SYS$LOGIN); sub check_env { my($key) = @_; # Make sure $ENV{'SYS$LOGIN'} is only honored on VMS. if( $key eq 'SYS$LOGIN' && !$IsVMS ) { ok( !chdir(), "chdir() on $^O ignores only \$ENV{$key} set" ); is( abs_path, $Cwd, ' abs_path() did not change' ); pass( " no need to test SYS\$LOGIN on $^O" ) for 1..7; } else { ok( chdir(), "chdir() w/ only \$ENV{$key} set" ); is( abs_path, $ENV{$key}, ' abs_path() agrees' ); chdir($Cwd); is( abs_path, $Cwd, ' and back again' ); my $warning = ''; local $SIG{__WARN__} = sub { $warning .= join '', @_ }; # Check the deprecated chdir(undef) feature. #line 64 ok( chdir(undef), "chdir(undef) w/ only \$ENV{$key} set" ); is( abs_path, $ENV{$key}, ' abs_path() agrees' ); is( $warning, <method("a","b","c"), "method,a,b,c"); is(Pack->$mname("a","b","c"), "method,a,b,c"); is(method Pack ("a","b","c"), "method,a,b,c"); is((method Pack "a","b","c"), "method,a,b,c"); is(Pack->method(), "method"); is(Pack->$mname(), "method"); is(method Pack (), "method"); is(Pack->method, "method"); is(Pack->$mname, "method"); is(method Pack, "method"); is($obj->method("a","b","c"), "method,a,b,c"); is($obj->$mname("a","b","c"), "method,a,b,c"); is((method $obj ("a","b","c")), "method,a,b,c"); is((method $obj "a","b","c"), "method,a,b,c"); is($obj->method(0), "method,0"); is($obj->method(1), "method,1"); is($obj->method(), "method"); is($obj->$mname(), "method"); is((method $obj ()), "method"); is($obj->method, "method"); is($obj->$mname, "method"); is(method $obj, "method"); is( A->d, "C::d"); # Update hash table; *B::d = \&D::d; # Import now. is(A->d, "D::d"); # Update hash table; { local @A::ISA = qw(C); # Update hash table with split() assignment is(A->d, "C::d"); $#A::ISA = -1; is(eval { A->d } || "fail", "fail"); } is(A->d, "D::d"); { local *B::d; eval 'sub B::d {"B::d1"}'; # Import now. is(A->d, "B::d1"); # Update hash table; undef &B::d; is((eval { A->d }, ($@ =~ /Undefined subroutine/)), 1); } is(A->d, "D::d"); # Back to previous state eval 'sub B::d {"B::d2"}'; # Import now. is(A->d, "B::d2"); # Update hash table; # What follows is hardly guarantied to work, since the names in scripts # are already linked to "pruned" globs. Say, `undef &B::d' if it were # after `delete $B::{d}; sub B::d {}' would reach an old subroutine. undef &B::d; delete $B::{d}; is(A->d, "C::d"); # Update hash table; eval 'sub B::d {"B::d3"}'; # Import now. is(A->d, "B::d3"); # Update hash table; delete $B::{d}; *dummy::dummy = sub {}; # Mark as updated is(A->d, "C::d"); eval 'sub B::d {"B::d4"}'; # Import now. is(A->d, "B::d4"); # Update hash table; delete $B::{d}; # Should work without any help too is(A->d, "C::d"); { local *C::d; is(eval { A->d } || "nope", "nope"); } is(A->d, "C::d"); *A::x = *A::d; # See if cache incorrectly follows synonyms A->d; is(eval { A->x } || "nope", "nope"); eval <<'EOF'; sub C::e; BEGIN { *B::e = \&C::e } # Shouldn't prevent AUTOLOAD in original pkg sub Y::f; $counter = 0; @X::ISA = 'Y'; @Y::ISA = 'B'; sub B::AUTOLOAD { my $c = ++$counter; my $method = $B::AUTOLOAD; my $msg = "B: In $method, $c"; eval "sub $method { \$msg }"; goto &$method; } sub C::AUTOLOAD { my $c = ++$counter; my $method = $C::AUTOLOAD; my $msg = "C: In $method, $c"; eval "sub $method { \$msg }"; goto &$method; } EOF is(A->e(), "C: In C::e, 1"); # We get a correct autoload is(A->e(), "C: In C::e, 1"); # Which sticks is(A->ee(), "B: In A::ee, 2"); # We get a generic autoload, method in top is(A->ee(), "B: In A::ee, 2"); # Which sticks is(Y->f(), "B: In Y::f, 3"); # We vivify a correct method is(Y->f(), "B: In Y::f, 3"); # Which sticks # This test is not intended to be reasonable. It is here just to let you # know that you broke some old construction. Feel free to rewrite the test # if your patch breaks it. *B::AUTOLOAD = sub { my $c = ++$counter; my $method = $AUTOLOAD; *$AUTOLOAD = sub { "new B: In $method, $c" }; goto &$AUTOLOAD; }; is(A->eee(), "new B: In A::eee, 4"); # We get a correct $autoload is(A->eee(), "new B: In A::eee, 4"); # Which sticks # this test added due to bug discovery is(defined(@{"unknown_package::ISA"}) ? "defined" : "undefined", "undefined"); # test that failed subroutine calls don't affect method calls { package A1; sub foo { "foo" } package A2; @ISA = 'A1'; package main; is(A2->foo(), "foo"); is(do { eval 'A2::foo()'; $@ ? 1 : 0}, 1); is(A2->foo(), "foo"); } ## This test was totally misguided. It passed before only because the ## code to determine if a package was loaded used to look for the hash ## %Foo::Bar instead of the package Foo::Bar:: -- and Config.pm just ## happens to export %Config. # { # is(do { use Config; eval 'Config->foo()'; # $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1); # is(do { use Config; eval '$d = bless {}, "Config"; $d->foo()'; # $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1); # } # test error messages if method loading fails eval '$e = bless {}, "E::A"; E::A->foo()'; like ($@, qr/^\QCan't locate object method "foo" via package "E::A" at/); eval '$e = bless {}, "E::B"; $e->foo()'; like ($@, qr/^\QCan't locate object method "foo" via package "E::B" at/); eval 'E::C->foo()'; like ($@, qr/^\QCan't locate object method "foo" via package "E::C" (perhaps /); eval 'UNIVERSAL->E::D::foo()'; like ($@, qr/^\QCan't locate object method "foo" via package "E::D" (perhaps /); eval '$e = bless {}, "UNIVERSAL"; $e->E::E::foo()'; like ($@, qr/^\QCan't locate object method "foo" via package "E::E" (perhaps /); $e = bless {}, "E::F"; # force package to exist eval 'UNIVERSAL->E::F::foo()'; like ($@, qr/^\QCan't locate object method "foo" via package "E::F" at/); eval '$e = bless {}, "UNIVERSAL"; $e->E::F::foo()'; like ($@, qr/^\QCan't locate object method "foo" via package "E::F" at/); # TODO: we need some tests for the SUPER:: pseudoclass # failed method call or UNIVERSAL::can() should not autovivify packages is( $::{"Foo::"} || "none", "none"); # sanity check 1 is( $::{"Foo::"} || "none", "none"); # sanity check 2 is( UNIVERSAL::can("Foo", "boogie") ? "yes":"no", "no" ); is( $::{"Foo::"} || "none", "none"); # still missing? is( Foo->UNIVERSAL::can("boogie") ? "yes":"no", "no" ); is( $::{"Foo::"} || "none", "none"); # still missing? is( Foo->can("boogie") ? "yes":"no", "no" ); is( $::{"Foo::"} || "none", "none"); # still missing? is( eval 'Foo->boogie(); 1' ? "yes":"no", "no" ); is( $::{"Foo::"} || "none", "none"); # still missing? is(do { eval 'Foo->boogie()'; $@ =~ /^\QCan't locate object method "boogie" via package "Foo" (perhaps / ? 1 : $@}, 1); eval 'sub Foo::boogie { "yes, sir!" }'; is( $::{"Foo::"} ? "ok" : "none", "ok"); # should exist now is( Foo->boogie(), "yes, sir!"); # TODO: universal.t should test NoSuchPackage->isa()/can() # This is actually testing parsing of indirect objects and undefined subs # print foo("bar") where foo does not exist is not an indirect object. # print foo "bar" where foo does not exist is an indirect object. eval 'sub AUTOLOAD { "ok ", shift, "\n"; }'; ok(1); # Bug ID 20010902.002 is( eval q[ $x = 'x'; sub Foo::x : lvalue { $x } Foo->$x = 'ok'; ] || $@, 'ok' ); # An autoloaded, inherited DESTROY may be invoked differently than normal # methods, and has been known to give rise to spurious warnings # eg <200203121600.QAA11064@gizmo.fdgroup.co.uk> { use warnings; my $w = ''; local $SIG{__WARN__} = sub { $w = $_[0] }; sub AutoDest::Base::AUTOLOAD {} @AutoDest::ISA = qw(AutoDest::Base); { my $x = bless {}, 'AutoDest'; } $w =~ s/\n//g; is($w, ''); } # [ID 20020305.025] PACKAGE::SUPER doesn't work anymore package main; our @X; package Amajor; sub test { push @main::X, 'Amajor', @_; } package Bminor; use base qw(Amajor); package main; sub Bminor::test { $_[0]->Bminor::SUPER::test('x', 'y'); push @main::X, 'Bminor', @_; } Bminor->test('y', 'z'); is("@X", "Amajor Bminor x y Bminor Bminor y z"); package main; for my $meth (['Bar', 'Foo::Bar'], ['SUPER::Bar', 'main::SUPER::Bar'], ['Xyz::SUPER::Bar', 'Xyz::SUPER::Bar']) { fresh_perl_is(<$meth->[0](); EOT "Foo $meth->[1]", { switches => [ '-w' ] }, "check if UNIVERSAL::AUTOLOAD works", ); } # Test for #71952: crash when looking for a nonexistent destructor # Regression introduced by fbb3ee5af3d4 { fresh_perl_is(<<'EOT', sub M::DESTROY; bless {}, "M" ; print "survived\n"; EOT "survived", {}, "no crash with a declared but missing DESTROY method" ); } perl-5.12.0-RC0/t/op/arith.t0000555000175000017500000002136611325125742014317 0ustar jessejesse#!./perl -w BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } print "1..145\n"; sub try ($$) { print +($_[1] ? "ok" : "not ok"), " $_[0]\n"; } sub tryeq ($$$) { if ($_[1] == $_[2]) { print "ok $_[0]\n"; } else { print "not ok $_[0] # $_[1] != $_[2]\n"; } } sub tryeq_sloppy ($$$) { if ($_[1] == $_[2]) { print "ok $_[0]\n"; } else { my $error = abs ($_[1] - $_[2]) / $_[1]; if ($error < 1e-9) { print "ok $_[0] # $_[1] is close to $_[2], \$^O eq $^O\n"; } else { print "not ok $_[0] # $_[1] != $_[2]\n"; } } } my $T = 1; tryeq $T++, 13 % 4, 1; tryeq $T++, -13 % 4, 3; tryeq $T++, 13 % -4, -3; tryeq $T++, -13 % -4, -1; # Give abs() a good work-out before using it in anger tryeq $T++, abs(0), 0; tryeq $T++, abs(1), 1; tryeq $T++, abs(-1), 1; tryeq $T++, abs(2147483647), 2147483647; tryeq $T++, abs(-2147483647), 2147483647; tryeq $T++, abs(4294967295), 4294967295; tryeq $T++, abs(-4294967295), 4294967295; tryeq $T++, abs(9223372036854775807), 9223372036854775807; tryeq $T++, abs(-9223372036854775807), 9223372036854775807; tryeq $T++, abs(1e50), 1e50; # Assume no change whatever; no slop needed tryeq $T++, abs(-1e50), 1e50; # Assume only sign bit flipped my $limit = 1e6; # Division (and modulo) of floating point numbers # seem to be rather sloppy in Cray. $limit = 1e8 if $^O eq 'unicos'; try $T++, abs( 13e21 % 4e21 - 1e21) < $limit; try $T++, abs(-13e21 % 4e21 - 3e21) < $limit; try $T++, abs( 13e21 % -4e21 - -3e21) < $limit; try $T++, abs(-13e21 % -4e21 - -1e21) < $limit; # UVs should behave properly tryeq $T++, 4063328477 % 65535, 27407; tryeq $T++, 4063328477 % 4063328476, 1; tryeq $T++, 4063328477 % 2031664238, 1; tryeq $T++, 2031664238 % 4063328477, 2031664238; # These should trigger wrapping on 32 bit IVs and UVs tryeq $T++, 2147483647 + 0, 2147483647; # IV + IV promote to UV tryeq $T++, 2147483647 + 1, 2147483648; tryeq $T++, 2147483640 + 10, 2147483650; tryeq $T++, 2147483647 + 2147483647, 4294967294; # IV + UV promote to NV tryeq $T++, 2147483647 + 2147483649, 4294967296; # UV + IV promote to NV tryeq $T++, 4294967294 + 2, 4294967296; # UV + UV promote to NV tryeq $T++, 4294967295 + 4294967295, 8589934590; # UV + IV to IV tryeq $T++, 2147483648 + -1, 2147483647; tryeq $T++, 2147483650 + -10, 2147483640; # IV + UV to IV tryeq $T++, -1 + 2147483648, 2147483647; tryeq $T++, -10 + 4294967294, 4294967284; # IV + IV to NV tryeq $T++, -2147483648 + -2147483648, -4294967296; tryeq $T++, -2147483640 + -10, -2147483650; # Hmm. Don't forget the simple stuff tryeq $T++, 1 + 1, 2; tryeq $T++, 4 + -2, 2; tryeq $T++, -10 + 100, 90; tryeq $T++, -7 + -9, -16; tryeq $T++, -63 + +2, -61; tryeq $T++, 4 + -1, 3; tryeq $T++, -1 + 1, 0; tryeq $T++, +29 + -29, 0; tryeq $T++, -1 + 4, 3; tryeq $T++, +4 + -17, -13; # subtraction tryeq $T++, 3 - 1, 2; tryeq $T++, 3 - 15, -12; tryeq $T++, 3 - -7, 10; tryeq $T++, -156 - 5, -161; tryeq $T++, -156 - -5, -151; tryeq $T++, -5 - -12, 7; tryeq $T++, -3 - -3, 0; tryeq $T++, 15 - 15, 0; tryeq $T++, 2147483647 - 0, 2147483647; tryeq $T++, 2147483648 - 0, 2147483648; tryeq $T++, -2147483648 - 0, -2147483648; tryeq $T++, 0 - -2147483647, 2147483647; tryeq $T++, -1 - -2147483648, 2147483647; tryeq $T++, 2 - -2147483648, 2147483650; tryeq $T++, 4294967294 - 3, 4294967291; tryeq $T++, -2147483648 - -1, -2147483647; # IV - IV promote to UV tryeq $T++, 2147483647 - -1, 2147483648; tryeq $T++, 2147483647 - -2147483648, 4294967295; # UV - IV promote to NV tryeq $T++, 4294967294 - -3, 4294967297; # IV - IV promote to NV tryeq $T++, -2147483648 - +1, -2147483649; # UV - UV promote to IV tryeq $T++, 2147483648 - 2147483650, -2; # IV - UV promote to IV tryeq $T++, 2000000000 - 4000000000, -2000000000; # No warnings should appear; my $a; $a += 1; tryeq $T++, $a, 1; undef $a; $a += -1; tryeq $T++, $a, -1; undef $a; $a += 4294967290; tryeq $T++, $a, 4294967290; undef $a; $a += -4294967290; tryeq $T++, $a, -4294967290; undef $a; $a += 4294967297; tryeq $T++, $a, 4294967297; undef $a; $a += -4294967297; tryeq $T++, $a, -4294967297; my $s; $s -= 1; tryeq $T++, $s, -1; undef $s; $s -= -1; tryeq $T++, $s, +1; undef $s; $s -= -4294967290; tryeq $T++, $s, +4294967290; undef $s; $s -= 4294967290; tryeq $T++, $s, -4294967290; undef $s; $s -= 4294967297; tryeq $T++, $s, -4294967297; undef $s; $s -= -4294967297; tryeq $T++, $s, +4294967297; # Multiplication tryeq $T++, 1 * 3, 3; tryeq $T++, -2 * 3, -6; tryeq $T++, 3 * -3, -9; tryeq $T++, -4 * -3, 12; # check with 0xFFFF and 0xFFFF tryeq $T++, 65535 * 65535, 4294836225; tryeq $T++, 65535 * -65535, -4294836225; tryeq $T++, -65535 * 65535, -4294836225; tryeq $T++, -65535 * -65535, 4294836225; # check with 0xFFFF and 0x10001 tryeq $T++, 65535 * 65537, 4294967295; tryeq $T++, 65535 * -65537, -4294967295; tryeq $T++, -65535 * 65537, -4294967295; tryeq $T++, -65535 * -65537, 4294967295; # check with 0x10001 and 0xFFFF tryeq $T++, 65537 * 65535, 4294967295; tryeq $T++, 65537 * -65535, -4294967295; tryeq $T++, -65537 * 65535, -4294967295; tryeq $T++, -65537 * -65535, 4294967295; # These should all be dones as NVs tryeq $T++, 65537 * 65537, 4295098369; tryeq $T++, 65537 * -65537, -4295098369; tryeq $T++, -65537 * 65537, -4295098369; tryeq $T++, -65537 * -65537, 4295098369; # will overflow an IV (in 32-bit) tryeq $T++, 46340 * 46342, 0x80001218; tryeq $T++, 46340 * -46342, -0x80001218; tryeq $T++, -46340 * 46342, -0x80001218; tryeq $T++, -46340 * -46342, 0x80001218; tryeq $T++, 46342 * 46340, 0x80001218; tryeq $T++, 46342 * -46340, -0x80001218; tryeq $T++, -46342 * 46340, -0x80001218; tryeq $T++, -46342 * -46340, 0x80001218; # will overflow a positive IV (in 32-bit) tryeq $T++, 65536 * 32768, 0x80000000; tryeq $T++, 65536 * -32768, -0x80000000; tryeq $T++, -65536 * 32768, -0x80000000; tryeq $T++, -65536 * -32768, 0x80000000; tryeq $T++, 32768 * 65536, 0x80000000; tryeq $T++, 32768 * -65536, -0x80000000; tryeq $T++, -32768 * 65536, -0x80000000; tryeq $T++, -32768 * -65536, 0x80000000; # 2147483647 is prime. bah. tryeq $T++, 46339 * 46341, 0x7ffea80f; tryeq $T++, 46339 * -46341, -0x7ffea80f; tryeq $T++, -46339 * 46341, -0x7ffea80f; tryeq $T++, -46339 * -46341, 0x7ffea80f; # leading space should be ignored tryeq $T++, 1 + " 1", 2; tryeq $T++, 3 + " -1", 2; tryeq $T++, 1.2, " 1.2"; tryeq $T++, -1.2, " -1.2"; # divide tryeq $T++, 28/14, 2; tryeq $T++, 28/-7, -4; tryeq $T++, -28/4, -7; tryeq $T++, -28/-2, 14; tryeq $T++, 0x80000000/1, 0x80000000; tryeq $T++, 0x80000000/-1, -0x80000000; tryeq $T++, -0x80000000/1, -0x80000000; tryeq $T++, -0x80000000/-1, 0x80000000; # The example for sloppy divide, rigged to avoid the peephole optimiser. tryeq_sloppy $T++, "20." / "5.", 4; tryeq $T++, 2.5 / 2, 1.25; tryeq $T++, 3.5 / -2, -1.75; tryeq $T++, -4.5 / 2, -2.25; tryeq $T++, -5.5 / -2, 2.75; # Bluuurg if your floating point can't accurately cope with powers of 2 # [I suspect this is parsing string->float problems, not actual arith] tryeq_sloppy $T++, 18446744073709551616/1, 18446744073709551616; # Bluuurg tryeq_sloppy $T++, 18446744073709551616/2, 9223372036854775808; tryeq_sloppy $T++, 18446744073709551616/4294967296, 4294967296; tryeq_sloppy $T++, 18446744073709551616/9223372036854775808, 2; { # The peephole optimiser is wrong to think that it can substitute intops # in place of regular ops, because i_multiply can overflow. # Bug reported by "Sisyphus" my $n = 1127; my $float = ($n % 1000) * 167772160.0; tryeq_sloppy $T++, $float, 21307064320; # On a 32 bit machine, if the i_multiply op is used, you will probably get # -167772160. It's actually undefined behaviour, so anything may happen. my $int = ($n % 1000) * 167772160; tryeq $T++, $int, 21307064320; my $t = time; my $t1000 = time() * 1000; try $T++, abs($t1000 -1000 * $t) <= 2000; } my $vms_no_ieee; if ($^O eq 'VMS') { use vars '%Config'; eval {require Config; import Config}; $vms_no_ieee = 1 unless defined($Config{useieee}); } if ($^O eq 'vos') { print "not ok ", $T++, " # TODO VOS raises SIGFPE instead of producing infinity.\n"; } elsif ($vms_no_ieee) { print $T++, " # SKIP -- the IEEE infinity model is unavailable in this configuration.\n" } elsif ($^O eq 'ultrix') { print "not ok ", $T++, " # TODO Ultrix enters deep nirvana instead of producing infinity.\n"; } else { # The computation of $v should overflow and produce "infinity" # on any system whose max exponent is less than 10**1506. # The exact string used to represent infinity varies by OS, # so we don't test for it; all we care is that we don't die. # # Perl considers it to be an error if SIGFPE is raised. # Chances are the interpreter will die, since it doesn't set # up a handler for SIGFPE. That's why this test is last; to # minimize the number of test failures. --PG my $n = 5000; my $v = 2; while (--$n) { $v *= 2; } print "ok ", $T++, "\n"; } perl-5.12.0-RC0/t/op/index.t0000555000175000017500000001237111325127001014301 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } use strict; plan( tests => 111 ); run_tests() unless caller; sub run_tests { my $foo = 'Now is the time for all good men to come to the aid of their country.'; my $first = substr($foo,0,index($foo,'the')); is($first, "Now is "); my $last = substr($foo,rindex($foo,'the'),100); is($last, "their country."); $last = substr($foo,index($foo,'Now'),2); is($last, "No"); $last = substr($foo,rindex($foo,'Now'),2); is($last, "No"); $last = substr($foo,index($foo,'.'),100); is($last, "."); $last = substr($foo,rindex($foo,'.'),100); is($last, "."); is(index("ababa","a",-1), 0); is(index("ababa","a",0), 0); is(index("ababa","a",1), 2); is(index("ababa","a",2), 2); is(index("ababa","a",3), 4); is(index("ababa","a",4), 4); is(index("ababa","a",5), -1); is(rindex("ababa","a",-1), -1); is(rindex("ababa","a",0), 0); is(rindex("ababa","a",1), 0); is(rindex("ababa","a",2), 2); is(rindex("ababa","a",3), 2); is(rindex("ababa","a",4), 4); is(rindex("ababa","a",5), 4); # tests for empty search string is(index("abc", "", -1), 0); is(index("abc", "", 0), 0); is(index("abc", "", 1), 1); is(index("abc", "", 2), 2); is(index("abc", "", 3), 3); is(index("abc", "", 4), 3); is(rindex("abc", "", -1), 0); is(rindex("abc", "", 0), 0); is(rindex("abc", "", 1), 1); is(rindex("abc", "", 2), 2); is(rindex("abc", "", 3), 3); is(rindex("abc", "", 4), 3); $a = "foo \x{1234}bar"; is(index($a, "\x{1234}"), 4); is(index($a, "bar", ), 5); is(rindex($a, "\x{1234}"), 4); is(rindex($a, "foo", ), 0); { my $needle = "\x{1230}\x{1270}"; my @needles = split ( //, $needle ); my $haystack = "\x{1228}\x{1228}\x{1230}\x{1270}"; foreach ( @needles ) { my $a = index ( "\x{1228}\x{1228}\x{1230}\x{1270}", $_ ); my $b = index ( $haystack, $_ ); is($a, $b, q{[perl #22375] 'split'/'index' problem for utf8}); } $needle = "\x{1270}\x{1230}"; # Transpose them. @needles = split ( //, $needle ); foreach ( @needles ) { my $a = index ( "\x{1228}\x{1228}\x{1230}\x{1270}", $_ ); my $b = index ( $haystack, $_ ); is($a, $b, q{[perl #22375] 'split'/'index' problem for utf8}); } } { my $search; my $text; if (ord('A') == 193) { $search = "foo \x71 bar"; $text = "a\xb1\xb1a $search $search quux"; } else { $search = "foo \xc9 bar"; $text = "a\xa3\xa3a $search $search quux"; } my $text_utf8 = $text; utf8::upgrade($text_utf8); my $search_utf8 = $search; utf8::upgrade($search_utf8); is (index($text, $search), 5); is (rindex($text, $search), 18); is (index($text, $search_utf8), 5); is (rindex($text, $search_utf8), 18); is (index($text_utf8, $search), 5); is (rindex($text_utf8, $search), 18); is (index($text_utf8, $search_utf8), 5); is (rindex($text_utf8, $search_utf8), 18); my $text_octets = $text_utf8; utf8::encode ($text_octets); my $search_octets = $search_utf8; utf8::encode ($search_octets); is (index($text_octets, $search_octets), 7, "index octets, octets") or _diag ($text_octets, $search_octets); is (rindex($text_octets, $search_octets), 21, "rindex octets, octets"); is (index($text_octets, $search_utf8), -1); is (rindex($text_octets, $search_utf8), -1); is (index($text_utf8, $search_octets), -1); is (rindex($text_utf8, $search_octets), -1); is (index($text_octets, $search), -1); is (rindex($text_octets, $search), -1); is (index($text, $search_octets), -1); is (rindex($text, $search_octets), -1); } foreach my $utf8 ('', ', utf-8') { foreach my $arraybase (0, 1, -1, -2) { my $expect_pos = 2 + $arraybase; my $prog = "no warnings 'deprecated';\n"; $prog .= "\$[ = $arraybase; \$big = \"N\\xabN\\xab\"; "; $prog .= '$big .= chr 256; chop $big; ' if $utf8; $prog .= 'print rindex $big, "N", 2 + $['; fresh_perl_is($prog, $expect_pos, {}, "\$[ = $arraybase$utf8"); } } SKIP: { skip "UTF-EBCDIC is limited to 0x7fffffff", 3 if ord("A") == 193; my $a = "\x{80000000}"; my $s = $a.'defxyz'; is(index($s, 'def'), 1, "0x80000000 is a single character"); my $b = "\x{fffffffd}"; my $t = $b.'pqrxyz'; is(index($t, 'pqr'), 1, "0xfffffffd is a single character"); local ${^UTF8CACHE} = -1; is(index($t, 'xyz'), 4, "0xfffffffd and utf8cache"); } # Tests for NUL characters. { my @tests = ( ["", -1, -1, -1], ["foo", -1, -1, -1], ["\0", 0, -1, -1], ["\0\0", 0, 0, -1], ["\0\0\0", 0, 0, 0], ["foo\0", 3, -1, -1], ["foo\0foo\0\0", 3, 7, -1], ); foreach my $l (1 .. 3) { my $q = "\0" x $l; my $i = 0; foreach my $test (@tests) { $i ++; my $str = $$test [0]; my $res = $$test [$l]; { is (index ($str, $q), $res, "Find NUL character(s)"); } # # Bug #53746 shows a difference between variables and literals, # so test literals as well. # my $test_str = qq {is (index ("$str", "$q"), $res, } . qq {"Find NUL character(s)")}; $test_str =~ s/\0/\\0/g; eval $test_str; die $@ if $@; } } } } perl-5.12.0-RC0/t/op/studytied.t0000555000175000017500000000245611325127002015214 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } use strict; use warnings; plan tests => 14; { package J; my $c = 0; sub reset { $c = 0 } sub TIESCALAR { bless [] } sub FETCH { $c++ ? "next" : "first" } } # This test makes sure that we can't pull a fast one on study(). If we # study() a tied variable, perl should know that the studying isn't # valid on subsequent references, and should account for it. for my $do_study qw( 0 1 ) { J::reset(); my $x; tie $x, "J"; if ($do_study) { study $x; pass( "Studying..." ); } else { my $first_fetch = $x; pass( "Not studying..." ); } # When it was studied (or first_fetched), $x was "first", but is now "next", so # should not match /f/. ok( $x !~ /f/, qq{"next" doesn't match /f/} ); is( index( $x, 'f' ), -1, qq{"next" doesn't contain "f"} ); # Subsequent references to $x are "next", so should match /n/ ok( $x =~ /n/, qq{"next" matches /n/} ); is( index( $x, 'n' ), 0, qq{"next" contains "n" at pos 0} ); # The letter "t" is in both, but in different positions ok( $x =~ /t/, qq{"next" matches /t/} ); is( index( $x, 't' ), 3, qq{"next" contains "t" at pos 3} ); } perl-5.12.0-RC0/t/op/sselect.t0000555000175000017500000000173611325127001014637 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = ('.', '../lib'); } require 'test.pl'; plan (11); my $blank = ""; eval {select undef, $blank, $blank, 0}; is ($@, ""); eval {select $blank, undef, $blank, 0}; is ($@, ""); eval {select $blank, $blank, undef, 0}; is ($@, ""); eval {select "", $blank, $blank, 0}; is ($@, ""); eval {select $blank, "", $blank, 0}; is ($@, ""); eval {select $blank, $blank, "", 0}; is ($@, ""); eval {select "a", $blank, $blank, 0}; like ($@, qr/^Modification of a read-only value attempted/); eval {select $blank, "a", $blank, 0}; like ($@, qr/^Modification of a read-only value attempted/); eval {select $blank, $blank, "a", 0}; like ($@, qr/^Modification of a read-only value attempted/); my $sleep = 3; my $t = time; select(undef, undef, undef, $sleep); ok(time-$t >= $sleep, "$sleep seconds have passed"); my $empty = ""; vec($empty,0,1) = 0; $t = time; select($empty, undef, undef, $sleep); ok(time-$t >= $sleep, "$sleep seconds have passed"); perl-5.12.0-RC0/t/op/ord.t0000555000175000017500000000476011325125742013773 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = qw(. ../lib); # ../lib needed for test.deparse require "test.pl"; } plan tests => 35; # compile time evaluation # 'A' 65 ASCII # 'A' 193 EBCDIC ok(ord('A') == 65 || ord('A') == 193, "ord('A') is ".ord('A')); is(ord(chr(500)), 500, "compile time chr 500"); # run time evaluation $x = 'ABC'; ok(ord($x) == 65 || ord($x) == 193, "ord('$x') is ".ord($x)); ok(chr 65 eq 'A' || chr 193 eq 'A', "chr can produce 'A'"); $x = 500; is(ord(chr($x)), $x, "runtime chr $x"); is(ord("\x{1234}"), 0x1234, 'compile time ord \x{....}'); $x = "\x{1234}"; is(ord($x), 0x1234, 'runtime ord \x{....}'); { no warnings 'utf8'; # avoid Unicode warnings # The following code points are some interesting steps. is(ord(chr( 0x100)), 0x100, '0x0100'); is(ord(chr( 0x3FF)), 0x3FF, 'last two-byte char in UTF-EBCDIC'); is(ord(chr( 0x400)), 0x400, 'first three-byte char in UTF-EBCDIC'); is(ord(chr( 0x7FF)), 0x7FF, 'last two-byte char in UTF-8'); is(ord(chr( 0x800)), 0x800, 'first three-byte char in UTF-8'); is(ord(chr( 0xFFF)), 0xFFF, '0x0FFF'); is(ord(chr( 0x1000)), 0x1000, '0x1000'); is(ord(chr( 0x3FFF)), 0x3FFF, 'last three-byte char in UTF-EBCDIC'); is(ord(chr( 0x4000)), 0x4000, 'first four-byte char in UTF-EBCDIC'); is(ord(chr( 0xCFFF)), 0xCFFF, '0xCFFF'); is(ord(chr( 0xD000)), 0xD000, '0xD000'); is(ord(chr( 0xD7FF)), 0xD7FF, '0xD7FF'); is(ord(chr( 0xD800)), 0xD800, 'surrogate begin (not strict utf-8)'); is(ord(chr( 0xDFFF)), 0xDFFF, 'surrogate end (not strict utf-8)'); is(ord(chr( 0xE000)), 0xE000, '0xE000'); is(ord(chr( 0xFDD0)), 0xFDD0, 'first additional noncharacter in BMP'); is(ord(chr( 0xFDEF)), 0xFDEF, 'last additional noncharacter in BMP'); is(ord(chr( 0xFFFE)), 0xFFFE, '0xFFFE'); is(ord(chr( 0xFFFF)), 0xFFFF, 'last three-byte char in UTF-8'); is(ord(chr( 0x10000)), 0x10000, 'first four-byte char in UTF-8'); is(ord(chr( 0x3FFFF)), 0x3FFFF, 'last four-byte char in UTF-EBCDIC'); is(ord(chr( 0x40000)), 0x40000, 'first five-byte char in UTF-EBCDIC'); is(ord(chr( 0xFFFFF)), 0xFFFFF, '0xFFFFF'); is(ord(chr(0x100000)), 0x100000, '0x100000'); is(ord(chr(0x10FFFF)), 0x10FFFF, 'Unicode last code point'); is(ord(chr(0x110000)), 0x110000, '0x110000'); is(ord(chr(0x1FFFFF)), 0x1FFFFF, 'last four-byte char in UTF-8'); is(ord(chr(0x200000)), 0x200000, 'first five-byte char in UTF-8'); } perl-5.12.0-RC0/t/op/context.t0000555000175000017500000000062411325125742014666 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = qw(. ../lib); } require "test.pl"; plan( tests => 7 ); sub foo { $a='abcd'; $a=~/(.)/g; cmp_ok($1,'eq','a','context ' . curr_test()); } $a=foo; @a=foo; foo; foo(foo); my $before = curr_test(); $h{foo} = foo; my $after = curr_test(); cmp_ok($after-$before,'==',1,'foo called once') or diag("nr tests: before=$before, after=$after"); perl-5.12.0-RC0/t/op/blocks.t0000555000175000017500000000402111325125742014452 0ustar jessejesse#!./perl BEGIN { chdir 't'; @INC = '../lib'; require './test.pl'; } plan tests => 3; my @expect = qw( b1 b2 b3 b4 b6 u5 b7 u6 u1 c3 c2 c1 i1 i2 b5 u2 u3 u4 e2 e1 ); my $expect = ":" . join(":", @expect); fresh_perl_is(<<'SCRIPT', $expect,{switches => [''], stdin => '', stderr => 1 },'Order of execution of special blocks'); BEGIN {print ":b1"} END {print ":e1"} BEGIN {print ":b2"} { BEGIN {BEGIN {print ":b3"}; print ":b4"} } CHECK {print ":c1"} INIT {print ":i1"} UNITCHECK {print ":u1"} eval 'BEGIN {print ":b5"}'; eval 'UNITCHECK {print ":u2"}'; eval 'UNITCHECK {print ":u3"; UNITCHECK {print ":u4"}}'; "a" =~ /(?{UNITCHECK {print ":u5"}; CHECK {print ":c2"}; BEGIN {print ":b6"}})/x; eval {BEGIN {print ":b7"}}; eval {UNITCHECK {print ":u6"}}; eval {INIT {print ":i2"}}; eval {CHECK {print ":c3"}}; END {print ":e2"} SCRIPT @expect =( # BEGIN qw( main bar myfoo foo ), # UNITCHECK qw( foo myfoo bar main ), # CHECK qw( foo myfoo bar main ), # INIT qw( main bar myfoo foo ), # END qw(foo myfoo bar main )); $expect = ":" . join(":", @expect); fresh_perl_is(<<'SCRIPT2', $expect,{switches => [''], stdin => '', stderr => 1 },'blocks interact with packages/scopes'); BEGIN {$f = 'main'; print ":$f"} UNITCHECK {print ":$f"} CHECK {print ":$f"} INIT {print ":$f"} END {print ":$f"} package bar; BEGIN {$f = 'bar';print ":$f"} UNITCHECK {print ":$f"} CHECK {print ":$f"} INIT {print ":$f"} END {print ":$f"} package foo; { my $f; BEGIN {$f = 'myfoo'; print ":$f"} UNITCHECK {print ":$f"} CHECK {print ":$f"} INIT {print ":$f"} END {print ":$f"} } BEGIN {$f = "foo";print ":$f"} UNITCHECK {print ":$f"} CHECK {print ":$f"} INIT {print ":$f"} END {print ":$f"} SCRIPT2 @expect = qw(begin unitcheck check init end); $expect = ":" . join(":", @expect); fresh_perl_is(<<'SCRIPT3', $expect,{switches => [''], stdin => '', stderr => 1 },'can name blocks as sub FOO'); sub BEGIN {print ":begin"} sub UNITCHECK {print ":unitcheck"} sub CHECK {print ":check"} sub INIT {print ":init"} sub END {print ":end"} SCRIPT3 perl-5.12.0-RC0/t/op/hashwarn.t0000555000175000017500000000406611325125742015021 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = qw(. ../lib); } require 'test.pl'; plan( tests => 16 ); use strict; use warnings; use vars qw{ @warnings }; BEGIN { $SIG{'__WARN__'} = sub { push @warnings, @_ }; $| = 1; } my $fail_odd = 'Odd number of elements in hash assignment at '; my $fail_odd_anon = 'Odd number of elements in anonymous hash at '; my $fail_ref = 'Reference found where even-sized list expected at '; my $fail_not_hr = 'Not a HASH reference at '; { @warnings = (); my %hash = (1..3); cmp_ok(scalar(@warnings),'==',1,'odd count'); cmp_ok(substr($warnings[0],0,length($fail_odd)),'eq',$fail_odd,'odd msg'); @warnings = (); %hash = 1; cmp_ok(scalar(@warnings),'==',1,'scalar count'); cmp_ok(substr($warnings[0],0,length($fail_odd)),'eq',$fail_odd,'scalar msg'); @warnings = (); %hash = { 1..3 }; cmp_ok(scalar(@warnings),'==',2,'odd hashref count'); cmp_ok(substr($warnings[0],0,length($fail_odd_anon)),'eq',$fail_odd_anon,'odd hashref msg 1'); cmp_ok(substr($warnings[1],0,length($fail_ref)),'eq',$fail_ref,'odd hashref msg 2'); @warnings = (); %hash = [ 1..3 ]; cmp_ok(scalar(@warnings),'==',1,'arrayref count'); cmp_ok(substr($warnings[0],0,length($fail_ref)),'eq',$fail_ref,'arrayref msg'); @warnings = (); %hash = sub { print "fenice" }; cmp_ok(scalar(@warnings),'==',1,'coderef count'); cmp_ok(substr($warnings[0],0,length($fail_odd)),'eq',$fail_odd,'coderef msg'); @warnings = (); $_ = { 1..10 }; cmp_ok(scalar(@warnings),'==',0,'hashref assign'); # Old pseudo-hash syntax, now removed. @warnings = (); my $avhv = [{x=>1,y=>2}]; eval { %$avhv = (x=>13,'y'); }; cmp_ok(scalar(@warnings),'==',0,'pseudo-hash 1 count'); cmp_ok(substr($@,0,length($fail_not_hr)),'eq',$fail_not_hr,'pseudo-hash 1 msg'); @warnings = (); eval { %$avhv = 'x'; }; cmp_ok(scalar(@warnings),'==',0,'pseudo-hash 2 count'); cmp_ok(substr($@,0,length($fail_not_hr)),'eq',$fail_not_hr,'pseudo-hash 2 msg'); } perl-5.12.0-RC0/t/op/protowarn.t0000555000175000017500000000254511325127001015227 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = qw(. ../lib); } use strict; use warnings; BEGIN { require 'test.pl'; plan( tests => 12 ); } use vars qw{ @warnings $sub $warn }; BEGIN { $warn = 'Illegal character in prototype'; } sub one_warning_ok { cmp_ok(scalar(@warnings), '==', 1, 'One warning'); cmp_ok(substr($warnings[0],0,length($warn)),'eq',$warn,'warning message'); @warnings = (); } sub no_warnings_ok { cmp_ok(scalar(@warnings), '==', 0, 'No warnings'); @warnings = (); } BEGIN { $SIG{'__WARN__'} = sub { push @warnings, @_ }; $| = 1; } BEGIN { @warnings = () } $sub = sub (x) { }; BEGIN { one_warning_ok; } { no warnings 'syntax'; $sub = sub (x) { }; } BEGIN { no_warnings_ok; } { no warnings 'illegalproto'; $sub = sub (x) { }; } BEGIN { no_warnings_ok; } { no warnings 'syntax'; use warnings 'illegalproto'; $sub = sub (x) { }; } BEGIN { one_warning_ok; } BEGIN { $warn = q{Prototype after '@' for}; } $sub = sub (@$) { }; BEGIN { one_warning_ok; } { no warnings 'syntax'; $sub = sub (@$) { }; } BEGIN { no_warnings_ok; } { no warnings 'illegalproto'; $sub = sub (@$) { }; } BEGIN { no_warnings_ok; } { no warnings 'syntax'; use warnings 'illegalproto'; $sub = sub (@$) { }; } BEGIN { one_warning_ok; } perl-5.12.0-RC0/t/op/dbm.t0000555000175000017500000000253311325125742013745 0ustar jessejesse#!./perl BEGIN { chdir 't'; @INC = '../lib'; require './test.pl'; eval { require AnyDBM_File }; # not all places have dbm* functions skip_all("No dbm functions") if $@; } plan tests => 4; # This is [20020104.007] "coredump on dbmclose" my $filename = tempfile(); my $prog = <<'EOC'; package Foo; $filename = '@@@@'; sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = {}; bless($self,$class); my %LT; dbmopen(%LT, $filename, 0666) || die "Can't open $filename because of $!\n"; $self->{'LT'} = \%LT; return $self; } sub DESTROY { my $self = shift; dbmclose(%{$self->{'LT'}}); 1 while unlink $filename; 1 while unlink glob "$filename.*"; print "ok\n"; } package main; $test = Foo->new(); # must be package var EOC $prog =~ s/\@\@\@\@/$filename/; fresh_perl_is("require AnyDBM_File;\n$prog", 'ok', {}, 'explict require'); fresh_perl_is($prog, 'ok', {}, 'implicit require'); $prog = <<'EOC'; @INC = (); dbmopen(%LT, $filename, 0666); 1 while unlink $filename; 1 while unlink glob "$filename.*"; die "Failed to fail!"; EOC fresh_perl_like($prog, qr/No dbm on this machine/, {}, 'implicit require fails'); fresh_perl_like('delete $::{"AnyDBM_File::"}; ' . $prog, qr/No dbm on this machine/, {}, 'implicit require and no stash fails'); perl-5.12.0-RC0/t/op/exp.t0000555000175000017500000000221211325125742013771 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } plan tests => 16; # compile time evaluation $s = sqrt(2); is(substr($s,0,5), '1.414'); $s = exp(1); is(substr($s,0,7), '2.71828'); cmp_ok(exp(log(1)), '==', 1); # run time evaluation $x1 = 1; $x2 = 2; $s = sqrt($x2); is(substr($s,0,5), '1.414'); $s = exp($x1); is(substr($s,0,7), '2.71828'); cmp_ok(exp(log($x1)), '==', 1); # tests for transcendental functions my $pi = 3.1415926535897931160; my $pi_2 = 1.5707963267948965580; sub round { my $result = shift; return sprintf("%.9f", $result); } # sin() tests cmp_ok(sin(0), '==', 0.0); cmp_ok(round(sin($pi)), '==', 0.0); cmp_ok(round(sin(-1 * $pi)), '==', 0.0); cmp_ok(round(sin($pi_2)), '==', 1.0); cmp_ok(round(sin(-1 * $pi_2)), '==', -1.0); # cos() tests cmp_ok(cos(0), '==', 1.0); cmp_ok(round(cos($pi)), '==', -1.0); cmp_ok(round(cos(-1 * $pi)), '==', -1.0); cmp_ok(round(cos($pi_2)), '==', 0.0); cmp_ok(round(cos(-1 * $pi_2)), '==', 0.0); # atan2() tests were removed due to differing results from calls to # atan2() on various OS's and architectures. See perlport.pod for # more information. perl-5.12.0-RC0/t/op/stash.t0000555000175000017500000001144511333412746014331 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = qw(../lib); } BEGIN { require "./test.pl"; } plan( tests => 31 ); # Used to segfault (bug #15479) fresh_perl_like( '%:: = ""', qr/Odd number of elements in hash assignment at - line 1\./, { switches => [ '-w' ] }, 'delete $::{STDERR} and print a warning', ); # Used to segfault fresh_perl_is( 'BEGIN { $::{"X::"} = 2 }', '', { switches => [ '-w' ] }, q(Insert a non-GV in a stash, under warnings 'once'), ); { no warnings 'deprecated'; ok( !defined %oedipa::maas::, q(stashes aren't defined if not used) ); ok( !defined %{"oedipa::maas::"}, q(- work with hard refs too) ); ok( defined %tyrone::slothrop::, q(stashes are defined if seen at compile time) ); ok( defined %{"tyrone::slothrop::"}, q(- work with hard refs too) ); ok( defined %bongo::shaftsbury::, q(stashes are defined if a var is seen at compile time) ); ok( defined %{"bongo::shaftsbury::"}, q(- work with hard refs too) ); } package tyrone::slothrop; $bongo::shaftsbury::scalar = 1; package main; # Used to warn # Unbalanced string table refcount: (1) for "A::" during global destruction. # for ithreads. { local $ENV{PERL_DESTRUCT_LEVEL} = 2; fresh_perl_is( 'package A; sub a { // }; %::=""', '', '', ); } # now tests in eval ok( !eval { no warnings 'deprecated'; defined %achtfaden:: }, 'works in eval{}' ); ok( !eval q{ no warnings 'deprecated'; defined %schoenmaker:: }, 'works in eval("")' ); # now tests with strictures { use strict; no warnings 'deprecated'; ok( !defined %pig::, q(referencing a non-existent stash doesn't produce stricture errors) ); ok( !exists $pig::{bodine}, q(referencing a non-existent stash element doesn't produce stricture errors) ); } SKIP: { eval { require B; 1 } or skip "no B", 18; *b = \&B::svref_2object; my $CVf_ANON = B::CVf_ANON(); my $sub = do { package one; \&{"one"}; }; delete $one::{one}; my $gv = b($sub)->GV; isa_ok( $gv, "B::GV", "deleted stash entry leaves CV with valid GV"); is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set"); is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name"); is( eval { $gv->STASH->NAME }, "one", "...but leaves stash intact"); $sub = do { package two; \&{"two"}; }; %two:: = (); $gv = b($sub)->GV; isa_ok( $gv, "B::GV", "cleared stash leaves CV with valid GV"); is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set"); is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name"); is( eval { $gv->STASH->NAME }, "__ANON__", "...and an __ANON__ stash"); $sub = do { package three; \&{"three"}; }; undef %three::; $gv = b($sub)->GV; isa_ok( $gv, "B::GV", "undefed stash leaves CV with valid GV"); is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set"); is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name"); is( eval { $gv->STASH->NAME }, "__ANON__", "...and an __ANON__ stash"); TODO: { local $TODO = "anon CVs not accounted for yet"; my @results = split "\n", runperl( switches => [ "-MB", "-l" ], prog => q{ my $sub = do { package four; sub { 1 }; }; %four:: = (); my $gv = B::svref_2object($sub)->GV; print $gv->isa(q/B::GV/) ? q/ok/ : q/not ok/; my $st = eval { $gv->STASH->NAME }; print $st eq q/__ANON__/ ? q/ok/ : q/not ok/; my $sub = do { package five; sub { 1 }; }; undef %five::; $gv = B::svref_2object($sub)->GV; print $gv->isa(q/B::GV/) ? q/ok/ : q/not ok/; $st = eval { $gv->STASH->NAME }; print $st eq q/__ANON__/ ? q/ok/ : q/not ok/; print q/done/; }, ($^O eq 'VMS') ? (stderr => 1) : () ); ok( @results == 5 && $results[4] eq "done", "anon CVs in undefed stash don't segfault" ) or todo_skip $TODO, 4; ok( $results[0] eq "ok", "cleared stash leaves anon CV with valid GV"); ok( $results[1] eq "ok", "...and an __ANON__ stash"); ok( $results[2] eq "ok", "undefed stash leaves anon CV with valid GV"); ok( $results[3] eq "ok", "...and an __ANON__ stash"); } # [perl #58530] fresh_perl_is( 'sub foo { 1 }; use overload q/""/ => \&foo;' . 'delete $main::{foo}; bless []', "", {}, "no segfault with overload/deleted stash entry [#58530]", ); } perl-5.12.0-RC0/t/op/bless.t0000555000175000017500000000570311325125742014315 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } plan (108); sub expected { my($object, $package, $type) = @_; print "# $object $package $type\n"; is(ref($object), $package); my $r = qr/^\Q$package\E=(\w+)\(0x([0-9a-f]+)\)$/; like("$object", $r); if ("$object" =~ $r) { is($1, $type); # in 64-bit platforms hex warns for 32+ -bit values cmp_ok(do {no warnings 'portable'; hex($2)}, '==', $object); } else { fail(); fail(); } } # test blessing simple types $a1 = bless {}, "A"; expected($a1, "A", "HASH"); $b1 = bless [], "B"; expected($b1, "B", "ARRAY"); $c1 = bless \(map "$_", "test"), "C"; expected($c1, "C", "SCALAR"); our $test = "foo"; $d1 = bless \*test, "D"; expected($d1, "D", "GLOB"); $e1 = bless sub { 1 }, "E"; expected($e1, "E", "CODE"); $f1 = bless \[], "F"; expected($f1, "F", "REF"); $g1 = bless \substr("test", 1, 2), "G"; expected($g1, "G", "LVALUE"); # blessing ref to object doesn't modify object expected(bless(\$a1, "F"), "F", "REF"); expected($a1, "A", "HASH"); # reblessing does modify object bless $a1, "A2"; expected($a1, "A2", "HASH"); # local and my { local $a1 = bless $a1, "A3"; # should rebless outer $a1 local $b1 = bless [], "B3"; my $c1 = bless $c1, "C3"; # should rebless outer $c1 our $test2 = ""; my $d1 = bless \*test2, "D3"; expected($a1, "A3", "HASH"); expected($b1, "B3", "ARRAY"); expected($c1, "C3", "SCALAR"); expected($d1, "D3", "GLOB"); } expected($a1, "A3", "HASH"); expected($b1, "B", "ARRAY"); expected($c1, "C3", "SCALAR"); expected($d1, "D", "GLOB"); # class is magic "E" =~ /(.)/; expected(bless({}, $1), "E", "HASH"); { local $! = 1; my $string = "$!"; $! = 2; # attempt to avoid cached string $! = 1; expected(bless({}, $!), $string, "HASH"); # ref is ref to magic { { package F; sub test { main::is(${$_[0]}, $string) } } $! = 2; $f1 = bless \$!, "F"; $! = 1; $f1->test; } } # ref is magic ### example of magic variable that is a reference?? # no class, or empty string (with a warning), or undef (with two) expected(bless([]), 'main', "ARRAY"); { local $SIG{__WARN__} = sub { push @w, join '', @_ }; use warnings; $m = bless []; expected($m, 'main', "ARRAY"); is (scalar @w, 0); @w = (); $m = bless [], ''; expected($m, 'main', "ARRAY"); is (scalar @w, 1); @w = (); $m = bless [], undef; expected($m, 'main', "ARRAY"); is (scalar @w, 2); } # class is a ref $a1 = bless {}, "A4"; $b1 = eval { bless {}, $a1 }; isnt ($@, '', "class is a ref"); # class is an overloaded ref { package H4; use overload '""' => sub { "C4" }; } $h1 = bless {}, "H4"; $c4 = eval { bless \$test, $h1 }; is ($@, '', "class is an overloaded ref"); expected($c4, 'C4', "SCALAR"); { my %h = 1..2; my($k) = keys %h; my $x=\$k; bless $x, 'pam'; is(ref $x, 'pam'); my $a = bless \(keys %h), 'zap'; is(ref $a, 'zap'); } perl-5.12.0-RC0/t/op/args.t0000555000175000017500000000347611325125742014146 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } require './test.pl'; plan( tests => 23 ); # test various operations on @_ sub new1 { bless \@_ } { my $x = new1("x"); my $y = new1("y"); is("@$y","y"); is("@$x","x"); } sub new2 { splice @_, 0, 0, "a", "b", "c"; return \@_ } { my $x = new2("x"); my $y = new2("y"); is("@$x","a b c x"); is("@$y","a b c y"); } sub new3 { goto &new1 } { my $x = new3("x"); my $y = new3("y"); is("@$y","y"); is("@$x","x"); } sub new4 { goto &new2 } { my $x = new4("x"); my $y = new4("y"); is("@$x","a b c x"); is("@$y","a b c y"); } # see if POPSUB gets to see the right pad across a dounwind() with # a reified @_ sub methimpl { my $refarg = \@_; die( "got: @_\n" ); } sub method { &methimpl; } sub try { eval { method('foo', 'bar'); }; print "# $@" if $@; } for (1..5) { try() } pass(); # bug #21542 local $_[0] causes reify problems and coredumps sub local1 { local $_[0] } my $foo = 'foo'; local1($foo); local1($foo); print "got [$foo], expected [foo]\nnot " if $foo ne 'foo'; pass(); sub local2 { local $_[0]; last L } L: { local2 } pass(); # the following test for local(@_) used to be in t/op/nothr5005.t (because it # failed with 5005threads) $|=1; sub foo { local(@_) = ('p', 'q', 'r'); } sub bar { unshift @_, 'D'; @_ } sub baz { push @_, 'E'; return @_ } for (1..3) { is(join('',foo('a', 'b', 'c')),'pqr'); is(join('',bar('d')),'Dd'); is(join('',baz('e')),'eE'); } # [perl #28032] delete $_[0] was freeing things too early { my $flag = 0; sub X::DESTROY { $flag = 1 } sub f { delete $_[0]; ok(!$flag, 'delete $_[0] : in f'); } { my $x = bless [], 'X'; f($x); ok(!$flag, 'delete $_[0] : after f'); } ok($flag, 'delete $_[0] : outside block'); } perl-5.12.0-RC0/t/op/pwent.t0000555000175000017500000001506011325125742014337 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; eval {my @n = getpwuid 0; setpwent()}; if ($@ && $@ =~ /(The \w+ function is unimplemented)/) { print "1..0 # Skip: $1\n"; exit 0; } eval { require Config; import Config; }; my $reason; if ($Config{'i_pwd'} ne 'define') { $reason = '$Config{i_pwd} undefined'; } elsif (not -f "/etc/passwd" ) { # Play safe. $reason = 'no /etc/passwd file'; } if (not defined $where) { # Try NIS. foreach my $ypcat (qw(/usr/bin/ypcat /bin/ypcat /etc/ypcat)) { if (-x $ypcat && open(PW, "$ypcat passwd 2>/dev/null |") && defined()) { $where = "NIS passwd"; undef $reason; last; } } } if (not defined $where) { # Try NetInfo. foreach my $nidump (qw(/usr/bin/nidump)) { if (-x $nidump && open(PW, "$nidump passwd . 2>/dev/null |") && defined()) { $where = "NetInfo passwd"; undef $reason; last; } } } if (not defined $where && # Try dscl $Config{useperlio} eq 'define') { # need perlio # Map dscl items to passwd fields, and provide support for # mucking with the dscl output if we need to (and we do). my %want = do { my $inx = 0; map {$_ => {inx => $inx++, mung => sub {$_[0]}}} qw{RecordName Password UniqueID PrimaryGroupID RealName NFSHomeDirectory UserShell}; }; # The RecordName for a /User record is the username. In some # cases there are synonyms (e.g. _www and www), in which case we # get a blank-delimited list. We prefer the first entry in the # list because getpwnam() does. $want{RecordName}{mung} = sub {(split '\s+', $_[0], 2)[0]}; # The UniqueID and PrimaryGroupID for a /User record are the # user ID and the primary group ID respectively. In cases where # the high bit is set, 'dscl' returns a negative number, whereas # getpwnam() returns its twos complement. This mungs the dscl # output to agree with what getpwnam() produces. Interestingly # enough, getpwuid(-2) returns the right record ('nobody'), even # though it returns the uid as 4294967294. If you track uid_t # on an i386, you find it is an unsigned int, which makes the # unsigned version the right one; but both /etc/passwd and # /etc/master.passwd contain negative numbers. $want{UniqueID}{mung} = $want{PrimaryGroupID}{mung} = sub { unpack 'L', pack 'l', $_[0]}; foreach my $dscl (qw(/usr/bin/dscl)) { -x $dscl or next; open (my $fh, '-|', join (' ', $dscl, qw{. -readall /Users}, keys %want, '2>/dev/null')) or next; my $data; my @rec; while (<$fh>) { chomp; if ($_ eq '-') { @rec and $data .= join (':', @rec) . "\n"; @rec = (); next; } my ($name, $value) = split ':\s+', $_, 2; unless (defined $value) { s/:$//; $name = $_; $value = <$fh>; chomp $value; $value =~ s/^\s+//; } if (defined (my $info = $want{$name})) { $rec[$info->{inx}] = $info->{mung}->($value); } } @rec and $data .= join (':', @rec) . "\n"; if (open (PW, '<', \$data)) { $where = "dscl . -readall /Users"; undef $reason; last; } } } if (not defined $where) { # Try local. my $PW = "/etc/passwd"; if (-f $PW && open(PW, $PW) && defined()) { $where = $PW; undef $reason; } } if (not defined $where) { # Try NIS+ foreach my $niscat (qw(/bin/niscat)) { if (-x $niscat && open(PW, "$niscat passwd.org_dir 2>/dev/null |") && defined()) { $where = "NIS+ $niscat passwd.org_dir"; undef $reason; last; } } } if ($reason) { # Give up. print "1..0 # Skip: $reason\n"; exit 0; } } # By now the PW filehandle should be open and full of juicy password entries. print "1..2\n"; # Go through at most this many users. # (note that the first entry has been read away by now) my $max = 25; my $n = 0; my $tst = 1; my %perfect; my %seen; print "# where $where\n"; setpwent(); while () { chomp; # LIMIT -1 so that users with empty shells don't fall off my @s = split /:/, $_, -1; my ($name_s, $passwd_s, $uid_s, $gid_s, $gcos_s, $home_s, $shell_s); (my $v) = $Config{osvers} =~ /^(\d+)/; if ($^O eq 'darwin' && $v < 9) { ($name_s, $passwd_s, $uid_s, $gid_s, $gcos_s, $home_s, $shell_s) = @s[0,1,2,3,7,8,9]; } else { ($name_s, $passwd_s, $uid_s, $gid_s, $gcos_s, $home_s, $shell_s) = @s; } next if /^\+/; # ignore NIS includes if (@s) { push @{ $seen{$name_s} }, $.; } else { warn "# Your $where line $. is empty.\n"; next; } if ($n == $max) { local $/; my $junk = ; last; } # In principle we could whine if @s != 7 but do we know enough # of passwd file formats everywhere? if (@s == 7 || ($^O eq 'darwin' && @s == 10)) { @n = getpwuid($uid_s); # 'nobody' et al. next unless @n; my ($name,$passwd,$uid,$gid,$quota,$comment,$gcos,$home,$shell) = @n; # Protect against one-to-many and many-to-one mappings. if ($name_s ne $name) { @n = getpwnam($name_s); ($name,$passwd,$uid,$gid,$quota,$comment,$gcos,$home,$shell) = @n; next if $name_s ne $name; } $perfect{$name_s}++ if $name eq $name_s and $uid eq $uid_s and # Do not compare passwords: think shadow passwords. $gid eq $gid_s and $gcos eq $gcos_s and $home eq $home_s and $shell eq $shell_s; } $n++; } endpwent(); print "# max = $max, n = $n, perfect = ", scalar keys %perfect, "\n"; if (keys %perfect == 0 && $n) { $max++; print < 4); } } # Can't assume too much about the string returned by crypt(), # and about how many bytes of the encrypted (really, hashed) # string matter. # # HISTORICALLY the results started with the first two bytes of the salt, # followed by 11 bytes from the set [./0-9A-Za-z], and only the first # eight characters mattered, but those are probably no more safe # bets, given alternative encryption/hashing schemes like MD5, # C2 (or higher) security schemes, and non-UNIX platforms. SKIP: { skip ("VOS crypt ignores salt.", 1) if ($^O eq 'vos'); ok(substr(crypt("ab", "cd"), 2) ne substr(crypt("ab", "ce"), 2), "salt makes a difference"); } $a = "a\xFF\x{100}"; eval {$b = crypt($a, "cd")}; like($@, qr/Wide character in crypt/, "wide characters ungood"); chop $a; # throw away the wide character eval {$b = crypt($a, "cd")}; is($@, '', "downgrade to eight bit characters"); is($b, crypt("a\xFF", "cd"), "downgrade results agree"); perl-5.12.0-RC0/t/op/or.t0000555000175000017500000000165611143650501013622 0ustar jessejesse#!./perl # Test || in weird situations. BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } package Countdown; sub TIESCALAR { my $class = shift; my $instance = shift || undef; return bless \$instance => $class; } sub FETCH { print "# FETCH! ${$_[0]}\n"; return ${$_[0]}--; } package main; require './test.pl'; plan( tests => 8 ); my ($a, $b, $c); $! = 1; $a = $!; my $a_str = sprintf "%s", $a; my $a_num = sprintf "%d", $a; $c = $a || $b; is($c, $a_str); is($c+0, $a_num); # force numeric context. $a =~ /./g or die "Match failed for some reason"; # Make $a magic $c = $a || $b; is($c, $a_str); is($c+0, $a_num); # force numeric context. my $val = 3; $c = $val || $b; is($c, 3); tie $a, 'Countdown', $val; $c = $a; is($c, 3, 'Single FETCH on tied scalar'); $c = $a; is($c, 2, ' $tied = $var'); $c = $a || $b; { local $TODO = 'Double FETCH'; is($c, 1, ' $tied || $var'); } perl-5.12.0-RC0/t/op/tiehandle.t0000555000175000017500000001214411325125742015137 0ustar jessejesse#!./perl -w BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } my @expect; my $data = ""; my @data = (); require './test.pl'; plan(tests => 63); sub compare { local $Level = $Level + 1; return unless @expect; return ::fail() unless(@_ == @expect); for my $i (0..$#_) { next if $_[$i] eq $expect[$i]; return ::fail(); } ::pass(); } package Implement; sub TIEHANDLE { ::compare(TIEHANDLE => @_); my ($class,@val) = @_; return bless \@val,$class; } sub PRINT { ::compare(PRINT => @_); 1; } sub PRINTF { ::compare(PRINTF => @_); 2; } sub READLINE { ::compare(READLINE => @_); wantarray ? @data : shift @data; } sub GETC { ::compare(GETC => @_); substr($data,0,1); } sub READ { ::compare(READ => @_); substr($_[1],$_[3] || 0) = substr($data,0,$_[2]); 3; } sub EOF { ::compare(EOF => @_); @data ? '' : 1; } sub WRITE { ::compare(WRITE => @_); $data = substr($_[1],$_[3] || 0, $_[2]); length($data); } sub CLOSE { ::compare(CLOSE => @_); 5; } package main; use Symbol; my $fh = gensym; @expect = (TIEHANDLE => 'Implement'); my $ob = tie *$fh,'Implement'; is(ref($ob), 'Implement'); is(tied(*$fh), $ob); @expect = (PRINT => $ob,"some","text"); $r = print $fh @expect[2,3]; is($r, 1); @expect = (PRINTF => $ob,"%s","text"); $r = printf $fh @expect[2,3]; is($r, 2); @data = ("the line\n"); @expect = (EOF => $ob, 1); is(eof($fh), ''); $text = $data[0]; @expect = (READLINE => $ob); $ln = <$fh>; is($ln, $text); @expect = (EOF => $ob, 0); is(eof, 1); @expect = (); @in = @data = qw(a line at a time); @line = <$fh>; @expect = @in; compare(@line); @expect = (GETC => $ob); $data = "abc"; $ch = getc $fh; is($ch, "a"); $buf = "xyz"; @expect = (READ => $ob, $buf, 3); $data = "abc"; $r = read $fh,$buf,3; is($r, 3); is($buf, "abc"); $buf = "xyzasd"; @expect = (READ => $ob, $buf, 3,3); $data = "abc"; $r = sysread $fh,$buf,3,3; is($r, 3); is($buf, "xyzabc"); $buf = "qwerty"; @expect = (WRITE => $ob, $buf, 4,1); $data = ""; $r = syswrite $fh,$buf,4,1; is($r, 4); is($data, "wert"); $buf = "qwerty"; @expect = (WRITE => $ob, $buf, 4); $data = ""; $r = syswrite $fh,$buf,4; is($r, 4); is($data, "qwer"); $buf = "qwerty"; @expect = (WRITE => $ob, $buf, 6); $data = ""; $r = syswrite $fh,$buf; is($r, 6); is($data, "qwerty"); @expect = (CLOSE => $ob); $r = close $fh; is($r, 5); # Does aliasing work with tied FHs? *ALIAS = *$fh; @expect = (PRINT => $ob,"some","text"); $r = print ALIAS @expect[2,3]; is($r, 1); { use warnings; # Special case of aliasing STDERR, which used # to dump core when warnings were enabled local *STDERR = *$fh; @expect = (PRINT => $ob,"some","text"); $r = print STDERR @expect[2,3]; is($r, 1); } { package Bar::Say; use feature 'say'; use base qw(Implement); my $ors; sub PRINT { $ors = $\; my $self = shift; return $self->SUPER::PRINT(@_); } my $fh = Symbol::gensym; @expect = (TIEHANDLE => 'Bar::Say'); ::ok( my $obj = tie *$fh, 'Bar::Say' ); local $\ = 'something'; @expect = (PRINT => $obj, "stuff", "and", "things"); ::ok( print $fh @expect[2..4] ); ::is( $ors, 'something' ); ::ok( say $fh @expect[2..4] ); ::is( $ors, "\n", 'say sets $\ to \n in PRINT' ); ::is( $\, "something", " and it's localized" ); } { # Test for change #11536 package Foo; use strict; sub TIEHANDLE { bless {} } my $cnt = 'a'; sub READ { $_[1] = $cnt++; 1; } sub do_read { my $fh = shift; read $fh, my $buff, 1; ::pass(); } $|=1; tie *STDIN, 'Foo'; read STDIN, my $buff, 1; ::pass(); do_read(\*STDIN); untie *STDIN; } { # test for change 11639: Can't localize *FH, then tie it { local *foo; tie %foo, 'Blah'; } ok(!tied %foo); { local *bar; tie @bar, 'Blah'; } ok(!tied @bar); { local *BAZ; tie *BAZ, 'Blah'; } ok(!tied *BAZ); package Blah; sub TIEHANDLE {bless {}} sub TIEHASH {bless {}} sub TIEARRAY {bless {}} } { # warnings should pass to the PRINT method of tied STDERR my @received; local *STDERR = *$fh; no warnings 'redefine'; local *Implement::PRINT = sub { @received = @_ }; $r = warn("some", "text", "\n"); @expect = (PRINT => $ob,"sometext\n"); compare(PRINT => @received); use warnings; print undef; like($received[1], qr/Use of uninitialized value/); } { # [ID 20020713.001] chomp($data=) local *TEST; tie *TEST, 'CHOMP'; my $data; chomp($data = ); is($data, 'foobar'); package CHOMP; sub TIEHANDLE { bless {}, $_[0] } sub READLINE { "foobar\n" } } { # make sure the new eof() features work with @ARGV magic local *ARGV; @ARGV = ('haha'); @expect = (TIEHANDLE => 'Implement'); $ob = tie *ARGV, 'Implement'; is(ref($ob), 'Implement'); is(tied(*ARGV), $ob); @data = ("stuff\n"); @expect = (EOF => $ob, 1); is(eof(ARGV), ''); @expect = (EOF => $ob, 2); is(eof(), ''); shift @data; @expect = (EOF => $ob, 0); is(eof, 1); } perl-5.12.0-RC0/t/op/attrs.t0000555000175000017500000001515611325127001014333 0ustar jessejesse#!./perl # Regression tests for attributes.pm and the C< : attrs> syntax. BEGIN { if ($ENV{PERL_CORE_MINITEST}) { print "1..0 # skip: miniperl can't load attributes\n"; exit 0; } chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } use warnings; plan 92; $SIG{__WARN__} = sub { die @_ }; sub eval_ok ($;$) { eval shift; is( $@, '', @_); } our $anon1; eval_ok '$anon1 = sub : method { $_[0]++ }'; eval 'sub e1 ($) : plugh ;'; like $@, qr/^Invalid CODE attributes?: ["']?plugh["']? at/; eval 'sub e2 ($) : plugh(0,0) xyzzy ;'; like $@, qr/^Invalid CODE attributes: ["']?plugh\(0,0\)["']? /; eval 'sub e3 ($) : plugh(0,0 xyzzy ;'; like $@, qr/Unterminated attribute parameter in attribute list at/; eval 'sub e4 ($) : plugh + xyzzy ;'; like $@, qr/Invalid separator character '[+]' in attribute list at/; eval_ok 'my main $x : = 0;'; eval_ok 'my $x : = 0;'; eval_ok 'my $x ;'; eval_ok 'my ($x) : = 0;'; eval_ok 'my ($x) ;'; eval_ok 'my ($x) : ;'; eval_ok 'my ($x,$y) : = 0;'; eval_ok 'my ($x,$y) ;'; eval_ok 'my ($x,$y) : ;'; eval 'my ($x,$y) : plugh;'; like $@, qr/^Invalid SCALAR attribute: ["']?plugh["']? at/; # bug #16080 eval '{my $x : plugh}'; like $@, qr/^Invalid SCALAR attribute: ["']?plugh["']? at/; eval '{my ($x,$y) : plugh(})}'; like $@, qr/^Invalid SCALAR attribute: ["']?plugh\(}\)["']? at/; # More syntax tests from the attributes manpage eval 'my $x : switch(10,foo(7,3)) : expensive;'; like $@, qr/^Invalid SCALAR attributes: ["']?switch\(10,foo\(7,3\)\) : expensive["']? at/; eval q/my $x : Ugly('\(") :Bad;/; like $@, qr/^Invalid SCALAR attributes: ["']?Ugly\('\\\("\) : Bad["']? at/; eval 'my $x : _5x5;'; like $@, qr/^Invalid SCALAR attribute: ["']?_5x5["']? at/; eval 'my $x : locked method;'; like $@, qr/^Invalid SCALAR attributes: ["']?locked : method["']? at/; eval 'my $x : switch(10,foo();'; like $@, qr/^Unterminated attribute parameter in attribute list at/; eval q/my $x : Ugly('(');/; like $@, qr/^Unterminated attribute parameter in attribute list at/; eval 'my $x : 5x5;'; like $@, qr/error/; eval 'my $x : Y2::north;'; like $@, qr/Invalid separator character ':' in attribute list at/; sub A::MODIFY_SCALAR_ATTRIBUTES { return } eval 'my A $x : plugh;'; like $@, qr/^SCALAR package attribute may clash with future reserved word: ["']?plugh["']? at/; eval 'my A $x : plugh plover;'; like $@, qr/^SCALAR package attributes may clash with future reserved words: ["']?plugh["']? /; no warnings 'reserved'; eval 'my A $x : plugh;'; is $@, ''; eval 'package Cat; my Cat @socks;'; like $@, ''; eval 'my Cat %nap;'; like $@, ''; sub X::MODIFY_CODE_ATTRIBUTES { die "$_[0]" } sub X::foo { 1 } *Y::bar = \&X::foo; *Y::bar = \&X::foo; # second time for -w eval 'package Z; sub Y::bar : foo'; like $@, qr/^X at /; @attrs = eval 'attributes::get $anon1'; is "@attrs", "method"; sub Z::DESTROY { } sub Z::FETCH_CODE_ATTRIBUTES { return 'Z' } my $thunk = eval 'bless +sub : method { 1 }, "Z"'; is ref($thunk), "Z"; @attrs = eval 'attributes::get $thunk'; is "@attrs", "method Z"; # Test attributes on predeclared subroutines: eval 'package A; sub PS : lvalue'; @attrs = eval 'attributes::get \&A::PS'; is "@attrs", "lvalue"; # Test attributes on predeclared subroutines, after definition eval 'package A; sub PS : lvalue; sub PS { }'; @attrs = eval 'attributes::get \&A::PS'; is "@attrs", "lvalue"; # Test ability to modify existing sub's (or XSUB's) attributes. eval 'package A; sub X { $_[0] } sub X : method'; @attrs = eval 'attributes::get \&A::X'; is "@attrs", "method"; # Above not with just 'pure' built-in attributes. sub Z::MODIFY_CODE_ATTRIBUTES { (); } eval 'package Z; sub L { $_[0] } sub L : Z method'; @attrs = eval 'attributes::get \&Z::L'; is "@attrs", "method Z"; # Begin testing attributes that tie { package Ttie; sub DESTROY {} sub TIESCALAR { my $x = $_[1]; bless \$x, $_[0]; } sub FETCH { ${$_[0]} } sub STORE { ::pass; ${$_[0]} = $_[1]*2; } package Tloop; sub MODIFY_SCALAR_ATTRIBUTES { tie ${$_[1]}, 'Ttie', -1; (); } } eval_ok ' package Tloop; for my $i (0..2) { my $x : TieLoop = $i; $x != $i*2 and ::is $x, $i*2; } '; # bug #15898 eval 'our ${""} : foo = 1'; like $@, qr/Can't declare scalar dereference in "our"/; eval 'my $$foo : bar = 1'; like $@, qr/Can't declare scalar dereference in "my"/; my @code = qw(lvalue method); my @other = qw(shared); my @deprecated = qw(locked unique); my %valid; $valid{CODE} = {map {$_ => 1} @code}; $valid{SCALAR} = {map {$_ => 1} @other}; $valid{ARRAY} = $valid{HASH} = $valid{SCALAR}; my %deprecated; $deprecated{CODE} = { locked => 1 }; $deprecated{ARRAY} = $deprecated{HASH} = $deprecated{SCALAR} = { unique => 1 }; our ($scalar, @array, %hash); foreach my $value (\&foo, \$scalar, \@array, \%hash) { my $type = ref $value; foreach my $negate ('', '-') { foreach my $attr (@code, @other, @deprecated) { my $attribute = $negate . $attr; eval "use attributes __PACKAGE__, \$value, '$attribute'"; if ($deprecated{$type}{$attr}) { like $@, qr/^Attribute "$attr" is deprecated at \(eval \d+\)/, "$type attribute $attribute deprecated"; } elsif ($valid{$type}{$attr}) { if ($attribute eq '-shared') { like $@, qr/^A variable may not be unshared/; } else { is( $@, '', "$type attribute $attribute"); } } else { like $@, qr/^Invalid $type attribute: $attribute/, "Bogus $type attribute $attribute should fail"; } } } } # this will segfault if it fails sub PVBM () { 'foo' } { my $dummy = index 'foo', PVBM } ok !defined(attributes::get(\PVBM)), 'PVBMs don\'t segfault attributes::get'; { # [perl #49472] Attributes + Unkown Error eval ' use strict; sub MODIFY_CODE_ATTRIBUTE{} sub f:Blah {$nosuchvar}; '; my $err = $@; like ($err, qr/Global symbol "\$nosuchvar" requires /, 'perl #49472'); } # Test that code attributes always get applied to the same CV that # we're left with at the end (bug#66970). { package bug66970; our $c; sub MODIFY_CODE_ATTRIBUTES { $c = $_[1]; () } $c=undef; eval 'sub t0 :Foo'; main::ok $c == \&{"t0"}; $c=undef; eval 'sub t1 :Foo { }'; main::ok $c == \&{"t1"}; $c=undef; eval 'sub t2'; our $t2a = \&{"t2"}; $c=undef; eval 'sub t2 :Foo'; main::ok $c == \&{"t2"} && $c == $t2a; $c=undef; eval 'sub t3'; our $t3a = \&{"t3"}; $c=undef; eval 'sub t3 :Foo { }'; main::ok $c == \&{"t3"} && $c == $t3a; $c=undef; eval 'sub t4 :Foo'; our $t4a = \&{"t4"}; our $t4b = $c; $c=undef; eval 'sub t4 :Foo'; main::ok $c == \&{"t4"} && $c == $t4b && $c == $t4a; $c=undef; eval 'sub t5 :Foo'; our $t5a = \&{"t5"}; our $t5b = $c; $c=undef; eval 'sub t5 :Foo { }'; main::ok $c == \&{"t5"} && $c == $t5b && $c == $t5a; } perl-5.12.0-RC0/t/op/append.t0000555000175000017500000000330111325125742014444 0ustar jessejesse#!./perl print "1..13\n"; $a = 'ab' . 'c'; # compile time $b = 'def'; $c = $a . $b; print "#1\t:$c: eq :abcdef:\n"; if ($c eq 'abcdef') {print "ok 1\n";} else {print "not ok 1\n";} $c .= 'xyz'; print "#2\t:$c: eq :abcdefxyz:\n"; if ($c eq 'abcdefxyz') {print "ok 2\n";} else {print "not ok 2\n";} $_ = $a; $_ .= $b; print "#3\t:$_: eq :abcdef:\n"; if ($_ eq 'abcdef') {print "ok 3\n";} else {print "not ok 3\n";} # test that when right argument of concat is UTF8, and is the same # variable as the target, and the left argument is not UTF8, it no # longer frees the wrong string. { sub r2 { my $string = ''; $string .= pack("U0a*", 'mnopqrstuvwx'); $string = "abcdefghijkl$string"; } r2() and print "ok $_\n" for qw/ 4 5 /; } # test that nul bytes get copied { my ($a, $ab) = ("a", "a\0b"); my ($ua, $uab) = map pack("U0a*", $_), $a, $ab; my $ub = pack("U0a*", 'b'); my $t1 = $a; $t1 .= $ab; print $t1 =~ /b/ ? "ok 6\n" : "not ok 6\t# $t1\n"; my $t2 = $a; $t2 .= $uab; print eval '$t2 =~ /$ub/' ? "ok 7\n" : "not ok 7\t# $t2\n"; my $t3 = $ua; $t3 .= $ab; print $t3 =~ /$ub/ ? "ok 8\n" : "not ok 8\t# $t3\n"; my $t4 = $ua; $t4 .= $uab; print eval '$t4 =~ /$ub/' ? "ok 9\n" : "not ok 9\t# $t4\n"; my $t5 = $a; $t5 = $ab . $t5; print $t5 =~ /$ub/ ? "ok 10\n" : "not ok 10\t# $t5\n"; my $t6 = $a; $t6 = $uab . $t6; print eval '$t6 =~ /$ub/' ? "ok 11\n" : "not ok 11\t# $t6\n"; my $t7 = $ua; $t7 = $ab . $t7; print $t7 =~ /$ub/ ? "ok 12\n" : "not ok 12\t# $t7\n"; my $t8 = $ua; $t8 = $uab . $t8; print eval '$t8 =~ /$ub/' ? "ok 13\n" : "not ok 13\t# $t8\n"; } perl-5.12.0-RC0/t/op/getpid.t0000555000175000017500000000155611143650501014455 0ustar jessejesse#!perl -w # Tests if $$ and getppid return consistent values across threads BEGIN { chdir 't' if -d 't'; @INC = qw(../lib); require './test.pl'; } use strict; use Config; BEGIN { if (!$Config{useithreads}) { print "1..0 # Skip: no ithreads\n"; exit; } if (!$Config{d_getppid}) { print "1..0 # Skip: no getppid\n"; exit; } if ($ENV{PERL_CORE_MINITEST}) { print "1..0 # Skip: no dynamic loading on miniperl, no threads\n"; exit 0; } eval 'use threads; use threads::shared'; plan tests => 3; if ($@) { fail("unable to load thread modules"); } else { pass("thread modules loaded"); } } my ($pid, $ppid) = ($$, getppid()); my $pid2 : shared = 0; my $ppid2 : shared = 0; new threads( sub { ($pid2, $ppid2) = ($$, getppid()); } ) -> join(); is($pid, $pid2, 'pids'); is($ppid, $ppid2, 'ppids'); perl-5.12.0-RC0/t/op/fh.t0000555000175000017500000000061011325125742013572 0ustar jessejesse#!./perl BEGIN { chdir 't'; @INC = '../lib'; require './test.pl'; } plan tests => 8; # symbolic filehandles should only result in glob entries with FH constructors $|=1; my $a = "SYM000"; ok(!defined(fileno($a))); ok(!defined *{$a}); select select $a; ok(defined *{$a}); $a++; ok(!close $a); ok(!defined *{$a}); ok(open($a, ">&STDOUT")); ok(defined *{$a}); ok(close $a); perl-5.12.0-RC0/t/op/defins.t0000555000175000017500000000647511325127001014452 0ustar jessejesse#!./perl -w # # test auto defined() test insertion # BEGIN { chdir 't' if -d 't'; @INC = qw(. ../lib); $SIG{__WARN__} = sub { $warns++; warn $_[0] }; } require 'test.pl'; plan( tests => 19 ); my $unix_mode = 1; if ($^O eq 'VMS') { # We have to know if VMS is in UNIX mode. In UNIX mode, trailing dots # should not be present. There are actually two settings that control this. $unix_mode = 0; my $unix_rpt = 0; my $drop_dot = 0; if (eval 'require VMS::Feature') { $unix_rpt = VMS::Feature::current('filename_unix_report'); $drop_dot = VMS::Feature::current('readdir_dropdotnotype'); } else { my $unix_report = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; $unix_rpt = $unix_report =~ /^[ET1]/i; my $drop_dot_notype = $ENV{'DECC$READDIR_DROPDOTNOTYPE'} || ''; $drop_dot = $drop_dot_notype =~ /^[ET1]/i; } $unix_mode = 1 if $drop_dot && unix_rpt; } $wanted_filename = $unix_mode ? '0' : '0.'; $saved_filename = './0'; cmp_ok($warns,'==',0,'no warns at start'); open(FILE,">$saved_filename"); ok(defined(FILE),'created work file'); print FILE "1\n"; print FILE "0"; close(FILE); open(FILE,"<$saved_filename"); ok(defined(FILE),'opened work file'); my $seen = 0; my $dummy; while (my $name = ) { $seen++ if $name eq '0'; } cmp_ok($seen,'==',1,'seen in while()'); seek(FILE,0,0); $seen = 0; my $line = ''; do { $seen++ if $line eq '0'; } while ($line = ); cmp_ok($seen,'==',1,'seen in do/while'); seek(FILE,0,0); $seen = 0; while (($seen ? $dummy : $name) = ) { $seen++ if $name eq '0'; } cmp_ok($seen,'==',1,'seen in while() ternary'); seek(FILE,0,0); $seen = 0; my %where; while ($where{$seen} = ) { $seen++ if $where{$seen} eq '0'; } cmp_ok($seen,'==',1,'seen in hash while()'); close FILE; opendir(DIR,'.'); ok(defined(DIR),'opened current directory'); $seen = 0; while (my $name = readdir(DIR)) { $seen++ if $name eq $wanted_filename; } cmp_ok($seen,'==',1,'saw work file once'); rewinddir(DIR); $seen = 0; $dummy = ''; while (($seen ? $dummy : $name) = readdir(DIR)) { $seen++ if $name eq $wanted_filename; } cmp_ok($seen,'>',0,'saw file in while() ternary'); rewinddir(DIR); $seen = 0; while ($where{$seen} = readdir(DIR)) { $seen++ if $where{$seen} eq $wanted_filename; } cmp_ok($seen,'==',1,'saw file in hash while()'); $seen = 0; while (my $name = glob('*')) { $seen++ if $name eq $wanted_filename; } cmp_ok($seen,'==',1,'saw file in glob while()'); $seen = 0; $dummy = ''; while (($seen ? $dummy : $name) = glob('*')) { $seen++ if $name eq $wanted_filename; } cmp_ok($seen,'>',0,'saw file in glob hash while() ternary'); $seen = 0; while ($where{$seen} = glob('*')) { $seen++ if $where{$seen} eq $wanted_filename; } cmp_ok($seen,'==',1,'seen in glob hash while()'); unlink($saved_filename); ok(!(-f $saved_filename),'work file unlinked'); my %hash = (0 => 1, 1 => 2); $seen = 0; while (my $name = each %hash) { $seen++ if $name eq '0'; } cmp_ok($seen,'==',1,'seen in each'); $seen = 0; $dummy = ''; while (($seen ? $dummy : $name) = each %hash) { $seen++ if $name eq '0'; } cmp_ok($seen,'==',1,'seen in each ternary'); $seen = 0; while ($where{$seen} = each %hash) { $seen++ if $where{$seen} eq '0'; } cmp_ok($seen,'==',1,'seen in each hash'); cmp_ok($warns,'==',0,'no warns at finish'); perl-5.12.0-RC0/t/op/each_array.t0000555000175000017500000000403011325125742015273 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } use strict; use warnings; no warnings 'deprecated'; use vars qw(@array @r $k $v); plan tests => 48; @array = qw(crunch zam bloop); (@r) = each @array; is (scalar @r, 2); is ($r[0], 0); is ($r[1], 'crunch'); ($k, $v) = each @array; is ($k, 1); is ($v, 'zam'); ($k, $v) = each @array; is ($k, 2); is ($v, 'bloop'); (@r) = each @array; is (scalar @r, 0); (@r) = each @array; is (scalar @r, 2); is ($r[0], 0); is ($r[1], 'crunch'); ($k) = each @array; is ($k, 1); { $[ = 2; my ($k, $v) = each @array; is ($k, 4); is ($v, 'bloop'); (@r) = each @array; is (scalar @r, 0); } my @lex_array = qw(PLOP SKLIZZORCH RATTLE PBLRBLPSFT); (@r) = each @lex_array; is (scalar @r, 2); is ($r[0], 0); is ($r[1], 'PLOP'); ($k, $v) = each @lex_array; is ($k, 1); is ($v, 'SKLIZZORCH'); ($k) = each @lex_array; is ($k, 2); { $[ = -42; my ($k, $v) = each @lex_array; is ($k, -39); is ($v, 'PBLRBLPSFT'); } (@r) = each @lex_array; is (scalar @r, 0); my $ar = ['bacon']; (@r) = each @$ar; is (scalar @r, 2); is ($r[0], 0); is ($r[1], 'bacon'); (@r) = each @$ar; is (scalar @r, 0); is (each @$ar, 0); is (scalar each @$ar, undef); my @keys; @keys = keys @array; is ("@keys", "0 1 2"); @keys = keys @lex_array; is ("@keys", "0 1 2 3"); { $[ = 1; @keys = keys @array; is ("@keys", "1 2 3"); @keys = keys @lex_array; is ("@keys", "1 2 3 4"); } ($k, $v) = each @array; is ($k, 0); is ($v, 'crunch'); @keys = keys @array; is ("@keys", "0 1 2"); ($k, $v) = each @array; is ($k, 0); is ($v, 'crunch'); my @values; @values = values @array; is ("@values", "@array"); @values = values @lex_array; is ("@values", "@lex_array"); { $[ = 1; @values = values @array; is ("@values", "@array"); @values = values @lex_array; is ("@values", "@lex_array"); } ($k, $v) = each @array; is ($k, 0); is ($v, 'crunch'); @values = values @array; is ("@values", "@array"); ($k, $v) = each @array; is ($k, 0); is ($v, 'crunch'); perl-5.12.0-RC0/t/op/ref.t0000555000175000017500000004170511350231124013751 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = qw(. ../lib); } require 'test.pl'; use strict qw(refs subs); use re (); plan(196); # Test glob operations. $bar = "one"; $foo = "two"; { local(*foo) = *bar; is($foo, 'one'); } is ($foo, 'two'); $baz = "three"; $foo = "four"; { local(*foo) = 'baz'; is ($foo, 'three'); } is ($foo, 'four'); $foo = "global"; { local(*foo); is ($foo, undef); $foo = "local"; is ($foo, 'local'); } is ($foo, 'global'); { no strict 'refs'; # Test fake references. $baz = "valid"; $bar = 'baz'; $foo = 'bar'; is ($$$foo, 'valid'); } # Test real references. $FOO = \$BAR; $BAR = \$BAZ; $BAZ = "hit"; is ($$$FOO, 'hit'); # Test references to real arrays. my $test = curr_test(); @ary = ($test,$test+1,$test+2,$test+3); $ref[0] = \@a; $ref[1] = \@b; $ref[2] = \@c; $ref[3] = \@d; for $i (3,1,2,0) { push(@{$ref[$i]}, "ok $ary[$i]\n"); } print @a; print ${$ref[1]}[0]; print @{$ref[2]}[0]; { no strict 'refs'; print @{'d'}; } curr_test($test+4); # Test references to references. $refref = \\$x; $x = "Good"; is ($$$refref, 'Good'); # Test nested anonymous lists. $ref = [[],2,[3,4,5,]]; is (scalar @$ref, 3); is ($$ref[1], 2); is (${$$ref[2]}[2], 5); is (scalar @{$$ref[0]}, 0); is ($ref->[1], 2); is ($ref->[2]->[0], 3); # Test references to hashes of references. $refref = \%whatever; $refref->{"key"} = $ref; is ($refref->{"key"}->[2]->[0], 3); # Test to see if anonymous subarrays spring into existence. $spring[5]->[0] = 123; $spring[5]->[1] = 456; push(@{$spring[5]}, 789); is (join(':',@{$spring[5]}), "123:456:789"); # Test to see if anonymous subhashes spring into existence. @{$spring2{"foo"}} = (1,2,3); $spring2{"foo"}->[3] = 4; is (join(':',@{$spring2{"foo"}}), "1:2:3:4"); # Test references to subroutines. { my $called; sub mysub { $called++; } $subref = \&mysub; &$subref; is ($called, 1); } $subrefref = \\&mysub2; is ($$subrefref->("GOOD"), "good"); sub mysub2 { lc shift } # Test REGEXP assignment { my $x = qr/x/; my $str = "$x"; # regex stringification may change my $y = $$x; is ($y, $str, "bare REGEXP stringifies correctly"); ok (eval { "x" =~ $y }, "bare REGEXP matches correctly"); my $z = \$y; ok (re::is_regexp($z), "new ref to REXEXP passes is_regexp"); is ($z, $str, "new ref to REGEXP stringifies correctly"); ok (eval { "x" =~ $z }, "new ref to REGEXP matches correctly"); } { my ($x, $str); { my $y = qr/x/; $str = "$y"; $x = $$y; } is ($x, $str, "REGEXP keeps a ref to its mother_re"); ok (eval { "x" =~ $x }, "REGEXP with mother_re still matches"); } # Test the ref operator. sub PVBM () { 'foo' } { my $dummy = index 'foo', PVBM } my $pviv = 1; "$pviv"; my $pvnv = 1.0; "$pvnv"; my $x; # we don't test # tied lvalue => SCALAR, as we haven't tested tie yet # BIND, 'cos we can't create them yet # REGEXP, 'cos that requires overload or Scalar::Util # LVALUE ref, 'cos I can't work out how to create one :) for ( [ 'undef', SCALAR => \undef ], [ 'constant IV', SCALAR => \1 ], [ 'constant NV', SCALAR => \1.0 ], [ 'constant PV', SCALAR => \'f' ], [ 'scalar', SCALAR => \$x ], [ 'PVIV', SCALAR => \$pviv ], [ 'PVNV', SCALAR => \$pvnv ], [ 'PVMG', SCALAR => \$0 ], [ 'PVBM', SCALAR => \PVBM ], [ 'vstring', VSTRING => \v1 ], [ 'ref', REF => \\1 ], [ 'lvalue', LVALUE => \substr($x, 0, 0) ], [ 'named array', ARRAY => \@ary ], [ 'anon array', ARRAY => [ 1 ] ], [ 'named hash', HASH => \%whatever ], [ 'anon hash', HASH => { a => 1 } ], [ 'named sub', CODE => \&mysub, ], [ 'anon sub', CODE => sub { 1; } ], [ 'glob', GLOB => \*foo ], [ 'format', FORMAT => *STDERR{FORMAT} ], ) { my ($desc, $type, $ref) = @$_; is (ref $ref, $type, "ref() for ref to $desc"); like ("$ref", qr/^$type\(0x[0-9a-f]+\)$/, "stringify for ref to $desc"); } is (ref *STDOUT{IO}, 'IO::File', 'IO refs are blessed into IO::File'); like (*STDOUT{IO}, qr/^IO::File=IO\(0x[0-9a-f]+\)$/, 'stringify for IO refs'); # Test anonymous hash syntax. $anonhash = {}; is (ref $anonhash, 'HASH'); $anonhash2 = {FOO => 'BAR', ABC => 'XYZ',}; is (join('', sort values %$anonhash2), 'BARXYZ'); # Test bless operator. package MYHASH; $object = bless $main'anonhash2; main::is (ref $object, 'MYHASH'); main::is ($object->{ABC}, 'XYZ'); $object2 = bless {}; main::is (ref $object2, 'MYHASH'); # Test ordinary call on object method. &mymethod($object,"argument"); sub mymethod { local($THIS, @ARGS) = @_; die 'Got a "' . ref($THIS). '" instead of a MYHASH' unless ref $THIS eq 'MYHASH'; main::is ($ARGS[0], "argument"); main::is ($THIS->{FOO}, 'BAR'); } # Test automatic destructor call. $string = "bad"; $object = "foo"; $string = "good"; $main'anonhash2 = "foo"; $string = ""; DESTROY { return unless $string; main::is ($string, 'good'); # Test that the object has not already been "cursed". main::isnt (ref shift, 'HASH'); } # Now test inheritance of methods. package OBJ; @ISA = ('BASEOBJ'); $main'object = bless {FOO => 'foo', BAR => 'bar'}; package main; # Test arrow-style method invocation. is ($object->doit("BAR"), 'bar'); # Test indirect-object-style method invocation. $foo = doit $object "FOO"; main::is ($foo, 'foo'); sub BASEOBJ'doit { local $ref = shift; die "Not an OBJ" unless ref $ref eq 'OBJ'; $ref->{shift()}; } package UNIVERSAL; @ISA = 'LASTCHANCE'; package LASTCHANCE; sub foo { main::is ($_[1], 'works') } package WHATEVER; foo WHATEVER "works"; # # test the \(@foo) construct # package main; @foo = \(1..3); @bar = \(@foo); @baz = \(1,@foo,@bar); is (scalar (@bar), 3); is (scalar grep(ref($_), @bar), 3); is (scalar (@baz), 3); my(@fuu) = \(1..2,3); my(@baa) = \(@fuu); my(@bzz) = \(1,@fuu,@baa); is (scalar (@baa), 3); is (scalar grep(ref($_), @baa), 3); is (scalar (@bzz), 3); # also, it can't be an lvalue eval '\\($x, $y) = (1, 2);'; like ($@, qr/Can\'t modify.*ref.*in.*assignment/); # test for proper destruction of lexical objects $test = curr_test(); sub larry::DESTROY { print "# larry\nok $test\n"; } sub curly::DESTROY { print "# curly\nok ", $test + 1, "\n"; } sub moe::DESTROY { print "# moe\nok ", $test + 2, "\n"; } { my ($joe, @curly, %larry); my $moe = bless \$joe, 'moe'; my $curly = bless \@curly, 'curly'; my $larry = bless \%larry, 'larry'; print "# leaving block\n"; } print "# left block\n"; curr_test($test + 3); # another glob test $foo = "garbage"; { local(*bar) = "foo" } $bar = "glob 3"; local(*bar) = *bar; is ($bar, "glob 3"); $var = "glob 4"; $_ = \$var; is ($$_, 'glob 4'); # test if reblessing during destruction results in more destruction $test = curr_test(); { package A; sub new { bless {}, shift } DESTROY { print "# destroying 'A'\nok ", $test + 1, "\n" } package _B; sub new { bless {}, shift } DESTROY { print "# destroying '_B'\nok $test\n"; bless shift, 'A' } package main; my $b = _B->new; } curr_test($test + 2); # test if $_[0] is properly protected in DESTROY() { my $test = curr_test(); my $i = 0; local $SIG{'__DIE__'} = sub { my $m = shift; if ($i++ > 4) { print "# infinite recursion, bailing\nnot ok $test\n"; exit 1; } like ($m, qr/^Modification of a read-only/); }; package C; sub new { bless {}, shift } DESTROY { $_[0] = 'foo' } { print "# should generate an error...\n"; my $c = C->new; } print "# good, didn't recurse\n"; } # test if refgen behaves with autoviv magic { my @a; $a[1] = "good"; my $got; for (@a) { $got .= ${\$_}; $got .= ';'; } is ($got, ";good;"); } # This test is the reason for postponed destruction in sv_unref $a = [1,2,3]; $a = $a->[1]; is ($a, 2); # This test used to coredump. The BEGIN block is important as it causes the # op that created the constant reference to be freed. Hence the only # reference to the constant string "pass" is in $a. The hack that made # sure $a = $a->[1] would work didn't work with references to constants. foreach my $lexical ('', 'my $a; ') { my $expect = "pass\n"; my $result = runperl (switches => ['-wl'], stderr => 1, prog => $lexical . 'BEGIN {$a = \q{pass}}; $a = $$a; print $a'); is ($?, 0); is ($result, $expect); } $test = curr_test(); sub x::DESTROY {print "ok ", $test + shift->[0], "\n"} { my $a1 = bless [3],"x"; my $a2 = bless [2],"x"; { my $a3 = bless [1],"x"; my $a4 = bless [0],"x"; 567; } } curr_test($test+4); is (runperl (switches=>['-l'], prog=> 'print 1; print qq-*$\*-;print 1;'), "1\n*\n*\n1\n"); # bug #21347 runperl(prog => 'sub UNIVERSAL::AUTOLOAD { qr// } a->p' ); is ($?, 0, 'UNIVERSAL::AUTOLOAD called when freeing qr//'); runperl(prog => 'sub UNIVERSAL::DESTROY { warn } bless \$a, A', stderr => 1); is ($?, 0, 'warn called inside UNIVERSAL::DESTROY'); # bug #22719 runperl(prog => 'sub f { my $x = shift; *z = $x; } f({}); f();'); is ($?, 0, 'coredump on typeglob = (SvRV && !SvROK)'); # bug #27268: freeing self-referential typeglobs could trigger # "Attempt to free unreferenced scalar" warnings is (runperl( prog => 'use Symbol;my $x=bless \gensym,"t"; print;*$$x=$x', stderr => 1 ), '', 'freeing self-referential typeglob'); # using a regex in the destructor for STDOUT segfaulted because the # REGEX pad had already been freed (ithreads build only). The # object is required to trigger the early freeing of GV refs to to STDOUT TODO: { local $TODO = "works but output through pipe is mangled" if $^O eq 'VMS'; like (runperl( prog => '$x=bless[]; sub IO::Handle::DESTROY{$_="bad";s/bad/ok/;print}', stderr => 1 ), qr/^(ok)+$/, 'STDOUT destructor'); } TODO: { no strict 'refs'; $name8 = chr 163; $name_utf8 = $name8 . chr 256; chop $name_utf8; is ($$name8, undef, 'Nothing before we start'); is ($$name_utf8, undef, 'Nothing before we start'); $$name8 = "Pound"; is ($$name8, "Pound", 'Accessing via 8 bit symref works'); local $TODO = "UTF8 mangled in symrefs"; is ($$name_utf8, "Pound", 'Accessing via UTF8 symref works'); } TODO: { no strict 'refs'; $name_utf8 = $name = chr 9787; utf8::encode $name_utf8; is (length $name, 1, "Name is 1 char"); is (length $name_utf8, 3, "UTF8 representation is 3 chars"); is ($$name, undef, 'Nothing before we start'); is ($$name_utf8, undef, 'Nothing before we start'); $$name = "Face"; is ($$name, "Face", 'Accessing via Unicode symref works'); local $TODO = "UTF8 mangled in symrefs"; is ($$name_utf8, undef, 'Accessing via the UTF8 byte sequence gives nothing'); } { no strict 'refs'; $name1 = "\0Chalk"; $name2 = "\0Cheese"; isnt ($name1, $name2, "They differ"); is ($$name1, undef, 'Nothing before we start (scalars)'); is ($$name2, undef, 'Nothing before we start'); $$name1 = "Yummy"; is ($$name1, "Yummy", 'Accessing via the correct name works'); is ($$name2, undef, 'Accessing via a different NUL-containing name gives nothing'); # defined uses a different code path ok (defined $$name1, 'defined via the correct name works'); ok (!defined $$name2, 'defined via a different NUL-containing name gives nothing'); is ($name1->[0], undef, 'Nothing before we start (arrays)'); is ($name2->[0], undef, 'Nothing before we start'); $name1->[0] = "Yummy"; is ($name1->[0], "Yummy", 'Accessing via the correct name works'); is ($name2->[0], undef, 'Accessing via a different NUL-containing name gives nothing'); ok (defined $name1->[0], 'defined via the correct name works'); ok (!defined$name2->[0], 'defined via a different NUL-containing name gives nothing'); my (undef, $one) = @{$name1}[2,3]; my (undef, $two) = @{$name2}[2,3]; is ($one, undef, 'Nothing before we start (array slices)'); is ($two, undef, 'Nothing before we start'); @{$name1}[2,3] = ("Very", "Yummy"); (undef, $one) = @{$name1}[2,3]; (undef, $two) = @{$name2}[2,3]; is ($one, "Yummy", 'Accessing via the correct name works'); is ($two, undef, 'Accessing via a different NUL-containing name gives nothing'); ok (defined $one, 'defined via the correct name works'); ok (!defined $two, 'defined via a different NUL-containing name gives nothing'); is ($name1->{PWOF}, undef, 'Nothing before we start (hashes)'); is ($name2->{PWOF}, undef, 'Nothing before we start'); $name1->{PWOF} = "Yummy"; is ($name1->{PWOF}, "Yummy", 'Accessing via the correct name works'); is ($name2->{PWOF}, undef, 'Accessing via a different NUL-containing name gives nothing'); ok (defined $name1->{PWOF}, 'defined via the correct name works'); ok (!defined $name2->{PWOF}, 'defined via a different NUL-containing name gives nothing'); my (undef, $one) = @{$name1}{'SNIF', 'BEEYOOP'}; my (undef, $two) = @{$name2}{'SNIF', 'BEEYOOP'}; is ($one, undef, 'Nothing before we start (hash slices)'); is ($two, undef, 'Nothing before we start'); @{$name1}{'SNIF', 'BEEYOOP'} = ("Very", "Yummy"); (undef, $one) = @{$name1}{'SNIF', 'BEEYOOP'}; (undef, $two) = @{$name2}{'SNIF', 'BEEYOOP'}; is ($one, "Yummy", 'Accessing via the correct name works'); is ($two, undef, 'Accessing via a different NUL-containing name gives nothing'); ok (defined $one, 'defined via the correct name works'); ok (!defined $two, 'defined via a different NUL-containing name gives nothing'); $name1 = "Left"; $name2 = "Left\0Right"; my $glob2 = *{$name2}; is ($glob1, undef, "We get different typeglobs. In fact, undef"); *{$name1} = sub {"One"}; *{$name2} = sub {"Two"}; is (&{$name1}, "One"); is (&{$name2}, "Two"); } # test derefs after list slice is ( ({foo => "bar"})[0]{foo}, "bar", 'hash deref from list slice w/o ->' ); is ( ({foo => "bar"})[0]->{foo}, "bar", 'hash deref from list slice w/ ->' ); is ( ([qw/foo bar/])[0][1], "bar", 'array deref from list slice w/o ->' ); is ( ([qw/foo bar/])[0]->[1], "bar", 'array deref from list slice w/ ->' ); is ( (sub {"bar"})[0](), "bar", 'code deref from list slice w/o ->' ); is ( (sub {"bar"})[0]->(), "bar", 'code deref from list slice w/ ->' ); # deref on empty list shouldn't autovivify { local $@; eval { ()[0]{foo} }; like ( "$@", "Can't use an undefined value as a HASH reference", "deref of undef from list slice fails" ); } # test dereferencing errors { format STDERR = . my $ref; foreach $ref (*STDOUT{IO}, *STDERR{FORMAT}) { eval q/ $$ref /; like($@, qr/Not a SCALAR reference/, "Scalar dereference"); eval q/ @$ref /; like($@, qr/Not an ARRAY reference/, "Array dereference"); eval q/ %$ref /; like($@, qr/Not a HASH reference/, "Hash dereference"); eval q/ &$ref /; like($@, qr/Not a CODE reference/, "Code dereference"); } $ref = *STDERR{FORMAT}; eval q/ *$ref /; like($@, qr/Not a GLOB reference/, "Glob dereference"); $ref = *STDOUT{IO}; eval q/ *$ref /; is($@, '', "Glob dereference of PVIO is acceptable"); is($ref, *{$ref}{IO}, "IO slot of the temporary glob is set correctly"); } # these will segfault if they fail my $pvbm = PVBM; my $rpvbm = \$pvbm; ok (!eval { *$rpvbm }, 'PVBM ref is not a GLOB ref'); ok (!eval { *$pvbm }, 'PVBM is not a GLOB ref'); ok (!eval { $$pvbm }, 'PVBM is not a SCALAR ref'); ok (!eval { @$pvbm }, 'PVBM is not an ARRAY ref'); ok (!eval { %$pvbm }, 'PVBM is not a HASH ref'); ok (!eval { $pvbm->() }, 'PVBM is not a CODE ref'); ok (!eval { $rpvbm->foo }, 'PVBM is not an object'); # bug 24254 is( runperl(stderr => 1, prog => 'map eval qq(exit),1 for 1'), ""); is( runperl(stderr => 1, prog => 'eval { for (1) { map { die } 2 } };'), ""); is( runperl(stderr => 1, prog => 'for (125) { map { exit } (213)}'), ""); my $hushed = $^O eq 'VMS' ? 'use vmsish qw(hushed);' : ''; is( runperl(stderr => 1, prog => $hushed . 'map die,4 for 3'), "Died at -e line 1.\n"); is( runperl(stderr => 1, prog => $hushed . 'grep die,4 for 3'), "Died at -e line 1.\n"); is( runperl(stderr => 1, prog => $hushed . 'for $a (3) {@b=sort {die} 4,5}'), "Died at -e line 1.\n"); # bug 57564 is( runperl(stderr => 1, prog => 'my $i;for $i (1) { for $i (2) { } }'), ""); # Bit of a hack to make test.pl happy. There are 3 more tests after it leaves. $test = curr_test(); curr_test($test + 3); # test global destruction my $test1 = $test + 1; my $test2 = $test + 2; package FINALE; { $ref3 = bless ["ok $test2\n"]; # package destruction my $ref2 = bless ["ok $test1\n"]; # lexical destruction local $ref1 = bless ["ok $test\n"]; # dynamic destruction 1; # flush any temp values on stack } DESTROY { print $_[0][0]; } perl-5.12.0-RC0/t/op/filetest_t.t0000555000175000017500000000145311325127001015333 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } use strict; plan 2; my($dev_tty, $dev_null) = qw(/dev/tty /dev/null); ($dev_tty, $dev_null) = qw(con nul ) if $^O =~ /^(MSWin32|os2)$/; ($dev_tty, $dev_null) = qw(TT: _NLA0: ) if $^O eq "VMS"; SKIP: { open(my $tty, "<", $dev_tty) or skip("Can't open terminal '$dev_tty': $!"); if ($^O eq 'VMS') { # TT might be a mailbox or other non-terminal device my $tt_dev = VMS::Filespec::vmspath('TT'); skip("'$tt_dev' is probably not a terminal") if $tt_dev !~ m/^_(tt|ft|rt)/i; } ok(-t $tty, "'$dev_tty' is a TTY"); } SKIP: { open(my $null, "<", $dev_null) or skip("Can't open null device '$dev_null': $!"); ok(!-t $null, "'$dev_null' is not a TTY"); } perl-5.12.0-RC0/t/op/taint.t0000555000175000017500000010150711325127002014312 0ustar jessejesse#!./perl -T # # Taint tests by Tom Phoenix . # # I don't claim to know all about tainting. If anyone sees # tests that I've missed here, please add them. But this is # better than having no tests at all, right? # BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } use strict; use Config; use File::Spec::Functions; BEGIN { require './test.pl'; } plan tests => 302; $| = 1; use vars qw($ipcsysv); # did we manage to load IPC::SysV? my ($old_env_path, $old_env_dcl_path, $old_env_term); BEGIN { $old_env_path = $ENV{'PATH'}; $old_env_dcl_path = $ENV{'DCL$PATH'}; $old_env_term = $ENV{'TERM'}; if ($^O eq 'VMS' && !defined($Config{d_setenv})) { $ENV{PATH} = $ENV{PATH}; $ENV{TERM} = $ENV{TERM} ne ''? $ENV{TERM} : 'dummy'; } if ($Config{'extensions'} =~ /\bIPC\/SysV\b/ && ($Config{d_shm} || $Config{d_msg})) { eval { require IPC::SysV }; unless ($@) { $ipcsysv++; IPC::SysV->import(qw(IPC_PRIVATE IPC_RMID IPC_CREAT S_IRWXU IPC_NOWAIT)); } } } my $Is_VMS = $^O eq 'VMS'; my $Is_MSWin32 = $^O eq 'MSWin32'; my $Is_NetWare = $^O eq 'NetWare'; my $Is_Dos = $^O eq 'dos'; my $Is_Cygwin = $^O eq 'cygwin'; my $Is_OpenBSD = $^O eq 'openbsd'; my $Invoke_Perl = $Is_VMS ? 'MCR Sys$Disk:[]Perl.exe' : $Is_MSWin32 ? '.\perl' : $Is_NetWare ? 'perl' : './perl' ; my @MoreEnv = qw/IFS CDPATH ENV BASH_ENV/; if ($Is_VMS) { my (%old, $x); for $x ('DCL$PATH', @MoreEnv) { ($old{$x}) = $ENV{$x} =~ /^(.*)$/ if exists $ENV{$x}; } # VMS note: PATH and TERM are automatically created by the C # library in VMS on reference to the their keys in %ENV. # There is currently no way to determine if they did not exist # before this test was run. eval < $ECHO" or die "Can't create $ECHO: $!"; print PROG 'print "@ARGV\n"', "\n"; close PROG; my $echo = "$Invoke_Perl $ECHO"; my $TEST = catfile(curdir(), 'TEST'); # First, let's make sure that Perl is checking the dangerous # environment variables. Maybe they aren't set yet, so we'll # taint them ourselves. { $ENV{'DCL$PATH'} = '' if $Is_VMS; if ($Is_MSWin32 && $Config{ccname} =~ /bcc32/ && ! -f 'cc3250mt.dll') { my $bcc_dir; foreach my $dir (split /$Config{path_sep}/, $ENV{PATH}) { if (-f "$dir/cc3250mt.dll") { $bcc_dir = $dir and last; } } if (defined $bcc_dir) { require File::Copy; File::Copy::copy("$bcc_dir/cc3250mt.dll", '.') or die "$0: failed to copy cc3250mt.dll: $!\n"; eval q{ END { unlink "cc3250mt.dll" } }; } } $ENV{PATH} = ($Is_Cygwin) ? '/usr/bin' : ''; delete @ENV{@MoreEnv}; $ENV{TERM} = 'dumb'; test eval { `$echo 1` } eq "1\n"; SKIP: { skip "Environment tainting tests skipped", 4 if $Is_MSWin32 || $Is_NetWare || $Is_VMS || $Is_Dos; my @vars = ('PATH', @MoreEnv); while (my $v = $vars[0]) { local $ENV{$v} = $TAINT; last if eval { `$echo 1` }; last unless $@ =~ /^Insecure \$ENV{$v}/; shift @vars; } test !@vars, "@vars"; # tainted $TERM is unsafe only if it contains metachars local $ENV{TERM}; $ENV{TERM} = 'e=mc2'; test eval { `$echo 1` } eq "1\n"; $ENV{TERM} = 'e=mc2' . $TAINT; test !eval { `$echo 1` }; test $@ =~ /^Insecure \$ENV{TERM}/, $@; } my $tmp; if ($^O eq 'os2' || $^O eq 'amigaos' || $Is_MSWin32 || $Is_NetWare || $Is_Dos) { print "# all directories are writeable\n"; } else { $tmp = (grep { defined and -d and (stat _)[2] & 2 } qw(sys$scratch /tmp /var/tmp /usr/tmp), @ENV{qw(TMP TEMP)})[0] or print "# can't find world-writeable directory to test PATH\n"; } SKIP: { skip "all directories are writeable", 2 unless $tmp; local $ENV{PATH} = $tmp; test !eval { `$echo 1` }; test $@ =~ /^Insecure directory in \$ENV{PATH}/, $@; } SKIP: { skip "This is not VMS", 4 unless $Is_VMS; $ENV{'DCL$PATH'} = $TAINT; test eval { `$echo 1` } eq ''; test $@ =~ /^Insecure \$ENV{DCL\$PATH}/, $@; SKIP: { skip q[can't find world-writeable directory to test DCL$PATH], 2 unless $tmp; $ENV{'DCL$PATH'} = $tmp; test eval { `$echo 1` } eq ''; test $@ =~ /^Insecure directory in \$ENV{DCL\$PATH}/, $@; } $ENV{'DCL$PATH'} = ''; } } # Let's see that we can taint and untaint as needed. { my $foo = $TAINT; test tainted $foo; # That was a sanity check. If it failed, stop the insanity! die "Taint checks don't seem to be enabled" unless tainted $foo; $foo = "foo"; test not tainted $foo; taint_these($foo); test tainted $foo; my @list = 1..10; test not any_tainted @list; taint_these @list[1,3,5,7,9]; test any_tainted @list; test all_tainted @list[1,3,5,7,9]; test not any_tainted @list[0,2,4,6,8]; ($foo) = $foo =~ /(.+)/; test not tainted $foo; $foo = $1 if ('bar' . $TAINT) =~ /(.+)/; test not tainted $foo; test $foo eq 'bar'; { use re 'taint'; ($foo) = ('bar' . $TAINT) =~ /(.+)/; test tainted $foo; test $foo eq 'bar'; $foo = $1 if ('bar' . $TAINT) =~ /(.+)/; test tainted $foo; test $foo eq 'bar'; } $foo = $1 if 'bar' =~ /(.+)$TAINT/; test tainted $foo; test $foo eq 'bar'; my $pi = 4 * atan2(1,1) + $TAINT0; test tainted $pi; ($pi) = $pi =~ /(\d+\.\d+)/; test not tainted $pi; test sprintf("%.5f", $pi) eq '3.14159'; } # How about command-line arguments? The problem is that we don't # always get some, so we'll run another process with some. SKIP: { my $arg = tempfile(); open PROG, "> $arg" or die "Can't create $arg: $!"; print PROG q{ eval { join('', @ARGV), kill 0 }; exit 0 if $@ =~ /^Insecure dependency/; print "# Oops: \$@ was [$@]\n"; exit 1; }; close PROG; print `$Invoke_Perl "-T" $arg and some suspect arguments`; test !$?, "Exited with status $?"; unlink $arg; } # Reading from a file should be tainted { test open(FILE, $TEST), "Couldn't open '$TEST': $!"; my $block; sysread(FILE, $block, 100); my $line = ; close FILE; test tainted $block; test tainted $line; } # Globs should be forbidden, except under VMS, # which doesn't spawn an external program. SKIP: { skip "globs should be forbidden", 2 if 1 or $Is_VMS; my @globs = eval { <*> }; test @globs == 0 && $@ =~ /^Insecure dependency/; @globs = eval { glob '*' }; test @globs == 0 && $@ =~ /^Insecure dependency/; } # Output of commands should be tainted { my $foo = `$echo abc`; test tainted $foo; } # Certain system variables should be tainted { test all_tainted $^X, $0; } # Results of matching should all be untainted { my $foo = "abcdefghi" . $TAINT; test tainted $foo; $foo =~ /def/; test not any_tainted $`, $&, $'; $foo =~ /(...)(...)(...)/; test not any_tainted $1, $2, $3, $+; my @bar = $foo =~ /(...)(...)(...)/; test not any_tainted @bar; test tainted $foo; # $foo should still be tainted! test $foo eq "abcdefghi"; } # Operations which affect files can't use tainted data. { test !eval { chmod 0, $TAINT }, 'chmod'; test $@ =~ /^Insecure dependency/, $@; # There is no feature test in $Config{} for truncate, # so we allow for the possibility that it's missing. test !eval { truncate 'NoSuChFiLe', $TAINT0 }, 'truncate'; test $@ =~ /^(?:Insecure dependency|truncate not implemented)/, $@; test !eval { rename '', $TAINT }, 'rename'; test $@ =~ /^Insecure dependency/, $@; test !eval { unlink $TAINT }, 'unlink'; test $@ =~ /^Insecure dependency/, $@; test !eval { utime $TAINT }, 'utime'; test $@ =~ /^Insecure dependency/, $@; SKIP: { skip "chown() is not available", 2 unless $Config{d_chown}; test !eval { chown -1, -1, $TAINT }, 'chown'; test $@ =~ /^Insecure dependency/, $@; } SKIP: { skip "link() is not available", 2 unless $Config{d_link}; test !eval { link $TAINT, '' }, 'link'; test $@ =~ /^Insecure dependency/, $@; } SKIP: { skip "symlink() is not available", 2 unless $Config{d_symlink}; test !eval { symlink $TAINT, '' }, 'symlink'; test $@ =~ /^Insecure dependency/, $@; } } # Operations which affect directories can't use tainted data. { test !eval { mkdir "foo".$TAINT, 0755.$TAINT0 }, 'mkdir'; test $@ =~ /^Insecure dependency/, $@; test !eval { rmdir $TAINT }, 'rmdir'; test $@ =~ /^Insecure dependency/, $@; test !eval { chdir "foo".$TAINT }, 'chdir'; test $@ =~ /^Insecure dependency/, $@; SKIP: { skip "chroot() is not available", 2 unless $Config{d_chroot}; test !eval { chroot $TAINT }, 'chroot'; test $@ =~ /^Insecure dependency/, $@; } } # Some operations using files can't use tainted data. { my $foo = "imaginary library" . $TAINT; test !eval { require $foo }, 'require'; test $@ =~ /^Insecure dependency/, $@; my $filename = tempfile(); # NB: $filename isn't tainted! $foo = $filename . $TAINT; unlink $filename; # in any case test !eval { open FOO, $foo }, 'open for read'; test $@ eq '', $@; # NB: This should be allowed # Try first new style but allow also old style. # We do not want the whole taint.t to fail # just because Errno possibly failing. test eval('$!{ENOENT}') || $! == 2 || # File not found ($Is_Dos && $! == 22); test !eval { open FOO, "> $foo" }, 'open for write'; test $@ =~ /^Insecure dependency/, $@; } # Commands to the system can't use tainted data { my $foo = $TAINT; SKIP: { skip "open('|') is not available", 4 if $^O eq 'amigaos'; test !eval { open FOO, "| x$foo" }, 'popen to'; test $@ =~ /^Insecure dependency/, $@; test !eval { open FOO, "x$foo |" }, 'popen from'; test $@ =~ /^Insecure dependency/, $@; } test !eval { exec $TAINT }, 'exec'; test $@ =~ /^Insecure dependency/, $@; test !eval { system $TAINT }, 'system'; test $@ =~ /^Insecure dependency/, $@; $foo = "*"; taint_these $foo; test !eval { `$echo 1$foo` }, 'backticks'; test $@ =~ /^Insecure dependency/, $@; SKIP: { # wildcard expansion doesn't invoke shell on VMS, so is safe skip "This is not VMS", 2 unless $Is_VMS; test join('', eval { glob $foo } ) ne '', 'globbing'; test $@ eq '', $@; } } # Operations which affect processes can't use tainted data. { test !eval { kill 0, $TAINT }, 'kill'; test $@ =~ /^Insecure dependency/, $@; SKIP: { skip "setpgrp() is not available", 2 unless $Config{d_setpgrp}; test !eval { setpgrp 0, $TAINT0 }, 'setpgrp'; test $@ =~ /^Insecure dependency/, $@; } SKIP: { skip "setpriority() is not available", 2 unless $Config{d_setprior}; test !eval { setpriority 0, $TAINT0, $TAINT0 }, 'setpriority'; test $@ =~ /^Insecure dependency/, $@; } } # Some miscellaneous operations can't use tainted data. { SKIP: { skip "syscall() is not available", 2 unless $Config{d_syscall}; test !eval { syscall $TAINT }, 'syscall'; test $@ =~ /^Insecure dependency/, $@; } { my $foo = "x" x 979; taint_these $foo; local *FOO; my $temp = tempfile(); test open(FOO, "> $temp"), "Couldn't open $temp for write: $!"; test !eval { ioctl FOO, $TAINT0, $foo }, 'ioctl'; test $@ =~ /^Insecure dependency/, $@; SKIP: { skip "fcntl() is not available", 2 unless $Config{d_fcntl}; test !eval { fcntl FOO, $TAINT0, $foo }, 'fcntl'; test $@ =~ /^Insecure dependency/, $@; } close FOO; } } # Some tests involving references { my $foo = 'abc' . $TAINT; my $fooref = \$foo; test not tainted $fooref; test tainted $$fooref; test tainted $foo; } # Some tests involving assignment { my $foo = $TAINT0; my $bar = $foo; test all_tainted $foo, $bar; test tainted($foo = $bar); test tainted($bar = $bar); test tainted($bar += $bar); test tainted($bar -= $bar); test tainted($bar *= $bar); test tainted($bar++); test tainted($bar /= $bar); test tainted($bar += 0); test tainted($bar -= 2); test tainted($bar *= -1); test tainted($bar /= 1); test tainted($bar--); test $bar == 0; } # Test assignment and return of lists { my @foo = ("A", "tainted" . $TAINT, "B"); test not tainted $foo[0]; test tainted $foo[1]; test not tainted $foo[2]; my @bar = @foo; test not tainted $bar[0]; test tainted $bar[1]; test not tainted $bar[2]; my @baz = eval { "A", "tainted" . $TAINT, "B" }; test not tainted $baz[0]; test tainted $baz[1]; test not tainted $baz[2]; my @plugh = eval q[ "A", "tainted" . $TAINT, "B" ]; test not tainted $plugh[0]; test tainted $plugh[1]; test not tainted $plugh[2]; my $nautilus = sub { "A", "tainted" . $TAINT, "B" }; test not tainted ((&$nautilus)[0]); test tainted ((&$nautilus)[1]); test not tainted ((&$nautilus)[2]); my @xyzzy = &$nautilus; test not tainted $xyzzy[0]; test tainted $xyzzy[1]; test not tainted $xyzzy[2]; my $red_october = sub { return "A", "tainted" . $TAINT, "B" }; test not tainted ((&$red_october)[0]); test tainted ((&$red_october)[1]); test not tainted ((&$red_october)[2]); my @corge = &$red_october; test not tainted $corge[0]; test tainted $corge[1]; test not tainted $corge[2]; } # Test for system/library calls returning string data of dubious origin. { # No reliable %Config check for getpw* SKIP: { skip "getpwent() is not available", 1 unless eval { setpwent(); getpwent() }; setpwent(); my @getpwent = getpwent(); die "getpwent: $!\n" unless (@getpwent); test ( not tainted $getpwent[0] and tainted $getpwent[1] and not tainted $getpwent[2] and not tainted $getpwent[3] and not tainted $getpwent[4] and not tainted $getpwent[5] and tainted $getpwent[6] # ge?cos and not tainted $getpwent[7] and tainted $getpwent[8]); # shell endpwent(); } SKIP: { # pretty hard to imagine not skip "readdir() is not available", 1 unless $Config{d_readdir}; local(*D); opendir(D, "op") or die "opendir: $!\n"; my $readdir = readdir(D); test tainted $readdir; closedir(D); } SKIP: { skip "readlink() or symlink() is not available" unless $Config{d_readlink} && $Config{d_symlink}; my $symlink = "sl$$"; unlink($symlink); my $sl = "/something/naughty"; # it has to be a real path on Mac OS symlink($sl, $symlink) or die "symlink: $!\n"; my $readlink = readlink($symlink); test tainted $readlink; unlink($symlink); } } # test bitwise ops (regression bug) { my $why = "y"; my $j = "x" | $why; test not tainted $j; $why = $TAINT."y"; $j = "x" | $why; test tainted $j; } # test target of substitution (regression bug) { my $why = $TAINT."y"; $why =~ s/y/z/; test tainted $why; my $z = "[z]"; $why =~ s/$z/zee/; test tainted $why; $why =~ s/e/'-'.$$/ge; test tainted $why; } SKIP: { skip "no IPC::SysV", 2 unless $ipcsysv; # test shmread SKIP: { skip "shm*() not available", 1 unless $Config{d_shm}; no strict 'subs'; my $sent = "foobar"; my $rcvd; my $size = 2000; my $id = shmget(IPC_PRIVATE, $size, S_IRWXU); if (defined $id) { if (shmwrite($id, $sent, 0, 60)) { if (shmread($id, $rcvd, 0, 60)) { substr($rcvd, index($rcvd, "\0")) = ''; } else { warn "# shmread failed: $!\n"; } } else { warn "# shmwrite failed: $!\n"; } shmctl($id, IPC_RMID, 0) or warn "# shmctl failed: $!\n"; } else { warn "# shmget failed: $!\n"; } skip "SysV shared memory operation failed", 1 unless $rcvd eq $sent; test tainted $rcvd; } # test msgrcv SKIP: { skip "msg*() not available", 1 unless $Config{d_msg}; no strict 'subs'; my $id = msgget(IPC_PRIVATE, IPC_CREAT | S_IRWXU); my $sent = "message"; my $type_sent = 1234; my $rcvd; my $type_rcvd; if (defined $id) { if (msgsnd($id, pack("l! a*", $type_sent, $sent), IPC_NOWAIT)) { if (msgrcv($id, $rcvd, 60, 0, IPC_NOWAIT)) { ($type_rcvd, $rcvd) = unpack("l! a*", $rcvd); } else { warn "# msgrcv failed: $!\n"; } } else { warn "# msgsnd failed: $!\n"; } msgctl($id, IPC_RMID, 0) or warn "# msgctl failed: $!\n"; } else { warn "# msgget failed\n"; } SKIP: { skip "SysV message queue operation failed", 1 unless $rcvd eq $sent && $type_sent == $type_rcvd; test tainted $rcvd; } } } { # bug id 20001004.006 open IN, $TEST or warn "$0: cannot read $TEST: $!" ; local $/; my $a = ; my $b = ; ok tainted($a) && tainted($b) && !defined($b); close IN; } { # bug id 20001004.007 open IN, $TEST or warn "$0: cannot read $TEST: $!" ; my $a = ; my $c = { a => 42, b => $a }; ok !tainted($c->{a}) && tainted($c->{b}); my $d = { a => $a, b => 42 }; ok tainted($d->{a}) && !tainted($d->{b}); my $e = { a => 42, b => { c => $a, d => 42 } }; ok !tainted($e->{a}) && !tainted($e->{b}) && tainted($e->{b}->{c}) && !tainted($e->{b}->{d}); close IN; } { # bug id 20010519.003 BEGIN { use vars qw($has_fcntl); eval { require Fcntl; import Fcntl; }; unless ($@) { $has_fcntl = 1; } } SKIP: { skip "no Fcntl", 18 unless $has_fcntl; my $evil = "foo" . $TAINT; eval { sysopen(my $ro, $evil, &O_RDONLY) }; test $@ !~ /^Insecure dependency/, $@; eval { sysopen(my $wo, $evil, &O_WRONLY) }; test $@ =~ /^Insecure dependency/, $@; eval { sysopen(my $rw, $evil, &O_RDWR) }; test $@ =~ /^Insecure dependency/, $@; eval { sysopen(my $ap, $evil, &O_APPEND) }; test $@ =~ /^Insecure dependency/, $@; eval { sysopen(my $cr, $evil, &O_CREAT) }; test $@ =~ /^Insecure dependency/, $@; eval { sysopen(my $tr, $evil, &O_TRUNC) }; test $@ =~ /^Insecure dependency/, $@; eval { sysopen(my $ro, "foo", &O_RDONLY | $TAINT0) }; test $@ !~ /^Insecure dependency/, $@; eval { sysopen(my $wo, "foo", &O_WRONLY | $TAINT0) }; test $@ =~ /^Insecure dependency/, $@; eval { sysopen(my $rw, "foo", &O_RDWR | $TAINT0) }; test $@ =~ /^Insecure dependency/, $@; eval { sysopen(my $ap, "foo", &O_APPEND | $TAINT0) }; test $@ =~ /^Insecure dependency/, $@; eval { sysopen(my $cr, "foo", &O_CREAT | $TAINT0) }; test $@ =~ /^Insecure dependency/, $@; eval { sysopen(my $tr, "foo", &O_TRUNC | $TAINT0) }; test $@ =~ /^Insecure dependency/, $@; eval { sysopen(my $ro, "foo", &O_RDONLY, $TAINT0) }; test $@ !~ /^Insecure dependency/, $@; eval { sysopen(my $wo, "foo", &O_WRONLY, $TAINT0) }; test $@ =~ /^Insecure dependency/, $@; eval { sysopen(my $rw, "foo", &O_RDWR, $TAINT0) }; test $@ =~ /^Insecure dependency/, $@; eval { sysopen(my $ap, "foo", &O_APPEND, $TAINT0) }; test $@ =~ /^Insecure dependency/, $@; eval { sysopen(my $cr, "foo", &O_CREAT, $TAINT0) }; test $@ =~ /^Insecure dependency/, $@; eval { sysopen(my $tr, "foo", &O_TRUNC, $TAINT0) }; test $@ =~ /^Insecure dependency/, $@; unlink("foo"); # not unlink($evil), because that would fail... } } { # bug 20010526.004 use warnings; my $saw_warning = 0; local $SIG{__WARN__} = sub { $saw_warning = 1 }; sub fmi { my $divnum = shift()/1; sprintf("%1.1f\n", $divnum); } fmi(21 . $TAINT); fmi(37); fmi(248); test !$saw_warning; } { # Bug ID 20010730.010 my $i = 0; sub Tie::TIESCALAR { my $class = shift; my $arg = shift; bless \$arg => $class; } sub Tie::FETCH { $i ++; ${$_ [0]} } package main; my $bar = "The Big Bright Green Pleasure Machine"; taint_these $bar; tie my ($foo), Tie => $bar; my $baz = $foo; ok $i == 1; } { # Check that all environment variables are tainted. my @untainted; while (my ($k, $v) = each %ENV) { if (!tainted($v) && # These we have explicitly untainted or set earlier. $k !~ /^(BASH_ENV|CDPATH|ENV|IFS|PATH|PERL_CORE|TEMP|TERM|TMP)$/) { push @untainted, "# '$k' = '$v'\n"; } } test @untainted == 0, "untainted:\n @untainted"; } ok( ${^TAINT} == 1, '$^TAINT is on' ); eval { ${^TAINT} = 0 }; ok( ${^TAINT}, '$^TAINT is not assignable' ); ok( $@ =~ /^Modification of a read-only value attempted/, 'Assigning to ${^TAINT} fails' ); { # bug 20011111.105 my $re1 = qr/x$TAINT/; test tainted $re1; my $re2 = qr/^$re1\z/; test tainted $re2; my $re3 = "$re2"; test tainted $re3; } SKIP: { skip "system {} has different semantics on Win32", 1 if $Is_MSWin32; # bug 20010221.005 local $ENV{PATH} .= $TAINT; eval { system { "echo" } "/arg0", "arg1" }; test $@ =~ /^Insecure \$ENV/; } TODO: { todo_skip 'tainted %ENV warning occludes tainted arguments warning', 22 if $Is_VMS; # bug 20020208.005 plus some single arg exec/system extras my $err = qr/^Insecure dependency/ ; test !eval { exec $TAINT, $TAINT }, 'exec'; test $@ =~ $err, $@; test !eval { exec $TAINT $TAINT }, 'exec'; test $@ =~ $err, $@; test !eval { exec $TAINT $TAINT, $TAINT }, 'exec'; test $@ =~ $err, $@; test !eval { exec $TAINT 'notaint' }, 'exec'; test $@ =~ $err, $@; test !eval { exec {'notaint'} $TAINT }, 'exec'; test $@ =~ $err, $@; test !eval { system $TAINT, $TAINT }, 'system'; test $@ =~ $err, $@; test !eval { system $TAINT $TAINT }, 'system'; test $@ =~ $err, $@; test !eval { system $TAINT $TAINT, $TAINT }, 'system'; test $@ =~ $err, $@; test !eval { system $TAINT 'notaint' }, 'system'; test $@ =~ $err, $@; test !eval { system {'notaint'} $TAINT }, 'system'; test $@ =~ $err, $@; eval { no warnings; system("lskdfj does not exist","with","args"); }; test !$@; eval { no warnings; exec("lskdfj does not exist","with","args"); }; test !$@; # If you add tests here update also the above skip block for VMS. } { # [ID 20020704.001] taint propagation failure use re 'taint'; $TAINT =~ /(.*)/; test tainted(my $foo = $1); } { # [perl #24291] this used to dump core our %nonmagicalenv = ( PATH => "util" ); local *ENV = \%nonmagicalenv; eval { system("lskdfj"); }; test $@ =~ /^%ENV is aliased to another variable while running with -T switch/; local *ENV = *nonmagicalenv; eval { system("lskdfj"); }; test $@ =~ /^%ENV is aliased to %nonmagicalenv while running with -T switch/; } { # [perl #24248] $TAINT =~ /(.*)/; test !tainted($1); my $notaint = $1; test !tainted($notaint); my $l; $notaint =~ /($notaint)/; $l = $1; test !tainted($1); test !tainted($l); $notaint =~ /($TAINT)/; $l = $1; test tainted($1); test tainted($l); $TAINT =~ /($notaint)/; $l = $1; test !tainted($1); test !tainted($l); $TAINT =~ /($TAINT)/; $l = $1; test tainted($1); test tainted($l); my $r; ($r = $TAINT) =~ /($notaint)/; test !tainted($1); ($r = $TAINT) =~ /($TAINT)/; test tainted($1); # [perl #24674] # accessing $^O shoudn't taint it as a side-effect; # assigning tainted data to it is now an error test !tainted($^O); if (!$^X) { } elsif ($^O eq 'bar') { } test !tainted($^O); eval '$^O = $^X'; test $@ =~ /Insecure dependency in/; } EFFECTIVELY_CONSTANTS: { my $tainted_number = 12 + $TAINT0; test tainted( $tainted_number ); # Even though it's always 0, it's still tainted my $tainted_product = $tainted_number * 0; test tainted( $tainted_product ); test $tainted_product == 0; } TERNARY_CONDITIONALS: { my $tainted_true = $TAINT . "blah blah blah"; my $tainted_false = $TAINT0; test tainted( $tainted_true ); test tainted( $tainted_false ); my $result = $tainted_true ? "True" : "False"; test $result eq "True"; test !tainted( $result ); $result = $tainted_false ? "True" : "False"; test $result eq "False"; test !tainted( $result ); my $untainted_whatever = "The Fabulous Johnny Cash"; my $tainted_whatever = "Soft Cell" . $TAINT; $result = $tainted_true ? $tainted_whatever : $untainted_whatever; test $result eq "Soft Cell"; test tainted( $result ); $result = $tainted_false ? $tainted_whatever : $untainted_whatever; test $result eq "The Fabulous Johnny Cash"; test !tainted( $result ); } { # rt.perl.org 5900 $1 remains tainted if... # 1) The regular expression contains a scalar variable AND # 2) The regular expression appears in an elsif clause my $foo = "abcdefghi" . $TAINT; my $valid_chars = 'a-z'; if ( $foo eq '' ) { } elsif ( $foo =~ /([$valid_chars]+)/o ) { test not tainted $1; } if ( $foo eq '' ) { } elsif ( my @bar = $foo =~ /([$valid_chars]+)/o ) { test not any_tainted @bar; } } # at scope exit, a restored localised value should have its old # taint status, not the taint status of the current statement { our $x99 = $^X; test tainted $x99; $x99 = ''; test not tainted $x99; my $c = do { local $x99; $^X }; test not tainted $x99; } { our $x99 = $^X; test tainted $x99; my $c = do { local $x99; '' }; test tainted $x99; } # an mg_get of a tainted value during localization shouldn't taint the # statement { eval { local $0, eval '1' }; test $@ eq ''; } # [perl #8262] //g loops infinitely on tainted data { my @a; local $::TODO = 1; $a[0] = $^X; my $i = 0; while($a[0]=~ m/(.)/g ) { last if $i++ > 10000; } cmp_ok $i, '<', 10000, "infinite m//g"; } SKIP: { my $got_dualvar; eval 'use Scalar::Util "dualvar"; $got_dualvar++'; skip "No Scalar::Util::dualvar" unless $got_dualvar; my $a = Scalar::Util::dualvar(3, $^X); my $b = $a + 5; is ($b, 8, "Arithmetic on tainted dualvars works"); } # opening '|-' should not trigger $ENV{PATH} check { SKIP: { skip "fork() is not available", 3 unless $Config{'d_fork'}; skip "opening |- is not stable on threaded OpenBSD with taint", 3 if $Config{useithreads} && $Is_OpenBSD; $ENV{'PATH'} = $TAINT; local $SIG{'PIPE'} = 'IGNORE'; eval { my $pid = open my $pipe, '|-'; if (!defined $pid) { die "open failed: $!"; } if (!$pid) { kill 'KILL', $$; # child suicide } close $pipe; }; test $@ !~ /Insecure \$ENV/, 'fork triggers %ENV check'; test $@ eq '', 'pipe/fork/open/close failed'; eval { open my $pipe, "|$Invoke_Perl -e 1"; close $pipe; }; test $@ =~ /Insecure \$ENV/, 'popen neglects %ENV check'; } } { package AUTOLOAD_TAINT; sub AUTOLOAD { our $AUTOLOAD; return if $AUTOLOAD =~ /DESTROY/; if ($AUTOLOAD =~ /untainted/) { main::ok(!main::tainted($AUTOLOAD), '$AUTOLOAD can be untainted'); } else { main::ok(main::tainted($AUTOLOAD), '$AUTOLOAD can be tainted'); } } package main; my $o = bless [], 'AUTOLOAD_TAINT'; $o->$TAINT; $o->untainted; } { # tests for tainted format in s?printf eval { printf($TAINT . "# %s\n", "foo") }; like($@, qr/^Insecure dependency in printf/, q/printf doesn't like tainted formats/); eval { printf("# %s\n", $TAINT . "foo") }; ok(!$@, q/printf accepts other tainted args/); eval { sprintf($TAINT . "# %s\n", "foo") }; like($@, qr/^Insecure dependency in sprintf/, q/sprintf doesn't like tainted formats/); eval { sprintf("# %s\n", $TAINT . "foo") }; ok(!$@, q/sprintf accepts other tainted args/); } { # 40708 my $n = 7e9; 8e9 - $n; my $val = $n; is ($val, '7000000000', 'Assignment to untainted variable'); $val = $TAINT; $val = $n; is ($val, '7000000000', 'Assignment to tainted variable'); } { my $val = 0; my $tainted = '1' . $TAINT; eval '$val = eval $tainted;'; is ($val, 0, "eval doesn't like tainted strings"); like ($@, qr/^Insecure dependency in eval/); # Rather nice code to get a tainted undef by from Rick Delaney open FH, "test.pl" or die $!; seek FH, 0, 2 or die $!; $tainted = ; eval 'eval $tainted'; like ($@, qr/^Insecure dependency in eval/); } foreach my $ord (78, 163, 256) { # 47195 my $line = 'A1' . $TAINT . chr $ord; chop $line; is($line, 'A1'); $line =~ /(A\S*)/; ok(!tainted($1), "\\S match with chr $ord"); } { # 59998 sub cr { my $x = crypt($_[0], $_[1]); $x } sub co { my $x = ~$_[0]; $x } my ($a, $b); $a = cr('hello', 'foo' . $TAINT); $b = cr('hello', 'foo'); ok(tainted($a), "tainted crypt"); ok(!tainted($b), "untainted crypt"); $a = co('foo' . $TAINT); $b = co('foo'); ok(tainted($a), "tainted complement"); ok(!tainted($b), "untainted complement"); } { my @data = qw(bonk zam zlonk qunckkk); # Clearly some sort of usenet bang-path my $string = $TAINT . join "!", @data; ok(tainted($string), "tainted data"); my @got = split /!|,/, $string; # each @got would be useful here, but I want the test for earlier perls for my $i (0 .. $#data) { ok(tainted($got[$i]), "tainted result $i"); is($got[$i], $data[$i], "correct content $i"); } ok(tainted($string), "still tainted data"); my @got = split /[!,]/, $string; # each @got would be useful here, but I want the test for earlier perls for my $i (0 .. $#data) { ok(tainted($got[$i]), "tainted result $i"); is($got[$i], $data[$i], "correct content $i"); } ok(tainted($string), "still tainted data"); my @got = split /!/, $string; # each @got would be useful here, but I want the test for earlier perls for my $i (0 .. $#data) { ok(tainted($got[$i]), "tainted result $i"); is($got[$i], $data[$i], "correct content $i"); } } # Bug RT #52552 - broken by change at git commit id f337b08 { my $x = $TAINT. q{print "Hello world\n"}; my $y = pack "a*", $x; ok(tainted($y), "pack a* preserves tainting"); my $z = pack "A*", q{print "Hello world\n"}.$TAINT; ok(tainted($z), "pack A* preserves tainting"); my $zz = pack "a*a*", q{print "Hello world\n"}, $TAINT; ok(tainted($zz), "pack a*a* preserves tainting"); } # Bug RT #61976 tainted $! would show numeric rather than string value { my $tainted_path = substr($^X,0,0) . "/no/such/file"; my $err; # $! is used in a tainted expression, so gets tainted open my $fh, $tainted_path or $err= "$!"; unlike($err, qr/^\d+$/, 'tainted $!'); } # This may bomb out with the alarm signal so keep it last SKIP: { skip "No alarm()" unless $Config{d_alarm}; # Test from RT #41831] # [PATCH] Bug & fix: hang when using study + taint mode (perl 5.6.1, 5.8.x) my $DATA = <<'END' . $TAINT; line1 is here line2 is here line3 is here line4 is here END #study $DATA; ## don't set $SIG{ALRM}, since we'd never get to a user-level handler as ## perl is stuck in a regexp infinite loop! alarm(10); if ($DATA =~ /^line2.*line4/m) { fail("Should not be a match") } else { pass("Match on tainted multiline data should fail promptly"); } alarm(0); } __END__ # Keep the previous test last perl-5.12.0-RC0/t/op/repeat.t0000555000175000017500000001121311325125742014456 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } require './test.pl'; plan(tests => 42); # compile time is('-' x 5, '-----', 'compile time x'); is('-' x 3.1, '---', 'compile time 3.1'); is('-' x 3.9, '---', 'compile time 3.9'); is('-' x 1, '-', ' x 1'); is('-' x 0, '', ' x 0'); is('-' x -1, '', ' x -1'); is('-' x undef, '', ' x undef'); is('-' x "foo", '', ' x "foo"'); is('-' x "3rd", '---', ' x "3rd"'); is('ab' x 3, 'ababab', ' more than one char'); # run time $a = '-'; is($a x 5, '-----', 'run time x'); is($a x 3.1, '---', ' x 3.1'); is($a x 3.9, '---', ' x 3.9'); is($a x 1, '-', ' x 1'); is($a x 0, '', ' x 0'); is($a x -3, '', ' x -3'); is($a x undef, '', ' x undef'); is($a x "foo", '', ' x "foo"'); is($a x "3rd", '---', ' x "3rd"'); $a = 'ab'; is($a x 3, 'ababab', ' more than one char'); $a = 'ab'; is($a x 0, '', ' more than one char'); $a = 'ab'; is($a x -12, '', ' more than one char'); $a = 'xyz'; $a x= 2; is($a, 'xyzxyz', 'x=2'); $a x= 1; is($a, 'xyzxyz', 'x=1'); $a x= 0; is($a, '', 'x=0'); @x = (1,2,3); is(join('', @x x 4), '3333', '@x x Y'); is(join('', (@x) x 4), '123123123123', '(@x) x Y'); is(join('', (@x,()) x 4), '123123123123', '(@x,()) x Y'); is(join('', (@x,1) x 4), '1231123112311231', '(@x,1) x Y'); is(join(':', () x 4), '', '() x Y'); is(join(':', (9) x 4), '9:9:9:9', '(X) x Y'); is(join(':', (9,9) x 4), '9:9:9:9:9:9:9:9', '(X,X) x Y'); is(join('', (split(//,"123")) x 2), '123123', 'split and x'); is(join('', @x x -12), '', '@x x -12'); is(join('', (@x) x -14), '', '(@x) x -14'); # This test is actually testing for Digital C compiler optimizer bug, # present in Dec C versions 5.* and 6.0 (used in Digital UNIX and VMS), # found in December 1998. The bug was reported to Digital^WCompaq as # DECC 2745 (21-Dec-1998) # GEM_BUGS 7619 (23-Dec-1998) # As of April 1999 the bug has been fixed in Tru64 UNIX 5.0 and is planned # to be fixed also in 4.0G. # # The bug was as follows: broken code was produced for util.c:repeatcpy() # (a utility function for the 'x' operator) in the case *all* these # four conditions held: # # (1) len == 1 # (2) "from" had the 8th bit on in its single character # (3) count > 7 (the 'x' count > 16) # (4) the highest optimization level was used in compilation # (which is the default when compiling Perl) # # The bug looked like this (. being the eight-bit character and ? being \xff): # # 16 ................ # 17 .........???????. # 18 .........???????.. # 19 .........???????... # 20 .........???????.... # 21 .........???????..... # 22 .........???????...... # 23 .........???????....... # 24 .........???????.??????? # 25 .........???????.???????. # # The bug was triggered in the "if (len == 1)" branch. The fix # was to introduce a new temporary variable. In diff -u format: # # register char *frombase = from; # # if (len == 1) { #- todo = *from; #+ register char c = *from; # while (count-- > 0) #- *to++ = todo; #+ *to++ = c; # return; # } # # The bug could also be (obscurely) avoided by changing "from" to # be an unsigned char pointer. # # This obscure bug was not found by the then test suite but instead # by Mark.Martinec@nsc.ijs.si while trying to install Digest-MD5-2.00. # # jhi@iki.fi # is("\xdd" x 24, "\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd", 'Dec C bug'); # When we use a list repeat in a scalar context, it behaves like # a scalar repeat. Make sure that works properly, and doesn't leave # extraneous values on the stack. # -- robin@kitsite.com my ($x, $y) = scalar ((1,2)x2); is($x, "22", 'list repeat in scalar context'); is($y, undef, ' no extra values on stack'); # Make sure the stack doesn't get truncated too much - the left # operand of the eq binop needs to remain! is(77, scalar ((1,7)x2), 'stack truncation'); # perlbug 20011113.110 works in 5.6.1, broken in 5.7.2 { my $x= [("foo") x 2]; is( join('', @$x), 'foofoo', 'list repeat in anon array ref broken [ID 20011113.110]' ); } # [ID 20010809.028] x operator not copying elements in 'for' list? { local $TODO = "x operator not copying elements in 'for' list? [ID 20010809.028]"; my $x = 'abcd'; my $y = ''; for (($x =~ /./g) x 2) { $y .= chop; } is($y, 'abcdabcd'); } # [perl #35885] is( (join ',', (qw(a b c) x 3)), 'a,b,c,a,b,c,a,b,c', 'x on qw produces list' ); perl-5.12.0-RC0/t/op/not.t0000555000175000017500000000125511143650501013775 0ustar jessejesse#!./perl -w BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } plan tests => 16; # not() tests pass() if not(); is(not(), 1); is(not(), not(0)); # test not(..) and ! is(! 1, not 1); is(! 0, not 0); is(! (0, 0), not(0, 0)); # test the return of ! { my $not0 = ! 0; my $not1 = ! 1; no warnings; ok($not1 == undef); ok($not1 == ()); use warnings; ok($not1 eq ''); ok($not1 == 0); ok($not0 == 1); } # test the return of not { my $not0 = not 0; my $not1 = not 1; no warnings; ok($not1 == undef); ok($not1 == ()); use warnings; ok($not1 eq ''); ok($not1 == 0); ok($not0 == 1); } perl-5.12.0-RC0/t/op/lc.t0000555000175000017500000001636011325127001013572 0ustar jessejesse#!./perl BEGIN { chdir 't'; @INC = '../lib'; require './test.pl'; } plan tests => 93; is(lc(undef), "", "lc(undef) is ''"); is(lcfirst(undef), "", "lcfirst(undef) is ''"); is(uc(undef), "", "uc(undef) is ''"); is(ucfirst(undef), "", "ucfirst(undef) is ''"); $a = "HELLO.* world"; $b = "hello.* WORLD"; is("\Q$a\E." , "HELLO\\.\\*\\ world.", '\Q\E HELLO.* world'); is("\u$a" , "HELLO\.\* world", '\u'); is("\l$a" , "hELLO\.\* world", '\l'); is("\U$a" , "HELLO\.\* WORLD", '\U'); is("\L$a" , "hello\.\* world", '\L'); is(quotemeta($a) , "HELLO\\.\\*\\ world", 'quotemeta'); is(ucfirst($a) , "HELLO\.\* world", 'ucfirst'); is(lcfirst($a) , "hELLO\.\* world", 'lcfirst'); is(uc($a) , "HELLO\.\* WORLD", 'uc'); is(lc($a) , "hello\.\* world", 'lc'); is("\Q$b\E." , "hello\\.\\*\\ WORLD.", '\Q\E hello.* WORLD'); is("\u$b" , "Hello\.\* WORLD", '\u'); is("\l$b" , "hello\.\* WORLD", '\l'); is("\U$b" , "HELLO\.\* WORLD", '\U'); is("\L$b" , "hello\.\* world", '\L'); is(quotemeta($b) , "hello\\.\\*\\ WORLD", 'quotemeta'); is(ucfirst($b) , "Hello\.\* WORLD", 'ucfirst'); is(lcfirst($b) , "hello\.\* WORLD", 'lcfirst'); is(uc($b) , "HELLO\.\* WORLD", 'uc'); is(lc($b) , "hello\.\* world", 'lc'); # \x{100} is LATIN CAPITAL LETTER A WITH MACRON; its bijective lowercase is # \x{101}, LATIN SMALL LETTER A WITH MACRON. $a = "\x{100}\x{101}Aa"; $b = "\x{101}\x{100}aA"; is("\Q$a\E." , "\x{100}\x{101}Aa.", '\Q\E \x{100}\x{101}Aa'); is("\u$a" , "\x{100}\x{101}Aa", '\u'); is("\l$a" , "\x{101}\x{101}Aa", '\l'); is("\U$a" , "\x{100}\x{100}AA", '\U'); is("\L$a" , "\x{101}\x{101}aa", '\L'); is(quotemeta($a) , "\x{100}\x{101}Aa", 'quotemeta'); is(ucfirst($a) , "\x{100}\x{101}Aa", 'ucfirst'); is(lcfirst($a) , "\x{101}\x{101}Aa", 'lcfirst'); is(uc($a) , "\x{100}\x{100}AA", 'uc'); is(lc($a) , "\x{101}\x{101}aa", 'lc'); is("\Q$b\E." , "\x{101}\x{100}aA.", '\Q\E \x{101}\x{100}aA'); is("\u$b" , "\x{100}\x{100}aA", '\u'); is("\l$b" , "\x{101}\x{100}aA", '\l'); is("\U$b" , "\x{100}\x{100}AA", '\U'); is("\L$b" , "\x{101}\x{101}aa", '\L'); is(quotemeta($b) , "\x{101}\x{100}aA", 'quotemeta'); is(ucfirst($b) , "\x{100}\x{100}aA", 'ucfirst'); is(lcfirst($b) , "\x{101}\x{100}aA", 'lcfirst'); is(uc($b) , "\x{100}\x{100}AA", 'uc'); is(lc($b) , "\x{101}\x{101}aa", 'lc'); # \x{DF} is LATIN SMALL LETTER SHARP S, its uppercase is SS or \x{53}\x{53}; # \x{149} is LATIN SMALL LETTER N PRECEDED BY APOSTROPHE, its uppercase is # \x{2BC}\x{E4} or MODIFIER LETTER APOSTROPHE and N. # In EBCDIC \x{DF} is LATIN SMALL LETTER Y WITH DIAERESIS, # and it's uppercase is \x{178}, LATIN CAPITAL LETTER Y WITH DIAERESIS. if (ord("A") == 193) { # EBCDIC is("\U\x{DF}aB\x{149}cD" , "\x{178}AB\x{2BC}NCD", "multicharacter uppercase"); } elsif (ord("A") == 65) { is("\U\x{DF}aB\x{149}cD" , "SSAB\x{2BC}NCD", "multicharacter uppercase"); } else { fail("what is your encoding?"); } # The \x{DF} is its own lowercase, ditto for \x{149}. # There are no single character -> multiple characters lowercase mappings. if (ord("A") == 193) { # EBCDIC is("\LaB\x{149}cD" , "ab\x{149}cd", "multicharacter lowercase"); } elsif (ord("A") == 65) { is("\L\x{DF}aB\x{149}cD" , "\x{DF}ab\x{149}cd", "multicharacter lowercase"); } else { fail("what is your encoding?"); } # titlecase is used for \u / ucfirst. # \x{587} is ARMENIAN SMALL LIGATURE ECH YIWN and its titlecase is # \x{535}\x{582} ARMENIAN CAPITAL LETTER ECH + ARMENIAN SMALL LETTER YIWN # while its lowercase is # \x{587} itself # and its uppercase is # \x{535}\x{552} ARMENIAN CAPITAL LETTER ECH + ARMENIAN CAPITAL LETTER YIWN $a = "\x{587}"; is("\L\x{587}" , "\x{587}", "ligature lowercase"); is("\u\x{587}" , "\x{535}\x{582}", "ligature titlecase"); is("\U\x{587}" , "\x{535}\x{552}", "ligature uppercase"); # mktables had problems where many-to-one case mappings didn't work right. # The lib/uni/fold.t should give the fourth folding, "casefolding", a good # workout (one cannot directly get that from Perl). # \x{01C4} is LATIN CAPITAL LETTER DZ WITH CARON # \x{01C5} is LATIN CAPITAL LETTER D WITH SMALL LETTER Z WITH CARON # \x{01C6} is LATIN SMALL LETTER DZ WITH CARON # \x{03A3} is GREEK CAPITAL LETTER SIGMA # \x{03C2} is GREEK SMALL LETTER FINAL SIGMA # \x{03C3} is GREEK SMALL LETTER SIGMA is(lc("\x{1C4}") , "\x{1C6}", "U+01C4 lc is U+01C6"); is(lc("\x{1C5}") , "\x{1C6}", "U+01C5 lc is U+01C6, too"); is(ucfirst("\x{3C2}") , "\x{3A3}", "U+03C2 ucfirst is U+03A3"); is(ucfirst("\x{3C3}") , "\x{3A3}", "U+03C3 ucfirst is U+03A3, too"); is(uc("\x{1C5}") , "\x{1C4}", "U+01C5 uc is U+01C4"); is(uc("\x{1C6}") , "\x{1C4}", "U+01C6 uc is U+01C4, too"); # #18107: A host of bugs involving [ul]c{,first}. AMS 20021106 $a = "\x{3c3}foo.bar"; # \x{3c3} == GREEK SMALL LETTER SIGMA. $b = "\x{3a3}FOO.BAR"; # \x{3a3} == GREEK CAPITAL LETTER SIGMA. ($c = $b) =~ s/(\w+)/lc($1)/ge; is($c , $a, "Using s///e to change case."); ($c = $a) =~ s/(\p{IsWord}+)/uc($1)/ge; is($c , $b, "Using s///e to change case."); ($c = $b) =~ s/(\p{IsWord}+)/lcfirst($1)/ge; is($c , "\x{3c3}FOO.bAR", "Using s///e to change case."); ($c = $a) =~ s/(\p{IsWord}+)/ucfirst($1)/ge; is($c , "\x{3a3}foo.Bar", "Using s///e to change case."); # #18931: perl5.8.0 bug in \U..\E processing # Test case from Nicholas Clark. for my $a (0,1) { $_ = 'abcdefgh'; $_ .= chr 256; chop; /(.*)/; is(uc($1), "ABCDEFGH", "[perl #18931]"); } { foreach (0, 1) { $a = v10.v257; chop $a; $a =~ s/^(\s*)(\w*)/$1\u$2/; is($a, v10, "[perl #18857]"); } } # [perl #38619] Bug in lc and uc (interaction between UTF-8, substr, and lc/uc) for ("a\x{100}", "xyz\x{100}") { is(substr(uc($_), 0), uc($_), "[perl #38619] uc"); } for ("A\x{100}", "XYZ\x{100}") { is(substr(lc($_), 0), lc($_), "[perl #38619] lc"); } for ("a\x{100}", "ßyz\x{100}") { # ß to Ss (different length) is(substr(ucfirst($_), 0), ucfirst($_), "[perl #38619] ucfirst"); } # Related to [perl #38619] # the original report concerns PERL_MAGIC_utf8. # these cases concern PERL_MAGIC_regex_global. for (map { $_ } "a\x{100}", "abc\x{100}", "\x{100}") { chop; # get ("a", "abc", "") in utf8 my $return = uc($_) =~ /\G(.?)/g; my $result = $return ? $1 : "not"; my $expect = (uc($_) =~ /(.?)/g)[0]; is($return, 1, "[perl #38619]"); is($result, $expect, "[perl #38619]"); } for (map { $_ } "A\x{100}", "ABC\x{100}", "\x{100}") { chop; # get ("A", "ABC", "") in utf8 my $return = lc($_) =~ /\G(.?)/g; my $result = $return ? $1 : "not"; my $expect = (lc($_) =~ /(.?)/g)[0]; is($return, 1, "[perl #38619]"); is($result, $expect, "[perl #38619]"); } for (1, 4, 9, 16, 25) { is(uc "\x{03B0}" x $_, "\x{3a5}\x{308}\x{301}" x $_, 'uc U+03B0 grows threefold'); is(lc "\x{0130}" x $_, "i\x{307}" x $_, 'lc U+0130 grows'); } # bug #43207 my $temp = "Hello"; for ("$temp") { lc $_; is($_, "Hello"); } # new in Unicode 5.1.0 is(lc("\x{1E9E}"), "\x{df}", "lc(LATIN CAPITAL LETTER SHARP S)"); perl-5.12.0-RC0/t/op/sub_lval.t0000555000175000017500000002315511325127002015004 0ustar jessejesseBEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } plan tests=>71; sub a : lvalue { my $a = 34; ${\(bless \$a)} } # Return a temporary sub b : lvalue { ${\shift} } my $out = a(b()); # Check that temporaries are allowed. is(ref $out, 'main'); # Not reached if error. my @out = grep /main/, a(b()); # Check that temporaries are allowed. cmp_ok(scalar @out, '==', 1); # Not reached if error. my $in; # Check that we can return localized values from subroutines: sub in : lvalue { $in = shift; } sub neg : lvalue { #(num_str) return num_str local $_ = shift; s/^\+/-/; $_; } in(neg("+2")); is($in, '-2'); sub get_lex : lvalue { $in } sub get_st : lvalue { $blah } sub id : lvalue { ${\shift} } sub id1 : lvalue { $_[0] } sub inc : lvalue { ${\++$_[0]} } $in = 5; $blah = 3; get_st = 7; cmp_ok($blah, '==', 7); get_lex = 7; cmp_ok($in, '==', 7); ++get_st; cmp_ok($blah, '==', 8); ++get_lex; cmp_ok($in, '==', 8); id(get_st) = 10; cmp_ok($blah, '==', 10); id(get_lex) = 10; cmp_ok($in, '==', 10); ++id(get_st); cmp_ok($blah, '==', 11); ++id(get_lex); cmp_ok($in, '==', 11); id1(get_st) = 20; cmp_ok($blah, '==', 20); id1(get_lex) = 20; cmp_ok($in, '==', 20); ++id1(get_st); cmp_ok($blah, '==', 21); ++id1(get_lex); cmp_ok($in, '==', 21); inc(get_st); cmp_ok($blah, '==', 22); inc(get_lex); cmp_ok($in, '==', 22); inc(id(get_st)); cmp_ok($blah, '==', 23); inc(id(get_lex)); cmp_ok($in, '==', 23); ++inc(id1(id(get_st))); cmp_ok($blah, '==', 25); ++inc(id1(id(get_lex))); cmp_ok($in, '==', 25); @a = (1) x 3; @b = (undef) x 2; $#c = 3; # These slots are not fillable. # Explanation: empty slots contain &sv_undef. =for disabled constructs sub a3 :lvalue {@a} sub b2 : lvalue {@b} sub c4: lvalue {@c} $_ = ''; eval <<'EOE' or $_ = $@; ($x, a3, $y, b2, $z, c4, $t) = (34 .. 78); 1; EOE #@out = ($x, a3, $y, b2, $z, c4, $t); #@in = (34 .. 41, (undef) x 4, 46); #print "# `@out' ne `@in'\nnot " unless "@out" eq "@in"; like($_, qr/Can\'t return an uninitialized value from lvalue subroutine/); print "ok 22\n"; =cut my $var; sub a::var : lvalue { $var } "a"->var = 45; cmp_ok($var, '==', 45); my $oo; $o = bless \$oo, "a"; $o->var = 47; cmp_ok($var, '==', 47); sub o : lvalue { $o } o->var = 49; cmp_ok($var, '==', 49); sub nolv () { $x0, $x1 } # Not lvalue $_ = ''; eval <<'EOE' or $_ = $@; nolv = (2,3); 1; EOE like($_, qr/Can\'t modify non-lvalue subroutine call in scalar assignment/); $_ = ''; eval <<'EOE' or $_ = $@; nolv = (2,3) if $_; 1; EOE like($_, qr/Can\'t modify non-lvalue subroutine call in scalar assignment/); $_ = ''; eval <<'EOE' or $_ = $@; &nolv = (2,3) if $_; 1; EOE like($_, qr/Can\'t modify non-lvalue subroutine call in scalar assignment/); $x0 = $x1 = $_ = undef; $nolv = \&nolv; eval <<'EOE' or $_ = $@; $nolv->() = (2,3) if $_; 1; EOE ok(!defined $_) or diag "'$_', '$x0', '$x1'"; $x0 = $x1 = $_ = undef; $nolv = \&nolv; eval <<'EOE' or $_ = $@; $nolv->() = (2,3); 1; EOE like($_, qr/Can\'t modify non-lvalue subroutine call/) or diag "'$_', '$x0', '$x1'"; sub lv0 : lvalue { } # Converted to lv10 in scalar context $_ = undef; eval <<'EOE' or $_ = $@; lv0 = (2,3); 1; EOE like($_, qr/Can't return undef from lvalue subroutine/); sub lv10 : lvalue {} $_ = undef; eval <<'EOE' or $_ = $@; (lv0) = (2,3); 1; EOE ok(!defined $_) or diag $_; sub lv1u :lvalue { undef } $_ = undef; eval <<'EOE' or $_ = $@; lv1u = (2,3); 1; EOE like($_, qr/Can't return undef from lvalue subroutine/); $_ = undef; eval <<'EOE' or $_ = $@; (lv1u) = (2,3); 1; EOE # Fixed by change @10777 #print "# '$_'.\nnot " # unless /Can\'t return an uninitialized value from lvalue subroutine/; # print "ok 34 # Skip: removed test\n"; $x = '1234567'; $_ = undef; eval <<'EOE' or $_ = $@; sub lv1t : lvalue { index $x, 2 } lv1t = (2,3); 1; EOE like($_, qr/Can\'t modify index in lvalue subroutine return/); $_ = undef; eval <<'EOE' or $_ = $@; sub lv2t : lvalue { shift } (lv2t) = (2,3); 1; EOE like($_, qr/Can\'t modify shift in lvalue subroutine return/); $xxx = 'xxx'; sub xxx () { $xxx } # Not lvalue $_ = undef; eval <<'EOE' or $_ = $@; sub lv1tmp : lvalue { xxx } # is it a TEMP? lv1tmp = (2,3); 1; EOE like($_, qr/Can\'t modify non-lvalue subroutine call in lvalue subroutine return/); $_ = undef; eval <<'EOE' or $_ = $@; (lv1tmp) = (2,3); 1; EOE like($_, qr/Can\'t return a temporary from lvalue subroutine/); sub yyy () { 'yyy' } # Const, not lvalue $_ = undef; eval <<'EOE' or $_ = $@; sub lv1tmpr : lvalue { yyy } # is it read-only? lv1tmpr = (2,3); 1; EOE like($_, qr/Can\'t modify constant item in lvalue subroutine return/); $_ = undef; eval <<'EOE' or $_ = $@; (lv1tmpr) = (2,3); 1; EOE like($_, qr/Can\'t return a readonly value from lvalue subroutine/); sub lva : lvalue {@a} $_ = undef; @a = (); $a[1] = 12; eval <<'EOE' or $_ = $@; (lva) = (2,3); 1; EOE is("'@a' $_", "'2 3' "); $_ = undef; @a = (); $a[0] = undef; $a[1] = 12; eval <<'EOE' or $_ = $@; (lva) = (2,3); 1; EOE is("'@a' $_", "'2 3' "); $_ = undef; @a = (); $a[0] = undef; $a[1] = 12; eval <<'EOE' or $_ = $@; (lva) = (2,3); 1; EOE is("'@a' $_", "'2 3' "); sub lv1n : lvalue { $newvar } $_ = undef; eval <<'EOE' or $_ = $@; lv1n = (3,4); 1; EOE is("'$newvar' $_", "'4' "); sub lv1nn : lvalue { $nnewvar } $_ = undef; eval <<'EOE' or $_ = $@; (lv1nn) = (3,4); 1; EOE is("'$nnewvar' $_", "'3' "); $a = \&lv1nn; $a->() = 8; is($nnewvar, '8'); eval 'sub AUTOLOAD : lvalue { $newvar }'; foobar() = 12; is($newvar, "12"); { my %hash; my @array; sub alv : lvalue { $array[1] } sub alv2 : lvalue { $array[$_[0]] } sub hlv : lvalue { $hash{"foo"} } sub hlv2 : lvalue { $hash{$_[0]} } $array[1] = "not ok 51\n"; alv() = "ok 50\n"; is(alv(), "ok 50\n"); alv2(20) = "ok 51\n"; is($array[20], "ok 51\n"); $hash{"foo"} = "not ok 52\n"; hlv() = "ok 52\n"; is($hash{foo}, "ok 52\n"); $hash{bar} = "not ok 53\n"; hlv("bar") = "ok 53\n"; is(hlv("bar"), "ok 53\n"); sub array : lvalue { @array } sub array2 : lvalue { @array2 } # This is a global. sub hash : lvalue { %hash } sub hash2 : lvalue { %hash2 } # So's this. @array2 = qw(foo bar); %hash2 = qw(foo bar); (array()) = qw(ok 54); is("@array", "ok 54"); (array2()) = qw(ok 55); is("@array2", "ok 55"); (hash()) = qw(ok 56); cmp_ok($hash{ok}, '==', 56); (hash2()) = qw(ok 57); cmp_ok($hash2{ok}, '==', 57); @array = qw(a b c d); sub aslice1 : lvalue { @array[0,2] }; (aslice1()) = ("ok", "already"); is("@array", "ok b already d"); @array2 = qw(a B c d); sub aslice2 : lvalue { @array2[0,2] }; (aslice2()) = ("ok", "already"); is("@array2", "ok B already d"); %hash = qw(a Alpha b Beta c Gamma); sub hslice : lvalue { @hash{"c", "b"} } (hslice()) = ("CISC", "BogoMIPS"); is(join("/",@hash{"c","a","b"}), "CISC/Alpha/BogoMIPS"); } $str = "Hello, world!"; sub sstr : lvalue { substr($str, 1, 4) } sstr() = "i"; is($str, "Hi, world!"); $str = "Made w/ JavaScript"; sub veclv : lvalue { vec($str, 2, 32) } if (ord('A') != 193) { veclv() = 0x5065726C; } else { # EBCDIC? veclv() = 0xD7859993; } is($str, "Made w/ PerlScript"); sub position : lvalue { pos } @p = (); $_ = "fee fi fo fum"; while (/f/g) { push @p, position; position() += 6; } is("@p", "1 8"); # Bug 20001223.002: split thought that the list had only one element @ary = qw(4 5 6); sub lval1 : lvalue { $ary[0]; } sub lval2 : lvalue { $ary[1]; } (lval1(), lval2()) = split ' ', "1 2 3 4"; is(join(':', @ary), "1:2:6"); # check that an element of a tied hash/array can be assigned to via lvalueness package Tie_Hash; our ($key, $val); sub TIEHASH { bless \my $v => __PACKAGE__ } sub STORE { ($key, $val) = @_[1,2] } package main; sub lval_tie_hash : lvalue { tie my %t => 'Tie_Hash'; $t{key}; } eval { lval_tie_hash() = "value"; }; is($@, "", "element of tied hash"); is("$Tie_Hash::key-$Tie_Hash::val", "key-value"); package Tie_Array; our @val; sub TIEARRAY { bless \my $v => __PACKAGE__ } sub STORE { $val[ $_[1] ] = $_[2] } package main; sub lval_tie_array : lvalue { tie my @t => 'Tie_Array'; $t[0]; } eval { lval_tie_array() = "value"; }; is($@, "", "element of tied array"); is ($Tie_Array::val[0], "value"); TODO: { local $TODO = 'test explicit return of lval expr'; # subs are corrupted copies from tests 1-~4 sub bad_get_lex : lvalue { return $in }; sub bad_get_st : lvalue { return $blah } sub bad_id : lvalue { return ${\shift} } sub bad_id1 : lvalue { return $_[0] } sub bad_inc : lvalue { return ${\++$_[0]} } $in = 5; $blah = 3; bad_get_st = 7; is( $blah, 7 ); bad_get_lex = 7; is($in, 7, "yada"); ++bad_get_st; is($blah, 8, "yada"); } TODO: { local $TODO = "bug #23790"; my @arr = qw /one two three/; my $line = "zero"; sub lval_array () : lvalue {@arr} for (lval_array) { $line .= $_; } is($line, "zeroonetwothree"); } { package Foo; sub AUTOLOAD :lvalue { *{$AUTOLOAD} }; package main; my $foo = bless {},"Foo"; my $result; $foo->bar = sub { $result = "bar" }; $foo->bar; is ($result, 'bar', "RT #41550"); } fresh_perl_is(<<'----', <<'====', "lvalue can not be set after definition. [perl #68758]"); use warnings; our $x; sub foo { $x } sub foo : lvalue; foo = 3; ---- lvalue attribute ignored after the subroutine has been defined at - line 4. Can't modify non-lvalue subroutine call in scalar assignment at - line 5, near "3;" Execution of - aborted due to compilation errors. ==== { my $x; sub lval_decl : lvalue; sub lval_decl { $x } lval_decl = 5; is($x, 5, "subroutine declared with lvalue before definition retains lvalue. [perl #68758]"); } perl-5.12.0-RC0/t/op/utftaint.t0000555000175000017500000001036211325125742015040 0ustar jessejesse#!./perl -T # tests whether tainting works with UTF-8 BEGIN { chdir 't' if -d 't'; @INC = qw(../lib); } use strict; use Config; # How to identify taint when you see it sub any_tainted (@) { not eval { join("",@_), kill 0; 1 }; } sub tainted ($) { any_tainted @_; } require './test.pl'; plan(tests => 3*10 + 3*8 + 2*16 + 2); my $arg = $ENV{PATH}; # a tainted value use constant UTF8 => "\x{1234}"; *is_utf8 = \&utf8::is_utf8; for my $ary ([ascii => 'perl'], [latin1 => "\xB6"], [utf8 => "\x{100}"]) { my $encode = $ary->[0]; my $string = $ary->[1]; my $taint = $arg; substr($taint, 0) = $ary->[1]; is(tainted($taint), tainted($arg), "tainted: $encode, before test"); my $lconcat = $taint; $lconcat .= UTF8; is($lconcat, $string.UTF8, "compare: $encode, concat left"); is(tainted($lconcat), tainted($arg), "tainted: $encode, concat left"); my $rconcat = UTF8; $rconcat .= $taint; is($rconcat, UTF8.$string, "compare: $encode, concat right"); is(tainted($rconcat), tainted($arg), "tainted: $encode, concat right"); my $ljoin = join('!', $taint, UTF8); is($ljoin, join('!', $string, UTF8), "compare: $encode, join left"); is(tainted($ljoin), tainted($arg), "tainted: $encode, join left"); my $rjoin = join('!', UTF8, $taint); is($rjoin, join('!', UTF8, $string), "compare: $encode, join right"); is(tainted($rjoin), tainted($arg), "tainted: $encode, join right"); is(tainted($taint), tainted($arg), "tainted: $encode, after test"); } for my $ary ([ascii => 'perl'], [latin1 => "\xB6"], [utf8 => "\x{100}"]) { my $encode = $ary->[0]; my $utf8 = pack('U*') . $ary->[1]; my $byte = unpack('U0a*', $utf8); my $taint = $arg; substr($taint, 0) = $utf8; utf8::encode($taint); is($taint, $byte, "compare: $encode, encode utf8"); is(pack('a*',$taint), pack('a*',$byte), "bytecmp: $encode, encode utf8"); ok(!is_utf8($taint), "is_utf8: $encode, encode utf8"); is(tainted($taint), tainted($arg), "tainted: $encode, encode utf8"); my $taint = $arg; substr($taint, 0) = $byte; utf8::decode($taint); is($taint, $utf8, "compare: $encode, decode byte"); is(pack('a*',$taint), pack('a*',$utf8), "bytecmp: $encode, decode byte"); is(is_utf8($taint), ($encode ne 'ascii'), "is_utf8: $encode, decode byte"); is(tainted($taint), tainted($arg), "tainted: $encode, decode byte"); } for my $ary ([ascii => 'perl'], [latin1 => "\xB6"]) { my $encode = $ary->[0]; my $up = pack('U*') . $ary->[1]; my $down = pack("a*", $ary->[1]); my $taint = $arg; substr($taint, 0) = $up; utf8::upgrade($taint); is($taint, $up, "compare: $encode, upgrade up"); is(pack('a*',$taint), pack('a*',$up), "bytecmp: $encode, upgrade up"); ok(is_utf8($taint), "is_utf8: $encode, upgrade up"); is(tainted($taint), tainted($arg), "tainted: $encode, upgrade up"); my $taint = $arg; substr($taint, 0) = $down; utf8::upgrade($taint); is($taint, $up, "compare: $encode, upgrade down"); is(pack('a*',$taint), pack('a*',$up), "bytecmp: $encode, upgrade down"); ok(is_utf8($taint), "is_utf8: $encode, upgrade down"); is(tainted($taint), tainted($arg), "tainted: $encode, upgrade down"); my $taint = $arg; substr($taint, 0) = $up; utf8::downgrade($taint); is($taint, $down, "compare: $encode, downgrade up"); is(pack('a*',$taint), pack('a*',$down), "bytecmp: $encode, downgrade up"); ok(!is_utf8($taint), "is_utf8: $encode, downgrade up"); is(tainted($taint), tainted($arg), "tainted: $encode, downgrade up"); my $taint = $arg; substr($taint, 0) = $down; utf8::downgrade($taint); is($taint, $down, "compare: $encode, downgrade down"); is(pack('a*',$taint), pack('a*',$down), "bytecmp: $encode, downgrade down"); ok(!is_utf8($taint), "is_utf8: $encode, downgrade down"); is(tainted($taint), tainted($arg), "tainted: $encode, downgrade down"); } { fresh_perl_is('$a = substr $^X, 0, 0; /\x{100}/i; /$a\x{100}/i || print q,ok,', 'ok', {switches => ["-T", "-l"]}, "matching a regexp is taint agnostic"); fresh_perl_is('$a = substr $^X, 0, 0; /$a\x{100}/i || print q,ok,', 'ok', {switches => ["-T", "-l"]}, "therefore swash_init should be taint agnostic"); } perl-5.12.0-RC0/t/op/local.t0000555000175000017500000003607311325127001014271 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = qw(. ../lib); require './test.pl'; } plan tests => 296; my $list_assignment_supported = 1; #mg.c says list assignment not supported on VMS, EPOC, and SYMBIAN. $list_assignment_supported = 0 if ($^O eq 'VMS'); sub foo { local($a, $b) = @_; local($c, $d); $c = "c 3"; $d = "d 4"; { local($a,$c) = ("a 9", "c 10"); ($x, $y) = ($a, $c); } is($a, "a 1"); is($b, "b 2"); $c, $d; } $a = "a 5"; $b = "b 6"; $c = "c 7"; $d = "d 8"; my @res; @res = &foo("a 1","b 2"); is($res[0], "c 3"); is($res[1], "d 4"); is($a, "a 5"); is($b, "b 6"); is($c, "c 7"); is($d, "d 8"); is($x, "a 9"); is($y, "c 10"); # same thing, only with arrays and associative arrays sub foo2 { local($a, @b) = @_; local(@c, %d); @c = "c 3"; $d{''} = "d 4"; { local($a,@c) = ("a 19", "c 20"); ($x, $y) = ($a, @c); } is($a, "a 1"); is("@b", "b 2"); $c[0], $d{''}; } $a = "a 5"; @b = "b 6"; @c = "c 7"; $d{''} = "d 8"; @res = &foo2("a 1","b 2"); is($res[0], "c 3"); is($res[1], "d 4"); is($a, "a 5"); is("@b", "b 6"); is($c[0], "c 7"); is($d{''}, "d 8"); is($x, "a 19"); is($y, "c 20"); eval 'local($$e)'; like($@, qr/Can't localize through a reference/); eval '$e = []; local(@$e)'; like($@, qr/Can't localize through a reference/); eval '$e = {}; local(%$e)'; like($@, qr/Can't localize through a reference/); # Array and hash elements @a = ('a', 'b', 'c'); { local($a[1]) = 'foo'; local($a[2]) = $a[2]; is($a[1], 'foo'); is($a[2], 'c'); undef @a; } is($a[1], 'b'); is($a[2], 'c'); ok(!defined $a[0]); @a = ('a', 'b', 'c'); { local($a[4]) = 'x'; ok(!defined $a[3]); is($a[4], 'x'); } is(scalar(@a), 3); ok(!exists $a[3]); ok(!exists $a[4]); @a = ('a', 'b', 'c'); { local($a[5]) = 'z'; $a[4] = 'y'; ok(!defined $a[3]); is($a[4], 'y'); is($a[5], 'z'); } is(scalar(@a), 5); ok(!defined $a[3]); is($a[4], 'y'); ok(!exists $a[5]); @a = ('a', 'b', 'c'); { local(@a[4,6]) = ('x', 'z'); ok(!defined $a[3]); is($a[4], 'x'); ok(!defined $a[5]); is($a[6], 'z'); } is(scalar(@a), 3); ok(!exists $a[3]); ok(!exists $a[4]); ok(!exists $a[5]); ok(!exists $a[6]); @a = ('a', 'b', 'c'); { local(@a[4,6]) = ('x', 'z'); $a[5] = 'y'; ok(!defined $a[3]); is($a[4], 'x'); is($a[5], 'y'); is($a[6], 'z'); } is(scalar(@a), 6); ok(!defined $a[3]); ok(!defined $a[4]); is($a[5], 'y'); ok(!exists $a[6]); @a = ('a', 'b', 'c'); { local($a[1]) = "X"; shift @a; } is($a[0].$a[1], "Xb"); { my $d = "@a"; local @a = @a; is("@a", $d); } @a = ('a', 'b', 'c'); $a[4] = 'd'; { delete local $a[1]; is(scalar(@a), 5); is($a[0], 'a'); ok(!exists($a[1])); is($a[2], 'c'); ok(!exists($a[3])); is($a[4], 'd'); ok(!exists($a[888])); delete local $a[888]; is(scalar(@a), 5); ok(!exists($a[888])); ok(!exists($a[999])); my ($d, $zzz) = delete local @a[4, 999]; is(scalar(@a), 3); ok(!exists($a[4])); ok(!exists($a[999])); is($d, 'd'); is($zzz, undef); my $c = delete local $a[2]; is(scalar(@a), 1); ok(!exists($a[2])); is($c, 'c'); $a[888] = 'yyy'; $a[999] = 'zzz'; } is(scalar(@a), 5); is($a[0], 'a'); is($a[1], 'b'); is($a[2], 'c'); ok(!defined($a[3])); is($a[4], 'd'); ok(!exists($a[5])); ok(!exists($a[888])); ok(!exists($a[999])); %h = (a => 1, b => 2, c => 3, d => 4); { delete local $h{b}; is(scalar(keys(%h)), 3); is($h{a}, 1); ok(!exists($h{b})); is($h{c}, 3); is($h{d}, 4); ok(!exists($h{yyy})); delete local $h{yyy}; is(scalar(keys(%h)), 3); ok(!exists($h{yyy})); ok(!exists($h{zzz})); my ($d, $zzz) = delete local @h{qw/d zzz/}; is(scalar(keys(%h)), 2); ok(!exists($h{d})); ok(!exists($h{zzz})); is($d, 4); is($zzz, undef); my $c = delete local $h{c}; is(scalar(keys(%h)), 1); ok(!exists($h{c})); is($c, 3); $h{yyy} = 888; $h{zzz} = 999; } is(scalar(keys(%h)), 4); is($h{a}, 1); is($h{b}, 2); is($h{c}, 3); ok($h{d}, 4); ok(!exists($h{yyy})); ok(!exists($h{zzz})); %h = ('a' => { 'b' => 1 }, 'c' => 2); { my $a = delete local $h{a}; is(scalar(keys(%h)), 1); ok(!exists($h{a})); is($h{c}, 2); is(scalar(keys(%$a)), 1); my $b = delete local $a->{b}; is(scalar(keys(%$a)), 0); is($b, 1); $a->{d} = 3; } is(scalar(keys(%h)), 2); { my $a = $h{a}; is(scalar(keys(%$a)), 2); is($a->{b}, 1); is($a->{d}, 3); } is($h{c}, 2); %h = ('a' => 1, 'b' => 2, 'c' => 3); { local($h{'a'}) = 'foo'; local($h{'b'}) = $h{'b'}; is($h{'a'}, 'foo'); is($h{'b'}, 2); local($h{'c'}); delete $h{'c'}; } is($h{'a'}, 1); is($h{'b'}, 2); { my $d = join("\n", map { "$_=>$h{$_}" } sort keys %h); local %h = %h; is(join("\n", map { "$_=>$h{$_}" } sort keys %h), $d); } is($h{'c'}, 3); # check for scope leakage $a = 'outer'; if (1) { local $a = 'inner' } is($a, 'outer'); # see if localization works when scope unwinds local $m = 5; eval { for $m (6) { local $m = 7; die "bye"; } }; is($m, 5); # see if localization works on tied arrays { package TA; sub TIEARRAY { bless [], $_[0] } sub STORE { print "# STORE [@_]\n"; $_[0]->[$_[1]] = $_[2] } sub FETCH { my $v = $_[0]->[$_[1]]; print "# FETCH [@_=$v]\n"; $v } sub EXISTS { print "# EXISTS [@_]\n"; exists $_[0]->[$_[1]]; } sub DELETE { print "# DELETE [@_]\n"; delete $_[0]->[$_[1]]; } sub CLEAR { print "# CLEAR [@_]\n"; @{$_[0]} = (); } sub FETCHSIZE { scalar(@{$_[0]}) } sub SHIFT { shift (@{$_[0]}) } sub EXTEND {} } tie @a, 'TA'; @a = ('a', 'b', 'c'); { local($a[1]) = 'foo'; local($a[2]) = $a[2]; is($a[1], 'foo'); is($a[2], 'c'); @a = (); } is($a[1], 'b'); is($a[2], 'c'); ok(!defined $a[0]); { my $d = "@a"; local @a = @a; is("@a", $d); } # local() should preserve the existenceness of tied array elements @a = ('a', 'b', 'c'); { local($a[4]) = 'x'; ok(!defined $a[3]); is($a[4], 'x'); } is(scalar(@a), 3); ok(!exists $a[3]); ok(!exists $a[4]); @a = ('a', 'b', 'c'); { local($a[5]) = 'z'; $a[4] = 'y'; ok(!defined $a[3]); is($a[4], 'y'); is($a[5], 'z'); } is(scalar(@a), 5); ok(!defined $a[3]); is($a[4], 'y'); ok(!exists $a[5]); @a = ('a', 'b', 'c'); { local(@a[4,6]) = ('x', 'z'); ok(!defined $a[3]); is($a[4], 'x'); ok(!defined $a[5]); is($a[6], 'z'); } is(scalar(@a), 3); ok(!exists $a[3]); ok(!exists $a[4]); ok(!exists $a[5]); ok(!exists $a[6]); @a = ('a', 'b', 'c'); { local(@a[4,6]) = ('x', 'z'); $a[5] = 'y'; ok(!defined $a[3]); is($a[4], 'x'); is($a[5], 'y'); is($a[6], 'z'); } is(scalar(@a), 6); ok(!defined $a[3]); ok(!defined $a[4]); is($a[5], 'y'); ok(!exists $a[6]); @a = ('a', 'b', 'c'); $a[4] = 'd'; { delete local $a[1]; is(scalar(@a), 5); is($a[0], 'a'); ok(!exists($a[1])); is($a[2], 'c'); ok(!exists($a[3])); is($a[4], 'd'); ok(!exists($a[888])); delete local $a[888]; is(scalar(@a), 5); ok(!exists($a[888])); ok(!exists($a[999])); my ($d, $zzz) = delete local @a[4, 999]; is(scalar(@a), 3); ok(!exists($a[4])); ok(!exists($a[999])); is($d, 'd'); is($zzz, undef); my $c = delete local $a[2]; is(scalar(@a), 1); ok(!exists($a[2])); is($c, 'c'); $a[888] = 'yyy'; $a[999] = 'zzz'; } is(scalar(@a), 5); is($a[0], 'a'); is($a[1], 'b'); is($a[2], 'c'); ok(!defined($a[3])); is($a[4], 'd'); ok(!exists($a[5])); ok(!exists($a[888])); ok(!exists($a[999])); # see if localization works on tied hashes { package TH; sub TIEHASH { bless {}, $_[0] } sub STORE { print "# STORE [@_]\n"; $_[0]->{$_[1]} = $_[2] } sub FETCH { my $v = $_[0]->{$_[1]}; print "# FETCH [@_=$v]\n"; $v } sub EXISTS { print "# EXISTS [@_]\n"; exists $_[0]->{$_[1]}; } sub DELETE { print "# DELETE [@_]\n"; delete $_[0]->{$_[1]}; } sub CLEAR { print "# CLEAR [@_]\n"; %{$_[0]} = (); } sub FIRSTKEY { print "# FIRSTKEY [@_]\n"; keys %{$_[0]}; each %{$_[0]} } sub NEXTKEY { print "# NEXTKEY [@_]\n"; each %{$_[0]} } } tie %h, 'TH'; %h = ('a' => 1, 'b' => 2, 'c' => 3); { local($h{'a'}) = 'foo'; local($h{'b'}) = $h{'b'}; local($h{'y'}); local($h{'z'}) = 33; is($h{'a'}, 'foo'); is($h{'b'}, 2); local($h{'c'}); delete $h{'c'}; } is($h{'a'}, 1); is($h{'b'}, 2); is($h{'c'}, 3); # local() should preserve the existenceness of tied hash elements ok(! exists $h{'y'}); ok(! exists $h{'z'}); TODO: { todo_skip("Localize entire tied hash"); my $d = join("\n", map { "$_=>$h{$_}" } sort keys %h); local %h = %h; is(join("\n", map { "$_=>$h{$_}" } sort keys %h), $d); } %h = (a => 1, b => 2, c => 3, d => 4); { delete local $h{b}; is(scalar(keys(%h)), 3); is($h{a}, 1); ok(!exists($h{b})); is($h{c}, 3); is($h{d}, 4); ok(!exists($h{yyy})); delete local $h{yyy}; is(scalar(keys(%h)), 3); ok(!exists($h{yyy})); ok(!exists($h{zzz})); my ($d, $zzz) = delete local @h{qw/d zzz/}; is(scalar(keys(%h)), 2); ok(!exists($h{d})); ok(!exists($h{zzz})); is($d, 4); is($zzz, undef); my $c = delete local $h{c}; is(scalar(keys(%h)), 1); ok(!exists($h{c})); is($c, 3); $h{yyy} = 888; $h{zzz} = 999; } is(scalar(keys(%h)), 4); is($h{a}, 1); is($h{b}, 2); is($h{c}, 3); ok($h{d}, 4); ok(!exists($h{yyy})); ok(!exists($h{zzz})); @a = ('a', 'b', 'c'); { local($a[1]) = "X"; shift @a; } is($a[0].$a[1], "Xb"); # now try the same for %SIG $SIG{TERM} = 'foo'; $SIG{INT} = \&foo; $SIG{__WARN__} = $SIG{INT}; { local($SIG{TERM}) = $SIG{TERM}; local($SIG{INT}) = $SIG{INT}; local($SIG{__WARN__}) = $SIG{__WARN__}; is($SIG{TERM}, 'main::foo'); is($SIG{INT}, \&foo); is($SIG{__WARN__}, \&foo); local($SIG{INT}); delete $SIG{__WARN__}; } is($SIG{TERM}, 'main::foo'); is($SIG{INT}, \&foo); is($SIG{__WARN__}, \&foo); { my $d = join("\n", map { "$_=>$SIG{$_}" } sort keys %SIG); local %SIG = %SIG; is(join("\n", map { "$_=>$SIG{$_}" } sort keys %SIG), $d); } # and for %ENV $ENV{_X_} = 'a'; $ENV{_Y_} = 'b'; $ENV{_Z_} = 'c'; { local($ENV{_A_}); local($ENV{_B_}) = 'foo'; local($ENV{_X_}) = 'foo'; local($ENV{_Y_}) = $ENV{_Y_}; is($ENV{_X_}, 'foo'); is($ENV{_Y_}, 'b'); local($ENV{_Z_}); delete $ENV{_Z_}; } is($ENV{_X_}, 'a'); is($ENV{_Y_}, 'b'); is($ENV{_Z_}, 'c'); # local() should preserve the existenceness of %ENV elements ok(! exists $ENV{_A_}); ok(! exists $ENV{_B_}); SKIP: { skip("Can't make list assignment to \%ENV on this system") unless $list_assignment_supported; my $d = join("\n", map { "$_=>$ENV{$_}" } sort keys %ENV); local %ENV = %ENV; is(join("\n", map { "$_=>$ENV{$_}" } sort keys %ENV), $d); } # does implicit localization in foreach skip magic? $_ = "o 0,o 1,"; my $iter = 0; while (/(o.+?),/gc) { is($1, "o $iter"); foreach (1..1) { $iter++ } if ($iter > 2) { fail("endless loop"); last; } } { package UnderScore; sub TIESCALAR { bless \my $self, shift } sub FETCH { die "read \$_ forbidden" } sub STORE { die "write \$_ forbidden" } tie $_, __PACKAGE__; my @tests = ( "Nesting" => sub { print '#'; for (1..3) { print } print "\n" }, 1, "Reading" => sub { print }, 0, "Matching" => sub { $x = /badness/ }, 0, "Concat" => sub { $_ .= "a" }, 0, "Chop" => sub { chop }, 0, "Filetest" => sub { -x }, 0, "Assignment" => sub { $_ = "Bad" }, 0, # XXX whether next one should fail is debatable "Local \$_" => sub { local $_ = 'ok?'; print }, 0, "for local" => sub { for("#ok?\n"){ print } }, 1, ); while ( ($name, $code, $ok) = splice(@tests, 0, 3) ) { eval { &$code }; main::ok(($ok xor $@), "Underscore '$name'"); } untie $_; } { # BUG 20001205.22 my %x; $x{a} = 1; { local $x{b} = 1; } ok(! exists $x{b}); { local @x{c,d,e}; } ok(! exists $x{c}); } # local() and readonly magic variables eval { local $1 = 1 }; like($@, qr/Modification of a read-only value attempted/); eval { for ($1) { local $_ = 1 } }; like($@, qr/Modification of a read-only value attempted/); # make sure $1 is still read-only eval { for ($1) { local $_ = 1 } }; like($@, qr/Modification of a read-only value attempted/); # The s/// adds 'g' magic to $_, but it should remain non-readonly eval { for("a") { for $x (1,2) { local $_="b"; s/(.*)/+$1/ } } }; is($@, ""); # RT #4342 Special local() behavior for $[ { no warnings 'deprecated'; local $[ = 1; ok(1 == $[, 'lexcical scope of local $['); f(); } sub f { ok(0 == $[); } # sub localisation { package Other; sub f1 { "f1" } sub f2 { "f2" } no warnings "redefine"; { local *f1 = sub { "g1" }; ::ok(f1() eq "g1", "localised sub via glob"); } ::ok(f1() eq "f1", "localised sub restored"); { local $Other::{"f1"} = sub { "h1" }; ::ok(f1() eq "h1", "localised sub via stash"); } ::ok(f1() eq "f1", "localised sub restored"); { local @Other::{qw/ f1 f2 /} = (sub { "j1" }, sub { "j2" }); ::ok(f1() eq "j1", "localised sub via stash slice"); ::ok(f2() eq "j2", "localised sub via stash slice"); } ::ok(f1() eq "f1", "localised sub restored"); ::ok(f2() eq "f2", "localised sub restored"); } # Localising unicode keys (bug #38815) { my %h; $h{"\243"} = "pound"; $h{"\302\240"} = "octects"; is(scalar keys %h, 2); { my $unicode = chr 256; my $ambigous = "\240" . $unicode; chop $ambigous; local $h{$unicode} = 256; local $h{$ambigous} = 160; is(scalar keys %h, 4); is($h{"\243"}, "pound"); is($h{$unicode}, 256); is($h{$ambigous}, 160); is($h{"\302\240"}, "octects"); } is(scalar keys %h, 2); is($h{"\243"}, "pound"); is($h{"\302\240"}, "octects"); } # And with slices { my %h; $h{"\243"} = "pound"; $h{"\302\240"} = "octects"; is(scalar keys %h, 2); { my $unicode = chr 256; my $ambigous = "\240" . $unicode; chop $ambigous; local @h{$unicode, $ambigous} = (256, 160); is(scalar keys %h, 4); is($h{"\243"}, "pound"); is($h{$unicode}, 256); is($h{$ambigous}, 160); is($h{"\302\240"}, "octects"); } is(scalar keys %h, 2); is($h{"\243"}, "pound"); is($h{"\302\240"}, "octects"); } # [perl #39012] localizing @_ element then shifting frees element too # soon { my $x; my $y = bless [], 'X39012'; sub X39012::DESTROY { $x++ } sub { local $_[0]; shift }->($y); ok(!$x, '[perl #39012]'); } # when localising a hash element, the key should be copied, not referenced { my %h=('k1' => 111); my $k='k1'; { local $h{$k}=222; is($h{'k1'},222); $k='k2'; } ok(! exists($h{'k2'})); is($h{'k1'},111); } { my %h=('k1' => 111); our $k = 'k1'; # try dynamic too { local $h{$k}=222; is($h{'k1'},222); $k='k2'; } ok(! exists($h{'k2'})); is($h{'k1'},111); } like( runperl(stderr => 1, prog => 'use constant foo => q(a);' . 'index(q(a), foo);' . 'local *g=${::}{foo};print q(ok);'), "ok", "[perl #52740]"); # Keep this test last, as it can SEGV { local *@; pass("Localised *@"); eval {1}; pass("Can eval with *@ localised"); } perl-5.12.0-RC0/t/op/lfs.t0000555000175000017500000001543611325127001013763 0ustar jessejesse# NOTE: this file tests how large files (>2GB) work with perlio (stdio/sfio). # sysopen(), sysseek(), syswrite(), sysread() are tested in t/lib/syslfs.t. # If you modify/add tests here, remember to update also ext/Fcntl/t/syslfs.t. BEGIN { chdir 't' if -d 't'; @INC = '../lib'; # Don't bother if there are no quad offsets. require Config; import Config; if ($Config{lseeksize} < 8) { print "1..0 # Skip: no 64-bit file offsets\n"; exit(0); } require './test.pl'; } use strict; our @s; our $fail; my $big0 = tempfile(); my $big1 = tempfile(); my $big2 = tempfile(); sub zap { close(BIG); } sub bye { zap(); exit(0); } my $explained; sub explain { unless ($explained++) { print <$big1") or do { warn "open $big1 failed: $!\n"; bye }; binmode(BIG) or do { warn "binmode $big1 failed: $!\n"; bye }; seek(BIG, 1_000_000, $SEEK_SET) or do { warn "seek $big1 failed: $!\n"; bye }; print BIG "big" or do { warn "print $big1 failed: $!\n"; bye }; close(BIG) or do { warn "close $big1 failed: $!\n"; bye }; my @s1 = stat($big1); print "# s1 = @s1\n"; open(BIG, ">$big2") or do { warn "open $big2 failed: $!\n"; bye }; binmode(BIG) or do { warn "binmode $big2 failed: $!\n"; bye }; seek(BIG, 2_000_000, $SEEK_SET) or do { warn "seek $big2 failed; $!\n"; bye }; print BIG "big" or do { warn "print $big2 failed; $!\n"; bye }; close(BIG) or do { warn "close $big2 failed; $!\n"; bye }; my @s2 = stat($big2); print "# s2 = @s2\n"; zap(); unless ($s1[7] == 1_000_003 && $s2[7] == 2_000_003 && $s1[11] == $s2[11] && $s1[12] == $s2[12] && $s1[12] > 0) { print "1..0 # Skip: no sparse files?\n"; bye; } print "# we seem to have sparse files...\n"; # By now we better be sure that we do have sparse files: # if we are not, the following will hog 5 gigabytes of disk. Ooops. # This may fail by producing some signal; run in a subprocess first for safety $ENV{LC_ALL} = "C"; my $r = system '../perl', '-e', <<'EOF'; open(BIG, ">$big0"); seek(BIG, 5_000_000_000, 0); print BIG $big0; exit 0; EOF open(BIG, ">$big0") or do { warn "open failed: $!\n"; bye }; binmode BIG; if ($r or not seek(BIG, 5_000_000_000, $SEEK_SET)) { my $err = $r ? 'signal '.($r & 0x7f) : $!; explain("seeking past 2GB failed: $err"); bye(); } # Either the print or (more likely, thanks to buffering) the close will # fail if there are are filesize limitations (process or fs). my $print = print BIG "big"; print "# print failed: $!\n" unless $print; my $close = close BIG; print "# close failed: $!\n" unless $close; unless ($print && $close) { if ($! =~/too large/i) { explain("writing past 2GB failed: process limits?"); } elsif ($! =~ /quota/i) { explain("filesystem quota limits?"); } else { explain("error: $!"); } bye(); } @s = stat($big0); print "# @s\n"; unless ($s[7] == 5_000_000_003) { explain("kernel/fs not configured to use large files?"); bye(); } sub fail { print "not "; $fail++; } sub offset ($$) { my ($offset_will_be, $offset_want) = @_; my $offset_is = eval $offset_will_be; unless ($offset_is == $offset_want) { print "# bad offset $offset_is, want $offset_want\n"; my ($offset_func) = ($offset_will_be =~ /^(\w+)/); if (unpack("L", pack("L", $offset_want)) == $offset_is) { print "# 32-bit wraparound suspected in $offset_func() since\n"; print "# $offset_want cast into 32 bits equals $offset_is.\n"; } elsif ($offset_want - unpack("L", pack("L", $offset_want)) - 1 == $offset_is) { print "# 32-bit wraparound suspected in $offset_func() since\n"; printf "# %s - unpack('L', pack('L', %s)) - 1 equals %s.\n", $offset_want, $offset_want, $offset_is; } fail; } } print "1..17\n"; $fail = 0; fail unless $s[7] == 5_000_000_003; # exercizes pp_stat print "ok 1\n"; fail unless -s $big0 == 5_000_000_003; # exercizes pp_ftsize print "ok 2\n"; fail unless -e $big0; print "ok 3\n"; fail unless -f $big0; print "ok 4\n"; open(BIG, $big0) or do { warn "open failed: $!\n"; bye }; binmode BIG; fail unless seek(BIG, 4_500_000_000, $SEEK_SET); print "ok 5\n"; offset('tell(BIG)', 4_500_000_000); print "ok 6\n"; fail unless seek(BIG, 1, $SEEK_CUR); print "ok 7\n"; # If you get 205_032_705 from here it means that # your tell() is returning 32-bit values since (I32)4_500_000_001 # is exactly 205_032_705. offset('tell(BIG)', 4_500_000_001); print "ok 8\n"; fail unless seek(BIG, -1, $SEEK_CUR); print "ok 9\n"; offset('tell(BIG)', 4_500_000_000); print "ok 10\n"; fail unless seek(BIG, -3, $SEEK_END); print "ok 11\n"; offset('tell(BIG)', 5_000_000_000); print "ok 12\n"; my $big; fail unless read(BIG, $big, 3) == 3; print "ok 13\n"; fail unless $big eq "big"; print "ok 14\n"; # 705_032_704 = (I32)5_000_000_000 # See that we don't have "big" in the 705_... spot: # that would mean that we have a wraparound. fail unless seek(BIG, 705_032_704, $SEEK_SET); print "ok 15\n"; my $zero; fail unless read(BIG, $zero, 3) == 3; print "ok 16\n"; fail unless $zero eq "\0\0\0"; print "ok 17\n"; explain() if $fail; bye(); # does the necessary cleanup END { # unlink may fail if applied directly to a large file # be paranoid about leaving 5 gig files lying around open(BIG, ">$big0"); # truncate close(BIG); } # eof perl-5.12.0-RC0/t/op/study.t0000555000175000017500000000370411325127002014343 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } $Ok_Level = 0; my $test = 1; sub ok ($;$) { my($ok, $name) = @_; local $_; # You have to do it this way or VMS will get confused. printf "%s $test%s\n", $ok ? 'ok' : 'not ok', $name ? " - $name" : ''; printf "# Failed test at line %d\n", (caller($Ok_Level))[2] unless $ok; $test++; return $ok; } sub nok ($;$) { my($nok, $name) = @_; local $Ok_Level = 1; ok( !$nok, $name ); } use Config; my $have_alarm = $Config{d_alarm}; sub alarm_ok (&) { my $test = shift; local $SIG{ALRM} = sub { die "timeout\n" }; my $match; eval { alarm(2) if $have_alarm; $match = $test->(); alarm(0) if $have_alarm; }; local $Ok_Level = 1; ok( !$match && !$@, 'testing studys that used to hang' ); } print "1..26\n"; $x = "abc\ndef\n"; study($x); ok($x =~ /^abc/); ok($x !~ /^def/); # used to be a test for $* ok($x =~ /^def/m); $_ = '123'; study; ok(/^([0-9][0-9]*)/); nok($x =~ /^xxx/); nok($x !~ /^abc/); ok($x =~ /def/); nok($x !~ /def/); study($x); ok($x !~ /.def/); nok($x =~ /.def/); ok($x =~ /\ndef/); nok($x !~ /\ndef/); $_ = 'aaabbbccc'; study; ok(/(a*b*)(c*)/ && $1 eq 'aaabbb' && $2 eq 'ccc'); ok(/(a+b+c+)/ && $1 eq 'aaabbbccc'); nok(/a+b?c+/); $_ = 'aaabccc'; study; ok(/a+b?c+/); ok(/a*b+c*/); $_ = 'aaaccc'; study; ok(/a*b?c*/); nok(/a*b+c*/); $_ = 'abcdef'; study; ok(/bcd|xyz/); ok(/xyz|bcd/); ok(m|bc/*d|); ok(/^$_$/); # used to be a test for $* ok("ab\ncd\n" =~ /^cd/m); if ($^O eq 'os390' or $^O eq 'posix-bc') { # Even with the alarm() OS/390 and BS2000 can't manage these tests # (Perl just goes into a busy loop, luckily an interruptable one) for (25..26) { print "not ok $_ # TODO compiler bug?\n" } $test += 2; } else { # [ID 20010618.006] tests 25..26 may loop $_ = 'FGF'; study; alarm_ok { /G.F$/ }; alarm_ok { /[F]F$/ }; } perl-5.12.0-RC0/t/op/tiearray.t0000555000175000017500000001576211325127002015022 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } my %seen; package Implement; sub TIEARRAY { $seen{'TIEARRAY'}++; my ($class,@val) = @_; return bless \@val,$class; } sub STORESIZE { $seen{'STORESIZE'}++; my ($ob,$sz) = @_; return $#{$ob} = $sz-1; } sub EXTEND { $seen{'EXTEND'}++; my ($ob,$sz) = @_; return @$ob = $sz; } sub FETCHSIZE { $seen{'FETCHSIZE'}++; return scalar(@{$_[0]}); } sub FETCH { $seen{'FETCH'}++; my ($ob,$id) = @_; return $ob->[$id]; } sub STORE { $seen{'STORE'}++; my ($ob,$id,$val) = @_; $ob->[$id] = $val; } sub UNSHIFT { $seen{'UNSHIFT'}++; my $ob = shift; unshift(@$ob,@_); } sub PUSH { $seen{'PUSH'}++; my $ob = shift;; push(@$ob,@_); } sub CLEAR { $seen{'CLEAR'}++; @{$_[0]} = (); } sub DESTROY { $seen{'DESTROY'}++; } sub POP { $seen{'POP'}++; my ($ob) = @_; return pop(@$ob); } sub SHIFT { $seen{'SHIFT'}++; my ($ob) = @_; return shift(@$ob); } sub SPLICE { $seen{'SPLICE'}++; my $ob = shift; my $off = @_ ? shift : 0; my $len = @_ ? shift : @$ob-1; return splice(@$ob,$off,$len,@_); } package NegIndex; # 20020220 MJD @ISA = 'Implement'; # simulate indices -2 .. 2 my $offset = 2; $NegIndex::NEGATIVE_INDICES = 1; sub FETCH { my ($ob,$id) = @_; # print "# FETCH @_\n"; $id += $offset; $ob->[$id]; } sub STORE { my ($ob,$id,$value) = @_; # print "# STORE @_\n"; $id += $offset; $ob->[$id] = $value; } sub DELETE { my ($ob,$id) = @_; # print "# DELETE @_\n"; $id += $offset; delete $ob->[$id]; } sub EXISTS { my ($ob,$id) = @_; # print "# EXISTS @_\n"; $id += $offset; exists $ob->[$id]; } # # Returning -1 from FETCHSIZE used to get casted to U32 causing a # segfault # package NegFetchsize; sub TIEARRAY { bless [] } sub FETCH { } sub FETCHSIZE { -1 } package main; print "1..66\n"; my $test = 1; {my @ary; { my $ob = tie @ary,'Implement',3,2,1; print "not " unless $ob; print "ok ", $test++,"\n"; print "not " unless tied(@ary) == $ob; print "ok ", $test++,"\n"; } print "not " unless @ary == 3; print "ok ", $test++,"\n"; print "not " unless $#ary == 2; print "ok ", $test++,"\n"; print "not " unless join(':',@ary) eq '3:2:1'; print "ok ", $test++,"\n"; print "not " unless $seen{'FETCH'} >= 3; print "ok ", $test++,"\n"; @ary = (1,2,3); print "not " unless $seen{'STORE'} >= 3; print "ok ", $test++,"\n"; print "not " unless join(':',@ary) eq '1:2:3'; print "ok ", $test++,"\n"; {my @thing = @ary; print "not " unless join(':',@thing) eq '1:2:3'; print "ok ", $test++,"\n"; tie @thing,'Implement'; @thing = @ary; print "not " unless join(':',@thing) eq '1:2:3'; print "ok ", $test++,"\n"; } print "not " unless pop(@ary) == 3; print "ok ", $test++,"\n"; print "not " unless $seen{'POP'} == 1; print "ok ", $test++,"\n"; print "not " unless join(':',@ary) eq '1:2'; print "ok ", $test++,"\n"; push(@ary,4); print "not " unless $seen{'PUSH'} == 1; print "ok ", $test++,"\n"; print "not " unless join(':',@ary) eq '1:2:4'; print "ok ", $test++,"\n"; my @x = splice(@ary,1,1,7); print "not " unless $seen{'SPLICE'} == 1; print "ok ", $test++,"\n"; print "not " unless @x == 1; print "ok ", $test++,"\n"; print "not " unless $x[0] == 2; print "ok ", $test++,"\n"; print "not " unless join(':',@ary) eq '1:7:4'; print "ok ", $test++,"\n"; print "not " unless shift(@ary) == 1; print "ok ", $test++,"\n"; print "not " unless $seen{'SHIFT'} == 1; print "ok ", $test++,"\n"; print "not " unless join(':',@ary) eq '7:4'; print "ok ", $test++,"\n"; my $n = unshift(@ary,5,6); print "not " unless $seen{'UNSHIFT'} == 1; print "ok ", $test++,"\n"; print "not " unless $n == 4; print "ok ", $test++,"\n"; print "not " unless join(':',@ary) eq '5:6:7:4'; print "ok ", $test++,"\n"; @ary = split(/:/,'1:2:3'); print "not " unless join(':',@ary) eq '1:2:3'; print "ok ", $test++,"\n"; my $t = 0; foreach $n (@ary) { print "not " unless $n == ++$t; print "ok ", $test++,"\n"; } # (30-33) 20020303 mjd-perl-patch+@plover.com @ary = (); $seen{POP} = 0; pop @ary; # this didn't used to call POP at all print "not " unless $seen{POP} == 1; print "ok ", $test++,"\n"; $seen{SHIFT} = 0; shift @ary; # this didn't used to call SHIFT at all print "not " unless $seen{SHIFT} == 1; print "ok ", $test++,"\n"; $seen{PUSH} = 0; push @ary; # this didn't used to call PUSH at all print "not " unless $seen{PUSH} == 1; print "ok ", $test++,"\n"; $seen{UNSHIFT} = 0; unshift @ary; # this didn't used to call UNSHIFT at all print "not " unless $seen{UNSHIFT} == 1; print "ok ", $test++,"\n"; @ary = qw(3 2 1); print "not " unless join(':',@ary) eq '3:2:1'; print "ok ", $test++,"\n"; $#ary = 1; print "not " unless $seen{'STORESIZE'} == 1; print "ok ", $test++," -- seen STORESIZE\n"; print "not " unless join(':',@ary) eq '3:2'; print "ok ", $test++,"\n"; sub arysize :lvalue { $#ary } arysize()--; print "not " unless $seen{'STORESIZE'} == 2; print "ok ", $test++," -- seen STORESIZE\n"; print "not " unless join(':',@ary) eq '3'; print "ok ", $test++,"\n"; untie @ary; } # 20020401 mjd-perl-patch+@plover.com # Thanks to Dave Mitchell for the small test case and the fix { my @a; sub X::TIEARRAY { bless {}, 'X' } sub X::SPLICE { do '/dev/null'; die; } tie @a, 'X'; eval { splice(@a) }; # If we survived this far. print "ok ", $test++, "\n"; } { # 20020220 mjd-perl-patch+@plover.com my @n; tie @n => 'NegIndex', ('A' .. 'E'); # FETCH print "not " unless $n[0] eq 'C'; print "ok ", $test++,"\n"; print "not " unless $n[1] eq 'D'; print "ok ", $test++,"\n"; print "not " unless $n[2] eq 'E'; print "ok ", $test++,"\n"; print "not " unless $n[-1] eq 'B'; print "ok ", $test++,"\n"; print "not " unless $n[-2] eq 'A'; print "ok ", $test++,"\n"; # STORE $n[-2] = 'a'; print "not " unless $n[-2] eq 'a'; print "ok ", $test++,"\n"; $n[-1] = 'b'; print "not " unless $n[-1] eq 'b'; print "ok ", $test++,"\n"; $n[0] = 'c'; print "not " unless $n[0] eq 'c'; print "ok ", $test++,"\n"; $n[1] = 'd'; print "not " unless $n[1] eq 'd'; print "ok ", $test++,"\n"; $n[2] = 'e'; print "not " unless $n[2] eq 'e'; print "ok ", $test++,"\n"; # DELETE and EXISTS for (-2 .. 2) { print exists($n[$_]) ? "ok $test\n" : "not ok $test\n"; $test++; delete $n[$_]; print defined($n[$_]) ? "not ok $test\n" : "ok $test\n"; $test++; print exists($n[$_]) ? "not ok $test\n" : "ok $test\n"; $test++; } } { tie my @dummy, "NegFetchsize"; eval { "@dummy"; }; print "# $@" if $@; print "not " unless $@ =~ /^FETCHSIZE returned a negative value/; print "ok ", $test++, " - croak on negative FETCHSIZE\n"; } print "not " unless $seen{'DESTROY'} == 3; print "ok ", $test++,"\n"; perl-5.12.0-RC0/t/op/anonsub.t0000555000175000017500000000526611325127001014644 0ustar jessejesse#!./perl # Note : we're not using t/test.pl here, because we would need # fresh_perl_is, and fresh_perl_is uses a closure -- a special # case of what this program tests for. chdir 't' if -d 't'; @INC = '../lib'; $Is_VMS = $^O eq 'VMS'; $Is_MSWin32 = $^O eq 'MSWin32'; $Is_NetWare = $^O eq 'NetWare'; $ENV{PERL5LIB} = "../lib" unless $Is_VMS; $|=1; undef $/; @prgs = split "\n########\n", ; print "1..", 6 + scalar @prgs, "\n"; $tmpfile = "asubtmp000"; 1 while -f ++$tmpfile; END { if ($tmpfile) { 1 while unlink $tmpfile; } } for (@prgs){ my $switch = ""; if (s/^\s*(-\w+)//){ $switch = $1; } my($prog,$expected) = split(/\nEXPECT\n/, $_); open TEST, ">$tmpfile"; print TEST "$prog\n"; close TEST or die "Could not close: $!"; my $results = $Is_VMS ? `$^X "-I[-.lib]" $switch $tmpfile 2>&1` : $Is_MSWin32 ? `.\\perl -I../lib $switch $tmpfile 2>&1` : $Is_NetWare ? `perl -I../lib $switch $tmpfile 2>&1` : `./perl $switch $tmpfile 2>&1`; my $status = $?; $results =~ s/\n+$//; # allow expected output to be written as if $prog is on STDIN $results =~ s/runltmp\d+/-/g; $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg $expected =~ s/\n+$//; if ($results ne $expected) { print STDERR "PROG: $switch\n$prog\n"; print STDERR "EXPECTED:\n$expected\n"; print STDERR "GOT:\n$results\n"; print "not "; } print "ok ", ++$i, "\n"; } sub test_invalid_decl { my ($code,$todo) = @_; $todo //= ''; eval $code; if ($@ =~ /^Illegal declaration of anonymous subroutine at/) { print "ok ", ++$i, " - '$code' is illegal$todo\n"; } else { print "not ok ", ++$i, " - '$code' is illegal$todo\n# GOT: $@"; } } test_invalid_decl('sub;'); test_invalid_decl('sub ($) ;'); test_invalid_decl('{ $x = sub }'); test_invalid_decl('sub ($) && 1'); test_invalid_decl('sub ($) : lvalue;',' # TODO'); eval "sub #foo\n{print 1}"; if ($@ eq '') { print "ok ", ++$i, "\n"; } else { print "not ok ", ++$i, "\n# GOT: $@"; } __END__ sub X { my $n = "ok 1\n"; sub { print $n }; } my $x = X(); undef &X; $x->(); EXPECT ok 1 ######## sub X { my $n = "ok 1\n"; sub { my $dummy = $n; # eval can't close on $n without internal reference eval 'print $n'; die $@ if $@; }; } my $x = X(); undef &X; $x->(); EXPECT ok 1 ######## sub X { my $n = "ok 1\n"; eval 'sub { print $n }'; } my $x = X(); die $@ if $@; undef &X; $x->(); EXPECT ok 1 ######## sub X; sub X { my $n = "ok 1\n"; eval 'sub Y { my $p = shift; $p->() }'; die $@ if $@; Y(sub { print $n }); } X(); EXPECT ok 1 ######## print sub { return "ok 1\n" } -> (); EXPECT ok 1 perl-5.12.0-RC0/t/op/gv.t0000555000175000017500000003572311346121271013622 0ustar jessejesse#!./perl # # various typeglob tests # BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } use warnings; require './test.pl'; plan( tests => 188 ); # type coersion on assignment $foo = 'foo'; $bar = *main::foo; $bar = $foo; is(ref(\$bar), 'SCALAR'); $foo = *main::bar; # type coersion (not) on misc ops ok($foo); is(ref(\$foo), 'GLOB'); unlike ($foo, qr/abcd/); is(ref(\$foo), 'GLOB'); is($foo, '*main::bar'); is(ref(\$foo), 'GLOB'); # type coersion on substitutions that match $a = *main::foo; $b = $a; $a =~ s/^X//; is(ref(\$a), 'GLOB'); $a =~ s/^\*//; is($a, 'main::foo'); is(ref(\$b), 'GLOB'); # typeglobs as lvalues substr($foo, 0, 1) = "XXX"; is(ref(\$foo), 'SCALAR'); is($foo, 'XXXmain::bar'); # returning glob values sub foo { local($bar) = *main::foo; $foo = *main::bar; return ($foo, $bar); } ($fuu, $baa) = foo(); ok(defined $fuu); is(ref(\$fuu), 'GLOB'); ok(defined $baa); is(ref(\$baa), 'GLOB'); # nested package globs # NOTE: It's probably OK if these semantics change, because the # fact that %X::Y:: is stored in %X:: isn't documented. # (I hope.) { package Foo::Bar; no warnings 'once'; $test=1; } ok(exists $Foo::{'Bar::'}); is($Foo::{'Bar::'}, '*Foo::Bar::'); # test undef operator clearing out entire glob $foo = 'stuff'; @foo = qw(more stuff); %foo = qw(even more random stuff); undef *foo; is ($foo, undef); is (scalar @foo, 0); is (scalar %foo, 0); { # test warnings from assignment of undef to glob my $msg = ''; local $SIG{__WARN__} = sub { $msg = $_[0] }; use warnings; *foo = 'bar'; is($msg, ''); *foo = undef; like($msg, qr/Undefined value assigned to typeglob/); no warnings 'once'; # test warnings for converting globs to other forms my $copy = *PWOMPF; foreach ($copy, *SKREEE) { $msg = ''; my $victim = sprintf "%d", $_; like($msg, qr/Argument "\*main::[A-Z]{6}" isn't numeric in sprintf/, "Warning on conversion to IV"); is($victim, 0); $msg = ''; $victim = sprintf "%u", $_; like($msg, qr/Argument "\*main::[A-Z]{6}" isn't numeric in sprintf/, "Warning on conversion to UV"); is($victim, 0); $msg = ''; $victim = sprintf "%e", $_; like($msg, qr/Argument "\*main::[A-Z]{6}" isn't numeric in sprintf/, "Warning on conversion to NV"); like($victim, qr/^0\.0+E\+?00/i, "Expect floating point zero"); $msg = ''; $victim = sprintf "%s", $_; is($msg, '', "No warning on stringification"); is($victim, '' . $_); } } my $test = curr_test(); # test *glob{THING} syntax $x = "ok $test\n"; ++$test; @x = ("ok $test\n"); ++$test; %x = ("ok $test" => "\n"); ++$test; sub x { "ok $test\n" } print ${*x{SCALAR}}, @{*x{ARRAY}}, %{*x{HASH}}, &{*x{CODE}}; # This needs to go here, after the print, as sub x will return the current # value of test ++$test; format x = XXX This text isn't used. Should it be? . curr_test($test); is (ref *x{FORMAT}, "FORMAT"); *x = *STDOUT; is (*{*x{GLOB}}, "*main::STDOUT"); { my $test = curr_test(); print {*x{IO}} "ok $test\n"; ++$test; my $warn; local $SIG{__WARN__} = sub { $warn .= $_[0]; }; my $val = *x{FILEHANDLE}; print {*x{IO}} ($warn =~ /is deprecated/ ? "ok $test\n" : "not ok $test\n"); curr_test(++$test); } { # test if defined() doesn't create any new symbols my $a = "SYM000"; ok(!defined *{$a}); ok(!defined @{$a}); ok(!defined *{$a}); { no warnings 'deprecated'; ok(!defined %{$a}); } ok(!defined *{$a}); ok(!defined ${$a}); ok(!defined *{$a}); ok(!defined &{$a}); ok(!defined *{$a}); my $state = "not"; *{$a} = sub { $state = "ok" }; ok(defined &{$a}); ok(defined *{$a}); &{$a}; is ($state, 'ok'); } { # although it *should* if you're talking about magicals my $a = "]"; ok(defined ${$a}); ok(defined *{$a}); $a = "1"; "o" =~ /(o)/; ok(${$a}); ok(defined *{$a}); $a = "2"; ok(!${$a}); ok(defined *{$a}); $a = "1x"; ok(!defined ${$a}); ok(!defined *{$a}); $a = "11"; "o" =~ /(((((((((((o)))))))))))/; ok(${$a}); ok(defined *{$a}); } # [ID 20010526.001] localized glob loses value when assigned to $j=1; %j=(a=>1); @j=(1); local *j=*j; *j = sub{}; is($j, 1); is($j{a}, 1); is($j[0], 1); { # does pp_readline() handle glob-ness correctly? my $g = *foo; $g = ; is ($g, "Perl\n"); } { my $w = ''; local $SIG{__WARN__} = sub { $w = $_[0] }; sub abc1 (); local *abc1 = sub { }; is ($w, ''); sub abc2 (); local *abc2; *abc2 = sub { }; is ($w, ''); sub abc3 (); *abc3 = sub { }; like ($w, qr/Prototype mismatch/); } { # [17375] rcatline to formerly-defined undef was broken. Fixed in # do_readline by checking SvOK. AMS, 20020918 my $x = "not "; $x = undef; $x .= ; is ($x, "Rules\n"); } { # test the assignment of a GLOB to an LVALUE my $e = ''; local $SIG{__DIE__} = sub { $e = $_[0] }; my $v; sub f { $_[0] = 0; $_[0] = "a"; $_[0] = *DATA } f($v); is ($v, '*main::DATA'); my $x = <$v>; is ($x, "perl\n"); } { $e = ''; # GLOB assignment to tied element local $SIG{__DIE__} = sub { $e = $_[0] }; sub T::TIEARRAY { bless [] => "T" } sub T::STORE { $_[0]->[ $_[1] ] = $_[2] } sub T::FETCH { $_[0]->[ $_[1] ] } sub T::FETCHSIZE { @{$_[0]} } tie my @ary => "T"; $ary[0] = *DATA; is ($ary[0], '*main::DATA'); is ($e, ''); my $x = readline $ary[0]; is($x, "rocks\n"); } { # Need some sort of die or warn to get the global destruction text if the # bug is still present my $output = runperl(prog => <<'EOPROG'); package M; $| = 1; sub DESTROY {eval {die qq{Farewell $_[0]}}; print $@} package main; bless \$A::B, 'M'; *A:: = \*B::; EOPROG like($output, qr/^Farewell M=SCALAR/, "DESTROY was called"); unlike($output, qr/global destruction/, "unreferenced symbol tables should be cleaned up immediately"); } # Possibly not the correct test file for these tests. # There are certain space optimisations implemented via promotion rules to # GVs foreach (qw (oonk ga_shloip)) { ok(!exists $::{$_}, "no symbols of any sort to start with for $_"); } # A string in place of the typeglob is promoted to the function prototype $::{oonk} = "pie"; my $proto = eval 'prototype \&oonk'; die if $@; is ($proto, "pie", "String is promoted to prototype"); # A reference to a value is used to generate a constant subroutine foreach my $value (3, "Perl rules", \42, qr/whatever/, [1,2,3], {1=>2}, \*STDIN, \&ok, \undef, *STDOUT) { delete $::{oonk}; $::{oonk} = \$value; $proto = eval 'prototype \&oonk'; die if $@; is ($proto, '', "Prototype for a constant subroutine is empty"); my $got = eval 'oonk'; die if $@; is (ref $got, ref $value, "Correct type of value (" . ref($value) . ")"); is ($got, $value, "Value is correctly set"); } delete $::{oonk}; $::{oonk} = \"Value"; *{"ga_shloip"} = \&{"oonk"}; is (ref $::{ga_shloip}, 'SCALAR', "Export of proxy constant as is"); is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); is (eval 'ga_shloip', "Value", "Constant has correct value"); is (ref $::{ga_shloip}, 'SCALAR', "Inlining of constant doesn't change represenatation"); delete $::{ga_shloip}; eval 'sub ga_shloip (); 1' or die $@; is ($::{ga_shloip}, '', "Prototype is stored as an empty string"); # Check that a prototype expands. *{"ga_shloip"} = \&{"oonk"}; is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); is (eval 'ga_shloip', "Value", "Constant has correct value"); is (ref \$::{ga_shloip}, 'GLOB', "Symbol table has full typeglob"); @::zwot = ('Zwot!'); # Check that assignment to an existing typeglob works { my $w = ''; local $SIG{__WARN__} = sub { $w = $_[0] }; *{"zwot"} = \&{"oonk"}; is($w, '', "Should be no warning"); } is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); is (eval 'zwot', "Value", "Constant has correct value"); is (ref \$::{zwot}, 'GLOB', "Symbol table has full typeglob"); is (join ('!', @::zwot), 'Zwot!', "Existing array still in typeglob"); sub spritsits () { "Traditional"; } # Check that assignment to an existing subroutine works { my $w = ''; local $SIG{__WARN__} = sub { $w = $_[0] }; *{"spritsits"} = \&{"oonk"}; like($w, qr/^Constant subroutine main::spritsits redefined/, "Redefining a constant sub should warn"); } is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); is (eval 'spritsits', "Value", "Constant has correct value"); is (ref \$::{spritsits}, 'GLOB', "Symbol table has full typeglob"); # Check that assignment to an existing typeglob works { my $w = ''; local $SIG{__WARN__} = sub { $w = $_[0] }; *{"plunk"} = []; *{"plunk"} = \&{"oonk"}; is($w, '', "Should be no warning"); } is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); is (eval 'plunk', "Value", "Constant has correct value"); is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob"); my $gr = eval '\*plunk' or die; { my $w = ''; local $SIG{__WARN__} = sub { $w = $_[0] }; *{$gr} = \&{"oonk"}; is($w, '', "Redefining a constant sub to another constant sub with the same underlying value should not warn (It's just re-exporting, and that was always legal)"); } is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); is (eval 'plunk', "Value", "Constant has correct value"); is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob"); # Non-void context should defeat the optimisation, and will cause the original # to be promoted (what change 26482 intended) my $result; { my $w = ''; local $SIG{__WARN__} = sub { $w = $_[0] }; $result = *{"awkkkkkk"} = \&{"oonk"}; is($w, '', "Should be no warning"); } is (ref \$result, 'GLOB', "Non void assignment should still return a typeglob"); is (ref \$::{oonk}, 'GLOB', "This export does affect original"); is (eval 'plunk', "Value", "Constant has correct value"); is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob"); delete $::{oonk}; $::{oonk} = \"Value"; sub non_dangling { my $w = ''; local $SIG{__WARN__} = sub { $w = $_[0] }; *{"zap"} = \&{"oonk"}; is($w, '', "Should be no warning"); } non_dangling(); is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); is (eval 'zap', "Value", "Constant has correct value"); is (ref $::{zap}, 'SCALAR', "Exported target is also a PCS"); sub dangling { local $SIG{__WARN__} = sub { die $_[0] }; *{"biff"} = \&{"oonk"}; } dangling(); is (ref \$::{oonk}, 'GLOB', "This export does affect original"); is (eval 'biff', "Value", "Constant has correct value"); is (ref \$::{biff}, 'GLOB', "Symbol table has full typeglob"); { use vars qw($glook $smek $foof); # Check reference assignment isn't affected by the SV type (bug #38439) $glook = 3; $smek = 4; $foof = "halt and cool down"; my $rv = \*smek; is($glook, 3); *glook = $rv; is($glook, 4); my $pv = ""; $pv = \*smek; is($foof, "halt and cool down"); *foof = $pv; is($foof, 4); } format = . foreach my $value ([1,2,3], {1=>2}, *STDOUT{IO}, \&ok, *STDOUT{FORMAT}) { # *STDOUT{IO} returns a reference to a PVIO. As it's blessed, ref returns # IO::Handle, which isn't what we want. my $type = $value; $type =~ s/.*=//; $type =~ s/\(.*//; delete $::{oonk}; $::{oonk} = $value; $proto = eval 'prototype \&oonk'; like ($@, qr/^Cannot convert a reference to $type to typeglob/, "Cannot upgrade ref-to-$type to typeglob"); } { no warnings qw(once uninitialized); my $g = \*clatter; my $r = eval {no strict; ${*{$g}{SCALAR}}}; is ($@, '', "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax"); $g = \*vowm; $r = eval {use strict; ${*{$g}{SCALAR}}}; is ($@, '', "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax under strict"); } { # Bug reported by broquaint on IRC *slosh::{HASH}->{ISA}=[]; slosh->import; pass("gv_fetchmeth coped with the unexpected"); # An audit found these: { package slosh; sub rip { my $s = shift; $s->SUPER::rip; } } eval {slosh->rip;}; like ($@, qr/^Can't locate object method "rip"/, "Even with SUPER"); is(slosh->isa('swoosh'), ''); $CORE::GLOBAL::{"lock"}=[]; eval "no warnings; lock"; like($@, qr/^Not enough arguments for lock/, "Can't trip up general keyword overloading"); $CORE::GLOBAL::{"readline"}=[]; eval " if 0"; is($@, '', "Can't trip up readline overloading"); $CORE::GLOBAL::{"readpipe"}=[]; eval "`` if 0"; is($@, '', "Can't trip up readpipe overloading"); } { die if exists $::{BONK}; $::{BONK} = \"powie"; *{"BONK"} = \&{"BONK"}; eval 'is(BONK(), "powie", "Assigment works when glob created midway (bug 45607)"); 1' or die $@; } # For now these tests are here, but they would probably be better in a file for # tests for croaks. (And in turn, that probably deserves to be in a different # directory. Gerard Goossen has a point about the layout being unclear sub coerce_integer { no warnings 'numeric'; $_[0] |= 0; } sub coerce_number { no warnings 'numeric'; $_[0] += 0; } sub coerce_string { $_[0] .= ''; } foreach my $type (qw(integer number string)) { my $prog = "coerce_$type(*STDERR)"; is (scalar eval "$prog; 1", undef, "$prog failed..."); like ($@, qr/Can't coerce GLOB to $type in/, "with the correct error message"); } # RT #60954 anonymous glob should be defined, and not coredump when # stringified. The behaviours are: # # defined($glob) "$glob" # 5.8.8 false "" with uninit warning # 5.10.0 true (coredump) # 5.12.0 true "" { my $io_ref = *STDOUT{IO}; my $glob = *$io_ref; ok(defined $glob, "RT #60954 anon glob should be defined"); my $warn = ''; local $SIG{__WARN__} = sub { $warn = $_[0] }; use warnings; my $str = "$glob"; is($warn, '', "RT #60954 anon glob stringification shouln't warn"); is($str, '', "RT #60954 anon glob stringification should be empty"); } # [perl #71254] - Assigning a glob to a variable that has a current # match position. (We are testing that Perl_magic_setmglob respects globs' # special used of SvSCREAM.) { $m = 2; $m=~s/./0/gems; $m= *STDERR; is( "$m", "*main::STDERR", '[perl #71254] assignment of globs to vars with pos' ); } # [perl #72740] - indirect object syntax, heuristically imputed due to # the non-existence of a function, should not cause a stash entry to be # created for the non-existent function. { package RT72740a; my $f = bless({}, RT72740b); sub s1 { s2 $f; } our $s4; sub s3 { s4 $f; } } { package RT72740b; sub s2 { "RT72740b::s2" } sub s4 { "RT72740b::s4" } } ok(exists($RT72740a::{s1}), "RT72740a::s1 exists"); ok(!exists($RT72740a::{s2}), "RT72740a::s2 does not exist"); ok(exists($RT72740a::{s3}), "RT72740a::s3 exists"); ok(exists($RT72740a::{s4}), "RT72740a::s4 exists"); is(RT72740a::s1(), "RT72740b::s2", "RT72740::s1 parsed correctly"); is(RT72740a::s3(), "RT72740b::s4", "RT72740::s3 parsed correctly"); __END__ Perl Rules perl rocks perl-5.12.0-RC0/t/op/lex.t0000555000175000017500000000165711325127001013767 0ustar jessejesse#!perl use strict; use warnings; require './test.pl'; plan(tests => 4); { no warnings 'deprecated'; print <<; # Yow! ok 1 # previous line intentionally left blank. my $yow = "ok 2"; print <<; # Yow! $yow # previous line intentionally left blank. } curr_test(3); { my %foo = (aap => "monkey"); my $foo = ''; is("@{[$foo{'aap'}]}", 'monkey', 'interpolation of hash lookup with space between lexical variable and subscript'); is("@{[$foo {'aap'}]}", 'monkey', 'interpolation of hash lookup with space between lexical variable and subscript - test for [perl #70091]'); # Original bug report [perl #70091] # #!perl # use warnings; # my %foo; # my $foo = ''; # (my $tmp = $foo) =~ s/^/$foo {$0}/e; # __END__ # # This program causes a segfault with 5.10.0 and 5.10.1. # # The space between '$foo' and '{' is essential, which is why piping # it through perl -MO=Deparse "fixes" it. # } perl-5.12.0-RC0/t/op/inc.t0000555000175000017500000001343211325125742013754 0ustar jessejesse#!./perl -w # use strict; print "1..54\n"; my $test = 1; sub ok { my ($pass, $wrong, $err) = @_; if ($pass) { print "ok $test\n"; $test = $test + 1; # Would be doubleplusbad to use ++ in the ++ test. return 1; } else { if ($err) { chomp $err; print "not ok $test # $err\n"; } else { if (defined $wrong) { $wrong = ", got $wrong"; } else { $wrong = ''; } printf "not ok $test # line %d$wrong\n", (caller)[2]; } } $test = $test + 1; return; } # Verify that addition/subtraction properly upgrade to doubles. # These tests are only significant on machines with 32 bit longs, # and two's complement negation, but shouldn't fail anywhere. my $a = 2147483647; my $c=$a++; ok ($a == 2147483648, $a); $a = 2147483647; $c=++$a; ok ($a == 2147483648, $a); $a = 2147483647; $a=$a+1; ok ($a == 2147483648, $a); $a = -2147483648; $c=$a--; ok ($a == -2147483649, $a); $a = -2147483648; $c=--$a; ok ($a == -2147483649, $a); $a = -2147483648; $a=$a-1; ok ($a == -2147483649, $a); $a = 2147483648; $a = -$a; $c=$a--; ok ($a == -2147483649, $a); $a = 2147483648; $a = -$a; $c=--$a; ok ($a == -2147483649, $a); $a = 2147483648; $a = -$a; $a=$a-1; ok ($a == -2147483649, $a); $a = 2147483648; $b = -$a; $c=$b--; ok ($b == -$a-1, $a); $a = 2147483648; $b = -$a; $c=--$b; ok ($b == -$a-1, $a); $a = 2147483648; $b = -$a; $b=$b-1; ok ($b == -(++$a), $a); $a = undef; ok ($a++ eq '0', do { $a=undef; $a++ }, "postinc undef returns '0'"); $a = undef; ok (!defined($a--), do { $a=undef; $a-- }, "postdec undef returns undef"); # Verify that shared hash keys become unshared. sub check_same { my ($orig, $suspect) = @_; my $fail; while (my ($key, $value) = each %$suspect) { if (exists $orig->{$key}) { if ($orig->{$key} ne $value) { print "# key '$key' was '$orig->{$key}' now '$value'\n"; $fail = 1; } } else { print "# key '$key' is '$orig->{$key}', unexpect.\n"; $fail = 1; } } foreach (keys %$orig) { next if (exists $suspect->{$_}); print "# key '$_' was '$orig->{$_}' now missing\n"; $fail = 1; } ok (!$fail); } my (%orig) = my (%inc) = my (%dec) = my (%postinc) = my (%postdec) = (1 => 1, ab => "ab"); my %up = (1=>2, ab => 'ac'); my %down = (1=>0, ab => -1); foreach (keys %inc) { my $ans = $up{$_}; my $up; eval {$up = ++$_}; ok ((defined $up and $up eq $ans), $up, $@); } check_same (\%orig, \%inc); foreach (keys %dec) { my $ans = $down{$_}; my $down; eval {$down = --$_}; ok ((defined $down and $down eq $ans), $down, $@); } check_same (\%orig, \%dec); foreach (keys %postinc) { my $ans = $postinc{$_}; my $up; eval {$up = $_++}; ok ((defined $up and $up eq $ans), $up, $@); } check_same (\%orig, \%postinc); foreach (keys %postdec) { my $ans = $postdec{$_}; my $down; eval {$down = $_--}; ok ((defined $down and $down eq $ans), $down, $@); } check_same (\%orig, \%postdec); { no warnings 'uninitialized'; my ($x, $y); eval { $y ="$x\n"; ++$x; }; ok($x == 1, $x); ok($@ eq '', $@); my ($p, $q); eval { $q ="$p\n"; --$p; }; ok($p == -1, $p); ok($@ eq '', $@); } $a = 2147483648; $c=--$a; ok ($a == 2147483647, $a); $a = 2147483648; $c=$a--; ok ($a == 2147483647, $a); { use integer; my $x = 0; $x++; ok ($x == 1, "(void) i_postinc"); $x--; ok ($x == 0, "(void) i_postdec"); } # I'm sure that there's an IBM format with a 48 bit mantissa # IEEE doubles have a 53 bit mantissa # 80 bit long doubles have a 64 bit mantissa # sparcs have a 112 bit mantissa for their long doubles. Just to be awkward :-) sub check_some_code { my ($start, $warn, $action, $description) = @_; my $warn_line = ($warn ? 'use' : 'no') . " warnings 'imprecision';"; my @warnings; local $SIG{__WARN__} = sub {push @warnings, "@_"}; print "# checking $action under $warn_line\n"; my $code = <<"EOC"; $warn_line my \$i = \$start; for(0 .. 3) { my \$a = $action; } 1; EOC eval $code or die "# $@\n$code"; if ($warn) { unless (ok (scalar @warnings == 2, scalar @warnings)) { print STDERR "# $_" foreach @warnings; } foreach (@warnings) { unless (ok (/Lost precision when incrementing \d+/, $_)) { print STDERR "# $_" } } } else { unless (ok (scalar @warnings == 0)) { print STDERR "# @$_" foreach @warnings; } } } my $h_uv_max = 1 + (~0 >> 1); my $found; for my $n (47..113) { my $power_of_2 = 2**$n; my $plus_1 = $power_of_2 + 1; next if $plus_1 != $power_of_2; my ($start_p, $start_n); if ($h_uv_max > $power_of_2 / 2) { my $uv_max = 1 + 2 * (~0 >> 1); # UV_MAX is 2**$something - 1, so subtract 1 to get the start value $start_p = $uv_max - 1; # whereas IV_MIN is -(2**$something), so subtract 2 $start_n = -$h_uv_max + 2; print "# Mantissa overflows at 2**$n ($power_of_2)\n"; print "# But max UV ($uv_max) is greater so testing that\n"; } else { print "# Testing 2**$n ($power_of_2) which overflows the mantissa\n"; $start_p = int($power_of_2 - 2); $start_n = -$start_p; my $check = $power_of_2 - 2; die "Something wrong with our rounding assumptions: $check vs $start_p" unless $start_p == $check; } foreach my $warn (0, 1) { foreach (['++$i', 'pre-inc'], ['$i++', 'post-inc']) { check_some_code($start_p, $warn, @$_); } foreach (['--$i', 'pre-dec'], ['$i--', 'post-dec']) { check_some_code($start_n, $warn, @$_); } } $found = 1; last; } die "Could not find a value which overflows the mantissa" unless $found; # these will segfault if they fail sub PVBM () { 'foo' } { my $dummy = index 'foo', PVBM } ok (scalar eval { my $pvbm = PVBM; $pvbm++ }); ok (scalar eval { my $pvbm = PVBM; $pvbm-- }); ok (scalar eval { my $pvbm = PVBM; ++$pvbm }); ok (scalar eval { my $pvbm = PVBM; --$pvbm }); perl-5.12.0-RC0/t/op/localref.t0000555000175000017500000000535211143650501014766 0ustar jessejesse#!./perl chdir 't' if -d 't'; @INC = qw(. ../lib); require "test.pl"; plan( tests => 64 ); $aa = 1; { local $aa; $aa = 2; is($aa,2); } is($aa,1); { local ${aa}; $aa = 3; is($aa,3); } is($aa,1); { local ${"aa"}; $aa = 4; is($aa,4); } is($aa,1); $x = "aa"; { local ${$x}; $aa = 5; is($aa,5); undef $x; is($aa,5); } is($aa,1); $x = "a"; { local ${$x x2};$aa = 6; is($aa,6); undef $x; is($aa,6); } is($aa,1); $x = "aa"; { local $$x; $aa = 7; is($aa,7); undef $x; is($aa,7); } is($aa,1); @aa = qw/a b/; { local @aa; @aa = qw/c d/; is("@aa","c d"); } is("@aa","a b"); { local @{aa}; @aa = qw/e f/; is("@aa","e f"); } is("@aa","a b"); { local @{"aa"}; @aa = qw/g h/; is("@aa","g h"); } is("@aa","a b"); $x = "aa"; { local @{$x}; @aa = qw/i j/; is("@aa","i j"); undef $x; is("@aa","i j"); } is("@aa","a b"); $x = "a"; { local @{$x x2};@aa = qw/k l/; is("@aa","k l"); undef $x; is("@aa","k l"); } is("@aa","a b"); $x = "aa"; { local @$x; @aa = qw/m n/; is("@aa","m n"); undef $x; is("@aa","m n"); } is("@aa","a b"); %aa = qw/a b/; { local %aa; %aa = qw/c d/; is($aa{c},"d"); } is($aa{a},"b"); { local %{aa}; %aa = qw/e f/; is($aa{e},"f"); } is($aa{a},"b"); { local %{"aa"}; %aa = qw/g h/; is($aa{g},"h"); } is($aa{a},"b"); $x = "aa"; { local %{$x}; %aa = qw/i j/; is($aa{i},"j"); undef $x; is($aa{i},"j"); } is($aa{a},"b"); $x = "a"; { local %{$x x2};%aa = qw/k l/; is($aa{k},"l"); undef $x; is($aa{k},"l"); } is($aa{a},"b"); $x = "aa"; { local %$x; %aa = qw/m n/; is($aa{m},"n"); undef $x; is($aa{m},"n"); } is($aa{a},"b"); sub test_err_localref () { like($@,qr/Can't localize through a reference/,'error'); } $x = \$aa; my $y = \$aa; eval { local $$x; }; test_err_localref; eval { local ${$x}; }; test_err_localref; eval { local $$y; }; test_err_localref; eval { local ${$y}; }; test_err_localref; eval { local ${\$aa}; }; test_err_localref; eval { local ${\'aa'}; }; test_err_localref; $x = \@aa; $y = \@aa; eval { local @$x; }; test_err_localref; eval { local @{$x}; }; test_err_localref; eval { local @$y; }; test_err_localref; eval { local @{$y}; }; test_err_localref; eval { local @{\@aa}; }; test_err_localref; eval { local @{[]}; }; test_err_localref; $x = \%aa; $y = \%aa; eval { local %$x; }; test_err_localref; eval { local %{$x}; }; test_err_localref; eval { local %$y; }; test_err_localref; eval { local %{$y}; }; test_err_localref; eval { local %{\%aa}; }; test_err_localref; eval { local %{{a=>1}}; };test_err_localref; { # [perl #27638] when restoring a localized variable, the thing being # freed shouldn't be visible my $ok; $x = 0; sub X::DESTROY { $ok = !ref($x); } { local $x = \ bless {}, 'X'; 1; } ok($ok,'old value not visible during restore'); } perl-5.12.0-RC0/t/op/inccode.t0000555000175000017500000002110611325127001014572 0ustar jessejesse#!./perl -w # Tests for the coderef-in-@INC feature use Config; my $can_fork = 0; my $minitest = $ENV{PERL_CORE_MINITEST}; my $has_perlio = $Config{useperlio}; BEGIN { chdir 't' if -d 't'; @INC = qw(. ../lib); } if (!$minitest) { if ($Config{d_fork} && eval 'require POSIX; 1') { $can_fork = 1; } } use strict; use File::Spec; require "test.pl"; plan(tests => 49 + !$minitest * (3 + 14 * $can_fork)); sub get_temp_fh { my $f = tempfile(); open my $fh, ">$f" or die "Can't create $f: $!"; print $fh "package ".substr($_[0],0,-3).";\n1;\n"; print $fh $_[1] if @_ > 1; close $fh or die "Couldn't close: $!"; open $fh, $f or die "Can't open $f: $!"; return $fh; } sub fooinc { my ($self, $filename) = @_; if (substr($filename,0,3) eq 'Foo') { return get_temp_fh($filename); } else { return undef; } } push @INC, \&fooinc; my $evalret = eval { require Bar; 1 }; ok( !$evalret, 'Trying non-magic package' ); $evalret = eval { require Foo; 1 }; die $@ if $@; ok( $evalret, 'require Foo; magic via code ref' ); ok( exists $INC{'Foo.pm'}, ' %INC sees Foo.pm' ); is( ref $INC{'Foo.pm'}, 'CODE', ' val Foo.pm is a coderef in %INC' ); is( $INC{'Foo.pm'}, \&fooinc, ' val Foo.pm is correct in %INC' ); $evalret = eval "use Foo1; 1;"; die $@ if $@; ok( $evalret, 'use Foo1' ); ok( exists $INC{'Foo1.pm'}, ' %INC sees Foo1.pm' ); is( ref $INC{'Foo1.pm'}, 'CODE', ' val Foo1.pm is a coderef in %INC' ); is( $INC{'Foo1.pm'}, \&fooinc, ' val Foo1.pm is correct in %INC' ); $evalret = eval { do 'Foo2.pl'; 1 }; die $@ if $@; ok( $evalret, 'do "Foo2.pl"' ); ok( exists $INC{'Foo2.pl'}, ' %INC sees Foo2.pl' ); is( ref $INC{'Foo2.pl'}, 'CODE', ' val Foo2.pl is a coderef in %INC' ); is( $INC{'Foo2.pl'}, \&fooinc, ' val Foo2.pl is correct in %INC' ); pop @INC; sub fooinc2 { my ($self, $filename) = @_; if (substr($filename, 0, length($self->[1])) eq $self->[1]) { return get_temp_fh($filename); } else { return undef; } } my $arrayref = [ \&fooinc2, 'Bar' ]; push @INC, $arrayref; $evalret = eval { require Foo; 1; }; die $@ if $@; ok( $evalret, 'Originally loaded packages preserved' ); $evalret = eval { require Foo3; 1; }; ok( !$evalret, 'Original magic INC purged' ); $evalret = eval { require Bar; 1 }; die $@ if $@; ok( $evalret, 'require Bar; magic via array ref' ); ok( exists $INC{'Bar.pm'}, ' %INC sees Bar.pm' ); is( ref $INC{'Bar.pm'}, 'ARRAY', ' val Bar.pm is an arrayref in %INC' ); is( $INC{'Bar.pm'}, $arrayref, ' val Bar.pm is correct in %INC' ); ok( eval "use Bar1; 1;", 'use Bar1' ); ok( exists $INC{'Bar1.pm'}, ' %INC sees Bar1.pm' ); is( ref $INC{'Bar1.pm'}, 'ARRAY', ' val Bar1.pm is an arrayref in %INC' ); is( $INC{'Bar1.pm'}, $arrayref, ' val Bar1.pm is correct in %INC' ); ok( eval { do 'Bar2.pl'; 1 }, 'do "Bar2.pl"' ); ok( exists $INC{'Bar2.pl'}, ' %INC sees Bar2.pl' ); is( ref $INC{'Bar2.pl'}, 'ARRAY', ' val Bar2.pl is an arrayref in %INC' ); is( $INC{'Bar2.pl'}, $arrayref, ' val Bar2.pl is correct in %INC' ); pop @INC; sub FooLoader::INC { my ($self, $filename) = @_; if (substr($filename,0,4) eq 'Quux') { return get_temp_fh($filename); } else { return undef; } } my $href = bless( {}, 'FooLoader' ); push @INC, $href; $evalret = eval { require Quux; 1 }; die $@ if $@; ok( $evalret, 'require Quux; magic via hash object' ); ok( exists $INC{'Quux.pm'}, ' %INC sees Quux.pm' ); is( ref $INC{'Quux.pm'}, 'FooLoader', ' val Quux.pm is an object in %INC' ); is( $INC{'Quux.pm'}, $href, ' val Quux.pm is correct in %INC' ); pop @INC; my $aref = bless( [], 'FooLoader' ); push @INC, $aref; $evalret = eval { require Quux1; 1 }; die $@ if $@; ok( $evalret, 'require Quux1; magic via array object' ); ok( exists $INC{'Quux1.pm'}, ' %INC sees Quux1.pm' ); is( ref $INC{'Quux1.pm'}, 'FooLoader', ' val Quux1.pm is an object in %INC' ); is( $INC{'Quux1.pm'}, $aref, ' val Quux1.pm is correct in %INC' ); pop @INC; my $sref = bless( \(my $x = 1), 'FooLoader' ); push @INC, $sref; $evalret = eval { require Quux2; 1 }; die $@ if $@; ok( $evalret, 'require Quux2; magic via scalar object' ); ok( exists $INC{'Quux2.pm'}, ' %INC sees Quux2.pm' ); is( ref $INC{'Quux2.pm'}, 'FooLoader', ' val Quux2.pm is an object in %INC' ); is( $INC{'Quux2.pm'}, $sref, ' val Quux2.pm is correct in %INC' ); pop @INC; push @INC, sub { my ($self, $filename) = @_; if (substr($filename,0,4) eq 'Toto') { $INC{$filename} = 'xyz'; return get_temp_fh($filename); } else { return undef; } }; $evalret = eval { require Toto; 1 }; die $@ if $@; ok( $evalret, 'require Toto; magic via anonymous code ref' ); ok( exists $INC{'Toto.pm'}, ' %INC sees Toto.pm' ); ok( ! ref $INC{'Toto.pm'}, q/ val Toto.pm isn't a ref in %INC/ ); is( $INC{'Toto.pm'}, 'xyz', ' val Toto.pm is correct in %INC' ); pop @INC; push @INC, sub { my ($self, $filename) = @_; if ($filename eq 'abc.pl') { return get_temp_fh($filename, qq(return "abc";\n)); } else { return undef; } }; my $ret = ""; $ret ||= do 'abc.pl'; is( $ret, 'abc', 'do "abc.pl" sees return value' ); { my $filename = './Foo.pm'; #local @INC; # local fails on tied @INC my @old_INC = @INC; # because local doesn't work on tied arrays @INC = sub { $filename = 'seen'; return undef; }; eval { require $filename; }; is( $filename, 'seen', 'the coderef sees fully-qualified pathnames' ); @INC = @old_INC; } # this will segfault if it fails sub PVBM () { 'foo' } { my $dummy = index 'foo', PVBM } # I don't know whether these requires should succeed or fail. 5.8 failed # all of them; 5.10 with an ordinary constant in place of PVBM lets the # latter two succeed. For now I don't care, as long as they don't # segfault :). unshift @INC, sub { PVBM }; eval 'require foo'; ok( 1, 'returning PVBM doesn\'t segfault require' ); eval 'use foo'; ok( 1, 'returning PVBM doesn\'t segfault use' ); shift @INC; unshift @INC, sub { \PVBM }; eval 'require foo'; ok( 1, 'returning PVBM ref doesn\'t segfault require' ); eval 'use foo'; ok( 1, 'returning PVBM ref doesn\'t segfault use' ); shift @INC; exit if $minitest; SKIP: { skip( "No PerlIO available", 3 ) unless $has_perlio; pop @INC; push @INC, sub { my ($cr, $filename) = @_; my $module = $filename; $module =~ s,/,::,g; $module =~ s/\.pm$//; open my $fh, '<', \"package $module; sub complain { warn q() }; \$::file = __FILE__;" or die $!; $INC{$filename} = "/custom/path/to/$filename"; return $fh; }; require Publius::Vergilius::Maro; is( $INC{'Publius/Vergilius/Maro.pm'}, '/custom/path/to/Publius/Vergilius/Maro.pm', '%INC set correctly'); is( our $file, '/custom/path/to/Publius/Vergilius/Maro.pm', '__FILE__ set correctly' ); { my $warning; local $SIG{__WARN__} = sub { $warning = shift }; Publius::Vergilius::Maro::complain(); like( $warning, qr{something's wrong at /custom/path/to/Publius/Vergilius/Maro.pm}, 'warn() reports correct file source' ); } } pop @INC; if ($can_fork) { require PerlIO::scalar; # This little bundle of joy generates n more recursive use statements, # with each module chaining the next one down to 0. If it works, then we # can safely nest subprocesses my $use_filter_too; push @INC, sub { return unless $_[1] =~ /^BBBLPLAST(\d+)\.pm/; my $pid = open my $fh, "-|"; if ($pid) { # Parent return $fh unless $use_filter_too; # Try filters and state in addition. return ($fh, sub {s/$_[1]/pass/; return}, "die") } die "Can't fork self: $!" unless defined $pid; # Child my $count = $1; # Lets force some fun with odd sized reads. $| = 1; print 'push @main::bbblplast, '; print "$count;\n"; if ($count--) { print "use BBBLPLAST$count;\n"; } if ($use_filter_too) { print "die('In $_[1]');"; } else { print "pass('In $_[1]');"; } print '"Truth"'; POSIX::_exit(0); die "Can't get here: $!"; }; @::bbblplast = (); require BBBLPLAST5; is ("@::bbblplast", "0 1 2 3 4 5", "All ran"); foreach (keys %INC) { delete $INC{$_} if /^BBBLPLAST/; } @::bbblplast = (); $use_filter_too = 1; require BBBLPLAST5; is ("@::bbblplast", "0 1 2 3 4 5", "All ran with a filter"); } perl-5.12.0-RC0/t/op/goto.t0000555000175000017500000002237611325127001014150 0ustar jessejesse#!./perl # "This IS structured code. It's just randomly structured." BEGIN { chdir 't' if -d 't'; @INC = qw(. ../lib); require "test.pl"; } use warnings; use strict; plan tests => 66; our $TODO; my $deprecated = 0; local $SIG{__WARN__} = sub { if ($_[0] =~ m/jump into a construct/) { $deprecated++; } else { warn $_[0] } }; our $foo; while ($?) { $foo = 1; label1: is($deprecated, 1); $deprecated = 0; $foo = 2; goto label2; } continue { $foo = 0; goto label4; label3: is($deprecated, 1); $deprecated = 0; $foo = 4; goto label4; } is($deprecated, 0); goto label1; $foo = 3; label2: is($foo, 2, 'escape while loop'); is($deprecated, 0); goto label3; label4: is($foo, 4, 'second escape while loop'); my $r = run_perl(prog => 'goto foo;', stderr => 1); like($r, qr/label/, 'cant find label'); my $ok = 0; sub foo { goto bar; return; bar: $ok = 1; } &foo; ok($ok, 'goto in sub'); sub bar { my $x = 'bypass'; eval "goto $x"; } &bar; exit; FINALE: is(curr_test(), 20, 'FINALE'); # does goto LABEL handle block contexts correctly? # note that this scope-hopping differs from last & next, # which always go up-scope strictly. my $count = 0; my $cond = 1; for (1) { if ($cond == 1) { $cond = 0; goto OTHER; } elsif ($cond == 0) { OTHER: $cond = 2; is($count, 0, 'OTHER'); $count++; goto THIRD; } else { THIRD: is($count, 1, 'THIRD'); $count++; } } is($count, 2, 'end of loop'); # Does goto work correctly within a for(;;) loop? # (BUG ID 20010309.004) for(my $i=0;!$i++;) { my $x=1; goto label; label: is($x, 1, 'goto inside a for(;;) loop body from inside the body'); } # Does goto work correctly going *to* a for(;;) loop? # (make sure it doesn't skip the initializer) my ($z, $y) = (0); FORL1: for ($y=1; $z;) { ok($y, 'goto a for(;;) loop, from outside (does initializer)'); goto TEST19} ($y,$z) = (0, 1); goto FORL1; # Even from within the loop? TEST19: $z = 0; FORL2: for($y=1; 1;) { if ($z) { ok($y, 'goto a for(;;) loop, from inside (does initializer)'); last; } ($y, $z) = (0, 1); goto FORL2; } # Does goto work correctly within a try block? # (BUG ID 20000313.004) - [perl #2359] $ok = 0; eval { my $variable = 1; goto LABEL20; LABEL20: $ok = 1 if $variable; }; ok($ok, 'works correctly within a try block'); is($@, "", '...and $@ not set'); # And within an eval-string? $ok = 0; eval q{ my $variable = 1; goto LABEL21; LABEL21: $ok = 1 if $variable; }; ok($ok, 'works correctly within an eval string'); is($@, "", '...and $@ still not set'); # Test that goto works in nested eval-string $ok = 0; {eval q{ eval q{ goto LABEL22; }; $ok = 0; last; LABEL22: $ok = 1; }; $ok = 0 if $@; } ok($ok, 'works correctly in a nested eval string'); { my $false = 0; my $count; $ok = 0; { goto A; A: $ok = 1 } continue { } ok($ok, '#20357 goto inside /{ } continue { }/ loop'); $ok = 0; { do { goto A; A: $ok = 1 } while $false } ok($ok, '#20154 goto inside /do { } while ()/ loop'); $ok = 0; foreach(1) { goto A; A: $ok = 1 } continue { }; ok($ok, 'goto inside /foreach () { } continue { }/ loop'); $ok = 0; sub a { A: { if ($false) { redo A; B: $ok = 1; redo A; } } goto B unless $count++; } is($deprecated, 0); a(); ok($ok, '#19061 loop label wiped away by goto'); is($deprecated, 1); $deprecated = 0; $ok = 0; my $p; for ($p=1;$p && goto A;$p=0) { A: $ok = 1 } ok($ok, 'weird case of goto and for(;;) loop'); is($deprecated, 1); $deprecated = 0; } # bug #9990 - don't prematurely free the CV we're &going to. sub f1 { my $x; goto sub { $x=0; ok(1,"don't prematurely free CV\n") } } f1(); # bug #22181 - this used to coredump or make $x undefined, due to # erroneous popping of the inner BLOCK context undef $ok; for ($count=0; $count<2; $count++) { my $x = 1; goto LABEL29; LABEL29: $ok = $x; } is($ok, 1, 'goto in for(;;) with continuation'); # bug #22299 - goto in require doesn't find label open my $f, ">Op_goto01.pm" or die; print $f <<'EOT'; package goto01; goto YYY; die; YYY: print "OK\n"; 1; EOT close $f; $r = runperl(prog => 'use Op_goto01; print qq[DONE\n]'); is($r, "OK\nDONE\n", "goto within use-d file"); unlink "Op_goto01.pm"; # test for [perl #24108] $ok = 1; $count = 0; sub i_return_a_label { $count++; return "returned_label"; } eval { goto +i_return_a_label; }; $ok = 0; returned_label: is($count, 1, 'called i_return_a_label'); ok($ok, 'skipped to returned_label'); # [perl #29708] - goto &foo could leave foo() at depth two with # @_ == PL_sv_undef, causing a coredump $r = runperl( prog => 'sub f { return if $d; $d=1; my $a=sub {goto &f}; &$a; f() } f(); print qq(ok\n)', stderr => 1 ); is($r, "ok\n", 'avoid pad without an @_'); goto moretests; fail('goto moretests'); exit; bypass: is(curr_test(), 9, 'eval "goto $x"'); # Test autoloading mechanism. sub two { my ($pack, $file, $line) = caller; # Should indicate original call stats. is("@_ $pack $file $line", "1 2 3 main $::FILE $::LINE", 'autoloading mechanism.'); } sub one { eval <<'END'; no warnings 'redefine'; sub one { pass('sub one'); goto &two; fail('sub one tail'); } END goto &one; } $::FILE = __FILE__; $::LINE = __LINE__ + 1; &one(1,2,3); { my $wherever = 'NOWHERE'; eval { goto $wherever }; like($@, qr/Can't find label NOWHERE/, 'goto NOWHERE sets $@'); } # see if a modified @_ propagates { my $i; package Foo; sub DESTROY { my $s = shift; ::is($s->[0], $i, "destroy $i"); } sub show { ::is(+@_, 5, "show $i",); } sub start { push @_, 1, "foo", {}; goto &show; } for (1..3) { $i = $_; start(bless([$_]), 'bar'); } } sub auto { goto &loadit; } sub AUTOLOAD { $ok = 1 if "@_" eq "foo" } $ok = 0; auto("foo"); ok($ok, 'autoload'); { my $wherever = 'FINALE'; goto $wherever; } fail('goto $wherever'); moretests: # test goto duplicated labels. { my $z = 0; eval { $z = 0; for (0..1) { L4: # not outer scope $z += 10; last; } goto L4 if $z == 10; last; }; like($@, qr/Can't "goto" into the middle of a foreach loop/, 'catch goto middle of foreach'); $z = 0; # ambiguous label resolution (outer scope means endless loop!) L1: for my $x (0..1) { $z += 10; is($z, 10, 'prefer same scope (loop body) to outer scope (loop entry)'); goto L1 unless $x; $z += 10; L1: is($z, 10, 'prefer same scope: second'); last; } $z = 0; L2: { $z += 10; is($z, 10, 'prefer this scope (block body) to outer scope (block entry)'); goto L2 if $z == 10; $z += 10; L2: is($z, 10, 'prefer this scope: second'); } { $z = 0; while (1) { L3: # not inner scope $z += 10; last; } is($z, 10, 'prefer this scope to inner scope'); goto L3 if $z == 10; $z += 10; L3: # this scope ! is($z, 10, 'prefer this scope to inner scope: second'); } L4: # not outer scope { $z = 0; while (1) { L4: # not inner scope $z += 1; last; } is($z, 1, 'prefer this scope to inner,outer scopes'); goto L4 if $z == 1; $z += 10; L4: # this scope ! is($z, 1, 'prefer this scope to inner,outer scopes: second'); } { my $loop = 0; for my $x (0..1) { L2: # without this, fails 1 (middle) out of 3 iterations $z = 0; L2: $z += 10; is($z, 10, "same label, multiple times in same scope (choose 1st) $loop"); goto L2 if $z == 10 and not $loop++; } } } # deep recursion with gotos eventually caused a stack reallocation # which messed up buggy internals that didn't expect the stack to move sub recurse1 { unshift @_, "x"; no warnings 'recursion'; goto &recurse2; } sub recurse2 { my $x = shift; $_[0] ? +1 + recurse1($_[0] - 1) : 0 } is(recurse1(500), 500, 'recursive goto &foo'); # [perl #32039] Chained goto &sub drops data too early. sub a32039 { @_=("foo"); goto &b32039; } sub b32039 { goto &c32039; } sub c32039 { is($_[0], 'foo', 'chained &goto') } a32039(); # [perl #35214] next and redo re-entered the loop with the wrong cop, # causing a subsequent goto to crash { my $r = runperl( stderr => 1, prog => 'for ($_=0;$_<3;$_++){A: if($_==1){next} if($_==2){$_++;goto A}}print qq(ok\n)' ); is($r, "ok\n", 'next and goto'); $r = runperl( stderr => 1, prog => 'for ($_=0;$_<3;$_++){A: if($_==1){$_++;redo} if($_==2){$_++;goto A}}print qq(ok\n)' ); is($r, "ok\n", 'redo and goto'); } # goto &foo not allowed in evals sub null { 1 }; eval 'goto &null'; like($@, qr/Can't goto subroutine from an eval-string/, 'eval string'); eval { goto &null }; like($@, qr/Can't goto subroutine from an eval-block/, 'eval block'); # [perl #36521] goto &foo in warn handler could defeat recursion avoider { my $r = runperl( stderr => 1, prog => 'my $d; my $w = sub { return if $d++; warn q(bar)}; local $SIG{__WARN__} = sub { goto &$w; }; warn q(foo);' ); like($r, qr/bar/, "goto &foo in warn"); } TODO: { local $TODO = "[perl #43403] goto() from an if to an else doesn't undo local () changes"; our $global = "unmodified"; if ($global) { # true but not constant-folded local $global = "modified"; goto ELSE; } else { ELSE: is($global, "unmodified"); } } is($deprecated, 0); perl-5.12.0-RC0/t/op/split.t0000555000175000017500000003013111325127001014317 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } plan tests => 251; $FS = ':'; $_ = 'a:b:c'; ($a,$b,$c) = split($FS,$_); is(join(';',$a,$b,$c), 'a;b;c'); @ary = split(/:b:/); $cnt = split(/:b:/); is(join("$_",@ary), 'aa:b:cc'); is($cnt, scalar(@ary)); $_ = "abc\n"; my @xyz = (@ary = split(//)); $cnt = split(//); is(join(".",@ary), "a.b.c.\n"); is($cnt, scalar(@ary)); $_ = "a:b:c::::"; @ary = split(/:/); $cnt = split(/:/); is(join(".",@ary), "a.b.c"); is($cnt, scalar(@ary)); $_ = join(':',split(' '," a b\tc \t d ")); is($_, 'a:b:c:d'); @ary = split(' '," a b\tc \t d "); $cnt = split(' '," a b\tc \t d "); is($cnt, scalar(@ary)); $_ = join(':',split(/ */,"foo bar bie\tdoll")); is($_ , "f:o:o:b:a:r:b:i:e:\t:d:o:l:l"); @ary = split(/ */,"foo bar bie\tdoll"); $cnt = split(/ */,"foo bar bie\tdoll"); is($cnt, scalar(@ary)); $_ = join(':', 'foo', split(/ /,'a b c'), 'bar'); is($_, "foo:a:b::c:bar"); @ary = split(/ /,'a b c'); $cnt = split(/ /,'a b c'); is($cnt, scalar(@ary)); # Can we say how many fields to split to? $_ = join(':', split(' ','1 2 3 4 5 6', 3)); is($_, '1:2:3 4 5 6'); @ary = split(' ','1 2 3 4 5 6', 3); $cnt = split(' ','1 2 3 4 5 6', 3); is($cnt, scalar(@ary)); # Can we do it as a variable? $x = 4; $_ = join(':', split(' ','1 2 3 4 5 6', $x)); is($_, '1:2:3:4 5 6'); @ary = split(' ','1 2 3 4 5 6', $x); $cnt = split(' ','1 2 3 4 5 6', $x); is($cnt, scalar(@ary)); # Does the 999 suppress null field chopping? $_ = join(':', split(/:/,'1:2:3:4:5:6:::', 999)); is($_ , '1:2:3:4:5:6:::'); @ary = split(/:/,'1:2:3:4:5:6:::', 999); $cnt = split(/:/,'1:2:3:4:5:6:::', 999); is($cnt, scalar(@ary)); # Does assignment to a list imply split to one more field than that? $foo = runperl( switches => ['-Dt'], stderr => 1, prog => '($a,$b)=split;' ); ok($foo =~ /DEBUGGING/ || $foo =~ /const\n?\Q(IV(3))\E/); # Can we say how many fields to split to when assigning to a list? ($a,$b) = split(' ','1 2 3 4 5 6', 2); $_ = join(':',$a,$b); is($_, '1:2 3 4 5 6'); # do subpatterns generate additional fields (without trailing nulls)? $_ = join '|', split(/,|(-)/, "1-10,20,,,"); is($_, "1|-|10||20"); @ary = split(/,|(-)/, "1-10,20,,,"); $cnt = split(/,|(-)/, "1-10,20,,,"); is($cnt, scalar(@ary)); # do subpatterns generate additional fields (with a limit)? $_ = join '|', split(/,|(-)/, "1-10,20,,,", 10); is($_, "1|-|10||20||||||"); @ary = split(/,|(-)/, "1-10,20,,,", 10); $cnt = split(/,|(-)/, "1-10,20,,,", 10); is($cnt, scalar(@ary)); # is the 'two undefs' bug fixed? (undef, $a, undef, $b) = qw(1 2 3 4); is("$a|$b", "2|4"); # .. even for locals? { local(undef, $a, undef, $b) = qw(1 2 3 4); is("$a|$b", "2|4"); } # check splitting of null string $_ = join('|', split(/x/, '',-1), 'Z'); is($_, "Z"); @ary = split(/x/, '',-1); $cnt = split(/x/, '',-1); is($cnt, scalar(@ary)); $_ = join('|', split(/x/, '', 1), 'Z'); is($_, "Z"); @ary = split(/x/, '', 1); $cnt = split(/x/, '', 1); is($cnt, scalar(@ary)); $_ = join('|', split(/(p+)/,'',-1), 'Z'); is($_, "Z"); @ary = split(/(p+)/,'',-1); $cnt = split(/(p+)/,'',-1); is($cnt, scalar(@ary)); $_ = join('|', split(/.?/, '',-1), 'Z'); is($_, "Z"); @ary = split(/.?/, '',-1); $cnt = split(/.?/, '',-1); is($cnt, scalar(@ary)); # Are /^/m patterns scanned? $_ = join '|', split(/^a/m, "a b a\na d a", 20); is($_, "| b a\n| d a"); @ary = split(/^a/m, "a b a\na d a", 20); $cnt = split(/^a/m, "a b a\na d a", 20); is($cnt, scalar(@ary)); # Are /$/m patterns scanned? $_ = join '|', split(/a$/m, "a b a\na d a", 20); is($_, "a b |\na d |"); @ary = split(/a$/m, "a b a\na d a", 20); $cnt = split(/a$/m, "a b a\na d a", 20); is($cnt, scalar(@ary)); # Are /^/m patterns scanned? $_ = join '|', split(/^aa/m, "aa b aa\naa d aa", 20); is($_, "| b aa\n| d aa"); @ary = split(/^aa/m, "aa b aa\naa d aa", 20); $cnt = split(/^aa/m, "aa b aa\naa d aa", 20); is($cnt, scalar(@ary)); # Are /$/m patterns scanned? $_ = join '|', split(/aa$/m, "aa b aa\naa d aa", 20); is($_, "aa b |\naa d |"); @ary = split(/aa$/m, "aa b aa\naa d aa", 20); $cnt = split(/aa$/m, "aa b aa\naa d aa", 20); is($cnt, scalar(@ary)); # Greedyness: $_ = "a : b :c: d"; @ary = split(/\s*:\s*/); $cnt = split(/\s*:\s*/); is(($res = join(".",@ary)), "a.b.c.d", $res); is($cnt, scalar(@ary)); # use of match result as pattern (!) is('p:q:r:s', join ':', split('abc' =~ /b/, 'p1q1r1s')); @ary = split('abc' =~ /b/, 'p1q1r1s'); $cnt = split('abc' =~ /b/, 'p1q1r1s'); is($cnt, scalar(@ary)); # /^/ treated as /^/m $_ = join ':', split /^/, "ab\ncd\nef\n"; is($_, "ab\n:cd\n:ef\n"); # see if @a = @b = split(...) optimization works @list1 = @list2 = split ('p',"a p b c p"); ok(@list1 == @list2 && "@list1" eq "@list2" && @list1 == 2 && "@list1" eq "a b c "); # zero-width assertion $_ = join ':', split /(?=\w)/, "rm b"; is($_, "r:m :b"); @ary = split /(?=\w)/, "rm b"; $cnt = split /(?=\w)/, "rm b"; is($cnt, scalar(@ary)); # unicode splittage @ary = map {ord} split //, v1.20.300.4000.50000.4000.300.20.1; $cnt = split //, v1.20.300.4000.50000.4000.300.20.1; is("@ary", "1 20 300 4000 50000 4000 300 20 1"); is($cnt, scalar(@ary)); @ary = split(/\x{FE}/, "\x{FF}\x{FE}\x{FD}"); # bug id 20010105.016 $cnt = split(/\x{FE}/, "\x{FF}\x{FE}\x{FD}"); # bug id 20010105.016 ok(@ary == 2 && $ary[0] eq "\xFF" && $ary[1] eq "\xFD" && $ary[0] eq "\x{FF}" && $ary[1] eq "\x{FD}"); is($cnt, scalar(@ary)); @ary = split(/(\x{FE}\xFE)/, "\xFF\x{FF}\xFE\x{FE}\xFD\x{FD}"); # variant of 31 $cnt = split(/(\x{FE}\xFE)/, "\xFF\x{FF}\xFE\x{FE}\xFD\x{FD}"); # variant of 31 ok(@ary == 3 && $ary[0] eq "\xFF\xFF" && $ary[0] eq "\x{FF}\xFF" && $ary[0] eq "\x{FF}\x{FF}" && $ary[1] eq "\xFE\xFE" && $ary[1] eq "\x{FE}\xFE" && $ary[1] eq "\x{FE}\x{FE}" && $ary[2] eq "\xFD\xFD" && $ary[2] eq "\x{FD}\xFD" && $ary[2] eq "\x{FD}\x{FD}"); is($cnt, scalar(@ary)); { my @a = map ord, split(//, join("", map chr, (1234, 123, 2345))); my $c = split(//, join("", map chr, (1234, 123, 2345))); is("@a", "1234 123 2345"); is($c, scalar(@a)); } { my $x = 'A'; my @a = map ord, split(/$x/, join("", map chr, (1234, ord($x), 2345))); my $c = split(/$x/, join("", map chr, (1234, ord($x), 2345))); is("@a", "1234 2345"); is($c, scalar(@a)); } { # bug id 20000427.003 use warnings; use strict; my $sushi = "\x{b36c}\x{5a8c}\x{ff5b}\x{5079}\x{505b}"; my @charlist = split //, $sushi; my $charnum = split //, $sushi; is($charnum, scalar(@charlist)); my $r = ''; foreach my $ch (@charlist) { $r = $r . " " . sprintf "U+%04X", ord($ch); } is($r, " U+B36C U+5A8C U+FF5B U+5079 U+505B"); } { my $s = "\x20\x40\x{80}\x{100}\x{80}\x40\x20"; SKIP: { if (ord('A') == 193) { skip("EBCDIC", 1); } else { # bug id 20000426.003 my ($a, $b, $c) = split(/\x40/, $s); ok($a eq "\x20" && $b eq "\x{80}\x{100}\x{80}" && $c eq $a); } } my ($a, $b) = split(/\x{100}/, $s); ok($a eq "\x20\x40\x{80}" && $b eq "\x{80}\x40\x20"); my ($a, $b) = split(/\x{80}\x{100}\x{80}/, $s); ok($a eq "\x20\x40" && $b eq "\x40\x20"); SKIP: { if (ord('A') == 193) { skip("EBCDIC", 1); } else { my ($a, $b) = split(/\x40\x{80}/, $s); ok($a eq "\x20" && $b eq "\x{100}\x{80}\x40\x20"); } } my ($a, $b, $c) = split(/[\x40\x{80}]+/, $s); ok($a eq "\x20" && $b eq "\x{100}" && $c eq "\x20"); } { # 20001205.014 my $a = "ABC\x{263A}"; my @b = split( //, $a ); my $c = split( //, $a ); is($c, scalar(@b)); is(scalar @b, 4); ok(length($b[3]) == 1 && $b[3] eq "\x{263A}"); $a =~ s/^A/Z/; ok(length($a) == 4 && $a eq "ZBC\x{263A}"); } { my @a = split(/\xFE/, "\xFF\xFE\xFD"); my $b = split(/\xFE/, "\xFF\xFE\xFD"); ok(@a == 2 && $a[0] eq "\xFF" && $a[1] eq "\xFD"); is($b, scalar(@a)); } { # check that PMf_WHITE is cleared after \s+ is used # reported in <20010627113312.RWGY6087.viemta06@localhost> my $r; foreach my $pat ( qr/\s+/, qr/ll/ ) { $r = join ':' => split($pat, "hello cruel world"); } is($r, "he:o cruel world"); } { # split /(A)|B/, "1B2" should return (1, undef, 2) my @x = split /(A)|B/, "1B2"; my $y = split /(A)|B/, "1B2"; is($y, scalar(@x)); ok($x[0] eq '1' and (not defined $x[1]) and $x[2] eq '2'); } { # [perl #17064] my $warn; local $SIG{__WARN__} = sub { $warn = join '', @_; chomp $warn }; my $char = "\x{10f1ff}"; my @a = split /\r?\n/, "$char\n"; my $b = split /\r?\n/, "$char\n"; is($b, scalar(@a)); ok(@a == 1 && $a[0] eq $char && !defined($warn)); } { # [perl #18195] for my $u (0, 1) { for my $a (0, 1) { $_ = 'readin,database,readout'; utf8::upgrade $_ if $u; /(.+)/; my @d = split /[,]/,$1; my $e = split /[,]/,$1; is($e, scalar(@d)); is(join (':',@d), 'readin:database:readout', "[perl #18195]"); } } } { $p="a,b"; utf8::upgrade $p; eval { @a=split(/[, ]+/,$p) }; eval { $b=split(/[, ]+/,$p) }; is($b, scalar(@a)); is ("$@-@a-", '-a b-', '#20912 - split() to array with /[]+/ and utf8'); } { is (\@a, \@{"a"}, '@a must be global for following test'); $p=""; $n = @a = split /,/,$p; is ($n, 0, '#21765 - pmreplroot hack used to return undef for 0 iters'); } { # [perl #28938] # assigning off the end of the array after a split could leave garbage # in the inner elements my $x; @a = split /,/, ',,,,,'; $a[3]=1; $x = \$a[2]; is (ref $x, 'SCALAR', '#28938 - garbage after extend'); } { # check the special casing of split /\s/ and unicode use charnames qw(:full); # below test data is extracted from # PropList-5.0.0.txt # Date: 2006-06-07, 23:22:52 GMT [MD] # # Unicode Character Database # Copyright (c) 1991-2006 Unicode, Inc. # For terms of use, see http://www.unicode.org/terms_of_use.html # For documentation, see UCD.html my @spaces=( ord("\t"), # Cc ord("\n"), # Cc # not PerlSpace # Cc ord("\f"), # Cc ord("\r"), # Cc ord(" "), # Zs SPACE ord("\N{NEL}"), # Cc ord("\N{NO-BREAK SPACE}"), # Zs NO-BREAK SPACE 0x1680, # Zs OGHAM SPACE MARK 0x180E, # Zs MONGOLIAN VOWEL SEPARATOR 0x2000..0x200A, # Zs [11] EN QUAD..HAIR SPACE 0x2028, # Zl LINE SEPARATOR 0x2029, # Zp PARAGRAPH SEPARATOR 0x202F, # Zs NARROW NO-BREAK SPACE 0x205F, # Zs MEDIUM MATHEMATICAL SPACE 0x3000 # Zs IDEOGRAPHIC SPACE ); #diag "Have @{[0+@spaces]} to test\n"; foreach my $cp (@spaces) { my $msg = sprintf "Space: U+%04x", $cp; my $space = chr($cp); my $str="A:$space:B\x{FFFD}"; chop $str; my @res=split(/\s+/,$str); my $cnt=split(/\s+/,$str); ok(@res == 2 && join('-',@res) eq "A:-:B", "$msg - /\\s+/"); is($cnt, scalar(@res), "$msg - /\\s+/ (count)"); my $s2 = "$space$space:A:$space$space:B\x{FFFD}"; chop $s2; my @r2 = split(' ',$s2); my $c2 = split(' ',$s2); ok(@r2 == 2 && join('-', @r2) eq ":A:-:B", "$msg - ' '"); is($c2, scalar(@r2), "$msg - ' ' (count)"); my @r3 = split(/\s+/, $s2); my $c3 = split(/\s+/, $s2); ok(@r3 == 3 && join('-', @r3) eq "-:A:-:B", "$msg - /\\s+/ No.2"); is($c3, scalar(@r3), "$msg - /\\s+/ No.2 (count)"); } } { my $src = "ABC \0 FOO \0 XYZ"; my @s = split(" \0 ", $src); my @r = split(/ \0 /, $src); my $cs = split(" \0 ", $src); my $cr = split(/ \0 /, $src); is(scalar(@s), 3); is($cs, 3); is($cr, 3); is($s[0], "ABC"); is($s[1], "FOO"); is($s[2]," XYZ"); is(join(':',@s), join(':',@r)); } { use constant BANG => {}; () = split m/,/, "", BANG; ok(1); } { # Bug #69875 # 'Hybrid' scalar-and-array context scalar(our @PATH = split /::/, "Font::GlyphNames"); # 'my' doesn't trigger the bug is "@PATH", "Font GlyphNames", "hybrid scalar-and-array context"; } perl-5.12.0-RC0/t/op/symbolcache.t0000555000175000017500000000207211325125742015472 0ustar jessejesse#!./perl -w BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; plan( tests => 8 ); } use strict; # first, with delete # simple removal sub removed { 23 } sub bound { removed() } delete $main::{removed}; is( bound(), 23, 'function still bound' ); ok( !main->can('removed'), 'function not available as method' ); # replacement sub replaced { 'func' } is( replaced(), 'func', 'original function still bound' ); is( main->replaced, 'meth', 'method is replaced function' ); BEGIN { delete $main::{replaced} } sub replaced { 'meth' } # and now with undef # simple removal sub removed2 { 24 } sub bound2 { removed2() } undef $main::{removed2}; eval { bound2() }; like( $@, qr/Undefined subroutine &main::removed2 called/, 'function not bound' ); ok( !main->can('removed2'), 'function not available as method' ); # replacement sub replaced2 { 'func' } is( replaced2(), 'meth', 'original function not bound, was replaced' ); ok( main->replaced2 eq 'meth', 'method is replaced function' ); BEGIN { undef $main::{replaced2} } sub replaced2 { 'meth' } perl-5.12.0-RC0/t/op/readdir.t0000555000175000017500000000356511325127001014611 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } eval 'opendir(NOSUCH, "no/such/directory");'; if ($@) { print "1..0\n"; exit; } print "1..12\n"; for $i (1..2000) { local *OP; opendir(OP, "op") or die "can't opendir: $!"; # should auto-closedir() here } if (opendir(OP, "op")) { print "ok 1\n"; } else { print "not ok 1\n"; } @D = grep(/^[^\.].*\.t$/i, readdir(OP)); closedir(OP); open $man, "<../MANIFEST" or die "Can't open ../MANIFEST: $!"; my $expect; while (<$man>) { ++$expect if m!^t/op/[^/]+\t!; } my ($min, $max) = ($expect - 10, $expect + 10); if (@D > $min && @D < $max) { print "ok 2\n"; } else { printf "not ok 2 # counting op/*.t, expect $min < %d < $max files\n", scalar @D; } @R = sort @D; @G = sort ; if ($G[0] =~ m#.*\](\w+\.t)#i) { # grep is to convert filespecs returned from glob under VMS to format # identical to that returned by readdir @G = grep(s#.*\](\w+\.t).*#op/$1#i,); } while (@R && @G && $G[0] eq 'op/'.$R[0]) { shift(@R); shift(@G); } if (@R == 0 && @G == 0) { print "ok 3\n"; } else { print "not ok 3\n"; } if (opendir($fh, "op")) { print "ok 4\n"; } else { print "not ok 4\n"; } if (ref($fh) eq 'GLOB') { print "ok 5\n"; } else { print "not ok 5\n"; } if (opendir($fh[0], "op")) { print "ok 6\n"; } else { print "not ok 6\n"; } if (ref($fh[0]) eq 'GLOB') { print "ok 7\n"; } else { print "not ok 7\n"; } if (opendir($fh{abc}, "op")) { print "ok 8\n"; } else { print "not ok 8\n"; } if (ref($fh{abc}) eq 'GLOB') { print "ok 9\n"; } else { print "not ok 9\n"; } if ("$fh" ne "$fh[0]") { print "ok 10\n"; } else { print "not ok 10\n"; } if ("$fh" ne "$fh{abc}") { print "ok 11\n"; } else { print "not ok 11\n"; } # See that perl does not segfault upon readdir($x="."); # http://rt.perl.org/rt3/Ticket/Display.html?id=68182 eval { my $x = "."; my @files = readdir($x); }; print "ok 12\n"; perl-5.12.0-RC0/t/op/threads.t0000555000175000017500000001361411342547046014643 0ustar jessejesse#!perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; $| = 1; require Config; if (!$Config::Config{useithreads}) { print "1..0 # Skip: no ithreads\n"; exit 0; } if ($ENV{PERL_CORE_MINITEST}) { print "1..0 # Skip: no dynamic loading on miniperl, no threads\n"; exit 0; } plan(18); } use strict; use warnings; use threads; # test that we don't get: # Attempt to free unreferenced scalar: SV 0x40173f3c fresh_perl_is(<<'EOI', 'ok', { }, 'delete() under threads'); use threads; threads->create(sub { my %h=(1,2); delete $h{1}})->join for 1..2; print "ok"; EOI #PR24660 # test that we don't get: # Attempt to free unreferenced scalar: SV 0x814e0dc. fresh_perl_is(<<'EOI', 'ok', { }, 'weaken ref under threads'); use threads; use Scalar::Util; my $data = "a"; my $obj = \$data; my $copy = $obj; Scalar::Util::weaken($copy); threads->create(sub { 1 })->join for (1..1); print "ok"; EOI #PR24663 # test that we don't get: # panic: magic_killbackrefs. # Scalars leaked: 3 fresh_perl_is(<<'EOI', 'ok', { }, 'weaken ref #2 under threads'); package Foo; sub new { bless {},shift } package main; use threads; use Scalar::Util qw(weaken); my $object = Foo->new; my $ref = $object; weaken $ref; threads->create(sub { $ref = $object } )->join; # $ref = $object causes problems print "ok"; EOI #PR30333 - sort() crash with threads sub mycmp { length($b) <=> length($a) } sub do_sort_one_thread { my $kid = shift; print "# kid $kid before sort\n"; my @list = ( 'x', 'yy', 'zzz', 'a', 'bb', 'ccc', 'aaaaa', 'z', 'hello', 's', 'thisisalongname', '1', '2', '3', 'abc', 'xyz', '1234567890', 'm', 'n', 'p' ); for my $j (1..99999) { for my $k (sort mycmp @list) {} } print "# kid $kid after sort, sleeping 1\n"; sleep(1); print "# kid $kid exit\n"; } sub do_sort_threads { my $nthreads = shift; my @kids = (); for my $i (1..$nthreads) { my $t = threads->create(\&do_sort_one_thread, $i); print "# parent $$: continue\n"; push(@kids, $t); } for my $t (@kids) { print "# parent $$: waiting for join\n"; $t->join(); print "# parent $$: thread exited\n"; } } do_sort_threads(2); # crashes ok(1); # Change 24643 made the mistake of assuming that CvCONST can only be true on # XSUBs. Somehow it can also end up on perl subs. fresh_perl_is(<<'EOI', 'ok', { }, 'cloning constant subs'); use constant x=>1; use threads; $SIG{__WARN__} = sub{}; async sub {}; print "ok"; EOI # From a test case by Tim Bunce in # http://www.nntp.perl.org/group/perl.perl5.porters/63123 fresh_perl_is(<<'EOI', 'ok', { }, 'Ensure PL_linestr can be cloned'); use threads; print do 'op/threads_create.pl' || die $@; EOI TODO: { no strict 'vars'; # Accessing $TODO from test.pl local $TODO = 'refcount issues with threads'; # Scalars leaked: 1 foreach my $BLOCK (qw(CHECK INIT)) { fresh_perl_is(<create(sub {})->join; } print 'ok'; EOI } } # TODO # Scalars leaked: 1 fresh_perl_is(<<'EOI', 'ok', { }, 'Bug #41138'); use threads; leak($x); sub leak { local $x; threads->create(sub {})->join(); } print 'ok'; EOI # [perl #45053] Memory corruption with heavy module loading in threads # # run-time usage of newCONSTSUB (as done by the IO boot code) wasn't # thread-safe - got occasional coredumps or malloc corruption { local $SIG{__WARN__} = sub {}; # Ignore any thread creation failure warnings my @t; for (1..100) { my $thr = threads->create( sub { require IO }); last if !defined($thr); # Probably ran out of memory push(@t, $thr); } $_->join for @t; ok(1, '[perl #45053]'); } sub matchit { is (ref $_[1], "Regexp"); like ($_[0], $_[1]); } threads->new(\&matchit, "Pie", qr/pie/i)->join(); # tests in threads don't get counted, so curr_test(curr_test() + 2); # the seen_evals field of a regexp was getting zeroed on clone, so # within a thread it didn't know that a regex object contrained a 'safe' # re_eval expression, so it later died with 'Eval-group not allowed' when # you tried to interpolate the object sub safe_re { my $re = qr/(?{1})/; # this is literal, so safe eval { "a" =~ /$re$re/ }; # interpolating safe values, so safe ok($@ eq "", 'clone seen-evals'); } threads->new(\&safe_re)->join(); # tests in threads don't get counted, so curr_test(curr_test() + 1); # This used to crash in 5.10.0 [perl #64954] undef *a; threads->new(sub {})->join; pass("undefing a typeglob doesn't cause a crash during cloning"); # Test we don't get: # panic: del_backref during global destruction. # when returning a non-closure sub from a thread and subsequently starting # a new thread. fresh_perl_is(<<'EOI', 'ok', { }, 'No del_backref panic [perl #70748]'); use threads; sub foo { return (sub { }); } my $bar = threads->create(\&foo)->join(); threads->create(sub { })->join(); print "ok"; EOI # Another, more reliable test for the same del_backref bug: fresh_perl_like( <<' EOJ', qr/ok/, {}, 'No del_backref panic [perl #70748] (2)' use threads; push @bar, threads->create(sub{sub{}})->join() for 1...10; print "ok"; EOJ ); # Simple closure-returning test: At least this case works (though it # leaks), and we don't want to break it. fresh_perl_like(<<'EOJ', qr/^foo\n/, {}, 'returning a closure'); use threads; print create threads sub { my $x = "foo\n"; sub{sub{$x}} }=>->join->()() //"undef" EOJ # At the point of thread creation, $h{1} is on the temps stack. # The weak reference $a, however, is visible from the symbol table. fresh_perl_is(<<'EOI', 'ok', { }, 'Test for 34394ecd06e704e9'); use threads; %h = (1, 2); use Scalar::Util 'weaken'; $a = \$h{1}; weaken($a); delete $h{1} && threads->create(sub {}, shift)->join(); print 'ok'; EOI # EOF perl-5.12.0-RC0/t/op/range.t0000555000175000017500000002315711325127001014272 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = ('../lib', '.'); } # Avoid using eq_array below as it uses .. internally. require 'test.pl'; use Config; plan (141); is(join(':',1..5), '1:2:3:4:5'); @foo = (1,2,3,4,5,6,7,8,9); @foo[2..4] = ('c','d','e'); is(join(':',@foo[$foo[0]..5]), '2:c:d:e:6'); @bar[2..4] = ('c','d','e'); is(join(':',@bar[1..5]), ':c:d:e:'); ($a,@bcd[0..2],$e) = ('a','b','c','d','e'); is(join(':',$a,@bcd[0..2],$e), 'a:b:c:d:e'); $x = 0; for (1..100) { $x += $_; } is($x, 5050); $x = 0; for ((100,2..99,1)) { $x += $_; } is($x, 5050); $x = join('','a'..'z'); is($x, 'abcdefghijklmnopqrstuvwxyz'); @x = 'A'..'ZZ'; is (scalar @x, 27 * 26); @x = '09' .. '08'; # should produce '09', '10',... '99' (strange but true) is(join(",", @x), join(",", map {sprintf "%02d",$_} 9..99)); # same test with foreach (which is a separate implementation) @y = (); foreach ('09'..'08') { push(@y, $_); } is(join(",", @y), join(",", @x)); # check bounds if ($Config{ivsize} == 8) { @a = eval "0x7ffffffffffffffe..0x7fffffffffffffff"; $a = "9223372036854775806 9223372036854775807"; @b = eval "-0x7fffffffffffffff..-0x7ffffffffffffffe"; $b = "-9223372036854775807 -9223372036854775806"; } else { @a = eval "0x7ffffffe..0x7fffffff"; $a = "2147483646 2147483647"; @b = eval "-0x7fffffff..-0x7ffffffe"; $b = "-2147483647 -2147483646"; } is ("@a", $a); is ("@b", $b); # check magic { my $bad = 0; local $SIG{'__WARN__'} = sub { $bad = 1 }; my $x = 'a-e'; $x =~ s/(\w)-(\w)/join ':', $1 .. $2/e; is ($x, 'a:b:c:d:e'); } # Should use magical autoinc only when both are strings { my $scalar = (() = "0"..-1); is ($scalar, 0); } { my $fail = 0; for my $x ("0"..-1) { $fail++; } is ($fail, 0); } # [#18165] Should allow "-4".."0", broken by #4730. (AMS 20021031) is(join(":","-4".."0") , "-4:-3:-2:-1:0"); is(join(":","-4".."-0") , "-4:-3:-2:-1:0"); is(join(":","-4\n".."0\n") , "-4:-3:-2:-1:0"); is(join(":","-4\n".."-0\n"), "-4:-3:-2:-1:0"); # undef should be treated as 0 for numerical range is(join(":",undef..2), '0:1:2'); is(join(":",-2..undef), '-2:-1:0'); is(join(":",undef..'2'), '0:1:2'); is(join(":",'-2'..undef), '-2:-1:0'); # undef should be treated as "" for magical range is(join(":", map "[$_]", "".."B"), '[]'); is(join(":", map "[$_]", undef.."B"), '[]'); is(join(":", map "[$_]", "B"..""), ''); is(join(":", map "[$_]", "B"..undef), ''); # undef..undef used to segfault is(join(":", map "[$_]", undef..undef), '[]'); # also test undef in foreach loops @foo=(); push @foo, $_ for undef..2; is(join(":", @foo), '0:1:2'); @foo=(); push @foo, $_ for -2..undef; is(join(":", @foo), '-2:-1:0'); @foo=(); push @foo, $_ for undef..'2'; is(join(":", @foo), '0:1:2'); @foo=(); push @foo, $_ for '-2'..undef; is(join(":", @foo), '-2:-1:0'); @foo=(); push @foo, $_ for undef.."B"; is(join(":", map "[$_]", @foo), '[]'); @foo=(); push @foo, $_ for "".."B"; is(join(":", map "[$_]", @foo), '[]'); @foo=(); push @foo, $_ for "B"..undef; is(join(":", map "[$_]", @foo), ''); @foo=(); push @foo, $_ for "B"..""; is(join(":", map "[$_]", @foo), ''); @foo=(); push @foo, $_ for undef..undef; is(join(":", map "[$_]", @foo), '[]'); # again with magic { my @a = (1..3); @foo=(); push @foo, $_ for undef..$#a; is(join(":", @foo), '0:1:2'); } { my @a = (); @foo=(); push @foo, $_ for $#a..undef; is(join(":", @foo), '-1:0'); } { local $1; "2" =~ /(.+)/; @foo=(); push @foo, $_ for undef..$1; is(join(":", @foo), '0:1:2'); } { local $1; "-2" =~ /(.+)/; @foo=(); push @foo, $_ for $1..undef; is(join(":", @foo), '-2:-1:0'); } { local $1; "B" =~ /(.+)/; @foo=(); push @foo, $_ for undef..$1; is(join(":", map "[$_]", @foo), '[]'); } { local $1; "B" =~ /(.+)/; @foo=(); push @foo, $_ for ""..$1; is(join(":", map "[$_]", @foo), '[]'); } { local $1; "B" =~ /(.+)/; @foo=(); push @foo, $_ for $1..undef; is(join(":", map "[$_]", @foo), ''); } { local $1; "B" =~ /(.+)/; @foo=(); push @foo, $_ for $1..""; is(join(":", map "[$_]", @foo), ''); } # Test upper range limit my $MAX_INT = ~0>>1; foreach my $ii (-3 .. 3) { my ($first, $last); eval { my $lim=0; for ($MAX_INT-10 .. $MAX_INT+$ii) { if (! defined($first)) { $first = $_; } $last = $_; last if ($lim++ > 100); # Protect against integer wrap } }; if ($ii <= 0) { ok(! $@, 'Upper bound accepted: ' . ($MAX_INT+$ii)); is($first, $MAX_INT-10, 'Lower bound okay'); is($last, $MAX_INT+$ii, 'Upper bound okay'); } else { ok($@, 'Upper bound rejected: ' . ($MAX_INT+$ii)); } } foreach my $ii (-3 .. 3) { my ($first, $last); eval { my $lim=0; for ($MAX_INT+$ii .. $MAX_INT) { if (! defined($first)) { $first = $_; } $last = $_; last if ($lim++ > 100); } }; if ($ii <= 0) { ok(! $@, 'Lower bound accepted: ' . ($MAX_INT+$ii)); is($first, $MAX_INT+$ii, 'Lower bound okay'); is($last, $MAX_INT, 'Upper bound okay'); } else { ok($@, 'Lower bound rejected: ' . ($MAX_INT+$ii)); } } { my $first; eval { my $lim=0; for ($MAX_INT .. $MAX_INT-1) { if (! defined($first)) { $first = $_; } $last = $_; last if ($lim++ > 100); } }; ok(! $@, 'Range accepted'); ok(! defined($first), 'Range ineffectual'); } foreach my $ii (~0, ~0+1, ~0+(~0>>4)) { eval { my $lim=0; for ($MAX_INT-10 .. $ii) { last if ($lim++ > 100); } }; ok($@, 'Upper bound rejected: ' . $ii); } # Test lower range limit my $MIN_INT = -1-$MAX_INT; if (! $Config{d_nv_preserves_uv}) { # $MIN_INT needs adjustment when IV won't fit into an NV my $NV = $MIN_INT - 1; my $OFFSET = 1; while (($NV + $OFFSET) == $MIN_INT) { $OFFSET++ } $MIN_INT += $OFFSET; } foreach my $ii (-3 .. 3) { my ($first, $last); eval { my $lim=0; for ($MIN_INT+$ii .. $MIN_INT+10) { if (! defined($first)) { $first = $_; } $last = $_; last if ($lim++ > 100); } }; if ($ii >= 0) { ok(! $@, 'Lower bound accepted: ' . ($MIN_INT+$ii)); is($first, $MIN_INT+$ii, 'Lower bound okay'); is($last, $MIN_INT+10, 'Upper bound okay'); } else { ok($@, 'Lower bound rejected: ' . ($MIN_INT+$ii)); } } foreach my $ii (-3 .. 3) { my ($first, $last); eval { my $lim=0; for ($MIN_INT .. $MIN_INT+$ii) { if (! defined($first)) { $first = $_; } $last = $_; last if ($lim++ > 100); } }; if ($ii >= 0) { ok(! $@, 'Upper bound accepted: ' . ($MIN_INT+$ii)); is($first, $MIN_INT, 'Lower bound okay'); is($last, $MIN_INT+$ii, 'Upper bound okay'); } else { ok($@, 'Upper bound rejected: ' . ($MIN_INT+$ii)); } } { my $first; eval { my $lim=0; for ($MIN_INT+1 .. $MIN_INT) { if (! defined($first)) { $first = $_; } $last = $_; last if ($lim++ > 100); } }; ok(! $@, 'Range accepted'); ok(! defined($first), 'Range ineffectual'); } foreach my $ii (~0, ~0+1, ~0+(~0>>4)) { eval { my $lim=0; for (-$ii .. $MIN_INT+10) { last if ($lim++ > 100); } }; ok($@, 'Lower bound rejected: ' . -$ii); } # double/tripple magic tests sub TIESCALAR { bless { value => $_[1], orig => $_[1] } } sub STORE { $_[0]{store}++; $_[0]{value} = $_[1] } sub FETCH { $_[0]{fetch}++; $_[0]{value} } sub stores { tied($_[0])->{value} = tied($_[0])->{orig}; delete(tied($_[0])->{store}) || 0 } sub fetches { delete(tied($_[0])->{fetch}) || 0 } tie $x, "main", 6; my @foo; @foo = 4 .. $x; is(scalar @foo, 3); is("@foo", "4 5 6"); { local $TODO = "test for double magic with range operator"; is(fetches($x), 1); } is(stores($x), 0); @foo = $x .. 8; is(scalar @foo, 3); is("@foo", "6 7 8"); { local $TODO = "test for double magic with range operator"; is(fetches($x), 1); } is(stores($x), 0); @foo = $x .. $x + 1; is(scalar @foo, 2); is("@foo", "6 7"); { local $TODO = "test for double magic with range operator"; is(fetches($x), 2); } is(stores($x), 0); @foo = (); for (4 .. $x) { push @foo, $_; } is(scalar @foo, 3); is("@foo", "4 5 6"); { local $TODO = "test for double magic with range operator"; is(fetches($x), 1); } is(stores($x), 0); @foo = (); for (reverse 4 .. $x) { push @foo, $_; } is(scalar @foo, 3); is("@foo", "6 5 4"); { local $TODO = "test for double magic with range operator"; is(fetches($x), 1); } is(stores($x), 0); is( ( join ' ', map { join '', map ++$_, ($x=1)..4 } 1..2 ), '2345 2345', 'modifiable variable num range' ); is( ( join ' ', map { join '', map ++$_, 1..4 } 1..2 ), '2345 3456', 'modifiable const num range' ); # Unresolved bug RT#3105 $s = ''; for (1..2) { for (1..4) { $s .= ++$_ } $s.=' ' if $_==1; } is( $s, '2345 2345','modifiable num counting loop counter' ); is( ( join ' ', map { join '', map ++$_, ($x='a')..'d' } 1..2 ), 'bcde bcde', 'modifiable variable alpha range' ); is( ( join ' ', map { join '', map ++$_, 'a'..'d' } 1..2 ), 'bcde cdef', 'modifiable const alpha range' ); # Unresolved bug RT#3105 $s = ''; for (1..2) { for ('a'..'d') { $s .= ++$_ } $s.=' ' if $_==1; } is( $s, 'bcde bcde','modifiable alpha counting loop counter' ); # EOF perl-5.12.0-RC0/t/op/qq.t0000555000175000017500000000274111143650501013617 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } print q(1..21 ); # This is() function is written to avoid "" my $test = 1; sub is { my($left, $right) = @_; if ($left eq $right) { printf 'ok %d ', $test++; return 1; } foreach ($left, $right) { # Comment out these regexps to map non-printables to ord if the perl under # test is so broken that it's not helping s/([^-+A-Za-z_0-9])/sprintf q{'.chr(%d).'}, ord $1/ge; $_ = sprintf q('%s'), $_; s/^''\.//; s/\.''$//; } printf q(not ok %d - got %s expected %s ), $test++, $left, $right; printf q(# Failed test at line %d ), (caller)[2]; return 0; } is ("\x53", chr 83); is ("\x4EE", chr (78) . 'E'); is ("\x4i", chr (4) . 'i'); # This will warn is ("\xh", chr (0) . 'h'); # This will warn is ("\xx", chr (0) . 'x'); # This will warn is ("\xx9", chr (0) . 'x9'); # This will warn. \x9 is tab in EBCDIC too? is ("\x9_E", chr (9) . '_E'); # This will warn is ("\x{4E}", chr 78); is ("\x{6_9}", chr 105); is ("\x{_6_3}", chr 99); is ("\x{_6B}", chr 107); is ("\x{9__0}", chr 9); # multiple underscores not allowed. is ("\x{77_}", chr 119); # trailing underscore warns. is ("\x{6FQ}z", chr (111) . 'z'); is ("\x{0x4E}", chr 0); is ("\x{x4E}", chr 0); is ("\x{0065}", chr 101); is ("\x{000000000000000000000000000000000000000000000000000000000000000072}", chr 114); is ("\x{0_06_5}", chr 101); is ("\x{1234}", chr 4660); is ("\x{10FFFD}", chr 1114109); perl-5.12.0-RC0/t/op/packagev.t0000555000175000017500000001321611332332763014765 0ustar jessejesse#!./perl BEGIN { chdir 't'; @INC = '../lib'; require './test.pl'; } # XXX remove this later -- dagolden, 2010-01-13 # local *STDERR = *STDOUT; my @syntax_cases = ( 'package Foo', 'package Bar 1.23', 'package Baz v1.2.3', ); my @version_cases = ; plan tests => 5 * @syntax_cases + 5 * (grep { $_ !~ /^#/ } @version_cases) + 3; use warnings qw/syntax/; use version; for my $string ( @syntax_cases ) { eval "$string"; is( $@, '', qq/eval "$string"/ ); eval "$string;"; is( $@, '', qq/eval "$string;"/ ); eval "$string ;"; is( $@, '', qq/eval "$string ;"/ ); eval "{$string}"; is( $@, '', qq/eval "{$string}"/ ); eval "{ $string }"; is( $@, '', qq/eval "{ $string }"/ ); } LINE: for my $line (@version_cases) { chomp $line; # comments in data section are just diagnostics if ($line =~ /^#/) { diag $line; next LINE; } my ($v, $package, $quoted, $bare, $match) = split /\t+/, $line; my $warning = ""; local $SIG{__WARN__} = sub { $warning .= $_[0] . "\n" }; $match = defined $match ? $match : ""; $match =~ s/\s*\z//; # kill trailing spaces # First handle the 'package NAME VERSION' case $withversion::VERSION = undef; if ($package eq 'fail') { eval "package withversion $v"; like($@, qr/$match/, "package withversion $v -> syntax error ($match)"); ok(! version::is_strict($v), qq{... and "$v" should also fail STRICT regex}); } else { my $ok = eval "package withversion $v; $v eq \$withversion::VERSION"; ok($ok, "package withversion $v") or diag( $@ ? $@ : "and \$VERSION = $withversion::VERSION"); ok( version::is_strict($v), qq{... and "$v" should pass STRICT regex}); } # Now check the version->new("V") case my $ver = undef; eval qq/\$ver = version->new("$v")/; if ($quoted eq 'fail') { like($@, qr/$match/, qq{version->new("$v") -> invalid format ($match)}) or diag( $@ ? $@ : "and \$ver = $ver" ); ok( ! version::is_lax($v), qq{... and "$v" should fail LAX regex}); } else { is($@, "", qq{version->new("$v")}); ok( version::is_lax($v), qq{... and "$v" should pass LAX regex}); } # Now check the version->new(V) case, unless we're skipping it if ( $bare eq 'na' ) { pass( "... skipping version->new($v)" ); next LINE; } $ver = undef; eval qq/\$ver = version->new($v)/; if ($bare eq 'fail') { like($@, qr/$match/m, qq{... and unquoted version->new($v) has same error}) or diag( $@ ? $@ : "and \$ver = $ver" ); } else { is($@, "", qq{... and version->new($v) is ok}); } } # # Tests for #72432 - which reports a syntax error if there's a newline # between the package name and the version. # # Note that we are using 'run_perl' here - there's no problem if # "package Foo\n1;" is evalled. # for my $v ("1", "1.23", "v1.2.3") { ok (run_perl (prog => "package Foo\n$v; print 1;"), "New line between package name and version"); } # The data is organized in tab delimited format with these columns: # # value package version->new version->new regex # quoted unquoted # # For each value, it is tested using eval in the following expressions # # package foo $value; # column 2 # and # my $ver = version->new("$value"); # column 3 # and # my $ver = version->new($value); # column 4 # # The second through fourth columns can contain 'pass' or 'fail'. # # For any column with 'pass', the tests makes sure that no warning/error # was thrown. For any column with 'fail', the tests make sure that the # error thrown matches the regex in the last column. The unquoted column # may also have 'na' indicating that it's pointless to test as behavior # is subject to the perl parser before a stringifiable value is available # to version->new # # If all columns are marked 'pass', the regex column is left empty. # # there are multiple ways that underscores can fail depending on strict # vs lax format so these test do not distinguish between them # # If the DATA line begins with a # mark, it is used as a diag comment __DATA__ 1.00 pass pass pass 1.00001 pass pass pass 0.123 pass pass pass 12.345 pass pass pass 42 pass pass pass 0 pass pass pass 0.0 pass pass pass v1.2.3 pass pass pass v1.2.3.4 pass pass pass v0.1.2 pass pass pass v0.0.0 pass pass pass 01 fail pass pass no leading zeros 01.0203 fail pass pass no leading zeros v01 fail pass pass no leading zeros v01.02.03 fail pass pass no leading zeros .1 fail pass pass 0 before decimal required .1.2 fail pass pass 0 before decimal required 1. fail pass pass fractional part required 1.a fail fail na fractional part required 1._ fail fail na fractional part required 1.02_03 fail pass pass underscore v1.2_3 fail pass pass underscore v1.02_03 fail pass pass underscore v1.2_3_4 fail fail fail underscore v1.2_3.4 fail fail fail underscore 1.2_3.4 fail fail fail underscore 0_ fail fail na underscore 1_ fail fail na underscore 1_. fail fail na underscore 1.1_ fail fail na underscore 1.02_03_04 fail fail na underscore 1.2.3 fail pass pass dotted-decimal versions must begin with 'v' v1.2 fail pass pass dotted-decimal versions require at least three parts v0 fail pass pass dotted-decimal versions require at least three parts v1 fail pass pass dotted-decimal versions require at least three parts v.1.2.3 fail fail na dotted-decimal versions require at least three parts v fail fail na dotted-decimal versions require at least three parts v1.2345.6 fail pass pass maximum 3 digits between decimals undef fail pass pass non-numeric data 1a fail fail na non-numeric data 1.2a3 fail fail na non-numeric data bar fail fail na non-numeric data _ fail fail na non-numeric data perl-5.12.0-RC0/t/op/sysio.t0000555000175000017500000001210211325127002014331 0ustar jessejesse#!./perl BEGIN { chdir('op') || chdir('t/op') || die "sysio.t: cannot look for myself: $!"; @INC = '../../lib'; require '../test.pl'; } plan tests => 48; open(I, 'sysio.t') || die "sysio.t: cannot find myself: $!"; $reopen = ($^O eq 'VMS' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'dos' || $^O eq 'mpeix'); $x = 'abc'; # should not be able to do negative lengths eval { sysread(I, $x, -1) }; like($@, qr/^Negative length /); # $x should be intact is($x, 'abc'); # should not be able to read before the buffer eval { sysread(I, $x, 1, -4) }; like($@, qr/^Offset outside string /); # $x should be intact is($x, 'abc'); $a ='0123456789'; # default offset 0 is(sysread(I, $a, 3), 3); # $a should be as follows is($a, '#!.'); # reading past the buffer should zero pad is(sysread(I, $a, 2, 5), 2); # the zero pad should be seen now is($a, "#!.\0\0/p"); # try changing the last two characters of $a is(sysread(I, $a, 3, -2), 3); # the last two characters of $a should have changed (into three) is($a, "#!.\0\0erl"); $outfile = tempfile(); open(O, ">$outfile") || die "sysio.t: cannot write $outfile: $!"; select(O); $|=1; select(STDOUT); # cannot write negative lengths eval { syswrite(O, $x, -1) }; like($@, qr/^Negative length /); # $x still intact is($x, 'abc'); # $outfile still intact ok(!-s $outfile); # should not be able to write from after the buffer eval { syswrite(O, $x, 1, 4) }; like($@, qr/^Offset outside string /); # $x still intact is($x, 'abc'); # but it should be ok to write from the end of the buffer syswrite(O, $x, 0, 3); syswrite(O, $x, 1, 3); # $outfile still intact if ($reopen) { # must close file to update EOF marker for stat close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; } ok(!-s $outfile); # should not be able to write from before the buffer eval { syswrite(O, $x, 1, -4) }; like($@, qr/^Offset outside string /); # $x still intact is($x, 'abc'); # $outfile still intact if ($reopen) { # must close file to update EOF marker for stat close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; } ok(!-s $outfile); # [perl #67912] syswrite prints garbage if called with empty scalar and non-zero offset eval { my $buf = ''; syswrite(O, $buf, 1, 1) }; like($@, qr/^Offset outside string /); # $x still intact is($x, 'abc'); # $outfile still intact if ($reopen) { # must close file to update EOF marker for stat close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; } ok(!-s $outfile); eval { my $buf = 'x'; syswrite(O, $buf, 1, 2) }; like($@, qr/^Offset outside string /); # $x still intact is($x, 'abc'); # $outfile still intact if ($reopen) { # must close file to update EOF marker for stat close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; } ok(!-s $outfile); # default offset 0 if (syswrite(O, $a, 2) == 2){ pass(); } else { diag($!); fail(); # most other tests make no sense after e.g. "No space left on device" die $!; } # $a still intact is($a, "#!.\0\0erl"); # $outfile should have grown now if ($reopen) { # must close file to update EOF marker for stat close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; } is(-s $outfile, 2); # with offset is(syswrite(O, $a, 2, 5), 2); # $a still intact is($a, "#!.\0\0erl"); # $outfile should have grown now if ($reopen) { # must close file to update EOF marker for stat close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; } is(-s $outfile, 4); # with negative offset and a bit too much length is(syswrite(O, $a, 5, -3), 3); # $a still intact is($a, "#!.\0\0erl"); # $outfile should have grown now if ($reopen) { # must close file to update EOF marker for stat close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; } is(-s $outfile, 7); # with implicit length argument is(syswrite(O, $x), 3); # $a still intact is($x, "abc"); # $outfile should have grown now if ($reopen) { # must close file to update EOF marker for stat close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; } is(-s $outfile, 10); close(O); open(I, $outfile) || die "sysio.t: cannot read $outfile: $!"; $b = 'xyz'; # reading too much only return as much as available is(sysread(I, $b, 100), 10); # this we should have is($b, '#!ererlabc'); # test sysseek is(sysseek(I, 2, 0), 2); sysread(I, $b, 3); is($b, 'ere'); is(sysseek(I, -2, 1), 3); sysread(I, $b, 4); is($b, 'rerl'); ok(sysseek(I, 0, 0) eq '0 but true'); ok(not defined sysseek(I, -1, 1)); close(I); unlink $outfile; # Check that utf8 IO doesn't upgrade the scalar open(I, ">$outfile") || die "sysio.t: cannot write $outfile: $!"; # Will skip harmlessly on stdioperl eval {binmode STDOUT, ":utf8"}; die $@ if $@ and $@ !~ /^IO layers \(like ':utf8'\) unavailable/; # y diaresis is \w when UTF8 $a = chr 255; unlike($a, qr/\w/); syswrite I, $a; # Should not be upgraded as a side effect of syswrite. unlike($a, qr/\w/); # This should work eval {syswrite I, 2;}; is($@, ''); close(I); unlink $outfile; chdir('..'); 1; # eof perl-5.12.0-RC0/t/op/lop.t0000555000175000017500000000233411325125742013774 0ustar jessejesse#!./perl # # test the logical operators '&&', '||', '!', 'and', 'or', 'not' # BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } print "1..11\n"; my $test = 0; for my $i (undef, 0 .. 2, "", "0 but true") { my $true = 1; my $false = 0; for my $j (undef, 0 .. 2, "", "0 but true") { $true &&= !( ((!$i || !$j) != !($i && $j)) or (!($i || $j) != (!$i && !$j)) or (!!($i || $j) != !(!$i && !$j)) or (!(!$i || !$j) != !!($i && $j)) ); $false ||= ( ((!$i || !$j) == !!($i && $j)) and (!!($i || $j) == (!$i && !$j)) and ((!$i || $j) == ($i && !$j)) and (($i || !$j) != (!$i && $j)) ); } if (not $true) { print "not "; } elsif ($false) { print "not "; } print "ok ", ++$test, "\n"; } # $test == 6 my $i = 0; (($i ||= 1) &&= 3) += 4; print "not " unless $i == 7; print "ok ", ++$test, "\n"; my ($x, $y) = (1, 8); $i = !$x || $y; print "not " unless $i == 8; print "ok ", ++$test, "\n"; ++$y; $i = !$x || !$x || !$x || $y; print "not " unless $i == 9; print "ok ", ++$test, "\n"; $x = 0; ++$y; $i = !$x && $y; print "not " unless $i == 10; print "ok ", ++$test, "\n"; ++$y; $i = !$x && !$x && !$x && $y; print "not " unless $i == 11; print "ok ", ++$test, "\n"; perl-5.12.0-RC0/t/op/my_stash.t0000555000175000017500000000074611325125742015036 0ustar jessejesse#!./perl package Foo; BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } plan 7; use constant MyClass => 'Foo::Bar::Biz::Baz'; { package Foo::Bar::Biz::Baz; 1; } for (qw(Foo Foo:: MyClass __PACKAGE__)) { eval "sub { my $_ \$obj = shift; }"; ok ! $@; # print $@ if $@; } use constant NoClass => 'Nope::Foo::Bar::Biz::Baz'; for (qw(Nope Nope:: NoClass)) { eval "sub { my $_ \$obj = shift; }"; ok $@; # print $@ if $@; } perl-5.12.0-RC0/t/op/length.t0000555000175000017500000000720111325125742014461 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; require './test.pl'; @INC = '../lib'; } plan (tests => 28); print "not " unless length("") == 0; print "ok 1\n"; print "not " unless length("abc") == 3; print "ok 2\n"; $_ = "foobar"; print "not " unless length() == 6; print "ok 3\n"; # Okay, so that wasn't very challenging. Let's go Unicode. { my $a = "\x{41}"; print "not " unless length($a) == 1; print "ok 4\n"; $test++; use bytes; print "not " unless $a eq "\x41" && length($a) == 1; print "ok 5\n"; $test++; } { my $a = pack("U", 0xFF); print "not " unless length($a) == 1; print "ok 6\n"; $test++; use bytes; if (ord('A') == 193) { printf "#%vx for 0xFF\n",$a; print "not " unless $a eq "\x8b\x73" && length($a) == 2; } else { print "not " unless $a eq "\xc3\xbf" && length($a) == 2; } print "ok 7\n"; $test++; } { my $a = "\x{100}"; print "not " unless length($a) == 1; print "ok 8\n"; $test++; use bytes; if (ord('A') == 193) { printf "#%vx for 0x100\n",$a; print "not " unless $a eq "\x8c\x41" && length($a) == 2; } else { print "not " unless $a eq "\xc4\x80" && length($a) == 2; } print "ok 9\n"; $test++; } { my $a = "\x{100}\x{80}"; print "not " unless length($a) == 2; print "ok 10\n"; $test++; use bytes; if (ord('A') == 193) { printf "#%vx for 0x100 0x80\n",$a; print "not " unless $a eq "\x8c\x41\x8a\x67" && length($a) == 4; } else { print "not " unless $a eq "\xc4\x80\xc2\x80" && length($a) == 4; } print "ok 11\n"; $test++; } { my $a = "\x{80}\x{100}"; print "not " unless length($a) == 2; print "ok 12\n"; $test++; use bytes; if (ord('A') == 193) { printf "#%vx for 0x80 0x100\n",$a; print "not " unless $a eq "\x8a\x67\x8c\x41" && length($a) == 4; } else { print "not " unless $a eq "\xc2\x80\xc4\x80" && length($a) == 4; } print "ok 13\n"; $test++; } # Now for Unicode with magical vtbls { require Tie::Scalar; my $a; tie $a, 'Tie::StdScalar'; # makes $a magical $a = "\x{263A}"; print "not " unless length($a) == 1; print "ok 14\n"; $test++; use bytes; print "not " unless length($a) == 3; print "ok 15\n"; $test++; } { # Play around with Unicode strings, # give a little workout to the UTF-8 length cache. my $a = chr(256) x 100; print length $a == 100 ? "ok 16\n" : "not ok 16\n"; chop $a; print length $a == 99 ? "ok 17\n" : "not ok 17\n"; $a .= $a; print length $a == 198 ? "ok 18\n" : "not ok 18\n"; $a = chr(256) x 999; print length $a == 999 ? "ok 19\n" : "not ok 19\n"; substr($a, 0, 1) = ''; print length $a == 998 ? "ok 20\n" : "not ok 20\n"; } curr_test(21); require Tie::Scalar; $u = "ASCII"; tie $u, 'Tie::StdScalar', chr 256; is(length $u, 1, "Length of a UTF-8 scalar returned from tie"); is(length $u, 1, "Again! Again!"); $^W = 1; my $warnings = 0; $SIG{__WARN__} = sub { $warnings++; warn @_; }; is(length(undef), undef, "Length of literal undef"); my $u; is(length($u), undef, "Length of regular scalar"); $u = "Gotcha!"; tie $u, 'Tie::StdScalar'; is(length($u), undef, "Length of tied scalar (MAGIC)"); is($u, undef); { package U; use overload '""' => sub {return undef;}; } my $uo = bless [], 'U'; is(length($uo), undef, "Length of overloaded reference"); # ok(!defined $uo); Turns you can't test this. FIXME for pp_defined? is($warnings, 0, "There were no warnings"); perl-5.12.0-RC0/t/op/tie.t0000555000175000017500000002766611325127002013771 0ustar jessejesse#!./perl # Add new tests to the end with format: # ######## # # # test description # Test code # EXPECT # Warn or die msgs (if any) at - line 1234 # chdir 't' if -d 't'; @INC = '../lib'; $ENV{PERL5LIB} = "../lib"; $|=1; undef $/; @prgs = split /^########\n/m, ; require './test.pl'; plan(tests => scalar @prgs); for (@prgs){ ++$i; my($prog,$expected) = split(/\nEXPECT\n/, $_, 2); print("not ok $i # bad test format\n"), next unless defined $expected; my ($testname) = $prog =~ /^# (.*)\n/m; $testname ||= ''; $TODO = $testname =~ s/^TODO //; $results =~ s/\n+$//; $expected =~ s/\n+$//; fresh_perl_is($prog, $expected, {}, $testname); } __END__ # standard behaviour, without any extra references use Tie::Hash ; tie %h, Tie::StdHash; untie %h; EXPECT ######## # standard behaviour, without any extra references use Tie::Hash ; {package Tie::HashUntie; use base 'Tie::StdHash'; sub UNTIE { warn "Untied\n"; } } tie %h, Tie::HashUntie; untie %h; EXPECT Untied ######## # standard behaviour, with 1 extra reference use Tie::Hash ; $a = tie %h, Tie::StdHash; untie %h; EXPECT ######## # standard behaviour, with 1 extra reference via tied use Tie::Hash ; tie %h, Tie::StdHash; $a = tied %h; untie %h; EXPECT ######## # standard behaviour, with 1 extra reference which is destroyed use Tie::Hash ; $a = tie %h, Tie::StdHash; $a = 0 ; untie %h; EXPECT ######## # standard behaviour, with 1 extra reference via tied which is destroyed use Tie::Hash ; tie %h, Tie::StdHash; $a = tied %h; $a = 0 ; untie %h; EXPECT ######## # strict behaviour, without any extra references use warnings 'untie'; use Tie::Hash ; tie %h, Tie::StdHash; untie %h; EXPECT ######## # strict behaviour, with 1 extra references generating an error use warnings 'untie'; use Tie::Hash ; $a = tie %h, Tie::StdHash; untie %h; EXPECT untie attempted while 1 inner references still exist at - line 6. ######## # strict behaviour, with 1 extra references via tied generating an error use warnings 'untie'; use Tie::Hash ; tie %h, Tie::StdHash; $a = tied %h; untie %h; EXPECT untie attempted while 1 inner references still exist at - line 7. ######## # strict behaviour, with 1 extra references which are destroyed use warnings 'untie'; use Tie::Hash ; $a = tie %h, Tie::StdHash; $a = 0 ; untie %h; EXPECT ######## # strict behaviour, with extra 1 references via tied which are destroyed use warnings 'untie'; use Tie::Hash ; tie %h, Tie::StdHash; $a = tied %h; $a = 0 ; untie %h; EXPECT ######## # strict error behaviour, with 2 extra references use warnings 'untie'; use Tie::Hash ; $a = tie %h, Tie::StdHash; $b = tied %h ; untie %h; EXPECT untie attempted while 2 inner references still exist at - line 7. ######## # strict behaviour, check scope of strictness. no warnings 'untie'; use Tie::Hash ; $A = tie %H, Tie::StdHash; $C = $B = tied %H ; { use warnings 'untie'; use Tie::Hash ; tie %h, Tie::StdHash; untie %h; } untie %H; EXPECT ######## # Forbidden aggregate self-ties sub Self::TIEHASH { bless $_[1], $_[0] } { my %c; tie %c, 'Self', \%c; } EXPECT Self-ties of arrays and hashes are not supported at - line 6. ######## # Allowed scalar self-ties my $destroyed = 0; sub Self::TIESCALAR { bless $_[1], $_[0] } sub Self::DESTROY { $destroyed = 1; } { my $c = 42; tie $c, 'Self', \$c; } die "self-tied scalar not DESTROYed" unless $destroyed == 1; EXPECT ######## # Allowed glob self-ties my $destroyed = 0; my $printed = 0; sub Self2::TIEHANDLE { bless $_[1], $_[0] } sub Self2::DESTROY { $destroyed = 1; } sub Self2::PRINT { $printed = 1; } { use Symbol; my $c = gensym; tie *$c, 'Self2', $c; print $c 'Hello'; } die "self-tied glob not PRINTed" unless $printed == 1; die "self-tied glob not DESTROYed" unless $destroyed == 1; EXPECT ######## # Allowed IO self-ties my $destroyed = 0; sub Self3::TIEHANDLE { bless $_[1], $_[0] } sub Self3::DESTROY { $destroyed = 1; } sub Self3::PRINT { $printed = 1; } { use Symbol 'geniosym'; my $c = geniosym; tie *$c, 'Self3', $c; print $c 'Hello'; } die "self-tied IO not PRINTed" unless $printed == 1; die "self-tied IO not DESTROYed" unless $destroyed == 1; EXPECT ######## # TODO IO "self-tie" via TEMP glob my $destroyed = 0; sub Self3::TIEHANDLE { bless $_[1], $_[0] } sub Self3::DESTROY { $destroyed = 1; } sub Self3::PRINT { $printed = 1; } { use Symbol 'geniosym'; my $c = geniosym; tie *$c, 'Self3', \*$c; print $c 'Hello'; } die "IO tied to TEMP glob not PRINTed" unless $printed == 1; die "IO tied to TEMP glob not DESTROYed" unless $destroyed == 1; EXPECT ######## # Interaction of tie and vec my ($a, $b); use Tie::Scalar; tie $a,Tie::StdScalar or die; vec($b,1,1)=1; $a = $b; vec($a,1,1)=0; vec($b,1,1)=0; die unless $a eq $b; EXPECT ######## # correct unlocalisation of tied hashes (patch #16431) use Tie::Hash ; tie %tied, Tie::StdHash; { local $hash{'foo'} } warn "plain hash bad unlocalize" if exists $hash{'foo'}; { local $tied{'foo'} } warn "tied hash bad unlocalize" if exists $tied{'foo'}; { local $ENV{'foo'} } warn "%ENV bad unlocalize" if exists $ENV{'foo'}; EXPECT ######## # An attempt at lvalueable barewords broke this tie FH, 'main'; EXPECT Can't modify constant item in tie at - line 3, near "'main';" Execution of - aborted due to compilation errors. ######## # localizing tied hash slices $ENV{FooA} = 1; $ENV{FooB} = 2; print exists $ENV{FooA} ? 1 : 0, "\n"; print exists $ENV{FooB} ? 2 : 0, "\n"; print exists $ENV{FooC} ? 3 : 0, "\n"; { local @ENV{qw(FooA FooC)}; print exists $ENV{FooA} ? 4 : 0, "\n"; print exists $ENV{FooB} ? 5 : 0, "\n"; print exists $ENV{FooC} ? 6 : 0, "\n"; } print exists $ENV{FooA} ? 7 : 0, "\n"; print exists $ENV{FooB} ? 8 : 0, "\n"; print exists $ENV{FooC} ? 9 : 0, "\n"; # this should not exist EXPECT 1 2 0 4 5 6 7 8 0 ######## # # FETCH freeing tie'd SV sub TIESCALAR { bless [] } sub FETCH { *a = \1; 1 } tie $a, 'main'; print $a; EXPECT ######## # [20020716.007] - nested FETCHES sub F1::TIEARRAY { bless [], 'F1' } sub F1::FETCH { 1 } my @f1; tie @f1, 'F1'; sub F2::TIEARRAY { bless [2], 'F2' } sub F2::FETCH { my $self = shift; my $x = $f1[3]; $self } my @f2; tie @f2, 'F2'; print $f2[4][0],"\n"; sub F3::TIEHASH { bless [], 'F3' } sub F3::FETCH { 1 } my %f3; tie %f3, 'F3'; sub F4::TIEHASH { bless [3], 'F4' } sub F4::FETCH { my $self = shift; my $x = $f3{3}; $self } my %f4; tie %f4, 'F4'; print $f4{'foo'}[0],"\n"; EXPECT 2 3 ######## # test untie() from within FETCH package Foo; sub TIESCALAR { my $pkg = shift; return bless [@_], $pkg; } sub FETCH { my $self = shift; my ($obj, $field) = @$self; untie $obj->{$field}; $obj->{$field} = "Bar"; } package main; tie $a->{foo}, "Foo", $a, "foo"; $a->{foo}; # access once # the hash element should not be tied anymore print defined tied $a->{foo} ? "not ok" : "ok"; EXPECT ok ######## # the tmps returned by FETCH should appear to be SCALAR # (even though they are now implemented using PVLVs.) package X; sub TIEHASH { bless {} } sub TIEARRAY { bless {} } sub FETCH {1} my (%h, @a); tie %h, 'X'; tie @a, 'X'; my $r1 = \$h{1}; my $r2 = \$a[0]; my $s = "$r1 ". ref($r1) . " $r2 " . ref($r2); $s=~ s/\(0x\w+\)//g; print $s, "\n"; EXPECT SCALAR SCALAR SCALAR SCALAR ######## # [perl #23287] segfault in untie sub TIESCALAR { bless $_[1], $_[0] } my $var; tie $var, 'main', \$var; untie $var; EXPECT ######## # Test case from perlmonks by runrig # http://www.perlmonks.org/index.pl?node_id=273490 # "Here is what I tried. I think its similar to what you've tried # above. Its odd but convienient that after untie'ing you are left with # a variable that has the same value as was last returned from # FETCH. (At least on my perl v5.6.1). So you don't need to pass a # reference to the variable in order to set it after the untie (here it # is accessed through a closure)." use strict; use warnings; package MyTied; sub TIESCALAR { my ($class,$code) = @_; bless $code, $class; } sub FETCH { my $self = shift; print "Untie\n"; $self->(); } package main; my $var; tie $var, 'MyTied', sub { untie $var; 4 }; print "One\n"; print "$var\n"; print "Two\n"; print "$var\n"; print "Three\n"; print "$var\n"; EXPECT One Untie 4 Two 4 Three 4 ######## # [perl #22297] cannot untie scalar from within tied FETCH my $counter = 0; my $x = 7; my $ref = \$x; tie $x, 'Overlay', $ref, $x; my $y; $y = $x; $y = $x; $y = $x; $y = $x; #print "WILL EXTERNAL UNTIE $ref\n"; untie $$ref; $y = $x; $y = $x; $y = $x; $y = $x; #print "counter = $counter\n"; print (($counter == 1) ? "ok\n" : "not ok\n"); package Overlay; sub TIESCALAR { my $pkg = shift; my ($ref, $val) = @_; return bless [ $ref, $val ], $pkg; } sub FETCH { my $self = shift; my ($ref, $val) = @$self; #print "WILL INTERNAL UNITE $ref\n"; $counter++; untie $$ref; return $val; } EXPECT ok ######## # [perl #948] cannot meaningfully tie $, package TieDollarComma; sub TIESCALAR { my $pkg = shift; return bless \my $x, $pkg; } sub STORE { my $self = shift; $$self = shift; print "STORE set '$$self'\n"; } sub FETCH { my $self = shift; print ""; return $$self; } package main; tie $,, 'TieDollarComma'; $, = 'BOBBINS'; print "join", "things", "up\n"; EXPECT STORE set 'BOBBINS' joinBOBBINSthingsBOBBINSup ######## # test SCALAR method package TieScalar; sub TIEHASH { my $pkg = shift; bless { } => $pkg; } sub STORE { $_[0]->{$_[1]} = $_[2]; } sub FETCH { $_[0]->{$_[1]} } sub CLEAR { %{ $_[0] } = (); } sub SCALAR { print "SCALAR\n"; return 0 if ! keys %{$_[0]}; sprintf "%i/%i", scalar keys %{$_[0]}, scalar keys %{$_[0]}; } package main; tie my %h => "TieScalar"; $h{key1} = "val1"; $h{key2} = "val2"; print scalar %h, "\n" if %h; # this should also call SCALAR but implicitly %h = (); print scalar %h, "\n" if !%h; # this should also call SCALAR but implicitly EXPECT SCALAR SCALAR 2/2 SCALAR SCALAR 0 ######## # test scalar on tied hash when no SCALAR method has been given package TieScalar; sub TIEHASH { my $pkg = shift; bless { } => $pkg; } sub STORE { $_[0]->{$_[1]} = $_[2]; } sub FETCH { $_[0]->{$_[1]} } sub CLEAR { %{ $_[0] } = (); } sub FIRSTKEY { my $a = keys %{ $_[0] }; print "FIRSTKEY\n"; each %{ $_[0] }; } package main; tie my %h => "TieScalar"; if (!%h) { print "empty\n"; } else { print "not empty\n"; } $h{key1} = "val1"; print "not empty\n" if %h; print "not empty\n" if %h; print "-->\n"; my ($k,$v) = each %h; print "<--\n"; print "not empty\n" if %h; %h = (); print "empty\n" if ! %h; EXPECT FIRSTKEY empty FIRSTKEY not empty FIRSTKEY not empty --> FIRSTKEY <-- not empty FIRSTKEY empty ######## sub TIESCALAR { bless {} } sub FETCH { my $x = 3.3; 1 if 0+$x; $x } tie $h, "main"; print $h,"\n"; EXPECT 3.3 ######## sub TIESCALAR { bless {} } sub FETCH { shift()->{i} ++ } tie $h, "main"; print $h.$h; EXPECT 01 ######## # Bug 53482 (and maybe others) sub TIESCALAR { my $foo = $_[1]; bless \$foo, $_[0] } sub FETCH { ${$_[0]} } tie my $x1, "main", 2; tie my $y1, "main", 8; print $x1 | $y1; print $x1 | $y1; tie my $x2, "main", "2"; tie my $y2, "main", "8"; print $x2 | $y2; print $x2 | $y2; EXPECT 1010:: ######## # Bug 36267 sub TIEHASH { bless {}, $_[0] } sub STORE { $_[0]->{$_[1]} = $_[2] } sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} } sub NEXTKEY { each %{$_[0]} } sub DELETE { delete $_[0]->{$_[1]} } sub CLEAR { %{$_[0]} = () } $h{b}=1; delete $h{b}; print scalar keys %h, "\n"; tie %h, 'main'; $i{a}=1; %h = %i; untie %h; print scalar keys %h, "\n"; EXPECT 0 0 ######## # Bug 37731 sub foo::TIESCALAR { bless {value => $_[1]}, $_[0] } sub foo::FETCH { $_[0]->{value} } tie my $VAR, 'foo', '42'; foreach my $var ($VAR) { print +($var eq $VAR) ? "yes\n" : "no\n"; } EXPECT yes ######## sub TIEARRAY { bless [], 'main' } { local @a; tie @a, 'main'; } print "tied\n" if tied @a; EXPECT ######## sub TIEHASH { bless [], 'main' } { local %h; tie %h, 'main'; } print "tied\n" if tied %h; EXPECT perl-5.12.0-RC0/t/op/array.t0000555000175000017500000002070511325127001014310 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = ('.', '../lib'); } require 'test.pl'; plan (127); # # @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them # @ary = (1,2,3,4,5); is(join('',@ary), '12345'); $tmp = $ary[$#ary]; --$#ary; is($tmp, 5); is($#ary, 3); is(join('',@ary), '1234'); { no warnings 'deprecated'; $[ = 1; @ary = (1,2,3,4,5); is(join('',@ary), '12345'); $tmp = $ary[$#ary]; --$#ary; is($tmp, 5); # Must do == here beacuse $[ isn't 0 ok($#ary == 4); is(join('',@ary), '1234'); is($ary[5], undef); $#ary += 1; # see if element 5 gone for good ok($#ary == 5); ok(!defined $ary[5]); $[ = 0; @foo = (); $r = join(',', $#foo, @foo); is($r, "-1"); $foo[0] = '0'; $r = join(',', $#foo, @foo); is($r, "0,0"); $foo[2] = '2'; $r = join(',', $#foo, @foo); is($r, "2,0,,2"); @bar = (); $bar[0] = '0'; $bar[1] = '1'; $r = join(',', $#bar, @bar); is($r, "1,0,1"); @bar = (); $r = join(',', $#bar, @bar); is($r, "-1"); $bar[0] = '0'; $r = join(',', $#bar, @bar); is($r, "0,0"); $bar[2] = '2'; $r = join(',', $#bar, @bar); is($r, "2,0,,2"); reset 'b' if $^O ne 'VMS'; @bar = (); $bar[0] = '0'; $r = join(',', $#bar, @bar); is($r, "0,0"); $bar[2] = '2'; $r = join(',', $#bar, @bar); is($r, "2,0,,2"); } $foo = 'now is the time'; ok(scalar (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/))); is($F1, 'now'); is($F2, 'is'); is($Etc, 'the time'); $foo = 'lskjdf'; ok(!($cnt = (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/)))) or diag("$cnt $F1:$F2:$Etc"); %foo = ('blurfl','dyick','foo','bar','etc.','etc.'); %bar = %foo; is($bar{'foo'}, 'bar'); %bar = (); is($bar{'foo'}, undef); (%bar,$a,$b) = (%foo,'how','now'); is($bar{'foo'}, 'bar'); is($bar{'how'}, 'now'); @bar{keys %foo} = values %foo; is($bar{'foo'}, 'bar'); is($bar{'how'}, 'now'); @foo = grep(/e/,split(' ','now is the time for all good men to come to')); is(join(' ',@foo), 'the time men come'); @foo = grep(!/e/,split(' ','now is the time for all good men to come to')); is(join(' ',@foo), 'now is for all good to to'); $foo = join('',('a','b','c','d','e','f')[0..5]); is($foo, 'abcdef'); $foo = join('',('a','b','c','d','e','f')[0..1]); is($foo, 'ab'); $foo = join('',('a','b','c','d','e','f')[6]); is($foo, ''); @foo = ('a','b','c','d','e','f')[0,2,4]; @bar = ('a','b','c','d','e','f')[1,3,5]; $foo = join('',(@foo,@bar)[0..5]); is($foo, 'acebdf'); $foo = ('a','b','c','d','e','f')[0,2,4]; is($foo, 'e'); $foo = ('a','b','c','d','e','f')[1]; is($foo, 'b'); @foo = ( 'foo', 'bar', 'burbl'); { no warnings 'deprecated'; push(foo, 'blah'); } is($#foo, 3); # various AASSIGN_COMMON checks (see newASSIGNOP() in op.c) #curr_test(38); @foo = @foo; is("@foo", "foo bar burbl blah"); # 38 (undef,@foo) = @foo; is("@foo", "bar burbl blah"); # 39 @foo = ('XXX',@foo, 'YYY'); is("@foo", "XXX bar burbl blah YYY"); # 40 @foo = @foo = qw(foo b\a\r bu\\rbl blah); is("@foo", 'foo b\a\r bu\\rbl blah'); # 41 @bar = @foo = qw(foo bar); # 42 is("@foo", "foo bar"); is("@bar", "foo bar"); # 43 # try the same with local # XXX tie-stdarray fails the tests involving local, so we use # different variable names to escape the 'tie' @bee = ( 'foo', 'bar', 'burbl', 'blah'); { local @bee = @bee; is("@bee", "foo bar burbl blah"); # 44 { local (undef,@bee) = @bee; is("@bee", "bar burbl blah"); # 45 { local @bee = ('XXX',@bee,'YYY'); is("@bee", "XXX bar burbl blah YYY"); # 46 { local @bee = local(@bee) = qw(foo bar burbl blah); is("@bee", "foo bar burbl blah"); # 47 { local (@bim) = local(@bee) = qw(foo bar); is("@bee", "foo bar"); # 48 is("@bim", "foo bar"); # 49 } is("@bee", "foo bar burbl blah"); # 50 } is("@bee", "XXX bar burbl blah YYY"); # 51 } is("@bee", "bar burbl blah"); # 52 } is("@bee", "foo bar burbl blah"); # 53 } # try the same with my { my @bee = @bee; is("@bee", "foo bar burbl blah"); # 54 { my (undef,@bee) = @bee; is("@bee", "bar burbl blah"); # 55 { my @bee = ('XXX',@bee,'YYY'); is("@bee", "XXX bar burbl blah YYY"); # 56 { my @bee = my @bee = qw(foo bar burbl blah); is("@bee", "foo bar burbl blah"); # 57 { my (@bim) = my(@bee) = qw(foo bar); is("@bee", "foo bar"); # 58 is("@bim", "foo bar"); # 59 } is("@bee", "foo bar burbl blah"); # 60 } is("@bee", "XXX bar burbl blah YYY"); # 61 } is("@bee", "bar burbl blah"); # 62 } is("@bee", "foo bar burbl blah"); # 63 } # try the same with our (except that previous values aren't restored) { our @bee = @bee; is("@bee", "foo bar burbl blah"); { our (undef,@bee) = @bee; is("@bee", "bar burbl blah"); { our @bee = ('XXX',@bee,'YYY'); is("@bee", "XXX bar burbl blah YYY"); { our @bee = our @bee = qw(foo bar burbl blah); is("@bee", "foo bar burbl blah"); { our (@bim) = our(@bee) = qw(foo bar); is("@bee", "foo bar"); is("@bim", "foo bar"); } } } } } # make sure reification behaves my $t = curr_test(); sub reify { $_[1] = $t++; print "@_\n"; } reify('ok'); reify('ok'); curr_test($t); # qw() is no longer a runtime split, it's compiletime. is (qw(foo bar snorfle)[2], 'snorfle'); @ary = (12,23,34,45,56); is(shift(@ary), 12); is(pop(@ary), 56); is(push(@ary,56), 4); is(unshift(@ary,12), 5); sub foo { "a" } @foo=(foo())[0,0]; is ($foo[1], "a"); # $[ should have the same effect regardless of whether the aelem # op is optimized to aelemfast. sub tary { no warnings 'deprecated'; local $[ = 10; my $five = 5; is ($tary[5], $tary[$five]); } @tary = (0..50); tary(); # bugid #15439 - clearing an array calls destructors which may try # to modify the array - caused 'Attempt to free unreferenced scalar' my $got = runperl ( prog => q{ sub X::DESTROY { @a = () } @a = (bless {}, 'X'); @a = (); }, stderr => 1 ); $got =~ s/\n/ /g; is ($got, ''); # Test negative and funky indices. { my @a = 0..4; is($a[-1], 4); is($a[-2], 3); is($a[-5], 0); ok(!defined $a[-6]); is($a[2.1] , 2); is($a[2.9] , 2); is($a[undef], 0); is($a["3rd"], 3); } { my @a; eval '$a[-1] = 0'; like($@, qr/Modification of non-creatable array value attempted, subscript -1/, "\$a[-1] = 0"); } sub test_arylen { my $ref = shift; local $^W = 1; is ($$ref, undef, "\$# on freed array is undef"); my @warn; local $SIG{__WARN__} = sub {push @warn, "@_"}; $$ref = 1000; is (scalar @warn, 1); like ($warn[0], qr/^Attempt to set length of freed array/); } { my $a = \$#{[]}; # Need a new statement to make it go out of scope test_arylen ($a); test_arylen (do {my @a; \$#a}); } { use vars '@array'; my $outer = \$#array; is ($$outer, -1); is (scalar @array, 0); $$outer = 3; is ($$outer, 3); is (scalar @array, 4); my $ref = \@array; my $inner; { local @array; $inner = \$#array; is ($$inner, -1); is (scalar @array, 0); $$outer = 6; is (scalar @$ref, 7); is ($$inner, -1); is (scalar @array, 0); $$inner = 42; } is (scalar @array, 7); is ($$outer, 6); is ($$inner, undef, "orphaned $#foo is always undef"); is (scalar @array, 7); is ($$outer, 6); $$inner = 1; is (scalar @array, 7); is ($$outer, 6); $$inner = 503; # Bang! is (scalar @array, 7); is ($$outer, 6); } { # Bug #36211 use vars '@array'; for (1,2) { { local @a; is ($#a, -1); @a=(1..4) } } } { # Bug #37350 my @array = (1..4); $#{@array} = 7; is ($#{4}, 7); my $x; $#{$x} = 3; is(scalar @$x, 4); push @{@array}, 23; is ($4[8], 23); } { # Bug #37350 -- once more with a global use vars '@array'; @array = (1..4); $#{@array} = 7; is ($#{4}, 7); my $x; $#{$x} = 3; is(scalar @$x, 4); push @{@array}, 23; is ($4[8], 23); } # more tests for AASSIGN_COMMON { our($x,$y,$z) = (1..3); our($y,$z) = ($x,$y); is("$x $y $z", "1 1 2"); } { our($x,$y,$z) = (1..3); (our $y, our $z) = ($x,$y); is("$x $y $z", "1 1 2"); } # [perl #70171] { my $x = get_x(); my %x = %$x; sub get_x { %x=(1..4); return \%x }; is( join(" ", map +($_,$x{$_}), sort keys %x), "1 2 3 4", 'bug 70171 (self-assignment via my %x = %$x)' ); my $y = get_y(); my @y = @$y; sub get_y { @y=(1..4); return \@y }; is( "@y", "1 2 3 4", 'bug 70171 (self-assignment via my @x = @$x)' ); } "We're included by lib/Tie/Array/std.t so we need to return something true"; perl-5.12.0-RC0/t/op/sub.t0000555000175000017500000000054111143650501013763 0ustar jessejesse#!./perl -w BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } plan( tests => 4 ); sub empty_sub {} is(empty_sub,undef,"Is empty"); is(empty_sub(1,2,3),undef,"Is still empty"); @test = empty_sub(); is(scalar(@test), 0, 'Didnt return anything'); @test = empty_sub(1,2,3); is(scalar(@test), 0, 'Didnt return anything'); perl-5.12.0-RC0/t/op/time_loop.t0000555000175000017500000000057211333417500015166 0ustar jessejesse#!perl -w # d95a2ea538e6c332f36c34ca45b78d6ad93c3a1f allowed times greater than # 2**63 to be handed to gm/localtime() which caused an internal overflow # and an excessively long loop. Test this does not happen. use strict; BEGIN { require './test.pl'; } plan tests => 2; watchdog(2); local $SIG{__WARN__} = sub {}; is gmtime(2**69), undef; is localtime(2**69), undef; perl-5.12.0-RC0/t/op/die.t0000555000175000017500000000246611325125742013751 0ustar jessejesse#!./perl print "1..15\n"; $SIG{__DIE__} = sub { print ref($_[0]) ? ("ok ",$_[0]->[0]++,"\n") : @_ } ; $err = "#[\000]\nok 1\n"; eval { die $err; }; print "not " unless $@ eq $err; print "ok 2\n"; $x = [3]; eval { die $x; }; print "not " unless $x->[0] == 4; print "ok 4\n"; eval { eval { die [ 5 ]; }; die if $@; }; eval { eval { die bless [ 7 ], "Error"; }; die if $@; }; print "not " unless ref($@) eq "Out"; print "ok 10\n"; { package Error; sub PROPAGATE { print "ok ",$_[0]->[0]++,"\n"; bless [$_[0]->[0]], "Out"; } } { # die/warn and utf8 use utf8; local $SIG{__DIE__}; my $msg = "ce ºtii tu, bã ?\n"; eval { die $msg }; print "not " unless $@ eq $msg; print "ok 11\n"; our $err; local $SIG{__WARN__} = $SIG{__DIE__} = sub { $err = shift }; eval { die $msg }; print "not " unless $err eq $msg; print "ok 12\n"; eval { warn $msg }; print "not " unless $err eq $msg; print "ok 13\n"; eval qq/ use strict; \$\x{3b1} /; print "not " unless $@ =~ /Global symbol "\$\x{3b1}"/; print "ok 14\n"; } # [perl #36470] got uninit warning if $@ was undef { my $ok = 1; local $SIG{__DIE__}; local $SIG{__WARN__} = sub { $ok = 0 }; eval { undef $@; die }; print "not " unless $ok; print "ok 15\n"; } perl-5.12.0-RC0/t/op/reset.t0000555000175000017500000000503511325125742014325 0ustar jessejesse#!./perl -w BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } use strict; # Currently only testing the reset of patterns. plan tests => 24; package aiieee; sub zlopp { (shift =~ ?zlopp?) ? 1 : 0; } sub reset_zlopp { reset; } package CLINK; sub ZZIP { shift =~ ?ZZIP? ? 1 : 0; } sub reset_ZZIP { reset; } package main; is(aiieee::zlopp(""), 0, "mismatch doesn't match"); is(aiieee::zlopp("zlopp"), 1, "match matches first time"); is(aiieee::zlopp(""), 0, "mismatch doesn't match"); is(aiieee::zlopp("zlopp"), 0, "match doesn't match second time"); aiieee::reset_zlopp(); is(aiieee::zlopp("zlopp"), 1, "match matches after reset"); is(aiieee::zlopp(""), 0, "mismatch doesn't match"); aiieee::reset_zlopp(); is(aiieee::zlopp(""), 0, "mismatch doesn't match"); is(aiieee::zlopp("zlopp"), 1, "match matches first time"); is(CLINK::ZZIP(""), 0, "mismatch doesn't match"); is(CLINK::ZZIP("ZZIP"), 1, "match matches first time"); is(CLINK::ZZIP(""), 0, "mismatch doesn't match"); is(CLINK::ZZIP("ZZIP"), 0, "match doesn't match second time"); is(aiieee::zlopp(""), 0, "mismatch doesn't match"); is(aiieee::zlopp("zlopp"), 0, "match doesn't match second time"); aiieee::reset_zlopp(); is(aiieee::zlopp("zlopp"), 1, "match matches after reset"); is(aiieee::zlopp(""), 0, "mismatch doesn't match"); is(CLINK::ZZIP(""), 0, "mismatch doesn't match"); is(CLINK::ZZIP("ZZIP"), 0, "match doesn't match third time"); CLINK::reset_ZZIP(); is(CLINK::ZZIP("ZZIP"), 1, "match matches after reset"); is(CLINK::ZZIP(""), 0, "mismatch doesn't match"); undef $/; my $prog = ; SKIP: { eval {require threads; 1} or skip "No threads", 4; foreach my $eight ('/', '?') { foreach my $nine ('/', '?') { my $copy = $prog; $copy =~ s/8/$eight/gm; $copy =~ s/9/$nine/gm; fresh_perl_is($copy, "pass", "", "first pattern $eight$eight, second $nine$nine"); } } } __DATA__ #!perl use warnings; use strict; # Note that there are no digits in this program, other than the placeholders sub a { 8one8; } sub b { 9two9; } use threads; use threads::shared; sub wipe { eval 'no warnings; sub b {}'; } sub lock_then_wipe { my $l_r = shift; lock $$l_r; cond_wait($$l_r) until $$l_r eq "B"; wipe; $$l_r = "C"; cond_signal $$l_r; } my $lock : shared = "A"; my $r = \$lock; my $t; { lock $$r; $t = threads->new(\&lock_then_wipe, $r); wipe; $lock = "B"; cond_signal $lock; } { lock $lock; cond_wait($lock) until $lock eq "C"; reset; } $t->join; print "pass\n"; perl-5.12.0-RC0/t/op/state.t0000555000175000017500000002104611325127001014311 0ustar jessejesse#!./perl -w # tests state variables BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } use strict; use feature ":5.10"; plan tests => 130; ok( ! defined state $uninit, q(state vars are undef by default) ); # basic functionality sub stateful { state $x; state $y = 1; my $z = 2; state ($t) //= 3; return ($x++, $y++, $z++, $t++); } my ($x, $y, $z, $t) = stateful(); is( $x, 0, 'uninitialized state var' ); is( $y, 1, 'initialized state var' ); is( $z, 2, 'lexical' ); is( $t, 3, 'initialized state var, list syntax' ); ($x, $y, $z, $t) = stateful(); is( $x, 1, 'incremented state var' ); is( $y, 2, 'incremented state var' ); is( $z, 2, 'reinitialized lexical' ); is( $t, 4, 'incremented state var, list syntax' ); ($x, $y, $z, $t) = stateful(); is( $x, 2, 'incremented state var' ); is( $y, 3, 'incremented state var' ); is( $z, 2, 'reinitialized lexical' ); is( $t, 5, 'incremented state var, list syntax' ); # in a nested block sub nesting { state $foo = 10; my $t; { state $bar = 12; $t = ++$bar } ++$foo; return ($foo, $t); } ($x, $y) = nesting(); is( $x, 11, 'outer state var' ); is( $y, 13, 'inner state var' ); ($x, $y) = nesting(); is( $x, 12, 'outer state var' ); is( $y, 14, 'inner state var' ); # in a closure sub generator { my $outer; # we use $outer to generate a closure sub { ++$outer; ++state $x } } my $f1 = generator(); is( $f1->(), 1, 'generator 1' ); is( $f1->(), 2, 'generator 1' ); my $f2 = generator(); is( $f2->(), 1, 'generator 2' ); is( $f1->(), 3, 'generator 1 again' ); is( $f2->(), 2, 'generator 2 once more' ); # with ties { package countfetches; our $fetchcount = 0; sub TIESCALAR {bless {}}; sub FETCH { ++$fetchcount; 18 }; tie my $y, "countfetches"; sub foo { state $x = $y; $x++ } ::is( foo(), 18, "initialisation with tied variable" ); ::is( foo(), 19, "increments correctly" ); ::is( foo(), 20, "increments correctly, twice" ); ::is( $fetchcount, 1, "fetch only called once" ); } # state variables are shared among closures sub gen_cashier { my $amount = shift; state $cash_in_store = 0; return { add => sub { $cash_in_store += $amount }, del => sub { $cash_in_store -= $amount }, bal => sub { $cash_in_store }, }; } gen_cashier(59)->{add}->(); gen_cashier(17)->{del}->(); is( gen_cashier()->{bal}->(), 42, '$42 in my drawer' ); # stateless assignment to a state variable sub stateless { state $reinitme = 42; ++$reinitme; } is( stateless(), 43, 'stateless function, first time' ); is( stateless(), 44, 'stateless function, second time' ); # array state vars sub stateful_array { state @x; push @x, 'x'; return $#x; } my $xsize = stateful_array(); is( $xsize, 0, 'uninitialized state array' ); $xsize = stateful_array(); is( $xsize, 1, 'uninitialized state array after one iteration' ); # hash state vars sub stateful_hash { state %hx; return $hx{foo}++; } my $xhval = stateful_hash(); is( $xhval, 0, 'uninitialized state hash' ); $xhval = stateful_hash(); is( $xhval, 1, 'uninitialized state hash after one iteration' ); # Recursion sub noseworth { my $level = shift; state $recursed_state = 123; is($recursed_state, 123, "state kept through recursion ($level)"); noseworth($level - 1) if $level; } noseworth(2); # Assignment return value sub pugnax { my $x = state $y = 42; $y++; $x; } is( pugnax(), 42, 'scalar state assignment return value' ); is( pugnax(), 43, 'scalar state assignment return value' ); # # Test various blocks. # foreach my $x (1 .. 3) { state $y = $x; is ($y, 1, "foreach $x"); } for (my $x = 1; $x < 4; $x ++) { state $y = $x; is ($y, 1, "for $x"); } while ($x < 4) { state $y = $x; is ($y, 1, "while $x"); $x ++; } $x = 1; until ($x >= 4) { state $y = $x; is ($y, 1, "until $x"); $x ++; } $x = 0; $y = 0; { state $z = $x; $z ++; $y ++; is ($z, $y, "bare block $y"); redo if $y < 3 } # # Check state $_ # my @stones = qw [fred wilma barny betty]; my $first = $stones [0]; my $First = ucfirst $first; $_ = "bambam"; foreach my $flint (@stones) { state $_ = $flint; is $_, $first, 'state $_'; ok /$first/, '/.../ binds to $_'; is ucfirst, $First, '$_ default argument'; } is $_, "bambam", '$_ is still there'; # # Goto. # my @simpsons = qw [Homer Marge Bart Lisa Maggie]; again: my $next = shift @simpsons; state $simpson = $next; is $simpson, 'Homer', 'goto 1'; goto again if @simpsons; my $vi; { goto Elvis unless $vi; state $calvin = ++ $vi; Elvis: state $vile = ++ $vi; redo unless defined $calvin; is $calvin, 2, "goto 2"; is $vile, 1, "goto 3"; is $vi, 2, "goto 4"; } my @presidents = qw [Taylor Garfield Ford Arthur Monroe]; sub president { my $next = shift @presidents; state $president = $next; goto &president if @presidents; $president; } my $president_answer = $presidents [0]; is president, $president_answer, '&goto'; my @flowers = qw [Bluebonnet Goldenrod Hawthorn Peony]; foreach my $f (@flowers) { goto state $flower = $f; ok 0, 'computed goto 0'; next; Bluebonnet: ok 1, 'computed goto 1'; next; Goldenrod: ok 0, 'computed goto 2'; next; Hawthorn: ok 0, 'computed goto 3'; next; Peony: ok 0, 'computed goto 4'; next; ok 0, 'computed goto 5'; next; } # # map/grep # my @apollo = qw [Eagle Antares Odyssey Aquarius]; my @result1 = map {state $x = $_;} @apollo; my @result2 = grep {state $x = /Eagle/} @apollo; { local $" = ""; is "@result1", $apollo [0] x @apollo, "map"; is "@result2", "@apollo", "grep"; } # # Reference to state variable. # sub reference {\state $x} my $ref1 = reference; my $ref2 = reference; is $ref1, $ref2, "Reference to state variable"; # # Pre/post increment. # foreach my $x (1 .. 3) { ++ state $y; state $z ++; is $y, $x, "state pre increment"; is $z, $x, "state post increment"; } # # Substr # my $tintin = "Tin-Tin"; my @thunderbirds = qw [Scott Virgel Alan Gordon John]; my @thunderbirds2 = qw [xcott xxott xxxtt xxxxt xxxxx]; foreach my $x (0 .. 4) { state $c = \substr $tintin, $x, 1; my $d = \substr ((state $tb = $thunderbirds [$x]), $x, 1); $$c = "x"; $$d = "x"; is $tintin, "xin-Tin", "substr"; is $tb, $thunderbirds2 [$x], "substr"; } # # Use with given. # my @spam = qw [spam ham bacon beans]; foreach my $spam (@spam) { given (state $spam = $spam) { when ($spam [0]) {ok 1, "given"} default {ok 0, "given"} } } # # Redefine. # { state $x = "one"; no warnings; state $x = "two"; is $x, "two", "masked" } # normally closureless anon subs share a CV and pad. If the anon sub has a # state var, this would mean that it is shared. Check that this doesn't # happen { my @f; push @f, sub { state $x; ++$x } for 1..2; $f[0]->() for 1..10; is $f[0]->(), 11; is $f[1]->(), 1; } # each copy of an anon sub should get its own 'once block' { my $x; # used to force a closure my @f; push @f, sub { $x=0; state $s = $_[0]; $s } for 1..2; is $f[0]->(1), 1; is $f[0]->(2), 1; is $f[1]->(3), 3; is $f[1]->(4), 3; } foreach my $forbidden () { chomp $forbidden; no strict 'vars'; eval $forbidden; like $@, qr/Initialization of state variables in list context currently forbidden/, "Currently forbidden: $forbidden"; } # [perl #49522] state variable not available { my @warnings; local $SIG{__WARN__} = sub { push @warnings, $_[0] }; eval q{ use warnings; sub f_49522 { state $s = 88; sub g_49522 { $s } sub { $s }; } sub h_49522 { state $t = 99; sub i_49522 { sub { $t }; } } }; is $@, '', "eval f_49522"; # shouldn't be any 'not available' or 'not stay shared' warnings ok !@warnings, "suppress warnings part 1 [@warnings]"; @warnings = (); my $f = f_49522(); is $f->(), 88, "state var closure 1"; is g_49522(), 88, "state var closure 2"; ok !@warnings, "suppress warnings part 2 [@warnings]"; @warnings = (); $f = i_49522(); h_49522(); # initialise $t is $f->(), 99, "state var closure 3"; ok !@warnings, "suppress warnings part 3 [@warnings]"; } __DATA__ state ($a) = 1; (state $a) = 1; state @a = 1; state (@a) = 1; (state @a) = 1; state %a = (); state (%a) = (); (state %a) = (); state ($a, $b) = (); state ($a, @b) = (); (state $a, state $b) = (); (state $a, $b) = (); (state $a, my $b) = (); (state $a, state @b) = (); (state $a, local @b) = (); (state $a, undef, state $b) = (); state ($a, undef, $b) = (); perl-5.12.0-RC0/t/op/do.t0000555000175000017500000001271211325127001013573 0ustar jessejesse#!./perl sub foo1 { ok($_[0]); 'value'; } sub foo2 { shift; ok($_[0]); $x = 'value'; $x; } my $test = 1; sub ok { my($ok, $name) = @_; # You have to do it this way or VMS will get confused. printf "%s %d%s\n", $ok ? "ok" : "not ok", $test, defined $name ? " - $name" : ''; printf "# Failed test at line %d\n", (caller)[2] unless $ok; $test++; return $ok; } print "1..50\n"; # Test do &sub and proper @_ handling. $_[0] = 0; { no warnings 'deprecated'; $result = do foo1(1); } ok( $result eq 'value', ":$result: eq :value:" ); ok( $_[0] == 0 ); $_[0] = 0; { no warnings 'deprecated'; $result = do foo2(0,1,0); } ok( $result eq 'value', ":$result: eq :value:" ); ok( $_[0] == 0 ); $result = do{ ok 1; 'value';}; ok( $result eq 'value', ":$result: eq :value:" ); sub blather { ok 1 foreach @_; } { no warnings 'deprecated'; do blather("ayep","sho nuff"); } @x = ("jeepers", "okydoke"); @y = ("uhhuh", "yeppers"); { no warnings 'deprecated'; do blather(@x,"noofie",@y); } unshift @INC, '.'; if (open(DO, ">$$.16")) { print DO "ok(1, 'do in scalar context') if defined wantarray && not wantarray\n"; close DO or die "Could not close: $!"; } my $a = do "$$.16"; die $@ if $@; if (open(DO, ">$$.17")) { print DO "ok(1, 'do in list context') if defined wantarray && wantarray\n"; close DO or die "Could not close: $!"; } my @a = do "$$.17"; die $@ if $@; if (open(DO, ">$$.18")) { print DO "ok(1, 'do in void context') if not defined wantarray\n"; close DO or die "Could not close: $!"; } do "$$.18"; die $@ if $@; # bug ID 20010920.007 eval qq{ do qq(a file that does not exist); }; ok( !$@, "do on a non-existing file, first try" ); eval qq{ do uc qq(a file that does not exist); }; ok( !$@, "do on a non-existing file, second try" ); # 6 must be interpreted as a file name here ok( (!defined do 6) && $!, "'do 6' : $!" ); # [perl #19545] push @t, ($u = (do {} . "This should be pushed.")); ok( $#t == 0, "empty do result value" ); $zok = ''; $owww = do { 1 if $zok }; ok( $owww eq '', 'last is unless' ); $owww = do { 2 unless not $zok }; ok( $owww == 1, 'last is if not' ); $zok = 'swish'; $owww = do { 3 unless $zok }; ok( $owww eq 'swish', 'last is unless' ); $owww = do { 4 if not $zok }; ok( $owww eq '', 'last is if not' ); # [perl #38809] @a = (7); $x = sub { do { return do { @a } }; 2 }->(); ok(defined $x && $x == 1, 'return do { } receives caller scalar context'); @x = sub { do { return do { @a } }; 2 }->(); ok("@x" eq "7", 'return do { } receives caller list context'); @a = (7, 8); $x = sub { do { return do { 1; @a } }; 3 }->(); ok(defined $x && $x == 2, 'return do { ; } receives caller scalar context'); @x = sub { do { return do { 1; @a } }; 3 }->(); ok("@x" eq "7 8", 'return do { ; } receives caller list context'); @b = (11 .. 15); $x = sub { do { return do { 1; @a, @b } }; 3 }->(); ok(defined $x && $x == 5, 'return do { ; , } receives caller scalar context'); @x = sub { do { return do { 1; @a, @b } }; 3 }->(); ok("@x" eq "7 8 11 12 13 14 15", 'return do { ; , } receives caller list context'); $x = sub { do { return do { 1; @a }, do { 2; @b } }; 3 }->(); ok(defined $x && $x == 5, 'return do { ; }, do { ; } receives caller scalar context'); @x = sub { do { return do { 1; @a }, do { 2; @b } }; 3 }->(); ok("@x" eq "7 8 11 12 13 14 15", 'return do { ; }, do { ; } receives caller list context'); @a = (7, 8, 9); $x = sub { do { do { 1; return @a } }; 4 }->(); ok(defined $x && $x == 3, 'do { return } receives caller scalar context'); @x = sub { do { do { 1; return @a } }; 4 }->(); ok("@x" eq "7 8 9", 'do { return } receives caller list context'); @a = (7, 8, 9, 10); $x = sub { do { return do { 1; do { 2; @a } } }; 5 }->(); ok(defined $x && $x == 4, 'return do { do { ; } } receives caller scalar context'); @x = sub { do { return do { 1; do { 2; @a } } }; 5 }->(); ok("@x" eq "7 8 9 10", 'return do { do { ; } } receives caller list context'); # Do blocks created by constant folding # [perl #68108] $x = sub { if (1) { 20 } }->(); ok($x == 20, 'if (1) { $x } receives caller scalar context'); @a = (21 .. 23); $x = sub { if (1) { @a } }->(); ok($x == 3, 'if (1) { @a } receives caller scalar context'); @x = sub { if (1) { @a } }->(); ok("@x" eq "21 22 23", 'if (1) { @a } receives caller list context'); $x = sub { if (1) { 0; 20 } }->(); ok($x == 20, 'if (1) { ...; $x } receives caller scalar context'); @a = (24 .. 27); $x = sub { if (1) { 0; @a } }->(); ok($x == 4, 'if (1) { ...; @a } receives caller scalar context'); @x = sub { if (1) { 0; @a } }->(); ok("@x" eq "24 25 26 27", 'if (1) { ...; @a } receives caller list context'); $x = sub { if (1) { 0; 20 } else{} }->(); ok($x == 20, 'if (1) { ...; $x } else{} receives caller scalar context'); @a = (24 .. 27); $x = sub { if (1) { 0; @a } else{} }->(); ok($x == 4, 'if (1) { ...; @a } else{} receives caller scalar context'); @x = sub { if (1) { 0; @a } else{} }->(); ok("@x" eq "24 25 26 27", 'if (1) { ...; @a } else{} receives caller list context'); $x = sub { if (0){} else { 0; 20 } }->(); ok($x == 20, 'if (0){} else { ...; $x } receives caller scalar context'); @a = (24 .. 27); $x = sub { if (0){} else { 0; @a } }->(); ok($x == 4, 'if (0){} else { ...; @a } receives caller scalar context'); @x = sub { if (0){} else { 0; @a } }->(); ok("@x" eq "24 25 26 27", 'if (0){} else { ...; @a } receives caller list context'); END { 1 while unlink("$$.16", "$$.17", "$$.18"); } perl-5.12.0-RC0/t/op/glob.t0000555000175000017500000000400711325127001014112 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = qw(. ../lib); } require 'test.pl'; plan( tests => 15 ); @oops = @ops = ; if ($^O eq 'MSWin32') { map { $files{lc($_)}++ } ; map { delete $files{"op/$_"} } split /[\s\n]/, `dir /b /l op & dir /b /l /ah op 2>nul`, } elsif ($^O eq 'VMS') { map { $files{lc($_)}++ } <[.op]*>; map { s/;.*$//; delete $files{lc($_)}; } split /[\n]/, `directory/noheading/notrailing/versions=1 [.op]`, } else { map { $files{$_}++ } ; map { delete $files{$_} } split /[\s\n]/, `echo op/*`; } ok( !(keys(%files)),'leftover op/* files' ) or diag(join(' ',sort keys %files)); cmp_ok($/,'eq',"\n",'sane input record separator'); $not = ''; while () { $not = "not " unless $_ eq shift @ops; $not = "not at all " if $/ eq "\0"; } ok(!$not,"glob amid garbage [$not]"); cmp_ok($/,'eq',"\n",'input record separator still sane'); $_ = "op/*"; @glops = glob $_; cmp_ok("@glops",'eq',"@oops",'glob operator 1'); @glops = glob; cmp_ok("@glops",'eq',"@oops",'glob operator 2'); # glob should still work even after the File::Glob stash has gone away # (this used to dump core) my $i = 0; for (1..2) { eval "<.>"; ok(!length($@),"eval'ed a glob $_"); undef %File::Glob::; ++$i; } cmp_ok($i,'==',2,'remore File::Glob stash'); # ... while ($var = glob(...)) should test definedness not truth SKIP: { skip('no File::Glob to emulate Unix-ism', 1) unless $INC{'File/Glob.pm'}; my $ok = 0; $ok = 1 while my $var = glob("0"); ok($ok,'define versus truth'); } # The formerly-broken test for the situation above would accidentally # test definedness for an assignment with a LOGOP on the right: { my $f = 0; my $ok = 1; $ok = 0, undef $f while $x = $f||$f; ok($ok,'test definedness with LOGOP'); } cmp_ok(scalar(@oops),'>',0,'glob globbed something'); *aieee = 4; pass('Can assign integers to typeglobs'); *aieee = 3.14; pass('Can assign floats to typeglobs'); *aieee = 'pi'; pass('Can assign strings to typeglobs'); perl-5.12.0-RC0/t/op/exists_sub.t0000555000175000017500000000163211325127001015360 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } print "1..9\n"; sub t1; sub t2 : lvalue; sub t3 (); sub t4 ($); sub t5 {1;} { package P1; sub tmc {1;} package P2; @ISA = 'P1'; } print "not " unless exists &t1 && not defined &t1; print "ok 1\n"; print "not " unless exists &t2 && not defined &t2; print "ok 2\n"; print "not " unless exists &t3 && not defined &t3; print "ok 3\n"; print "not " unless exists &t4 && not defined &t4; print "ok 4\n"; print "not " unless exists &t5 && defined &t5; print "ok 5\n"; P2::->tmc; print "not " unless not exists &P2::tmc && not defined &P2::tmc; print "ok 6\n"; my $ref; $ref->{A}[0] = \&t4; print "not " unless exists &{$ref->{A}[0]} && not defined &{$ref->{A}[0]}; print "ok 7\n"; undef &P1::tmc; print "not " unless exists &P1::tmc && not defined &P1::tmc; print "ok 8\n"; eval 'exists &t5()'; print "not " unless $@; print "ok 9\n"; exit 0; perl-5.12.0-RC0/t/op/qr.t0000555000175000017500000000164311334306514013624 0ustar jessejesse#!./perl -w use strict; require './test.pl'; plan(tests => 18); sub r { return qr/Good/; } my $a = r(); isa_ok($a, 'Regexp'); my $b = r(); isa_ok($b, 'Regexp'); my $b1 = $b; isnt($a + 0, $b + 0, 'Not the same object'); bless $b, 'Pie'; isa_ok($b, 'Pie'); isa_ok($a, 'Regexp'); isa_ok($b1, 'Pie'); my $c = r(); like("$c", qr/Good/); my $d = r(); like("$d", qr/Good/); my $d1 = $d; isnt($c + 0, $d + 0, 'Not the same object'); $$d = 'Bad'; like("$c", qr/Good/); is($$d, 'Bad'); is($$d1, 'Bad'); # Assignment to an implicitly blessed Regexp object retains the class # (No different from direct value assignment to any other blessed SV isa_ok($d, 'Regexp'); like("$d", qr/\ARegexp=SCALAR\(0x[0-9a-f]+\)\z/); # As does an explicitly blessed Regexp object. my $e = bless qr/Faux Pie/, 'Stew'; isa_ok($e, 'Stew'); $$e = 'Fake!'; is($$e, 'Fake!'); isa_ok($e, 'Stew'); like("$e", qr/\Stew=SCALAR\(0x[0-9a-f]+\)\z/); perl-5.12.0-RC0/t/op/kill0.t0000555000175000017500000000206611325125742014217 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } BEGIN { if ($^O eq 'riscos') { skip_all("kill() not implemented on this platform"); } } use strict; plan tests => 5; ok( kill(0, $$), 'kill(0, $pid) returns true if $pid exists' ); # It's not easy to come up with an individual PID that is known not to exist, # so just check that at least some PIDs in a large range are reported not to # exist. my $count = 0; my $total = 30_000; for my $pid (1 .. $total) { ++$count if kill(0, $pid); } # It is highly unlikely that all of the above PIDs are genuinely in use, # so $count should be less than $total. ok( $count < $total, 'kill(0, $pid) returns false if $pid does not exist' ); # Verify that trying to kill a non-numeric PID is fatal my @bad_pids = ( [ undef , 'undef' ], [ '' , 'empty string' ], [ 'abcd', 'alphabetic' ], ); for my $case ( @bad_pids ) { my ($pid, $name) = @$case; eval { kill 0, $pid }; like( $@, qr/^Can't kill a non-numeric process ID/, "dies killing $name pid"); } perl-5.12.0-RC0/t/op/oct.t0000555000175000017500000001027611325125742013773 0ustar jessejesse#!./perl # tests 51 onwards aren't all warnings clean. (intentionally) print "1..71\n"; my $test = 1; sub test ($$$) { my ($act, $string, $value) = @_; my $result; if ($act eq 'oct') { $result = oct $string; } elsif ($act eq 'hex') { $result = hex $string; } else { die "Unknown action 'act'"; } if ($value == $result) { if ($^O eq 'VMS' && length $string > 256) { $string = ''; } else { $string = "\"$string\""; } print "ok $test # $act $string\n"; } else { my ($valstr, $resstr); if ($act eq 'hex' or $string =~ /x/) { $valstr = sprintf "0x%X", $value; $resstr = sprintf "0x%X", $result; } elsif ($string =~ /b/) { $valstr = sprintf "0b%b", $value; $resstr = sprintf "0b%b", $result; } else { $valstr = sprintf "0%o", $value; $resstr = sprintf "0%o", $result; } print "not ok $test # $act \"$string\" gives \"$result\" ($resstr), not $value ($valstr)\n"; } $test++; } test ('oct', '0b1_0101', 0b101_01); test ('oct', '0b10_101', 0_2_5); test ('oct', '0b101_01', 2_1); test ('oct', '0b1010_1', 0x1_5); test ('oct', 'b1_0101', 0b10101); test ('oct', 'b10_101', 025); test ('oct', 'b101_01', 21); test ('oct', 'b1010_1', 0x15); test ('oct', '01_234', 0b10_1001_1100); test ('oct', '012_34', 01234); test ('oct', '0123_4', 668); test ('oct', '01234', 0x29c); test ('oct', '0x1_234', 0b10010_00110100); test ('oct', '0x12_34', 01_1064); test ('oct', '0x123_4', 4660); test ('oct', '0x1234', 0x12_34); test ('oct', 'x1_234', 0b100100011010_0); test ('oct', 'x12_34', 0_11064); test ('oct', 'x123_4', 4660); test ('oct', 'x1234', 0x_1234); test ('hex', '01_234', 0b_1001000110100); test ('hex', '012_34', 011064); test ('hex', '0123_4', 4660); test ('hex', '01234_', 0x1234); test ('hex', '0x_1234', 0b1001000110100); test ('hex', '0x1_234', 011064); test ('hex', '0x12_34', 4660); test ('hex', '0x1234_', 0x1234); test ('hex', 'x_1234', 0b1001000110100); test ('hex', 'x12_34', 011064); test ('hex', 'x123_4', 4660); test ('hex', 'x1234_', 0x1234); test ('oct', '0b1111_1111_1111_1111_1111_1111_1111_1111', 4294967295); test ('oct', '037_777_777_777', 4294967295); test ('oct', '0xffff_ffff', 4294967295); test ('hex', '0xff_ff_ff_ff', 4294967295); $_ = "\0_7_7"; print length eq 5 ? "ok" : "not ok", " 37\n"; print $_ eq "\0"."_"."7"."_"."7" ? "ok" : "not ok", " 38\n"; chop, chop, chop, chop; print $_ eq "\0" ? "ok" : "not ok", " 39\n"; if (ord("\t") != 9) { # question mark is 111 in 1047, 037, && POSIX-BC print "\157_" eq "?_" ? "ok" : "not ok", " 40\n"; } else { print "\077_" eq "?_" ? "ok" : "not ok", " 40\n"; } $_ = "\x_7_7"; print length eq 5 ? "ok" : "not ok", " 41\n"; print $_ eq "\0"."_"."7"."_"."7" ? "ok" : "not ok", " 42\n"; chop, chop, chop, chop; print $_ eq "\0" ? "ok" : "not ok", " 43\n"; if (ord("\t") != 9) { # / is 97 in 1047, 037, && POSIX-BC print "\x61_" eq "/_" ? "ok" : "not ok", " 44\n"; } else { print "\x2F_" eq "/_" ? "ok" : "not ok", " 44\n"; } $test = 45; test ('oct', '0b'.( '0'x10).'1_0101', 0b101_01); test ('oct', '0b'.( '0'x100).'1_0101', 0b101_01); test ('oct', '0b'.('0'x1000).'1_0101', 0b101_01); test ('hex', ( '0'x10).'01234', 0x1234); test ('hex', ( '0'x100).'01234', 0x1234); test ('hex', ('0'x1000).'01234', 0x1234); # Things that perl 5.6.1 and 5.7.2 did wrong (plus some they got right) test ('oct', "b00b0101", 0); test ('oct', "bb0101", 0); test ('oct', "0bb0101", 0); test ('oct', "0x0x3A", 0); test ('oct', "0xx3A", 0); test ('oct', "x0x3A", 0); test ('oct', "xx3A", 0); test ('oct', "0x3A", 0x3A); test ('oct', "x3A", 0x3A); test ('oct', "0x0x4", 0); test ('oct', "0xx4", 0); test ('oct', "x0x4", 0); test ('oct', "xx4", 0); test ('oct', "0x4", 4); test ('oct', "x4", 4); test ('hex', "0x3A", 0x3A); test ('hex', "x3A", 0x3A); test ('hex', "0x4", 4); test ('hex', "x4", 4); eval '$a = oct "10\x{100}"'; print $@ =~ /Wide character/ ? "ok $test\n" : "not ok $test\n"; $test++; eval '$a = hex "ab\x{100}"'; print $@ =~ /Wide character/ ? "ok $test\n" : "not ok $test\n"; $test++; perl-5.12.0-RC0/t/op/upgrade.t0000555000175000017500000000222611325125742014631 0ustar jessejesse#!./perl -w # Check that we can "upgrade" from anything to anything else. # Curiously, before this, lib/Math/Trig.t was the only code anywhere in the # build or testsuite that upgraded an NV to an RV BEGIN { chdir 't'; @INC = '../lib'; require './test.pl'; } use strict; my $null; $! = 1; my %types = ( null => $null, iv => 3, nv => .5, rv => [], pv => "Perl rules", pviv => 3, pvnv => 1==1, pvmg => $^, ); # This is somewhat cheating but I can't think of anything built in that I can # copy that already has type PVIV $types{pviv} = "Perl rules!"; # use Devel::Peek; Dump $pvmg; my @keys = keys %types; plan tests => @keys * @keys; foreach my $source_type (@keys) { foreach my $dest_type (@keys) { # Pads re-using variables might contaminate this my $vars = {}; $vars->{dest} = $types{$dest_type}; $vars->{source} = $types{$source_type}; # The assignment can potentially trigger assertion failures, so it's # useful to have the diagnostics about what was attempted printed first print "# Assigning $source_type to $dest_type\n"; $vars->{dest} = $vars->{source}; is ($vars->{dest}, $vars->{source}); } } perl-5.12.0-RC0/t/op/mkdir.t0000555000175000017500000000162311325127001014276 0ustar jessejesse#!./perl -w BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } plan tests => 22; use File::Path; rmtree('blurfl'); # tests 3 and 7 rather naughtily expect English error messages $ENV{'LC_ALL'} = 'C'; $ENV{LANGUAGE} = 'C'; # GNU locale extension ok(mkdir('blurfl',0777)); ok(!mkdir('blurfl',0777)); like($!, qr/cannot move|exist|denied|unknown/i); ok(-d 'blurfl'); ok(rmdir('blurfl')); ok(!rmdir('blurfl')); like($!, qr/cannot find|such|exist|not found|not a directory|unknown/i); ok(mkdir('blurfl')); ok(rmdir('blurfl')); # trailing slashes will be removed before the system call to mkdir ok(mkdir('blurfl///')); ok(-d 'blurfl'); ok(rmdir('blurfl///')); ok(!-d 'blurfl'); # test default argument $_ = 'blurfl'; ok(mkdir); ok(-d); ok(rmdir); ok(!-d); $_ = 'lfrulb'; { my $_ = 'blurfl'; ok(mkdir); ok(-d); ok(-d 'blurfl'); ok(!-d 'lfrulb'); ok(rmdir); } perl-5.12.0-RC0/t/op/int.t0000555000175000017500000000343611325125742014000 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } print "1..14\n"; # compile time evaluation if (int(1.234) == 1) {print "ok 1\n";} else {print "not ok 1\n";} if (int(-1.234) == -1) {print "ok 2\n";} else {print "not ok 2\n";} # run time evaluation $x = 1.234; if (int($x) == 1) {print "ok 3\n";} else {print "not ok 3\n";} if (int(-$x) == -1) {print "ok 4\n";} else {print "not ok 4\n";} $x = length("abc") % -10; print $x == -7 ? "ok 5\n" : "# expected -7, got $x\nnot ok 5\n"; { use integer; $x = length("abc") % -10; $y = (3/-10)*-10; print $x+$y == 3 && abs($x) < 10 ? "ok 6\n" : "not ok 6\n"; } # check bad strings still get converted @x = ( 6, 8, 10); print "not " if $x["1foo"] != 8; print "ok 7\n"; # check values > 32 bits work. $x = 4294967303.15; $y = int ($x); if ($y eq "4294967303") { print "ok 8\n" } else { print "not ok 8 # int($x) is $y, not 4294967303\n" } $y = int (-$x); if ($y eq "-4294967303") { print "ok 9\n" } else { print "not ok 9 # int($x) is $y, not -4294967303\n" } $x = 4294967294.2; $y = int ($x); if ($y eq "4294967294") { print "ok 10\n" } else { print "not ok 10 # int($x) is $y, not 4294967294\n" } $x = 4294967295.7; $y = int ($x); if ($y eq "4294967295") { print "ok 11\n" } else { print "not ok 11 # int($x) is $y, not 4294967295\n" } $x = 4294967296.11312; $y = int ($x); if ($y eq "4294967296") { print "ok 12\n" } else { print "not ok 12 # int($x) is $y, not 4294967296\n" } $y = int(279964589018079/59); if ($y == 4745162525730) { print "ok 13\n" } else { print "not ok 13 # int(279964589018079/59) is $y, not 4745162525730\n" } $y = 279964589018079; $y = int($y/59); if ($y == 4745162525730) { print "ok 14\n" } else { print "not ok 14 # int(279964589018079/59) is $y, not 4745162525730\n" } perl-5.12.0-RC0/t/op/cmp.t0000555000175000017500000001277711325125742013775 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } # 2s complement assumption. Won't break test, just makes the internals of # the SVs less interesting if were not on 2s complement system. my $uv_max = ~0; my $uv_maxm1 = ~0 ^ 1; my $uv_big = $uv_max; $uv_big = ($uv_big - 20000) | 1; my ($iv0, $iv1, $ivm1, $iv_min, $iv_max, $iv_big, $iv_small); $iv_max = $uv_max; # Do copy, *then* divide $iv_max /= 2; $iv_min = $iv_max; { use integer; $iv0 = 2 - 2; $iv1 = 3 - 2; $ivm1 = 2 - 3; $iv_max -= 1; $iv_min += 0; $iv_big = $iv_max - 3; $iv_small = $iv_min + 2; } my $uv_bigi = $iv_big; $uv_bigi |= 0x0; my @array = qw(perl rules); # Seems one needs to perform the maths on 'Inf' to get the NV correctly primed. @FOO = ('s', 'N/A', 'a', 'NaN', -1, undef, 0, 1, 3.14, 1e37, 0.632120558, -.5, 'Inf'+1, '-Inf'-1, 0x0, 0x1, 0x5, 0xFFFFFFFF, $uv_max, $uv_maxm1, $uv_big, $uv_bigi, $iv0, $iv1, $ivm1, $iv_min, $iv_max, $iv_big, $iv_small, \$array[0], \$array[0], \$array[1], \$^X); $expect = 7 * ($#FOO+2) * ($#FOO+1); print "1..$expect\n"; sub nok ($$$$$$$$) { my ($test, $left, $threeway, $right, $result, $i, $j, $boolean) = @_; $result = defined $result ? "'$result'" : 'undef'; print "not ok $test # ($left <=> $right) gives: $result \$i=$i \$j=$j, $boolean disagrees\n"; } my $ok = 0; for my $i (0..$#FOO) { for my $j ($i..$#FOO) { $ok++; # Comparison routines may convert these internally, which would change # what is used to determine the comparison on later runs. Hence copy my ($i1, $i2, $i3, $i4, $i5, $i6, $i7, $i8, $i9, $i10, $i11, $i12, $i13, $i14, $i15, $i16, $i17) = ($FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i]); my ($j1, $j2, $j3, $j4, $j5, $j6, $j7, $j8, $j9, $j10, $j11, $j12, $j13, $j14, $j15, $j16, $j17) = ($FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j]); my $cmp = $i1 <=> $j1; if (!defined($cmp) ? !($i2 < $j2) : ($cmp == -1 && $i2 < $j2 || $cmp == 0 && !($i2 < $j2) || $cmp == 1 && !($i2 < $j2))) { print "ok $ok\n"; } else { nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '<'); } $ok++; if (!defined($cmp) ? !($i4 == $j4) : ($cmp == -1 && !($i4 == $j4) || $cmp == 0 && $i4 == $j4 || $cmp == 1 && !($i4 == $j4))) { print "ok $ok\n"; } else { nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '=='); } $ok++; if (!defined($cmp) ? !($i5 > $j5) : ($cmp == -1 && !($i5 > $j5) || $cmp == 0 && !($i5 > $j5) || $cmp == 1 && ($i5 > $j5))) { print "ok $ok\n"; } else { nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '>'); } $ok++; if (!defined($cmp) ? !($i6 >= $j6) : ($cmp == -1 && !($i6 >= $j6) || $cmp == 0 && $i6 >= $j6 || $cmp == 1 && $i6 >= $j6)) { print "ok $ok\n"; } else { nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '>='); } $ok++; # OK, so the docs are wrong it seems. NaN != NaN if (!defined($cmp) ? ($i7 != $j7) : ($cmp == -1 && $i7 != $j7 || $cmp == 0 && !($i7 != $j7) || $cmp == 1 && $i7 != $j7)) { print "ok $ok\n"; } else { nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '!='); } $ok++; if (!defined($cmp) ? !($i8 <= $j8) : ($cmp == -1 && $i8 <= $j8 || $cmp == 0 && $i8 <= $j8 || $cmp == 1 && !($i8 <= $j8))) { print "ok $ok\n"; } else { nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '<='); } $ok++; my $pmc = $j16 <=> $i16; # cmp it in reverse # Should give -ve of other answer, or undef for NaNs # a + -a should be zero. not zero is truth. which avoids using == if (defined($cmp) ? !($cmp + $pmc) : !defined $pmc) { print "ok $ok\n"; } else { nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '<=> transposed'); } # String comparisons $ok++; $cmp = $i9 cmp $j9; if ($cmp == -1 && $i10 lt $j10 || $cmp == 0 && !($i10 lt $j10) || $cmp == 1 && !($i10 lt $j10)) { print "ok $ok\n"; } else { nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'lt'); } $ok++; if ($cmp == -1 && !($i11 eq $j11) || $cmp == 0 && ($i11 eq $j11) || $cmp == 1 && !($i11 eq $j11)) { print "ok $ok\n"; } else { nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'eq'); } $ok++; if ($cmp == -1 && !($i12 gt $j12) || $cmp == 0 && !($i12 gt $j12) || $cmp == 1 && ($i12 gt $j12)) { print "ok $ok\n"; } else { nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'gt'); } $ok++; if ($cmp == -1 && $i13 le $j13 || $cmp == 0 && ($i13 le $j13) || $cmp == 1 && !($i13 le $j13)) { print "ok $ok\n"; } else { nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'le'); } $ok++; if ($cmp == -1 && ($i14 ne $j14) || $cmp == 0 && !($i14 ne $j14) || $cmp == 1 && ($i14 ne $j14)) { print "ok $ok\n"; } else { nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'ne'); } $ok++; if ($cmp == -1 && !($i15 ge $j15) || $cmp == 0 && ($i15 ge $j15) || $cmp == 1 && ($i15 ge $j15)) { print "ok $ok\n"; } else { nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'ge'); } $ok++; $pmc = $j17 cmp $i17; # cmp it in reverse # Should give -ve of other answer # a + -a should be zero. not zero is truth. which avoids using == if (!($cmp + $pmc)) { print "ok $ok\n"; } else { nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, 'cmp transposed'); } } } perl-5.12.0-RC0/t/op/eval.t0000555000175000017500000003255611325127001014130 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } print "1..105\n"; eval 'print "ok 1\n";'; if ($@ eq '') {print "ok 2\n";} else {print "not ok 2\n";} eval "\$foo\n = # this is a comment\n'ok 3';"; print $foo,"\n"; eval "\$foo\n = # this is a comment\n'ok 4\n';"; print $foo; print eval ' $foo =;'; # this tests for a call through yyerror() if ($@ =~ /line 2/) {print "ok 5\n";} else {print "not ok 5\n";} print eval '$foo = /'; # this tests for a call through fatal() if ($@ =~ /Search/) {print "ok 6\n";} else {print "not ok 6\n";} print eval '"ok 7\n";'; # calculate a factorial with recursive evals $foo = 5; $fact = 'if ($foo <= 1) {1;} else {push(@x,$foo--); (eval $fact) * pop(@x);}'; $ans = eval $fact; if ($ans == 120) {print "ok 8\n";} else {print "not ok 8\n";} $foo = 5; $fact = 'local($foo)=$foo; $foo <= 1 ? 1 : $foo-- * (eval $fact);'; $ans = eval $fact; if ($ans == 120) {print "ok 9\n";} else {print "not ok 9 $ans\n";} my $tempfile = tempfile(); open(try,'>',$tempfile); print try 'print "ok 10\n";',"\n"; close try; do "./$tempfile"; print $@; # Test the singlequoted eval optimizer $i = 11; for (1..3) { eval 'print "ok ", $i++, "\n"'; } eval { print "ok 14\n"; die "ok 16\n"; 1; } || print "ok 15\n$@"; # check whether eval EXPR determines value of EXPR correctly { my @a = qw(a b c d); my @b = eval @a; print "@b" eq '4' ? "ok 17\n" : "not ok 17\n"; print $@ ? "not ok 18\n" : "ok 18\n"; my $a = q[defined(wantarray) ? (wantarray ? ($b='A') : ($b='S')) : ($b='V')]; my $b; @a = eval $a; print "@a" eq 'A' ? "ok 19\n" : "# $b\nnot ok 19\n"; print $b eq 'A' ? "ok 20\n" : "# $b\nnot ok 20\n"; $_ = eval $a; print $b eq 'S' ? "ok 21\n" : "# $b\nnot ok 21\n"; eval $a; print $b eq 'V' ? "ok 22\n" : "# $b\nnot ok 22\n"; $b = 'wrong'; $x = sub { my $b = "right"; print eval('"$b"') eq $b ? "ok 23\n" : "not ok 23\n"; }; &$x(); } my $b = 'wrong'; my $X = sub { my $b = "right"; print eval('"$b"') eq $b ? "ok 24\n" : "not ok 24\n"; }; &$X(); # check navigation of multiple eval boundaries to find lexicals my $x = 25; eval <<'EOT'; die if $@; print "# $x\n"; # clone into eval's pad sub do_eval1 { eval $_[0]; die if $@; } EOT do_eval1('print "ok $x\n"'); $x++; do_eval1('eval q[print "ok $x\n"]'); $x++; do_eval1('sub { print "# $x\n"; eval q[print "ok $x\n"] }->()'); $x++; # calls from within eval'' should clone outer lexicals eval <<'EOT'; die if $@; sub do_eval2 { eval $_[0]; die if $@; } do_eval2('print "ok $x\n"'); $x++; do_eval2('eval q[print "ok $x\n"]'); $x++; do_eval2('sub { print "# $x\n"; eval q[print "ok $x\n"] }->()'); $x++; EOT # calls outside eval'' should NOT clone lexicals from called context $main::ok = 'not ok'; my $ok = 'ok'; eval <<'EOT'; die if $@; # $x unbound here sub do_eval3 { eval $_[0]; die if $@; } EOT { my $ok = 'not ok'; do_eval3('print "$ok ' . $x++ . '\n"'); do_eval3('eval q[print "$ok ' . $x++ . '\n"]'); do_eval3('sub { eval q[print "$ok ' . $x++ . '\n"] }->()'); } # can recursive subroutine-call inside eval'' see its own lexicals? sub recurse { my $l = shift; if ($l < $x) { ++$l; eval 'print "# level $l\n"; recurse($l);'; die if $@; } else { print "ok $l\n"; } } { local $SIG{__WARN__} = sub { die "not ok $x\n" if $_[0] =~ /^Deep recurs/ }; recurse($x-5); } $x++; # do closures created within eval bind correctly? eval <<'EOT'; sub create_closure { my $self = shift; return sub { print $self; }; } EOT create_closure("ok $x\n")->(); $x++; # does lexical search terminate correctly at subroutine boundary? $main::r = "ok $x\n"; sub terminal { eval 'print $r' } { my $r = "not ok $x\n"; eval 'terminal($r)'; } $x++; # Have we cured panic which occurred with require/eval in die handler ? $SIG{__DIE__} = sub { eval {1}; die shift }; eval { die "ok ".$x++,"\n" }; print $@; # does scalar eval"" pop stack correctly? { my $c = eval "(1,2)x10"; print $c eq '2222222222' ? "ok $x\n" : "# $c\nnot ok $x\n"; $x++; } # return from eval {} should clear $@ correctly { my $status = eval { eval { die }; print "# eval { return } test\n"; return; # removing this changes behavior }; print "not " if $@; print "ok $x\n"; $x++; } # ditto for eval "" { my $status = eval q{ eval q{ die }; print "# eval q{ return } test\n"; return; # removing this changes behavior }; print "not " if $@; print "ok $x\n"; $x++; } # Check that eval catches bad goto calls # (BUG ID 20010305.003) { eval { eval { goto foo; }; print ($@ ? "ok 41\n" : "not ok 41\n"); last; foreach my $i (1) { foo: print "not ok 41\n"; print "# jumped into foreach\n"; } }; print "not ok 41\n" if $@; } # Make sure that "my $$x" is forbidden # 20011224 MJD { eval q{my $$x}; print $@ ? "ok 42\n" : "not ok 42\n"; eval q{my @$x}; print $@ ? "ok 43\n" : "not ok 43\n"; eval q{my %$x}; print $@ ? "ok 44\n" : "not ok 44\n"; eval q{my $$$x}; print $@ ? "ok 45\n" : "not ok 45\n"; } # [ID 20020623.002] eval "" doesn't clear $@ { $@ = 5; eval q{}; print length($@) ? "not ok 46\t# \$\@ = '$@'\n" : "ok 46\n"; } # DAPM Nov-2002. Perl should now capture the full lexical context during # evals. $::zzz = $::zzz = 0; my $zzz = 1; eval q{ sub fred1 { eval q{ print eval '$zzz' == 1 ? 'ok' : 'not ok', " $_[0]\n"} } fred1(47); { my $zzz = 2; fred1(48) } }; eval q{ sub fred2 { print eval('$zzz') == 1 ? 'ok' : 'not ok', " $_[0]\n"; } }; fred2(49); { my $zzz = 2; fred2(50) } # sort() starts a new context stack. Make sure we can still find # the lexically enclosing sub sub do_sort { my $zzz = 2; my @a = sort { print eval('$zzz') == 2 ? 'ok' : 'not ok', " 51\n"; $a <=> $b } 2, 1; } do_sort(); # more recursion and lexical scope leak tests eval q{ my $r = -1; my $yyy = 9; sub fred3 { my $l = shift; my $r = -2; return 1 if $l < 1; return 0 if eval '$zzz' != 1; return 0 if $yyy != 9; return 0 if eval '$yyy' != 9; return 0 if eval '$l' != $l; return $l * fred3($l-1); } my $r = fred3(5); print $r == 120 ? 'ok' : 'not ok', " 52\n"; $r = eval'fred3(5)'; print $r == 120 ? 'ok' : 'not ok', " 53\n"; $r = 0; eval '$r = fred3(5)'; print $r == 120 ? 'ok' : 'not ok', " 54\n"; $r = 0; { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' }; print $r == 120 ? 'ok' : 'not ok', " 55\n"; }; my $r = fred3(5); print $r == 120 ? 'ok' : 'not ok', " 56\n"; $r = eval'fred3(5)'; print $r == 120 ? 'ok' : 'not ok', " 57\n"; $r = 0; eval'$r = fred3(5)'; print $r == 120 ? 'ok' : 'not ok', " 58\n"; $r = 0; { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' }; print $r == 120 ? 'ok' : 'not ok', " 59\n"; # check that goto &sub within evals doesn't leak lexical scope my $yyy = 2; my $test = 60; sub fred4 { my $zzz = 3; print +($zzz == 3 && eval '$zzz' == 3) ? 'ok' : 'not ok', " $test\n"; $test++; print eval '$yyy' == 2 ? 'ok' : 'not ok', " $test\n"; $test++; } eval q{ fred4(); sub fred5 { my $zzz = 4; print +($zzz == 4 && eval '$zzz' == 4) ? 'ok' : 'not ok', " $test\n"; $test++; print eval '$yyy' == 2 ? 'ok' : 'not ok', " $test\n"; $test++; goto &fred4; } fred5(); }; fred5(); { my $yyy = 88; my $zzz = 99; fred5(); } eval q{ my $yyy = 888; my $zzz = 999; fred5(); }; # [perl #9728] used to dump core { $eval = eval 'sub { eval "sub { %S }" }'; $eval->({}); print "ok $test\n"; $test++; } # evals that appear in the DB package should see the lexical scope of the # thing outside DB that called them (usually the debugged code), rather # than the usual surrounding scope $test=79; our $x = 1; { my $x=2; sub db1 { $x; eval '$x' } sub DB::db2 { $x; eval '$x' } package DB; sub db3 { eval '$x' } sub DB::db4 { eval '$x' } sub db5 { my $x=4; eval '$x' } package main; sub db6 { my $x=4; eval '$x' } } { my $x = 3; print db1() == 2 ? 'ok' : 'not ok', " $test\n"; $test++; print DB::db2() == 2 ? 'ok' : 'not ok', " $test\n"; $test++; print DB::db3() == 3 ? 'ok' : 'not ok', " $test\n"; $test++; print DB::db4() == 3 ? 'ok' : 'not ok', " $test\n"; $test++; print DB::db5() == 3 ? 'ok' : 'not ok', " $test\n"; $test++; print db6() == 4 ? 'ok' : 'not ok', " $test\n"; $test++; } require './test.pl'; $NO_ENDING = 1; # [perl #19022] used to end up with shared hash warnings # The program should generate no output, so anything we see is on stderr my $got = runperl (prog => '$h{a}=1; foreach my $k (keys %h) {eval qq{\$k}}', stderr => 1); if ($got eq '') { print "ok $test\n"; } else { print "not ok $test\n"; _diag ("# Got '$got'\n"); } $test++; # And a buggy way of fixing #19022 made this fail - $k became undef after the # eval for a build with copy on write { my %h; $h{a}=1; foreach my $k (keys %h) { if (defined $k and $k eq 'a') { print "ok $test\n"; } else { print "not $test # got ", _q ($k), "\n"; } $test++; eval "\$k"; if (defined $k and $k eq 'a') { print "ok $test\n"; } else { print "not $test # got ", _q ($k), "\n"; } $test++; } } sub Foo {} print Foo(eval {}); print "ok ",$test++," - #20798 (used to dump core)\n"; # check for context in string eval { my(@r,$r,$c); sub context { defined(wantarray) ? (wantarray ? ($c='A') : ($c='S')) : ($c='V') } my $code = q{ context() }; @r = qw( a b ); $r = 'ab'; @r = eval $code; print "@r$c" eq 'AA' ? "ok " : "# '@r$c' ne 'AA'\nnot ok ", $test++, "\n"; $r = eval $code; print "$r$c" eq 'SS' ? "ok " : "# '$r$c' ne 'SS'\nnot ok ", $test++, "\n"; eval $code; print $c eq 'V' ? "ok " : "# '$c' ne 'V'\nnot ok ", $test++, "\n"; } # [perl #34682] escaping an eval with last could coredump or dup output $got = runperl ( prog => 'sub A::TIEARRAY { L: { eval { last L } } } tie @a, A; warn qq(ok\n)', stderr => 1); print "not " unless $got eq "ok\n"; print "ok $test - eval and last\n"; $test++; # eval undef should be the same as eval "" barring any warnings { local $@ = "foo"; eval undef; print "not " unless $@ eq ""; print "ok $test # eval undef \n"; $test++; } { no warnings; eval "/ /a;"; print "not " unless $@ =~ /^syntax error/; print "ok $test # eval syntax error, no warnings \n"; $test++; } # a syntax error in an eval called magically 9eg vie tie or overload) # resulted in an assertion failure in S_docatch, since doeval had already # poppedthe EVAL context due to the failure, but S_docatch expected the # context to still be there. { my $ok = 0; package Eval1; sub STORE { eval '('; $ok = 1 } sub TIESCALAR { bless [] } my $x; tie $x, bless []; $x = 1; print "not " unless $ok; print "ok $test # eval docatch \n"; $test++; } # [perl #51370] eval { die "\x{a10d}" } followed by eval { 1 } did not reset # length $@ $@ = ""; eval { die "\x{a10d}"; }; $_ = length $@; eval { 1 }; print "not " if ($@ ne ""); print "ok $test # length of \$@ after eval\n"; $test++; print "not " if (length $@ != 0); print "ok $test # length of \$@ after eval\n"; $test++; # Check if eval { 1 }; compeltly resets $@ if (eval "use Devel::Peek; 1;") { $tempfile = tempfile(); $outfile = tempfile(); open PROG, ">", $tempfile or die "Can't create test file"; my $prog = <<'END_EVAL_TEST'; use Devel::Peek; $! = 0; $@ = $!; my $ok = 0; open(SAVERR, ">&STDERR") or die "Can't dup STDERR: $!"; if (open(OUT, '>', '@@@@')) { open(STDERR, ">&OUT") or die "Can't dup OUT: $!"; Dump($@); print STDERR "******\n"; eval { die "\x{a10d}"; }; $_ = length $@; eval { 1 }; Dump($@); open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!"; close(OUT); if (open(IN, '<', '@@@@')) { local $/; my $in = ; my ($first, $second) = split (/\*\*\*\*\*\*\n/, $in, 2); $first =~ s/,pNOK//; $ok = 1 if ($first eq $second); } } print $ok; END_EVAL_TEST $prog =~ s/\@\@\@\@/$outfile/g; print PROG $prog; close PROG; my $ok = runperl(progfile => $tempfile); print "not " unless $ok; print "ok $test # eval { 1 } completly resets \$@\n"; } else { print "ok $test # skipped - eval { 1 } completly resets \$@\n"; } $test++; # Test that "use feature" and other hint transmission in evals and s///ee # don't leak memory { use feature qw(:5.10); my $count_expected = ($^H & 0x20000) ? 2 : 1; my $t; my $s = "a"; $s =~ s/a/$t = \%^H; qq( qq() );/ee; print "not " if Internals::SvREFCNT(%$t) != $count_expected; print "ok $test - RT 63110\n"; $test++; } curr_test($test); { # test that the CV compiled for the eval is freed by checking that no additional # reference to outside lexicals are made. my $x; is(Internals::SvREFCNT($x), 1, "originally only 1 referece"); eval '$x'; is(Internals::SvREFCNT($x), 1, "execution eval doesn't create new references"); } fresh_perl_is(<<'EOP', "ok\n", undef, 'RT #70862'); $::{'@'}=''; eval {}; print "ok\n"; EOP fresh_perl_is(<<'EOP', "ok\n", undef, 'variant of RT #70862'); eval { $::{'@'}=''; }; print "ok\n"; EOP fresh_perl_is(<<'EOP', "ok\n", undef, 'related to RT #70862'); $::{'@'}=\3; eval {}; print "ok\n"; EOP fresh_perl_is(<<'EOP', "ok\n", undef, 'related to RT #70862'); eval { $::{'@'}=\3; }; print "ok\n"; EOP perl-5.12.0-RC0/t/op/time.t0000555000175000017500000001454411333417500014141 0ustar jessejesse#!./perl -w BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } plan tests => 62; # These tests make sure, among other things, that we don't end up # burning tons of CPU for dates far in the future. # watchdog() makes sure that the test script eventually exits if # the tests are triggering the failing behavior watchdog(15); ($beguser,$begsys) = times; $beg = time; while (($now = time) == $beg) { sleep 1 } ok($now > $beg && $now - $beg < 10, 'very basic time test'); for ($i = 0; $i < 1_000_000; $i++) { for my $j (1..100) {}; # burn some user cycles ($nowuser, $nowsys) = times; $i = 2_000_000 if $nowuser > $beguser && ( $nowsys >= $begsys || (!$nowsys && !$begsys)); last if time - $beg > 20; } ok($i >= 2_000_000, 'very basic times test'); ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($beg); ($xsec,$foo) = localtime($now); $localyday = $yday; isnt($sec, $xsec, 'localtime() list context'); ok $mday, ' month day'; ok $year, ' year'; ok(localtime() =~ /^(Sun|Mon|Tue|Wed|Thu|Fri|Sat)[ ] (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)[ ] ([ \d]\d)\ (\d\d):(\d\d):(\d\d)\ (\d{4})$ /x, 'localtime(), scalar context' ); SKIP: { # This conditional of "No tzset()" is stolen from ext/POSIX/t/time.t skip "No tzset()", 1 if $^O eq "VMS" || $^O eq "cygwin" || $^O eq "djgpp" || $^O eq "MSWin32" || $^O eq "dos" || $^O eq "interix"; # check that localtime respects changes to $ENV{TZ} $ENV{TZ} = "GMT-5"; ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($beg); $ENV{TZ} = "GMT+5"; ($sec,$min,$hour2,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($beg); ok($hour != $hour2, 'changes to $ENV{TZ} respected'); } ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($beg); ($xsec,$foo) = localtime($now); isnt($sec, $xsec, 'gmtime() list conext'); ok $mday, ' month day'; ok $year, ' year'; my $day_diff = $localyday - $yday; ok( grep({ $day_diff == $_ } (0, 1, -1, 364, 365, -364, -365)), 'gmtime() and localtime() agree what day of year'); # This could be stricter. ok(gmtime() =~ /^(Sun|Mon|Tue|Wed|Thu|Fri|Sat)[ ] (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)[ ] ([ \d]\d)\ (\d\d):(\d\d):(\d\d)\ (\d{4})$ /x, 'gmtime(), scalar context' ); # Test gmtime over a range of times. { # The range should be limited only by the 53-bit mantissa of an IEEE double (or # whatever kind of double you've got). Here we just prove that we're comfortably # beyond the range possible with 32-bit time_t. my %tests = ( # time_t gmtime list scalar -2**35 => [52, 13, 20, 7, 2, -1019, 5, 65, 0, "Fri Mar 7 20:13:52 881"], -2**32 => [44, 31, 17, 24, 10, -67, 0, 327, 0, "Sun Nov 24 17:31:44 1833"], -2**31 => [52, 45, 20, 13, 11, 1, 5, 346, 0, "Fri Dec 13 20:45:52 1901"], -1 => [59, 59, 23, 31, 11, 69, 3, 364, 0, "Wed Dec 31 23:59:59 1969"], 0 => [0, 0, 0, 1, 0, 70, 4, 0, 0, "Thu Jan 1 00:00:00 1970"], 1 => [1, 0, 0, 1, 0, 70, 4, 0, 0, "Thu Jan 1 00:00:01 1970"], 2**30 => [4, 37, 13, 10, 0, 104, 6, 9, 0, "Sat Jan 10 13:37:04 2004"], 2**31 => [8, 14, 3, 19, 0, 138, 2, 18, 0, "Tue Jan 19 03:14:08 2038"], 2**32 => [16, 28, 6, 7, 1, 206, 0, 37, 0, "Sun Feb 7 06:28:16 2106"], 2**39 => [8, 18, 12, 25, 0, 17491, 2, 24, 0, "Tue Jan 25 12:18:08 19391"], ); for my $time (keys %tests) { my @expected = @{$tests{$time}}; my $scalar = pop @expected; ok eq_array([gmtime($time)], \@expected), "gmtime($time) list context"; is scalar gmtime($time), $scalar, " scalar"; } } # Test localtime { # We pick times which fall in the middle of a month, so the month and year should be # the same regardless of the time zone. my %tests = ( # time_t month, year, scalar -8589934592 => [9, -203, qr/Oct \d+ .* 1697$/], -1296000 => [11, 69, qr/Dec \d+ .* 1969$/], 1296000 => [0, 70, qr/Jan \d+ .* 1970$/], 5000000000 => [5, 228, qr/Jun \d+ .* 2128$/], 1163500000 => [10, 106, qr/Nov \d+ .* 2006$/], ); for my $time (keys %tests) { my @expected = @{$tests{$time}}; my $scalar = pop @expected; my @time = (localtime($time))[4,5]; ok( eq_array(\@time, \@expected), "localtime($time) list context" ) or diag("@time"); like scalar localtime($time), $scalar, " scalar"; } } # Test floating point args { eval { $SIG{__WARN__} = sub { die @_; }; is( (localtime(1296000.23))[5] + 1900, 1970 ); }; is($@, '', 'Ignore fractional time'); eval { $SIG{__WARN__} = sub { die @_; }; is( (gmtime(1.23))[5] + 1900, 1970 ); }; is($@, '', 'Ignore fractional time'); } # Some sanity tests for the far, far future and far, far past { my %time2year = ( -2**52 => -142711421, -2**48 => -8917617, -2**46 => -2227927, 2**46 => 2231866, 2**48 => 8921556, 2**52 => 142715360, ); for my $time (sort keys %time2year) { my $want = $time2year{$time}; my $have = (gmtime($time))[5] + 1900; is $have, $want, "year check, gmtime($time)"; $have = (localtime($time))[5] + 1900; is $have, $want, "year check, localtime($time)"; } } # Test that Perl warns properly when it can't handle a time. { my $warning; local $SIG{__WARN__} = sub { $warning .= join "\n", @_; }; my $big_time = 2**60; my $small_time = -2**60; $warning = ''; my $date = gmtime($big_time); like $warning, qr/^gmtime(.*) too large/; $warning = ''; $date = localtime($big_time); like $warning, qr/^localtime(.*) too large/; $warning = ''; $date = gmtime($small_time); like $warning, qr/^gmtime(.*) too small/; $warning = ''; $date = localtime($small_time); like $warning, qr/^localtime(.*) too small/; } perl-5.12.0-RC0/t/op/overload_integer.t0000555000175000017500000000130211325125742016524 0ustar jessejesse#!./perl use strict; use warnings; print "1..2\n"; package Foo; use overload; sub import { overload::constant 'integer' => sub { return shift; }; } package main; BEGIN { $INC{'Foo.pm'} = "/lib/Foo.pm" } use Foo; my $result = eval "5+6"; my $error = $@; my $label = "No exception was thrown with an overload::constant 'integer' inside an eval."; # TEST if ($error eq "") { print "ok 1 - $label\n" } else { print "not ok 1 - $label\n"; print "# Error is $error\n"; } $label = "Correct solution"; if (!defined($result)) { $result = ""; } # TEST if ($result eq 11) { print "ok 2 - $label\n"; } else { print "not ok 2 - $label\n"; print "# Result is $result\n"; } perl-5.12.0-RC0/t/op/setpgrpstack.t0000555000175000017500000000056711325125742015722 0ustar jessejesse#!./perl -w BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } use Config; plan tests => 2; SKIP: { skip "setpgrp() is not available", 2 unless $Config{d_setpgrp}; ok(!eval { package A;sub foo { die("got here") }; package main; A->foo(setpgrp())}); ok($@ =~ /got here/, "setpgrp() should extend the stack before modifying it"); } perl-5.12.0-RC0/t/op/groups.t0000555000175000017500000002617411342547046014535 0ustar jessejesse#!./perl BEGIN { if ( $^O eq 'VMS' ) { my $p = "/bin:/usr/bin:/usr/xpg4/bin:/usr/ucb"; if ( $ENV{PATH} ) { $p .= ":$ENV{PATH}"; } $ENV{PATH} = $p; } $ENV{LC_ALL} = "C"; # so that external utilities speak English $ENV{LANGUAGE} = 'C'; # GNU locale extension chdir 't'; @INC = '../lib'; } use 5.010; use strict; use Config (); use POSIX (); unless (eval { my($foo) = getgrgid(0); 1 }) { quit( "getgrgid() not implemented" ); } quit("No `id' or `groups'") if $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS' || $^O =~ /lynxos/i; Test(); exit; sub Test { # Get our supplementary groups from the system by running commands # like `id -a'. my ( $groups_command, $groups_string ) = system_groups() or quit( "No `id' or `groups'" ); my @extracted_groups = extract_system_groups( $groups_string ) or quit( "Can't parse `${groups_command}'" ); my $pwgid = $( + 0; my ($pwgnam) = getgrgid($pwgid); $pwgnam //= ''; print "# pwgid=$pwgid pwgnam=$pwgnam \$(=$(\n"; # Get perl's supplementary groups by looking at $( my ( $gid_count, $all_perl_groups ) = perl_groups(); my %basegroup = basegroups( $pwgid, $pwgnam ); my @extracted_supplementary_groups = remove_basegroup( \ %basegroup, \ @extracted_groups ); print "1..2\n"; # Test: The supplementary groups in $( should match the # getgroups(2) kernal API call. # my $ngroups_max = posix_ngroups_max(); if ( defined $ngroups_max && $ngroups_max < @extracted_groups ) { # Some OSes (like darwin)but conceivably others might return # more groups from `id -a' than can be handled by the # kernel. On darwin, NGROUPS_MAX is 16 and 12 are taken up for # the system already. # # There is more fall-out from this than just Perl's unit # tests. You may be a member of a group according to Active # Directory (or whatever) but the OS won't respect it because # it's the 17th (or higher) group and there's no space to # store your membership. print "ok 1 # SKIP Your platform's `$groups_command' is broken\n"; } elsif ( darwin() ) { # darwin uses getgrouplist(3) or an Open Directory API within # /usr/bin/id and /usr/bin/groups which while "nice" isn't # accurate for this test. The hard, real, list of groups we're # running in derives from getgroups(2) and is not dynamic but # the Libc API getgrouplist(3) is. # # In practical terms, this meant that while `id -a' can be # relied on in other OSes to purely use getgroups(2) and show # us what's real, darwin will use getgrouplist(3) to show us # what might be real if only we'd open a new console. # print "ok 1 # SKIP darwin's `${groups_command}' can't be trusted\n"; } else { # Read $( but ignore any groups in $( that we failed to parse # successfully out of the `id -a` mess. # my @perl_groups = remove_unparsed_entries( \ @extracted_groups, \ @$all_perl_groups ); my @supplementary_groups = remove_basegroup( \ %basegroup, \ @perl_groups ); my $ok1 = 0; if ( match_groups( \ @supplementary_groups, \ @extracted_supplementary_groups, $pwgid ) ) { print "ok 1\n"; $ok1 = 1; } elsif ( cygwin_nt() ) { %basegroup = unixy_cygwin_basegroups(); @extracted_supplementary_groups = remove_basegroup( \ %basegroup, \ @extracted_groups ); if ( match_groups( \ @supplementary_groups, \ @extracted_supplementary_groups, $pwgid ) ) { print "ok 1 # This Cygwin behaves like Unix (Win2k?)\n"; $ok1 = 1; } } unless ( $ok1 ) { } } # multiple 0's indicate GROUPSTYPE is currently long but should be short $gid_count->{0} //= 0; if ( 0 == $pwgid || $gid_count->{0} < 2 ) { print "ok 2\n"; } else { print "not ok 2 (groupstype should be type short, not long)\n"; } return; } # Cleanly abort this entire test file sub quit { print "1..0 # SKIP: @_\n"; exit 0; } # Get the system groups and the command used to fetch them. # sub system_groups { my ( $cmd, $groups_string ) = _system_groups(); if ( $groups_string ) { chomp $groups_string; diag_variable( groups => $groups_string ); } return ( $cmd, $groups_string ); } # We have to find a command that prints all (effective # and real) group names (not ids). The known commands are: # groups # id -Gn # id -a # Beware 1: some systems do just 'id -G' even when 'id -Gn' is used. # Beware 2: id -Gn or id -a format might be id(name) or name(id). # Beware 3: the groups= might be anywhere in the id output. # Beware 4: groups can have spaces ('id -a' being the only defense against this) # Beware 5: id -a might not contain the groups= part. # # That is, we might meet the following: # # foo bar zot # accept # foo 22 42 bar zot # accept # 1 22 42 2 3 # reject # groups=(42),foo(1),bar(2),zot me(3) # parsed by $GROUP_RX1 # groups=22,42,1(foo),2(bar),3(zot(me)) # parsed by $GROUP_RX2 # # and the groups= might be after, before, or between uid=... and gid=... use constant GROUP_RX1 => qr/ ^ (?.+) \( (?\d+) \) $ /x; use constant GROUP_RX2 => qr/ ^ (?\d+) \( (?.+) \) $ /x; sub _system_groups { my $cmd; my $str; # prefer 'id' over 'groups' (is this ever wrong anywhere?) # and 'id -a' over 'id -Gn' (the former is good about spaces in group names) $cmd = 'id -a 2>/dev/null'; $str = `$cmd`; if ( $str && $str =~ /groups=/ ) { # $str is of the form: # uid=39957(gsar) gid=22(users) groups=33536,39181,22(users),0(root),1067(dev) # FreeBSD since 6.2 has a fake id -a: # uid=1001(tobez) gid=20(staff) groups=20(staff), 0(wheel), 68(dialer) # # Linux may also have a context= field return ( $cmd, $str ); } $cmd = 'id -Gn 2>/dev/null'; $str = `$cmd`; if ( $str && $str !~ /^[\d\s]$/ ) { # $str could be of the form: # users 33536 39181 root dev return ( $cmd, $str ); } $cmd = 'groups 2>/dev/null'; $str = `$cmd`; if ( $str ) { # may not reflect all groups in some places, so do a sanity check if (-d '/afs') { print < join ',', @extracted ); } return @extracted; } # Get the POSIX value NGROUPS_MAX. sub posix_ngroups_max { return eval { POSIX::NGROUPS_MAX(); }; } # Test if this is Apple's darwin sub darwin { # Observed 'darwin-2level' return $Config::Config{myuname} =~ /^darwin/; } # Test if this is Cygwin sub cygwin_nt { return $Config::Config{myuname} =~ /^cygwin_nt/i; } # Get perl's supplementary groups and the number of times each gid # appeared. sub perl_groups { # Lookup perl's own groups from $( my @gids = split ' ', $(; my %gid_count; my @gr_name; for my $gid ( @gids ) { ++ $gid_count{$gid}; my ($group) = getgrgid $gid; # Why does this test prefer to not test groups which we don't have # a name for? One possible answer is that my primary group comes # from from my entry in the user database but isn't mentioned in # the group database. Are there more reasons? next if ! defined $group; push @gr_name, $group; } diag_variable( gr_name => join ',', @gr_name ); return ( \ %gid_count, \ @gr_name ); } # Remove entries from our parsing of $( that don't appear in our # parsing of `id -a`. sub remove_unparsed_entries { my ( $extracted_groups, $perl_groups ) = @_; my %was_extracted = map { $_ => 1 } @$extracted_groups; return grep { $was_extracted{$_} } @$perl_groups; } # Get a list of base groups. I'm not sure why cygwin by default is # skipped here. sub basegroups { my ( $pwgid, $pwgnam ) = @_; if ( cygwin_nt() ) { return; } else { return ( $pwgid => 1, $pwgnam => 1, ); } } # Cygwin might have another form of basegroup which we should actually use sub unixy_cygwin_basegroups { my ( $pwgid, $pwgnam ) = @_; return ( $pwgid => 1, $pwgnam => 1, ); } # Filter a full list of groups and return only the supplementary # gorups. sub remove_basegroup { my ( $basegroups, $groups ) = @_; return grep { ! $basegroups->{$_} } @$groups; } # Test supplementary groups to see if they're a close enough match or # if there aren't any supplementary groups then validate the current # group against $(. sub match_groups { my ( $supplementary_groups, $extracted_supplementary_groups, $pwgid ) = @_; # Compare perl vs system groups my %g; $g{$_}[0] = 1 for @$supplementary_groups; $g{$_}[1] = 1 for @$extracted_supplementary_groups; # Find any mismatches my @misses = grep { ! ( $g{$_}[0] && $g{$_}[1] ) } sort keys %g; return ! @misses || ( ! @$supplementary_groups && 1 == @$extracted_supplementary_groups && $pwgid == $extracted_supplementary_groups->[0] ); } # Print a nice little diagnostic. sub diag_variable { my ( $label, $content ) = @_; printf "# %-11s=%s\n", $label, $content; return; } # Removes duplicates from a list sub uniq { my %seen; return grep { ! $seen{$_}++ } @_; } # Local variables: # indent-tabs-mode: nil # End: # # ex: set ts=8 sts=4 sw=4 noet: perl-5.12.0-RC0/t/op/fork.t0000555000175000017500000002117611342547046014154 0ustar jessejesse#!./perl # tests for both real and emulated fork() BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require Config; import Config; unless ($Config{'d_fork'} or $Config{'d_pseudofork'}) { print "1..0 # Skip: no fork\n"; exit 0; } $ENV{PERL5LIB} = "../lib"; require './test.pl'; } if ($^O eq 'mpeix') { print "1..0 # Skip: fork/status problems on MPE/iX\n"; exit 0; } $|=1; undef $/; @prgs = split "\n########\n", ; print "1..", scalar @prgs, "\n"; $tmpfile = tempfile(); END { close TEST } $CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : (($^O eq 'NetWare') ? 'perl -e "print <>"' : 'cat')); for (@prgs){ my $switch; if (s/^\s*(-\w.*)//){ $switch = $1; } my($prog,$expected) = split(/\nEXPECT\n/, $_); $expected =~ s/\n+$//; # results can be in any order, so sort 'em my @expected = sort split /\n/, $expected; open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!"; print TEST $prog, "\n"; close TEST or die "Cannot close $tmpfile: $!"; my $results; if ($^O eq 'MSWin32') { $results = `.\\perl -I../lib $switch $tmpfile 2>&1`; } elsif ($^O eq 'NetWare') { $results = `perl -I../lib $switch $tmpfile 2>&1`; } else { $results = `./perl $switch $tmpfile 2>&1`; } $status = $?; $results =~ s/\n+$//; $results =~ s/at\s+$::tempfile_regexp\s+line/at - line/g; $results =~ s/of\s+$::tempfile_regexp\s+aborted/of - aborted/g; # bison says 'parse error' instead of 'syntax error', # various yaccs may or may not capitalize 'syntax'. $results =~ s/^(syntax|parse) error/syntax error/mig; $results =~ s/^\n*Process terminated by SIG\w+\n?//mg if $^O eq 'os2'; my @results = sort split /\n/, $results; if ( "@results" ne "@expected" ) { print STDERR "PROG: $switch\n$prog\n"; print STDERR "EXPECTED:\n$expected\n"; print STDERR "GOT:\n$results\n"; print "not "; } print "ok ", ++$i, "\n"; } __END__ $| = 1; if ($cid = fork) { sleep 1; if ($result = (kill 9, $cid)) { print "ok 2\n"; } else { print "not ok 2 $result\n"; } sleep 1 if $^O eq 'MSWin32'; # avoid WinNT race bug } else { print "ok 1\n"; sleep 10; } EXPECT ok 1 ok 2 ######## $| = 1; if ($cid = fork) { sleep 1; print "not " unless kill 'INT', $cid; print "ok 2\n"; } else { # XXX On Windows the default signal handler kills the # XXX whole process, not just the thread (pseudo-process) $SIG{INT} = sub { exit }; print "ok 1\n"; sleep 5; die; } EXPECT ok 1 ok 2 ######## $| = 1; sub forkit { print "iteration $i start\n"; my $x = fork; if (defined $x) { if ($x) { print "iteration $i parent\n"; } else { print "iteration $i child\n"; } } else { print "pid $$ failed to fork\n"; } } while ($i++ < 3) { do { forkit(); }; } EXPECT iteration 1 start iteration 1 parent iteration 1 child iteration 2 start iteration 2 parent iteration 2 child iteration 2 start iteration 2 parent iteration 2 child iteration 3 start iteration 3 parent iteration 3 child iteration 3 start iteration 3 parent iteration 3 child iteration 3 start iteration 3 parent iteration 3 child iteration 3 start iteration 3 parent iteration 3 child ######## $| = 1; fork() ? (print("parent\n"),sleep(1)) : (print("child\n"),exit) ; EXPECT parent child ######## $| = 1; fork() ? (print("parent\n"),exit) : (print("child\n"),sleep(1)) ; EXPECT parent child ######## $| = 1; @a = (1..3); for (@a) { if (fork) { print "parent $_\n"; $_ = "[$_]"; } else { print "child $_\n"; $_ = "-$_-"; } } print "@a\n"; EXPECT parent 1 child 1 parent 2 child 2 parent 2 child 2 parent 3 child 3 parent 3 child 3 parent 3 child 3 parent 3 child 3 [1] [2] [3] -1- [2] [3] [1] -2- [3] [1] [2] -3- -1- -2- [3] -1- [2] -3- [1] -2- -3- -1- -2- -3- ######## $| = 1; foreach my $c (1,2,3) { if (fork) { print "parent $c\n"; } else { print "child $c\n"; exit; } } while (wait() != -1) { print "waited\n" } EXPECT child 1 child 2 child 3 parent 1 parent 2 parent 3 waited waited waited ######## use Config; $| = 1; $\ = "\n"; fork() ? print($Config{osname} eq $^O) : print($Config{osname} eq $^O) ; EXPECT 1 1 ######## $| = 1; $\ = "\n"; fork() ? do { require Config; print($Config::Config{osname} eq $^O); } : do { require Config; print($Config::Config{osname} eq $^O); } EXPECT 1 1 ######## $| = 1; use Cwd; my $cwd = cwd(); # Make sure we load Win32.pm while "../lib" still works. $\ = "\n"; my $dir; if (fork) { $dir = "f$$.tst"; mkdir $dir, 0755; chdir $dir; print cwd() =~ /\Q$dir/i ? "ok 1 parent" : "not ok 1 parent"; chdir ".."; rmdir $dir; } else { sleep 2; $dir = "f$$.tst"; mkdir $dir, 0755; chdir $dir; print cwd() =~ /\Q$dir/i ? "ok 1 child" : "not ok 1 child"; chdir ".."; rmdir $dir; } EXPECT ok 1 parent ok 1 child ######## $| = 1; $\ = "\n"; my $getenv; if ($^O eq 'MSWin32' || $^O eq 'NetWare') { $getenv = qq[$^X -e "print \$ENV{TST}"]; } else { $getenv = qq[$^X -e 'print \$ENV{TST}']; } $ENV{TST} = 'foo'; if (fork) { sleep 1; print "parent before: " . `$getenv`; $ENV{TST} = 'bar'; print "parent after: " . `$getenv`; } else { print "child before: " . `$getenv`; $ENV{TST} = 'baz'; print "child after: " . `$getenv`; } EXPECT child before: foo child after: baz parent before: foo parent after: bar ######## $| = 1; $\ = "\n"; if ($pid = fork) { waitpid($pid,0); print "parent got $?" } else { exit(42); } EXPECT parent got 10752 ######## $| = 1; $\ = "\n"; my $echo = 'echo'; if ($pid = fork) { waitpid($pid,0); print "parent got $?" } else { exec("$echo foo"); } EXPECT foo parent got 0 ######## if (fork) { die "parent died"; } else { die "child died"; } EXPECT parent died at - line 2. child died at - line 5. ######## if ($pid = fork) { eval { die "parent died" }; print $@; } else { eval { die "child died" }; print $@; } EXPECT parent died at - line 2. child died at - line 6. ######## if (eval q{$pid = fork}) { eval q{ die "parent died" }; print $@; } else { eval q{ die "child died" }; print $@; } EXPECT parent died at (eval 2) line 1. child died at (eval 2) line 1. ######## BEGIN { $| = 1; fork and exit; print "inner\n"; } # XXX In emulated fork(), the child will not execute anything after # the BEGIN block, due to difficulties in recreating the parse stacks # and restarting yyparse() midstream in the child. This can potentially # be overcome by treating what's after the BEGIN{} as a brand new parse. #print "outer\n" EXPECT inner ######## sub pipe_to_fork ($$) { my $parent = shift; my $child = shift; pipe($child, $parent) or die; my $pid = fork(); die "fork() failed: $!" unless defined $pid; close($pid ? $child : $parent); $pid; } if (pipe_to_fork('PARENT','CHILD')) { # parent print PARENT "pipe_to_fork\n"; close PARENT; } else { # child while () { print; } close CHILD; exit; } sub pipe_from_fork ($$) { my $parent = shift; my $child = shift; pipe($parent, $child) or die; my $pid = fork(); die "fork() failed: $!" unless defined $pid; close($pid ? $child : $parent); $pid; } if (pipe_from_fork('PARENT','CHILD')) { # parent while () { print; } close PARENT; } else { # child print CHILD "pipe_from_fork\n"; close CHILD; exit; } EXPECT pipe_from_fork pipe_to_fork ######## $|=1; if ($pid = fork()) { print "forked first kid\n"; print "waitpid() returned ok\n" if waitpid($pid,0) == $pid; } else { print "first child\n"; exit(0); } if ($pid = fork()) { print "forked second kid\n"; print "wait() returned ok\n" if wait() == $pid; } else { print "second child\n"; exit(0); } EXPECT forked first kid first child waitpid() returned ok forked second kid second child wait() returned ok ######## pipe(RDR,WTR) or die $!; my $pid = fork; die "fork: $!" if !defined $pid; if ($pid == 0) { close RDR; print WTR "STRING_FROM_CHILD\n"; close WTR; } else { close WTR; chomp(my $string_from_child = ); close RDR; print $string_from_child eq "STRING_FROM_CHILD", "\n"; } EXPECT 1 ######## # [perl #39145] Perl_dounwind() crashing with Win32's fork() emulation sub { @_ = 3; fork ? die "1\n" : die "1\n" }->(2); EXPECT 1 1 ######## # [perl #72604] @DB::args stops working across Win32 fork $|=1; sub f { if ($pid = fork()) { print "waitpid() returned ok\n" if waitpid($pid,0) == $pid; } else { package DB; my @c = caller(0); print "child: called as [$c[3](", join(',',@DB::args), ")]\n"; exit(0); } } f("foo", "bar"); EXPECT child: called as [main::f(foo,bar)] waitpid() returned ok perl-5.12.0-RC0/t/op/die_exit.t0000555000175000017500000000416411336536210014775 0ustar jessejesse#!./perl # # Verify that C return the return code # -- Robin Barker # BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } if ($^O eq 'mpeix') { print "1..0 # Skip: broken on MPE/iX\n"; exit 0; } $| = 1; use strict; my %tests = ( 1 => [ 0, 0], 2 => [ 0, 1], 3 => [ 0, 127], 4 => [ 0, 128], 5 => [ 0, 255], 6 => [ 0, 256], 7 => [ 0, 512], 8 => [ 1, 0], 9 => [ 1, 1], 10 => [ 1, 256], 11 => [ 128, 0], 12 => [ 128, 1], 13 => [ 128, 256], 14 => [ 255, 0], 15 => [ 255, 1], 16 => [ 255, 256], # see if implicit close preserves $? 17 => [ 0, 512, '{ local *F; open F, q[TEST]; close F; $!=0 } die;'], ); my $max = keys %tests; my $vms_exit_mode = 0; if ($^O eq 'VMS') { if (eval 'require VMS::Feature') { $vms_exit_mode = !(VMS::Feature::current("posix_exit")); } else { my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; my $env_posix_ex = $ENV{'PERL_VMS_POSIX_EXIT'} || ''; my $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; my $posix_ex = $env_posix_ex =~ /^[ET1]/i; if (($unix_rpt || $posix_ex) ) { $vms_exit_mode = 0; } else { $vms_exit_mode = 1; } } } print "1..$max\n"; # Dump any error messages from the dying processes off to a temp file. open(STDERR, ">die_exit.err") or die "Can't open temp error file: $!"; foreach my $test (1 .. $max) { my($bang, $query, $code) = @{$tests{$test}}; $code ||= 'die;'; if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') { system(qq{$^X -e "\$! = $bang; \$? = $query; $code"}); } else { system(qq{$^X -e '\$! = $bang; \$? = $query; $code'}); } my $exit = $?; # The legacy VMS exit code 44 (SS$_ABORT) is returned if a program dies. # We only get the severity bits, which boils down to 4. See L. $bang = 4 if $vms_exit_mode; printf "# 0x%04x 0x%04x 0x%04x\n", $exit, $bang, $query; print "not " unless $exit == (($bang || ($query >> 8) || 255) << 8); print "ok $test\n"; } close STDERR; END { 1 while unlink 'die_exit.err' } perl-5.12.0-RC0/t/op/delete.t0000555000175000017500000000567411325125742014456 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = qw(. ../lib); } require "test.pl"; plan( tests => 38 ); # delete() on hash elements $foo{1} = 'a'; $foo{2} = 'b'; $foo{3} = 'c'; $foo{4} = 'd'; $foo{5} = 'e'; $foo = delete $foo{2}; cmp_ok($foo,'eq','b','delete 2'); ok(!(exists $foo{2}),'b absent'); cmp_ok($foo{1},'eq','a','a exists'); cmp_ok($foo{3},'eq','c','c exists'); cmp_ok($foo{4},'eq','d','d exists'); cmp_ok($foo{5},'eq','e','e exists'); @foo = delete @foo{4, 5}; cmp_ok(scalar(@foo),'==',2,'deleted slice'); cmp_ok($foo[0],'eq','d','slice 1'); cmp_ok($foo[1],'eq','e','slice 2'); ok(!(exists $foo{4}),'d absent'); ok(!(exists $foo{5}),'e absent'); cmp_ok($foo{1},'eq','a','a still exists'); cmp_ok($foo{3},'eq','c','c still exists'); $foo = join('',values(%foo)); ok($foo eq 'ac' || $foo eq 'ca','remaining keys'); foreach $key (keys %foo) { delete $foo{$key}; } $foo{'foo'} = 'x'; $foo{'bar'} = 'y'; $foo = join('',values(%foo)); ok($foo eq 'xy' || $foo eq 'yx','fresh keys'); $refhash{"top"}->{"foo"} = "FOO"; $refhash{"top"}->{"bar"} = "BAR"; delete $refhash{"top"}->{"bar"}; @list = keys %{$refhash{"top"}}; cmp_ok("@list",'eq',"foo", 'autoviv and delete hashref'); { my %a = ('bar', 33); my($a) = \(values %a); my $b = \$a{bar}; my $c = \delete $a{bar}; ok($a == $b && $b == $c,'a b c equivalent'); } # delete() on array elements @foo = (); $foo[1] = 'a'; $foo[2] = 'b'; $foo[3] = 'c'; $foo[4] = 'd'; $foo[5] = 'e'; $foo = delete $foo[2]; cmp_ok($foo,'eq','b','ary delete 2'); ok(!(exists $foo[2]),'ary b absent'); cmp_ok($foo[1],'eq','a','ary a exists'); cmp_ok($foo[3],'eq','c','ary c exists'); cmp_ok($foo[4],'eq','d','ary d exists'); cmp_ok($foo[5],'eq','e','ary e exists'); @bar = delete @foo[4,5]; cmp_ok(scalar(@bar),'==',2,'ary deleted slice'); cmp_ok($bar[0],'eq','d','ary slice 1'); cmp_ok($bar[1],'eq','e','ary slice 2'); ok(!(exists $foo[4]),'ary d absent'); ok(!(exists $foo[5]),'ary e absent'); cmp_ok($foo[1],'eq','a','ary a still exists'); cmp_ok($foo[3],'eq','c','ary c still exists'); $foo = join('',@foo); cmp_ok($foo,'eq','ac','ary elems'); cmp_ok(scalar(@foo),'==',4,'four is the number thou shalt count'); foreach $key (0 .. $#foo) { delete $foo[$key]; } cmp_ok(scalar(@foo),'==',0,'and then there were none'); $foo[0] = 'x'; $foo[1] = 'y'; $foo = "@foo"; cmp_ok($foo,'eq','x y','two fresh'); $refary[0]->[0] = "FOO"; $refary[0]->[3] = "BAR"; delete $refary[0]->[3]; cmp_ok( scalar(@{$refary[0]}),'==',1,'one down'); { my @a = 33; my($a) = \(@a); my $b = \$a[0]; my $c = \delete $a[bar]; ok($a == $b && $b == $c,'a b c also equivalent'); } { my %h; my ($x,$y) = (1, scalar delete @h{()}); ok(!defined($y),q([perl #29127] scalar delete of empty slice returned garbage)); } { my $x = 0; sub X::DESTROY { $x++ } { my @a; $a[0] = bless [], 'X'; my $y = delete $a[0]; } cmp_ok($x,'==',1,q([perl #30733] array delete didn't free returned element)); } perl-5.12.0-RC0/t/op/magic.t0000555000175000017500000003050611336552551014270 0ustar jessejesse#!./perl BEGIN { $| = 1; chdir 't' if -d 't'; @INC = '../lib'; $ENV{PATH} = '/bin' if ${^TAINT}; $SIG{__WARN__} = sub { die "Dying on warning: ", @_ }; require './test.pl'; } use warnings; use Config; plan (tests => 80); $Is_MSWin32 = $^O eq 'MSWin32'; $Is_NetWare = $^O eq 'NetWare'; $Is_VMS = $^O eq 'VMS'; $Is_Dos = $^O eq 'dos'; $Is_os2 = $^O eq 'os2'; $Is_Cygwin = $^O eq 'cygwin'; $Is_MPE = $^O eq 'mpeix'; $Is_miniperl = $ENV{PERL_CORE_MINITEST}; $Is_BeOS = $^O eq 'beos'; $PERL = $ENV{PERL} || ($Is_NetWare ? 'perl' : $Is_VMS ? $^X : $Is_MSWin32 ? '.\perl' : './perl'); END { # On VMS, environment variable changes are peristent after perl exits delete $ENV{'FOO'} if $Is_VMS; } eval '$ENV{"FOO"} = "hi there";'; # check that ENV is inited inside eval # cmd.exe will echo 'variable=value' but 4nt will echo just the value # -- Nikola Knezevic if ($Is_MSWin32) { like `set FOO`, qr/^(?:FOO=)?hi there$/; } elsif ($Is_VMS) { is `write sys\$output f\$trnlnm("FOO")`, "hi there\n"; } else { is `echo \$FOO`, "hi there\n"; } unlink 'ajslkdfpqjsjfk'; $! = 0; open(FOO,'ajslkdfpqjsjfk'); isnt($!, 0); close FOO; # just mention it, squelch used-only-once SKIP: { skip('SIGINT not safe on this platform', 5) if $Is_MSWin32 || $Is_NetWare || $Is_Dos || $Is_MPE; # the next tests are done in a subprocess because sh spits out a # newline onto stderr when a child process kills itself with SIGINT. # We use a pipe rather than system() because the VMS command buffer # would overflow with a command that long. open( CMDPIPE, "| $PERL"); print CMDPIPE <<'END'; $| = 1; # command buffering $SIG{"INT"} = "ok3"; kill "INT",$$; sleep 1; $SIG{"INT"} = "IGNORE"; kill "INT",$$; sleep 1; print "ok 4\n"; $SIG{"INT"} = "DEFAULT"; kill "INT",$$; sleep 1; print "not ok 4\n"; sub ok3 { if (($x = pop(@_)) eq "INT") { print "ok 3\n"; } else { print "not ok 3 ($x @_)\n"; } } END close CMDPIPE; open( CMDPIPE, "| $PERL"); print CMDPIPE <<'END'; { package X; sub DESTROY { kill "INT",$$; } } sub x { my $x=bless [], 'X'; return sub { $x }; } $| = 1; # command buffering $SIG{"INT"} = "ok5"; { local $SIG{"INT"}=x(); print ""; # Needed to expose failure in 5.8.0 (why?) } sleep 1; delete $SIG{"INT"}; kill "INT",$$; sleep 1; sub ok5 { print "ok 5\n"; } END close CMDPIPE; $? >>= 8 if $^O eq 'VMS'; # POSIX status hiding in 2nd byte my $todo = ($^O eq 'os2' ? ' # TODO: EMX v0.9d_fix4 bug: wrong nibble? ' : ''); print $? & 0xFF ? "ok 6$todo\n" : "not ok 6$todo\n"; open(CMDPIPE, "| $PERL"); print CMDPIPE <<'END'; sub PVBM () { 'foo' } index 'foo', PVBM; my $pvbm = PVBM; sub foo { exit 0 } $SIG{"INT"} = $pvbm; kill "INT", $$; sleep 1; END close CMDPIPE; $? >>= 8 if $^O eq 'VMS'; print $? ? "not ok 7\n" : "ok 7\n"; curr_test(curr_test() + 5); } # can we slice ENV? @val1 = @ENV{keys(%ENV)}; @val2 = values(%ENV); is join(':',@val1), join(':',@val2); cmp_ok @val1, '>', 1; # regex vars 'foobarbaz' =~ /b(a)r/; is $`, 'foo'; is $&, 'bar'; is $', 'baz'; is $+, 'a'; # $" @a = qw(foo bar baz); is "@a", "foo bar baz"; { local $" = ','; is "@a", "foo,bar,baz"; } # $; %h = (); $h{'foo', 'bar'} = 1; is((keys %h)[0], "foo\034bar"); { local $; = 'x'; %h = (); $h{'foo', 'bar'} = 1; is((keys %h)[0], 'fooxbar'); } # $?, $@, $$ system qq[$PERL "-I../lib" -e "use vmsish qw(hushed); exit(0)"]; is $?, 0; system qq[$PERL "-I../lib" -e "use vmsish qw(hushed); exit(1)"]; isnt $?, 0; eval { die "foo\n" }; is $@, "foo\n"; cmp_ok($$, '>', 0); eval { $$++ }; like ($@, qr/^Modification of a read-only value attempted/); # $^X and $0 { if ($^O eq 'qnx') { chomp($wd = `/usr/bin/fullpath -t`); } elsif($Is_Cygwin || $Config{'d_procselfexe'}) { # Cygwin turns the symlink into the real file chomp($wd = `pwd`); $wd =~ s#/t$##; $wd =~ /(.*)/; $wd = $1; # untaint if ($Is_Cygwin) { $wd = Cygwin::win_to_posix_path(Cygwin::posix_to_win_path($wd, 1)); } } elsif($Is_os2) { $wd = Cwd::sys_cwd(); } else { $wd = '.'; } my $perl = $Is_VMS ? $^X : "$wd/perl"; my $headmaybe = ''; my $middlemaybe = ''; my $tailmaybe = ''; $script = "$wd/show-shebang"; if ($Is_MSWin32) { chomp($wd = `cd`); $wd =~ s|\\|/|g; $perl = "$wd/perl.exe"; $script = "$wd/show-shebang.bat"; $headmaybe = <$script") or diag "Can't write to $script: $!"; ok print(SCRIPT $headmaybe . <=', 5.00319; ok $^O; cmp_ok $^T, '>', 850000000; # Test change 25062 is working my $orig_osname = $^O; { local $^I = '.bak'; is $^O, $orig_osname, 'Assigning $^I does not clobber $^O'; } $^O = $orig_osname; SKIP: { skip("%ENV manipulations fail or aren't safe on $^O", 4) if $Is_VMS || $Is_Dos; SKIP: { skip("clearing \%ENV is not safe when running under valgrind") if $ENV{PERL_VALGRIND}; $PATH = $ENV{PATH}; $PDL = $ENV{PERL_DESTRUCT_LEVEL} || 0; $ENV{foo} = "bar"; %ENV = (); $ENV{PATH} = $PATH; $ENV{PERL_DESTRUCT_LEVEL} = $PDL || 0; if ($Is_MSWin32) { is `set foo 2>NUL`, ""; } else { is `echo \$foo`, "\n"; } } $ENV{__NoNeSuCh} = "foo"; $0 = "bar"; # cmd.exe will echo 'variable=value' but 4nt will echo just the value # -- Nikola Knezevic if ($Is_MSWin32) { like `set __NoNeSuCh`, qr/^(?:__NoNeSuCh=)?foo$/; } else { is `echo \$__NoNeSuCh`, "foo\n"; } SKIP: { skip("\$0 check only on Linux and FreeBSD", 2) unless $^O =~ /^(linux|freebsd)$/ && open CMDLINE, "/proc/$$/cmdline"; chomp(my $line = scalar ); my $me = (split /\0/, $line)[0]; is $me, $0, 'altering $0 is effective (testing with /proc/)'; close CMDLINE; # perlbug #22811 my $mydollarzero = sub { my($arg) = shift; $0 = $arg if defined $arg; # In FreeBSD the ps -o command= will cause # an empty header line, grab only the last line. my $ps = (`ps -o command= -p $$`)[-1]; return if $?; chomp $ps; printf "# 0[%s]ps[%s]\n", $0, $ps; $ps; }; my $ps = $mydollarzero->("x"); ok(!$ps # we allow that something goes wrong with the ps command # In Linux 2.4 we would get an exact match ($ps eq 'x') but # in Linux 2.2 there seems to be something funny going on: # it seems as if the original length of the argv[] would # be stored in the proc struct and then used by ps(1), # no matter what characters we use to pad the argv[]. # (And if we use \0:s, they are shown as spaces.) Sigh. || $ps =~ /^x\s*$/ # FreeBSD cannot get rid of both the leading "perl :" # and the trailing " (perl)": some FreeBSD versions # can get rid of the first one. || ($^O eq 'freebsd' && $ps =~ m/^(?:perl: )?x(?: \(perl\))?$/), 'altering $0 is effective (testing with `ps`)'); } } { my $ok = 1; my $warn = ''; local $SIG{'__WARN__'} = sub { $ok = 0; $warn = join '', @_; $warn =~ s/\n$//; }; $! = undef; local $TODO = $Is_VMS ? "'\$!=undef' does throw a warning" : ''; ok($ok, $warn); } # test case-insignificance of %ENV (these tests must be enabled only # when perl is compiled with -DENV_IS_CASELESS) SKIP: { skip('no caseless %ENV support', 4) unless $Is_MSWin32 || $Is_NetWare; %ENV = (); $ENV{'Foo'} = 'bar'; $ENV{'fOo'} = 'baz'; is scalar(keys(%ENV)), 1; ok exists $ENV{'FOo'}; is delete $ENV{'foO'}, 'baz'; is scalar(keys(%ENV)), 0; } SKIP: { skip ("miniperl can't rely on loading %Errno", 2) if $Is_miniperl; no warnings 'void'; # Make sure Errno hasn't been prematurely autoloaded ok !keys %Errno::; # Test auto-loading of Errno when %! is used ok scalar eval q{ %!; scalar %Errno::; }, $@; } SKIP: { skip ("miniperl can't rely on loading %Errno") if $Is_miniperl; # Make sure that Errno loading doesn't clobber $! undef %Errno::; delete $INC{"Errno.pm"}; open(FOO, "nonesuch"); # Generate ENOENT my %errs = %{"!"}; # Cause Errno.pm to be loaded at run-time ok ${"!"}{ENOENT}; } is $^S, 0; eval { is $^S,1 }; eval " BEGIN { ok ! defined \$^S } "; is $^S, 0; my $taint = ${^TAINT}; is ${^TAINT}, $taint; eval { ${^TAINT} = 1 }; is ${^TAINT}, $taint; # 5.6.1 had a bug: @+ and @- were not properly interpolated # into double-quoted strings # 20020414 mjd-perl-patch+@plover.com "I like pie" =~ /(I) (like) (pie)/; is "@-", "0 0 2 7"; is "@+", "10 1 6 10"; # Tests for the magic get of $\ { my $ok = 0; # [perl #19330] { local $\ = undef; $\++; $\++; $ok = $\ eq 2; } ok $ok; $ok = 0; { local $\ = "a\0b"; $ok = "a$\b" eq "aa\0bb"; } ok $ok; } # Test for bug [perl #27839] { my $x; sub f { "abc" =~ /(.)./; $x = "@+"; return @+; }; my @y = f(); is $x, "@y", "return a magic array ($x) vs (@y)"; } # Test for bug [perl #36434] # Can not do this test on VMS, EPOC, and SYMBIAN according to comments # in mg.c/Perl_magic_clear_all_env() SKIP: { skip('Can\'t make assignment to \%ENV on this system', 3) if $Is_VMS; local @ISA; local %ENV; # This used to be __PACKAGE__, but that causes recursive # inheritance, which is detected earlier now and broke # this test eval { push @ISA, __FILE__ }; is $@, '', 'Push a constant on a magic array'; $@ and print "# $@"; eval { %ENV = (PATH => __PACKAGE__) }; is $@, '', 'Assign a constant to a magic hash'; $@ and print "# $@"; eval { my %h = qw(A B); %ENV = (PATH => (keys %h)[0]) }; is $@, '', 'Assign a shared key to a magic hash'; $@ and print "# $@"; } # Tests for Perl_magic_clearsig foreach my $sig (qw(__WARN__ INT)) { $SIG{$sig} = lc $sig; is $SIG{$sig}, 'main::' . lc $sig, "Can assign to $sig"; is delete $SIG{$sig}, 'main::' . lc $sig, "Can delete from $sig"; is $SIG{$sig}, undef, "$sig is now gone"; is delete $SIG{$sig}, undef, "$sig remains gone"; } # And now one which doesn't exist; { no warnings 'signal'; $SIG{HUNGRY} = 'mmm, pie'; } is $SIG{HUNGRY}, 'mmm, pie', 'Can assign to HUNGRY'; is delete $SIG{HUNGRY}, 'mmm, pie', 'Can delete from HUNGRY'; is $SIG{HUNGRY}, undef, "HUNGRY is now gone"; is delete $SIG{HUNGRY}, undef, "HUNGRY remains gone"; # Test deleting signals that we never set foreach my $sig (qw(__DIE__ _BOGUS_HOOK KILL THIRSTY)) { is $SIG{$sig}, undef, "$sig is not present"; is delete $SIG{$sig}, undef, "delete of $sig returns undef"; } { $! = 9999; is int $!, 9999, q{[perl #72850] Core dump in bleadperl from perl -e '$! = 9999; $a = $!;'}; } perl-5.12.0-RC0/t/op/flip.t0000555000175000017500000000154411325127001014124 0ustar jessejesse#!./perl BEGIN { require "test.pl"; } plan(11); @a = (1,2,3,4,5,6,7,8,9,10,11,12); @b = (); while ($_ = shift(@a)) { if ($x = /4/../8/) { $z = $x; push @b, $x + 0; } $y .= /1/../2/; } is(join("*", @b), "1*2*3*4*5"); is($z, '5E0'); is($y, '12E0123E0'); @a = ('a','b','c','d','e','f','g'); { local $.; open(of,'harness') or die "Can't open harness: $!"; while () { (3 .. 5) && ($foo .= $_); } $x = ($foo =~ y/\n/\n/); is($x, 3); $x = 3.14; ok(($x...$x) eq "1"); { # coredump reported in bug 20001018.008 readline(UNKNOWN); $. = 1; $x = 1..10; ok(1); } } ok(!defined $.); use warnings; my $warn=''; $SIG{__WARN__} = sub { $warn .= join '', @_ }; ok(scalar(0..2)); like($warn, qr/uninitialized/); $warn = ''; $x = "foo".."bar"; ok((() = ($warn =~ /isn't numeric/g)) == 2); $warn = ''; $. = 15; ok(scalar(15..0)); perl-5.12.0-RC0/t/op/alarm.t0000555000175000017500000000250311325127001014262 0ustar jessejesse#!./perl BEGIN { chdir 't'; @INC = '../lib'; require './test.pl'; } BEGIN { use Config; if( !$Config{d_alarm} ) { skip_all("alarm() not implemented on this platform"); } } plan tests => 5; my $Perl = which_perl(); my $start_time = time; eval { local $SIG{ALRM} = sub { die "ALARM!\n" }; alarm 3; # perlfunc recommends against using sleep in combination with alarm. 1 while (time - $start_time < 6); }; alarm 0; my $diff = time - $start_time; # alarm time might be one second less than you said. is( $@, "ALARM!\n", 'alarm w/$SIG{ALRM} vs inf loop' ); ok( abs($diff - 3) <= 1, " right time" ); my $start_time = time; eval { local $SIG{ALRM} = sub { die "ALARM!\n" }; alarm 3; system(qq{$Perl -e "sleep 6"}); }; alarm 0; $diff = time - $start_time; # alarm time might be one second less than you said. is( $@, "ALARM!\n", 'alarm w/$SIG{ALRM} vs system()' ); { local $TODO = "Why does system() block alarm() on $^O?" if $^O eq 'VMS' || $^O eq 'dos'; ok( abs($diff - 3) <= 1, " right time (waited $diff secs for 3-sec alarm)" ); } { local $SIG{"ALRM"} = sub { die }; eval { alarm(1); my $x = qx($Perl -e "sleep 3") }; chomp (my $foo = "foo\n"); ok($foo eq "foo", '[perl #33928] chomp() fails after alarm(), `sleep`'); } perl-5.12.0-RC0/t/op/srand.t0000555000175000017500000000240511143650501014302 0ustar jessejesse#!./perl -w BEGIN { chdir "t" if -d "t"; @INC = qw(. ../lib); } # Test srand. use strict; require "test.pl"; plan(tests => 4); # Generate a load of random numbers. # int() avoids possible floating point error. sub mk_rand { map int rand 10000, 1..100; } # Check that rand() is deterministic. srand(1138); my @first_run = mk_rand; srand(1138); my @second_run = mk_rand; ok( eq_array(\@first_run, \@second_run), 'srand(), same arg, same rands' ); # Check that different seeds provide different random numbers srand(31337); @first_run = mk_rand; srand(1138); @second_run = mk_rand; ok( !eq_array(\@first_run, \@second_run), 'srand(), different arg, different rands' ); # Check that srand() isn't affected by $_ { local $_ = 42; srand(); @first_run = mk_rand; srand(42); @second_run = mk_rand; ok( !eq_array(\@first_run, \@second_run), 'srand(), no arg, not affected by $_'); } # This test checks whether Perl called srand for you. @first_run = `$^X -le "print int rand 100 for 1..100"`; sleep(1); # in case our srand() is too time-dependent @second_run = `$^X -le "print int rand 100 for 1..100"`; ok( !eq_array(\@first_run, \@second_run), 'srand() called automatically'); perl-5.12.0-RC0/t/op/cproto.t0000555000175000017500000000655711325127001014511 0ustar jessejesse#!./perl # Tests to ensure that we don't unexpectedly change prototypes of builtins BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } BEGIN { require './test.pl'; } plan tests => 237; while () { chomp; (my $keyword, my $proto, local $TODO) = split " ", $_, 3; if ($proto eq 'undef') { ok( !defined prototype "CORE::".$keyword, $keyword ); } elsif ($proto eq 'unknown') { eval { prototype "CORE::".$keyword }; like( $@, qr/Can't find an opnumber for/, $keyword ); } else { is( "(".prototype("CORE::".$keyword).")", $proto, $keyword ); } } # the keyword list : __DATA__ abs (_) accept (**) alarm (_) and () atan2 ($$) bind (*$) binmode (*;$) bless ($;$) caller (;$) chdir (;$) chmod (@) chomp undef chop undef chown (@) chr (_) chroot (_) close (;*) closedir (*) cmp unknown connect (*$) continue () cos (_) crypt ($$) dbmclose (\%) dbmopen (\%$$) defined undef delete undef die (@) do undef dump () each (\[@%]) else undef elsif undef endgrent () endhostent () endnetent () endprotoent () endpwent () endservent () eof (;*) eq ($$) eval undef exec undef exists undef exit (;$) exp (_) fcntl (*$$) fileno (*) flock (*$) for undef foreach undef fork () format undef formline ($@) ge ($$) getc (;*) getgrent () getgrgid ($) getgrnam ($) gethostbyaddr ($$) gethostbyname ($) gethostent () getlogin () getnetbyaddr ($$) getnetbyname ($) getnetent () getpeername (*) getpgrp (;$) getppid () getpriority ($$) getprotobyname ($) getprotobynumber ($) getprotoent () getpwent () getpwnam ($) getpwuid ($) getservbyname ($$) getservbyport ($$) getservent () getsockname (*) getsockopt (*$$) given undef glob undef gmtime (;$) goto undef grep undef gt ($$) hex (_) if undef index ($$;$) int (_) ioctl (*$$) join ($@) keys (\[@%]) kill (@) last undef lc (_) lcfirst (_) le ($$) length (_) link ($$) listen (*$) local undef localtime (;$) lock (\$) log (_) lstat (*) lt ($$) m undef map undef mkdir (_;$) msgctl ($$$) msgget ($$) msgrcv ($$$$$) msgsnd ($$$) my undef ne ($$) next undef no undef not ($) oct (_) open (*;$@) opendir (*$) or () ord (_) our undef pack ($@) package undef pipe (**) pop (;\@) pos undef print undef printf undef prototype undef push (\@@) q undef qq undef qr undef quotemeta (_) qw undef qx undef rand (;$) read (*\$$;$) readdir (*) readline (;*) readlink (_) readpipe (_) recv (*\$$$) redo undef ref (_) rename ($$) require undef reset (;$) return undef reverse (@) rewinddir (*) rindex ($$;$) rmdir (_) s undef say undef scalar undef seek (*$$) seekdir (*$) select (;*) semctl ($$$$) semget ($$$) semop ($$) send (*$$;$) setgrent () sethostent ($) setnetent ($) setpgrp (;$$) setpriority ($$$) setprotoent ($) setpwent () setservent ($) setsockopt (*$$$) shift (;\@) shmctl ($$$) shmget ($$$) shmread ($$$$) shmwrite ($$$$) shutdown (*$) sin (_) sleep (;$) socket (*$$$) socketpair (**$$$) sort undef splice (\@;$$@) split undef sprintf ($@) sqrt (_) srand (;$) stat (*) state undef study undef sub undef substr ($$;$$) symlink ($$) syscall ($@) sysopen (*$$;$) sysread (*\$$;$) sysseek (*$$) system undef syswrite (*$;$$) tell (;*) telldir (*) tie undef tied undef time () times () tr undef truncate ($$) uc (_) ucfirst (_) umask (;$) undef undef unless undef unlink (@) unpack ($;$) unshift (\@@) untie undef until undef use undef utime (@) values (\[@%]) vec ($$$) wait () waitpid ($$) wantarray () warn (@) when undef while undef write (;*) x unknown xor ($$) y undef perl-5.12.0-RC0/t/op/reverse.t0000555000175000017500000000264111325127001014644 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } plan tests => 21; is(reverse("abc"), "cba"); $_ = "foobar"; is(reverse(), "raboof"); { my @a = ("foo", "bar"); my @b = reverse @a; is($b[0], $a[1]); is($b[1], $a[0]); } { my @a = (1, 2, 3, 4); @a = reverse @a; is("@a", "4 3 2 1"); delete $a[1]; @a = reverse @a; ok(!exists $a[2]); is($a[0] . $a[1] . $a[3], '124'); @a = (5, 6, 7, 8, 9); @a = reverse @a; is("@a", "9 8 7 6 5"); delete $a[3]; @a = reverse @a; ok(!exists $a[1]); is($a[0] . $a[2] . $a[3] . $a[4], '5789'); delete $a[2]; @a = reverse @a; ok(!exists $a[2] && !exists $a[3]); is($a[0] . $a[1] . $a[4], '985'); } use Tie::Array; { tie my @a, 'Tie::StdArray'; @a = (1, 2, 3, 4); @a = reverse @a; is("@a", "4 3 2 1"); delete $a[1]; @a = reverse @a; ok(!exists $a[2]); is($a[0] . $a[1] . $a[3], '124'); @a = (5, 6, 7, 8, 9); @a = reverse @a; is("@a", "9 8 7 6 5"); delete $a[3]; @a = reverse @a; ok(!exists $a[1]); is($a[0] . $a[2] . $a[3] . $a[4], '5789'); delete $a[2]; @a = reverse @a; ok(!exists $a[2] && !exists $a[3]); is($a[0] . $a[1] . $a[4], '985'); } { # Unicode. my $a = "\x{263A}\x{263A}x\x{263A}y\x{263A}"; my $b = scalar reverse($a); my $c = scalar reverse($b); is($a, $c); } perl-5.12.0-RC0/t/op/utf8cache.t0000555000175000017500000000150511325127002015042 0ustar jessejesse#!./perl # Test for malfunctions of utf8 cache BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } unless (eval { require Devel::Peek }) { print "# Without Devel::Peek, never mind\n"; print "1..0\n"; exit; } print "1..1\n"; my $pid = open CHILD, '-|'; die "kablam: $!\n" unless defined $pid; unless ($pid) { open STDERR, ">&STDOUT"; $a = "hello \x{1234}"; for (1..2) { bar(substr($a, $_, 1)); } sub bar { $_[0] = "\x{4321}"; Devel::Peek::Dump($_[0]); } exit; } { local $/; $_ = } my $utf8magic = qr{ ^ \s+ MAGIC \s = .* \n \s+ MG_VIRTUAL \s = .* \n \s+ MG_TYPE \s = \s PERL_MAGIC_utf8 .* \n \s+ MG_LEN \s = .* \n }xm; if (m{ $utf8magic $utf8magic }x) { print "not "; } print "ok 1\n"; perl-5.12.0-RC0/t/op/filetest.t0000555000175000017500000001154511325127001015013 0ustar jessejesse#!./perl # There are few filetest operators that are portable enough to test. # See pod/perlport.pod for details. BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } use Config; plan(tests => 28 + 27*14); ok( -d 'op' ); ok( -f 'TEST' ); ok( !-f 'op' ); ok( !-d 'TEST' ); ok( -r 'TEST' ); # Make a read only file my $ro_file = tempfile(); { open my $fh, '>', $ro_file or die "open $fh: $!"; close $fh or die "close $fh: $!"; } chmod 0555, $ro_file or die "chmod 0555, '$ro_file' failed: $!"; $oldeuid = $>; # root can read and write anything eval '$> = 1'; # so switch uid (may not be implemented) print "# oldeuid = $oldeuid, euid = $>\n"; SKIP: { if (!$Config{d_seteuid}) { skip('no seteuid'); } else { ok( !-w $ro_file ); } } # Scripts are not -x everywhere so cannot test that. eval '$> = $oldeuid'; # switch uid back (may not be implemented) # this would fail for the euid 1 # (unless we have unpacked the source code as uid 1...) ok( -r 'op' ); # this would fail for the euid 1 # (unless we have unpacked the source code as uid 1...) SKIP: { if ($Config{d_seteuid}) { ok( -w 'op' ); } else { skip('no seteuid'); } } ok( -x 'op' ); # Hohum. Are directories -x everywhere? is( "@{[grep -r, qw(foo io noo op zoo)]}", "io op" ); # Test stackability of filetest operators ok( defined( -f -d 'TEST' ) && ! -f -d _ ); ok( !defined( -e 'zoo' ) ); ok( !defined( -e -d 'zoo' ) ); ok( !defined( -f -e 'zoo' ) ); ok( -f -e 'TEST' ); ok( -e -f 'TEST' ); ok( defined(-d -e 'TEST') ); ok( defined(-e -d 'TEST') ); ok( ! -f -d 'op' ); ok( -x -d -x 'op' ); ok( (-s -f 'TEST' > 1), "-s returns real size" ); ok( -f -s 'TEST' == 1 ); # now with an empty file my $tempfile = tempfile(); open my $fh, ">", $tempfile; close $fh; ok( -f $tempfile ); is( -s $tempfile, 0 ); is( -f -s $tempfile, 0 ); is( -s -f $tempfile, 0 ); unlink $tempfile; # test that _ is a bareword after filetest operators -f 'TEST'; ok( -f _ ); sub _ { "this is not a file name" } ok( -f _ ); my $over; { package OverFtest; use overload fallback => 1, -X => sub { $over = [qq($_[0]), $_[1]]; "-$_[1]"; }; } { package OverString; # No fallback. -X should fall back to string overload even without # it. use overload q/""/ => sub { $over = 1; "TEST" }; } { package OverBoth; use overload q/""/ => sub { "TEST" }, -X => sub { "-$_[1]" }; } { package OverNeither; # Need fallback. Previous versions of perl required 'fallback' to do # -X operations on an object with no "" overload. use overload '+' => sub { 1 }, fallback => 1; } my $ft = bless [], "OverFtest"; my $ftstr = qq($ft); my $str = bless [], "OverString"; my $both = bless [], "OverBoth"; my $neither = bless [], "OverNeither"; my $nstr = qq($neither); open my $gv, "<", "TEST"; bless $gv, "OverString"; open my $io, "<", "TEST"; $io = *{$io}{IO}; bless $io, "OverString"; my $fcntl_not_available; eval { require Fcntl } or $fcntl_not_available = 1; for my $op (split //, "rwxoRWXOezsfdlpSbctugkTMBAC") { $over = []; ok( my $rv = eval "-$op \$ft", "overloaded -$op succeeds" ) or diag( $@ ); is( $over->[0], $ftstr, "correct object for overloaded -$op" ); is( $over->[1], $op, "correct op for overloaded -$op" ); is( $rv, "-$op", "correct return value for overloaded -$op"); my ($exp, $is) = (1, "is"); if ( !$fcntl_not_available and ( $op eq "u" and not eval { Fcntl::S_ISUID() } or $op eq "g" and not eval { Fcntl::S_ISGID() } or $op eq "k" and not eval { Fcntl::S_ISVTX() } ) ) { ($exp, $is) = (0, "not"); } $over = 0; $rv = eval "-$op \$str"; ok( !$@, "-$op succeeds with string overloading" ) or diag( $@ ); is( $rv, eval "-$op 'TEST'", "correct -$op on string overload" ); is( $over, $exp, "string overload $is called for -$op" ); ($exp, $is) = $op eq "l" ? (1, "is") : (0, "not"); $over = 0; eval "-$op \$gv"; is( $over, $exp, "string overload $is called for -$op on GLOB" ); # IO refs always get string overload called. This might be a bug. $op eq "t" || $op eq "T" || $op eq "B" and ($exp, $is) = (1, "is"); $over = 0; eval "-$op \$io"; is( $over, $exp, "string overload $is called for -$op on IO"); $rv = eval "-$op \$both"; is( $rv, "-$op", "correct -$op on string/-X overload" ); $rv = eval "-$op \$neither"; ok( !$@, "-$op succeeds with random overloading" ) or diag( $@ ); is( $rv, eval "-$op \$nstr", "correct -$op with random overloading" ); is( eval "-r -$op \$ft", "-r", "stacked overloaded -$op" ); is( eval "-$op -r \$ft", "-$op", "overloaded stacked -$op" ); } perl-5.12.0-RC0/t/op/numconvert.t0000555000175000017500000002003211325125742015375 0ustar jessejesse#!./perl # # test the conversion operators # # Notations: # # "N p i N vs N N": Apply op-N, then op-p, then op-i, then reporter-N # Compare with application of op-N, then reporter-N # Right below are descriptions of different ops and reporters. # We do not use these subroutines any more, sub overhead makes a "switch" # solution better: # obviously, 0, 1 and 2, 3 are destructive. (XXXX 64-bit? 4 destructive too) # *0 = sub {--$_[0]}; # - # *1 = sub {++$_[0]}; # + # # Converters # *2 = sub { $_[0] = $max_uv & $_[0]}; # U # *3 = sub { use integer; $_[0] += $zero}; # I # *4 = sub { $_[0] += $zero}; # N # *5 = sub { $_[0] = "$_[0]" }; # P # # Side effects # *6 = sub { $max_uv & $_[0]}; # u # *7 = sub { use integer; $_[0] + $zero}; # i # *8 = sub { $_[0] + $zero}; # n # *9 = sub { $_[0] . "" }; # p # # Reporters # sub a2 { sprintf "%u", $_[0] } # U # sub a3 { sprintf "%d", $_[0] } # I # sub a4 { sprintf "%g", $_[0] } # N # sub a5 { "$_[0]" } # P BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } use strict 'vars'; my $max_chain = $ENV{PERL_TEST_NUMCONVERTS} || 2; # Bulk out if unsigned type is hopelessly wrong: my $max_uv1 = ~0; my $max_uv2 = sprintf "%u", $max_uv1 ** 6; # 6 is an arbitrary number here my $big_iv = do {use integer; $max_uv1 * 16}; # 16 is an arbitrary number here my $max_uv_less3 = $max_uv1 - 3; print "# max_uv1 = $max_uv1, max_uv2 = $max_uv2, big_iv = $big_iv\n"; print "# max_uv_less3 = $max_uv_less3\n"; if ($max_uv1 ne $max_uv2 or $big_iv > $max_uv1 or $max_uv1 == $max_uv_less3) { print "1..0 # skipped: unsigned perl arithmetic is not sane"; eval { require Config; import Config }; use vars qw(%Config); if ($Config{d_quad} eq 'define') { print " (common in 64-bit platforms)"; } print "\n"; exit 0; } if ($max_uv_less3 =~ tr/0-9//c) { print "1..0 # skipped: this perl stringifies large unsigned integers using E notation\n"; exit 0; } my $st_t = 4*4; # We try 4 initializers and 4 reporters my $num = 0; $num += 10**$_ - 4**$_ for 1.. $max_chain; $num *= $st_t; print "1..$num\n"; # In fact 15 times more subsubtests... my $max_uv = ~0; my $max_iv = int($max_uv/2); my $zero = 0; my $l_uv = length $max_uv; my $l_iv = length $max_iv; # Hope: the first digits are good my $larger_than_uv = substr 97 x 100, 0, $l_uv; my $smaller_than_iv = substr 12 x 100, 0, $l_iv; my $yet_smaller_than_iv = substr 97 x 100, 0, ($l_iv - 1); my @list = (1, $yet_smaller_than_iv, $smaller_than_iv, $max_iv, $max_iv + 1, $max_uv, $max_uv + 1); unshift @list, (reverse map -$_, @list), 0; # 15 elts @list = map "$_", @list; # Normalize print "# @list\n"; # need to special case ++ for max_uv, as ++ "magic" on a string gives # another string, whereas ++ magic on a string used as a number gives # a number. Not a problem when NV preserves UV, but if it doesn't then # stringification of the latter gives something in e notation. my $max_uv_pp = "$max_uv"; $max_uv_pp++; my $max_uv_p1 = "$max_uv"; $max_uv_p1+=0; $max_uv_p1++; # Also need to cope with %g notation for max_uv_p1 that actually gives an # integer less than max_uv because of correct rounding for the limited # precisision. This bites for 12 byte long doubles and 8 byte UVs my $temp = $max_uv_p1; my $max_uv_p1_as_iv; {use integer; $max_uv_p1_as_iv = 0 + sprintf "%s", $temp} my $max_uv_p1_as_uv = 0 | sprintf "%s", $temp; my @opnames = split //, "-+UINPuinp"; # @list = map { 2->($_), 3->($_), 4->($_), 5->($_), } @list; # Prepare input #print "@list\n"; #print "'@ops'\n"; my $test = 1; my $nok; for my $num_chain (1..$max_chain) { my @ops = map [split //], grep /[4-9]/, map { sprintf "%0${num_chain}d", $_ } 0 .. 10**$num_chain - 1; #@ops = ([]) unless $num_chain; #@ops = ([6, 4]); # print "'@ops'\n"; for my $op (@ops) { for my $first (2..5) { for my $last (2..5) { $nok = 0; my @otherops = grep $_ <= 3, @$op; my @curops = ($op,\@otherops); for my $num (@list) { my $inpt; my @ans; for my $short (0, 1) { # undef $inpt; # Forget all we had - some bugs were masked $inpt = $num; # Try to not contaminate $num... $inpt = "$inpt"; if ($first == 2) { $inpt = $max_uv & $inpt; # U 2 } elsif ($first == 3) { use integer; $inpt += $zero; # I 3 } elsif ($first == 4) { $inpt += $zero; # N 4 } else { $inpt = "$inpt"; # P 5 } # Saves 20% of time - not with this logic: #my $tmp = $inpt; #my $tmp1 = $num; #next if $num_chain > 1 # and "$tmp" ne "$tmp1"; # Already the coercion gives problems... for my $curop (@{$curops[$short]}) { if ($curop < 5) { if ($curop < 3) { if ($curop == 0) { --$inpt; # - 0 } elsif ($curop == 1) { ++$inpt; # + 1 } else { $inpt = $max_uv & $inpt; # U 2 } } elsif ($curop == 3) { use integer; $inpt += $zero; } else { $inpt += $zero; # N 4 } } elsif ($curop < 8) { if ($curop == 5) { $inpt = "$inpt"; # P 5 } elsif ($curop == 6) { $max_uv & $inpt; # u 6 } else { use integer; $inpt + $zero; } } elsif ($curop == 8) { $inpt + $zero; # n 8 } else { $inpt . ""; # p 9 } } if ($last == 2) { $inpt = sprintf "%u", $inpt; # U 2 } elsif ($last == 3) { $inpt = sprintf "%d", $inpt; # I 3 } elsif ($last == 4) { $inpt = sprintf "%g", $inpt; # N 4 } else { $inpt = "$inpt"; # P 5 } push @ans, $inpt; } if ($ans[0] ne $ans[1]) { print "# '$ans[0]' ne '$ans[1]',\t$num\t=> @opnames[$first,@{$curops[0]},$last] vs @opnames[$first,@{$curops[1]},$last]\n"; # XXX ought to check that "+" was in the list of opnames if ((($ans[0] eq $max_uv_pp) and ($ans[1] eq $max_uv_p1)) or (($ans[1] eq $max_uv_pp) and ($ans[0] eq $max_uv_p1))) { # string ++ versus numeric ++. Tolerate this little # bit of insanity print "# ok, as string ++ of max_uv is \"$max_uv_pp\", numeric is $max_uv_p1\n" } elsif ($opnames[$last] eq 'I' and $ans[1] eq "-1" and $ans[0] eq $max_uv_p1_as_iv) { # Max UV plus 1 is NV. This NV may stringify in E notation. # And the number of decimal digits shown in E notation will depend # on the binary digits in the mantissa. And it may be that # (say) 18446744073709551616 in E notation is truncated to # (say) 1.8446744073709551e+19 (say) which gets converted back # as 1.8446744073709551000e+19 # ie 18446744073709551000 # which isn't the integer we first had. # But each step of conversion is correct. So it's not an error. # (Only shows up for 64 bit UVs and NVs with 64 bit mantissas, # and on Crays (64 bit integers, 48 bit mantissas) IIRC) print "# ok, \"$max_uv_p1\" correctly converts to IV \"$max_uv_p1_as_iv\"\n"; } elsif ($opnames[$last] eq 'U' and $ans[1] eq ~0 and $ans[0] eq $max_uv_p1_as_uv) { # as aboce print "# ok, \"$max_uv_p1\" correctly converts to UV \"$max_uv_p1_as_uv\"\n"; } elsif (grep {/^N$/} @opnames[@{$curops[0]}] and $ans[0] == $ans[1] and $ans[0] <= ~0 # First must be in E notation (ie not just digits) and # second must still be an integer. # eg 1.84467440737095516e+19 # 1.84467440737095516e+19 for 64 bit mantissa is in the # integer range, so 1.84467440737095516e+19 + 0 is treated # as integer addition. [should it be?] # and 18446744073709551600 + 0 is 18446744073709551600 # Which isn't the string you first thought of. # I can't remember why there isn't symmetry in this # exception, ie why only the first ops are tested for 'N' and $ans[0] != /^-?\d+$/ and $ans[1] !~ /^-?\d+$/) { print "# ok, numerically equal - notation changed due to adding zero\n"; } else { $nok++, } } } if ($nok) { print "not ok $test\n"; } else { print "ok $test\n"; } #print $txt if $nok; $test++; } } } } perl-5.12.0-RC0/t/op/utfhash.t0000555000175000017500000001252411325127002014635 0ustar jessejesse#!./perl -w BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; plan(tests => 99); } use strict; # Two hashes one will all keys 8-bit possible (initially), other # with a utf8 requiring key from the outset. my %hash8 = ( "\xff" => 0xff, "\x7f" => 0x7f, ); my %hashu = ( "\xff" => 0xff, "\x7f" => 0x7f, "\x{1ff}" => 0x1ff, ); # Check that we can find the 8-bit things by various litterals is($hash8{"\x{00ff}"},0xFF); is($hash8{"\x{007f}"},0x7F); is($hash8{"\xff"},0xFF); is($hash8{"\x7f"},0x7F); is($hashu{"\x{00ff}"},0xFF); is($hashu{"\x{007f}"},0x7F); is($hashu{"\xff"},0xFF); is($hashu{"\x7f"},0x7F); # Now try same thing with variables forced into various forms. foreach ("\x7f","\xff") { my $a = $_; # Force a copy utf8::upgrade($a); is($hash8{$a},ord($a)); is($hashu{$a},ord($a)); utf8::downgrade($a); is($hash8{$a},ord($a)); is($hashu{$a},ord($a)); my $b = $a.chr(100); chop($b); is($hash8{$b},ord($b)); is($hashu{$b},ord($b)); } # Check we have not got an spurious extra keys is(join('',sort { ord $a <=> ord $b } keys %hash8),"\x7f\xff"); is(join('',sort { ord $a <=> ord $b } keys %hashu),"\x7f\xff\x{1ff}"); # Now add a utf8 key to the 8-bit hash $hash8{chr(0x1ff)} = 0x1ff; # Check we have not got an spurious extra keys is(join('',sort { ord $a <=> ord $b } keys %hash8),"\x7f\xff\x{1ff}"); foreach ("\x7f","\xff","\x{1ff}") { my $a = $_; utf8::upgrade($a); is($hash8{$a},ord($a)); my $b = $a.chr(100); chop($b); is($hash8{$b},ord($b)); } # and remove utf8 from the other hash is(delete $hashu{chr(0x1ff)},0x1ff); is(join('',sort keys %hashu),"\x7f\xff"); foreach ("\x7f","\xff") { my $a = $_; utf8::upgrade($a); is($hashu{$a},ord($a)); utf8::downgrade($a); is($hashu{$a},ord($a)); my $b = $a.chr(100); chop($b); is($hashu{$b},ord($b)); } { print "# Unicode hash keys and \\w\n"; # This is not really a regex test but regexes bring # out the issue nicely. use strict; my $u3 = "f\x{df}\x{100}"; my $u2 = substr($u3,0,2); my $u1 = substr($u2,0,1); my $u0 = chr (0xdf)x4; # Make this 4 chars so that all lengths are distinct. my @u = ($u0, $u1, $u2, $u3); while (@u) { my %u = (map {( $_, $_)} @u); my $keys = scalar @u; $keys .= ($keys == 1) ? " key" : " keys"; for (keys %u) { my $l = 0 + /^\w+$/; my $r = 0 + $u{$_} =~ /^\w+$/; is ($l, $r, "\\w on keys with $keys, key of length " . length $_); } my $more; do { $more = 0; # Want to do this direct, rather than copying to a temporary variable # The first time each will return key and value at the start of the hash. # each will return () after we've done the last pair. $more won't get # set then, and the do will exit. for (each %u) { $more = 1; my $l = 0 + /^\w+$/; my $r = 0 + $u{$_} =~ /^\w+$/; is ($l, $r, "\\w on each, with $keys, key of length " . length $_); } } while ($more); for (%u) { my $l = 0 + /^\w+$/; my $r = 0 + $u{$_} =~ /^\w+$/; is ($l, $r, "\\w on hash with $keys, key of length " . length $_); } pop @u; undef %u; } } { my $utf8_sz = my $bytes_sz = "\x{df}"; $utf8_sz .= chr 256; chop ($utf8_sz); my (%bytes_first, %utf8_first); $bytes_first{$bytes_sz} = $bytes_sz; for (keys %bytes_first) { my $l = 0 + /^\w+$/; my $r = 0 + $bytes_first{$_} =~ /^\w+$/; is ($l, $r, "\\w on each, bytes"); } $bytes_first{$utf8_sz} = $utf8_sz; for (keys %bytes_first) { my $l = 0 + /^\w+$/; my $r = 0 + $bytes_first{$_} =~ /^\w+$/; is ($l, $r, "\\w on each, bytes now utf8"); } $utf8_first{$utf8_sz} = $utf8_sz; for (keys %utf8_first) { my $l = 0 + /^\w+$/; my $r = 0 + $utf8_first{$_} =~ /^\w+$/; is ($l, $r, "\\w on each, utf8"); } $utf8_first{$bytes_sz} = $bytes_sz; for (keys %utf8_first) { my $l = 0 + /^\w+$/; my $r = 0 + $utf8_first{$_} =~ /^\w+$/; is ($l, $r, "\\w on each, utf8 now bytes"); } } { local $/; # Slurp. my $utf8 = ; my $utfebcdic = ; if (ord('A') == 65) { eval $utf8; } elsif (ord('A') == 193) { eval $utfebcdic; } } __END__ { # See if utf8 barewords work [perl #22969] use utf8; my %hash = (теÑÑ‚ => 123); is($hash{теÑÑ‚}, $hash{'теÑÑ‚'}); is($hash{теÑÑ‚}, 123); is($hash{'теÑÑ‚'}, 123); %hash = (теÑÑ‚ => 123); is($hash{теÑÑ‚}, $hash{'теÑÑ‚'}); is($hash{теÑÑ‚}, 123); is($hash{'теÑÑ‚'}, 123); # See if plain ASCII strings quoted with '=>' erroneously get utf8 flag [perl #68812] my %foo = (a => 'b', 'c' => 'd'); for my $key (keys %foo) { ok !utf8::is_utf8($key), "'$key' shouldn't have utf8 flag"; } } __END__ { # See if utf8 barewords work [perl #22969] use utf8; # UTF-EBCDIC, really. my %hash = (½ää½âÀ½äâ½ää => 123); is($hash{½ää½âÀ½äâ½ää}, $hash{'½ää½âÀ½äâ½ää'}); is($hash{½ää½âÀ½äâ½ää}, 123); is($hash{'½ää½âÀ½äâ½ää'}, 123); %hash = (½ää½âÀ½äâ½ää => 123); is($hash{½ää½âÀ½äâ½ää}, $hash{'½ää½âÀ½äâ½ää'}); is($hash{½ää½âÀ½äâ½ää}, 123); is($hash{'½ää½âÀ½äâ½ää'}, 123); # See if plain ASCII strings quoted with '=>' erroneously get utf8 flag [perl #68812] my %foo = (a => 'b', 'c' => 'd'); for my $key (keys %foo) { ok !utf8::is_utf8($key), "'$key' shouldn't have utf8 flag"; } } perl-5.12.0-RC0/t/op/while_readdir.t0000555000175000017500000000525611325127002016001 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } use strict; use warnings; open my $fh, ">", "0" or die "Can't open '0' for writing: $!\n"; print $fh <<'FILE0'; This file is here for testing while(readdir $dir){...} ... while readdir $dir etc FILE0 close $fh; plan 10; ok(-f '0', "'0' file is here"); opendir my $dirhandle, '.' or die "Failed test: unable to open directory: $!\n"; my @dir = readdir $dirhandle; rewinddir $dirhandle; { my @list; while(readdir $dirhandle){ push @list, $_; } ok( eq_array( \@dir, \@list ), 'while(readdir){push}' ); rewinddir $dirhandle; } { my @list; push @list, $_ while readdir $dirhandle; ok( eq_array( \@dir, \@list ), 'push while readdir' ); rewinddir $dirhandle; } { my $tmp; my @list; push @list, $tmp while $tmp = readdir $dirhandle; ok( eq_array( \@dir, \@list ), 'push $dir while $dir = readdir' ); rewinddir $dirhandle; } { my @list; while( my $dir = readdir $dirhandle){ push @list, $dir; } ok( eq_array( \@dir, \@list ), 'while($dir=readdir){push}' ); rewinddir $dirhandle; } { my @list; my $sub = sub{ push @list, $_; }; $sub->($_) while readdir $dirhandle; ok( eq_array( \@dir, \@list ), '$sub->($_) while readdir' ); rewinddir $dirhandle; } { my $works = 0; while(readdir $dirhandle){ $_ =~ s/\.$// if defined $_ && $^O eq 'VMS'; # may have zero-length extension if( defined $_ && $_ eq '0'){ $works = 1; last; } } ok( $works, 'while(readdir){} with file named "0"' ); rewinddir $dirhandle; } { my $works = 0; my $sub = sub{ $_ =~ s/\.$// if defined $_ && $^O eq 'VMS'; # may have zero-length extension if( defined $_ && $_ eq '0' ){ $works = 1; } }; $sub->($_) while readdir $dirhandle; ok( $works, '$sub->($_) while readdir; with file named "0"' ); rewinddir $dirhandle; } { my $works = 0; while( my $dir = readdir $dirhandle ){ $dir =~ s/\.$// if defined $dir && $^O eq 'VMS'; # may have zero-length extension if( defined $dir && $dir eq '0'){ $works = 1; last; } } ok( $works, 'while($dir=readdir){} with file named "0"'); rewinddir $dirhandle; } { my $tmp; my $ok; my @list; while( $tmp = readdir $dirhandle ){ $tmp =~ s/\.$// if defined $tmp && $^O eq 'VMS'; # may have zero-length extension last if defined($tmp)&& !$tmp && ($ok=1) } ok( $ok, '$dir while $dir = readdir; with file named "0"' ); rewinddir $dirhandle; } closedir $dirhandle; END { 1 while unlink "0" } perl-5.12.0-RC0/t/op/mydef.t0000555000175000017500000001326611325127001014302 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } print "1..72\n"; my $test = 0; sub ok ($@) { my ($ok, $name) = @_; ++$test; print $ok ? "ok $test - $name\n" : "not ok $test - $name\n"; } $_ = 'global'; ok( $_ eq 'global', '$_ initial value' ); s/oba/abo/; ok( $_ eq 'glabol', 's/// on global $_' ); { my $_ = 'local'; ok( $_ eq 'local', 'my $_ initial value' ); s/oca/aco/; ok( $_ eq 'lacol', 's/// on my $_' ); /(..)/; ok( $1 eq 'la', '// on my $_' ); ok( tr/c/d/ == 1, 'tr/// on my $_ counts correctly' ); ok( $_ eq 'ladol', 'tr/// on my $_' ); { my $_ = 'nested'; ok( $_ eq 'nested', 'my $_ nested' ); chop; ok( $_ eq 'neste', 'chop on my $_' ); } { our $_; ok( $_ eq 'glabol', 'gains access to our global $_' ); } ok( $_ eq 'ladol', 'my $_ restored' ); } ok( $_ eq 'glabol', 'global $_ restored' ); s/abo/oba/; ok( $_ eq 'global', 's/// on global $_ again' ); { my $_ = 11; our $_ = 22; ok( $_ eq 22, 'our $_ is seen explicitly' ); chop; ok( $_ eq 2, '...default chop chops our $_' ); /(.)/; ok( $1 eq 2, '...default match sees our $_' ); } $_ = "global"; { my $_ = 'local'; for my $_ ("foo") { ok( $_ eq "foo", 'for my $_' ); /(.)/; ok( $1 eq "f", '...m// in for my $_' ); ok( our $_ eq 'global', '...our $_ inside for my $_' ); } ok( $_ eq 'local', '...my $_ restored outside for my $_' ); ok( our $_ eq 'global', '...our $_ restored outside for my $_' ); } { my $_ = 'local'; for ("implicit foo") { # implicit "my $_" ok( $_ eq "implicit foo", 'for implicit my $_' ); /(.)/; ok( $1 eq "i", '...m// in for implicity my $_' ); ok( our $_ eq 'global', '...our $_ inside for implicit my $_' ); } ok( $_ eq 'local', '...my $_ restored outside for implicit my $_' ); ok( our $_ eq 'global', '...our $_ restored outside for implicit my $_' ); } { my $_ = 'local'; ok( $_ eq "postfix foo", 'postfix for' ) for 'postfix foo'; ok( $_ eq 'local', '...my $_ restored outside postfix for' ); ok( our $_ eq 'global', '...our $_ restored outside postfix for' ); } { for our $_ ("bar") { ok( $_ eq "bar", 'for our $_' ); /(.)/; ok( $1 eq "b", '...m// in for our $_' ); } ok( $_ eq 'global', '...our $_ restored outside for our $_' ); } { my $buf = ''; sub tmap1 { /(.)/; $buf .= $1 } # uses our $_ my $_ = 'x'; sub tmap2 { /(.)/; $buf .= $1 } # uses my $_ map { tmap1(); tmap2(); ok( /^[67]\z/, 'local lexical $_ is seen in map' ); { ok( our $_ eq 'global', 'our $_ still visible' ); } ok( $_ == 6 || $_ == 7, 'local lexical $_ is still seen in map' ); { my $_ ; ok( !defined, 'nested my $_ is undefined' ); } } 6, 7; ok( $buf eq 'gxgx', q/...map doesn't modify outer lexical $_/ ); ok( $_ eq 'x', '...my $_ restored outside map' ); ok( our $_ eq 'global', '...our $_ restored outside map' ); map { my $_; ok( !defined, 'redeclaring $_ in map block undefs it' ); } 1; } { map { my $_; ok( !defined, 'declaring $_ in map block undefs it' ); } 1; } { sub tmap3 () { return $_ }; my $_ = 'local'; sub tmap4 () { return $_ }; my $x = join '-', map $_.tmap3.tmap4, 1 .. 2; ok( $x eq '1globallocal-2globallocal', 'map without {}' ); } { for my $_ (1) { my $x = map $_, qw(a b); ok( $x == 2, 'map in scalar context' ); } } { my $buf = ''; sub tgrep1 { /(.)/; $buf .= $1 } my $_ = 'y'; sub tgrep2 { /(.)/; $buf .= $1 } grep { tgrep1(); tgrep2(); ok( /^[89]\z/, 'local lexical $_ is seen in grep' ); { ok( our $_ eq 'global', 'our $_ still visible' ); } ok( $_ == 8 || $_ == 9, 'local lexical $_ is still seen in grep' ); } 8, 9; ok( $buf eq 'gygy', q/...grep doesn't modify outer lexical $_/ ); ok( $_ eq 'y', '...my $_ restored outside grep' ); ok( our $_ eq 'global', '...our $_ restored outside grep' ); } { sub tgrep3 () { return $_ }; my $_ = 'local'; sub tgrep4 () { return $_ }; my $x = join '-', grep $_=$_.tgrep3.tgrep4, 1 .. 2; ok( $x eq '1globallocal-2globallocal', 'grep without {} with side-effect' ); ok( $_ eq 'local', '...but without extraneous side-effects' ); } { for my $_ (1) { my $x = grep $_, qw(a b); ok( $x == 2, 'grep in scalar context' ); } } { my $s = "toto"; my $_ = "titi"; $s =~ /to(?{ ok( $_ eq 'toto', 'my $_ in code-match # TODO' ) })to/ or ok( 0, "\$s=$s should match!" ); ok( our $_ eq 'global', '...our $_ restored outside code-match' ); } { my $_ = "abc"; my $x = reverse; ok( $x eq "cba", 'reverse without arguments picks up $_' ); } { package notmain; our $_ = 'notmain'; ::ok( $::_ eq 'notmain', 'our $_ forced into main::' ); /(.*)/; ::ok( $1 eq 'notmain', '...m// defaults to our $_ in main::' ); } my $file = tempfile(); { open my $_, '>', $file or die "Can't open $file: $!"; print $_ "hello\n"; close $_; ok( -s $file, 'writing to filehandle $_ works' ); } { open my $_, $file or die "Can't open $file: $!"; my $x = <$_>; ok( $x eq "hello\n", 'reading from <$_> works' ); close $_; } { $fqdb::_ = 'fqdb'; ok( $fqdb::_ eq 'fqdb', 'fully qualified $_ is not in main' ); ok( eval q/$fqdb::_/ eq 'fqdb', 'fully qualified, evaled $_ is not in main' ); package fqdb; ::ok( $_ ne 'fqdb', 'unqualified $_ is in main' ); ::ok( q/$_/ ne 'fqdb', 'unqualified, evaled $_ is in main' ); } { $clank_est::qunckkk = 3; our $qunckkk; $qunckkk = 4; package clank_est; our $qunckkk; ::ok($qunckkk == 3, 'regular variables are not forced to main'); } { $whack::_ = 3; our $_; $_ = 4; package whack; our $_; ::ok($_ == 4, '$_ is "special", and always forced to main'); } perl-5.12.0-RC0/t/op/grent.t0000555000175000017500000001055411325125742014324 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } eval {my @n = getgrgid 0}; if ($@ =~ /(The \w+ function is unimplemented)/) { skip_all "getgrgid unimplemented"; } eval { require Config; import Config; }; my $reason; if ($Config{'i_grp'} ne 'define') { $reason = '$Config{i_grp} not defined'; } elsif (not -f "/etc/group" ) { # Play safe. $reason = 'no /etc/group file'; } if (not defined $where) { # Try NIS. foreach my $ypcat (qw(/usr/bin/ypcat /bin/ypcat /etc/ypcat)) { if (-x $ypcat && open(GR, "$ypcat group 2>/dev/null |") && defined()) { print "# `ypcat group` worked\n"; # Check to make sure we're really using NIS. if( open(NSSW, "/etc/nsswitch.conf" ) ) { my($group) = grep /^\s*group:/, ; # If there's no group line, assume it default to compat. if( !$group || $group !~ /(nis|compat)/ ) { print "# Doesn't look like you're using NIS in ". "/etc/nsswitch.conf\n"; last; } } $where = "NIS group - $ypcat"; undef $reason; last; } } } if (not defined $where) { # Try NetInfo. foreach my $nidump (qw(/usr/bin/nidump)) { if (-x $nidump && open(GR, "$nidump group . 2>/dev/null |") && defined()) { $where = "NetInfo group - $nidump"; undef $reason; last; } } } if (not defined $where) { # Try local. my $GR = "/etc/group"; if (-f $GR && open(GR, $GR) && defined()) { undef $reason; $where = "local $GR"; } } if ($reason) { skip_all $reason; } # By now the GR filehandle should be open and full of juicy group entries. plan tests => 3; # Go through at most this many groups. # (note that the first entry has been read away by now) my $max = 25; my $n = 0; my $tst = 1; my %perfect; my %seen; print "# where $where\n"; ok( setgrent(), 'setgrent' ) || print "# $!\n"; while () { chomp; # LIMIT -1 so that groups with no users don't fall off my @s = split /:/, $_, -1; my ($name_s,$passwd_s,$gid_s,$members_s) = @s; if (@s) { push @{ $seen{$name_s} }, $.; } else { warn "# Your $where line $. is empty.\n"; next; } if ($n == $max) { local $/; my $junk = ; last; } # In principle we could whine if @s != 4 but do we know enough # of group file formats everywhere? if (@s == 4) { $members_s =~ s/\s*,\s*/,/g; $members_s =~ s/\s+$//; $members_s =~ s/^\s+//; @n = getgrgid($gid_s); # 'nogroup' et al. next unless @n; my ($name,$passwd,$gid,$members) = @n; # Protect against one-to-many and many-to-one mappings. if ($name_s ne $name) { @n = getgrnam($name_s); ($name,$passwd,$gid,$members) = @n; next if $name_s ne $name; } # NOTE: group names *CAN* contain whitespace. $members =~ s/\s+/,/g; # what about different orders of members? $perfect{$name_s}++ if $name eq $name_s and # Do not compare passwords: think shadow passwords. # Not that group passwords are used much but better not assume anything. $gid eq $gid_s and $members eq $members_s; } $n++; } endgrent(); print "# max = $max, n = $n, perfect = ", scalar keys %perfect, "\n"; if (keys %perfect == 0 && $n) { $max++; print < 4; sub ToUpper { return < 28); } use strict; sub gcd { return gcd($_[0] - $_[1], $_[1]) if ($_[0] > $_[1]); return gcd($_[0], $_[1] - $_[0]) if ($_[0] < $_[1]); $_[0]; } sub factorial { $_[0] < 2 ? 1 : $_[0] * factorial($_[0] - 1); } sub fibonacci { $_[0] < 2 ? 1 : fibonacci($_[0] - 2) + fibonacci($_[0] - 1); } # Highly recursive, highly aggressive. # Kids, don't try this at home. # # For example ackermann(4,1) will take quite a long time. # It will simply eat away your memory. Trust me. sub ackermann { return $_[1] + 1 if ($_[0] == 0); return ackermann($_[0] - 1, 1) if ($_[1] == 0); ackermann($_[0] - 1, ackermann($_[0], $_[1] - 1)); } # Highly recursive, highly boring. sub takeuchi { $_[1] < $_[0] ? takeuchi(takeuchi($_[0] - 1, $_[1], $_[2]), takeuchi($_[1] - 1, $_[2], $_[0]), takeuchi($_[2] - 1, $_[0], $_[1])) : $_[2]; } is(gcd(1147, 1271), 31, "gcd(1147, 1271) == 31"); is(gcd(1908, 2016), 36, "gcd(1908, 2016) == 36"); is(factorial(10), 3628800, "factorial(10) == 3628800"); is(factorial(factorial(3)), 720, "factorial(factorial(3)) == 720"); is(fibonacci(10), 89, "fibonacci(10) == 89"); is(fibonacci(fibonacci(7)), 17711, "fibonacci(fibonacci(7)) == 17711"); my @ack = qw(1 2 3 4 2 3 4 5 3 5 7 9 5 13 29 61); for my $x (0..3) { for my $y (0..3) { my $a = ackermann($x, $y); is($a, shift(@ack), "ackermann($x, $y) == $a"); } } my ($x, $y, $z) = (18, 12, 6); is(takeuchi($x, $y, $z), $z + 1, "takeuchi($x, $y, $z) == $z + 1"); { sub get_first1 { get_list1(@_)->[0]; } sub get_list1 { return [curr_test] unless $_[0]; my $u = get_first1(0); [$u]; } my $x = get_first1(1); ok($x, "premature FREETMPS (change 5699)"); } { sub get_first2 { return get_list2(@_)->[0]; } sub get_list2 { return [curr_test] unless $_[0]; my $u = get_first2(0); return [$u]; } my $x = get_first2(1); ok($x, "premature FREETMPS (change 5699)"); } { local $^W = 0; # We do not need recursion depth warning. sub sillysum { return $_[0] + ($_[0] > 0 ? sillysum($_[0] - 1) : 0); } is(sillysum(1000), 1000*1001/2, "recursive sum of 1..1000"); } # check ok for recursion depth > 65536 { my $r; eval { $r = runperl( nolib => 1, stderr => 1, prog => q{$d=0; $e=1; sub c { ++$d; if ($d > 66000) { $e=0 } else { c(); c() unless $d % 32768 } --$d } c(); exit $e}); }; SKIP: { skip("Out of memory -- increase your data/heap?", 2) if $r =~ /Out of memory/i; is($r, '', "64K deep recursion - no output expected"); is($?, 0, "64K deep recursion - no coredump expected"); } } perl-5.12.0-RC0/t/op/pos.t0000555000175000017500000000066411325125742014007 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } plan tests => 6; $x='banana'; $x=~/.a/g; is(pos($x), 2); $x=~/.z/gc; is(pos($x), 2); sub f { my $p=$_[0]; return $p } $x=~/.a/g; is(f(pos($x)), 4); # Is pos() set inside //g? (bug id 19990615.008) $x = "test string?"; $x =~ s/\w/pos($x)/eg; is($x, "0123 5678910?"); $x = "123 56"; $x =~ / /g; is(pos($x), 4); { local $x } is(pos($x), 4); perl-5.12.0-RC0/t/op/assignwarn.t0000555000175000017500000000634411336536210015361 0ustar jessejesse#!./perl # # Verify which OP= operators warn if their targets are undefined. # Based on redef.t, contributed by Graham Barr # -- Robin Barker # BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } use strict; use warnings; my $warn = ""; $SIG{q(__WARN__)} = sub { print $warn; $warn .= join("",@_) }; sub uninitialized { $warn =~ s/Use of uninitialized value[^\n]+\n//s; } sub tiex { tie $_[0], 'main' } sub TIESCALAR { my $x; bless \$x } sub FETCH { ${$_[0]} } sub STORE { ${$_[0]} = $_[1] } our $TODO; print "1..63\n"; # go through all tests once normally and once with tied $x for my $tie ("", ", tied") { { my $x; tiex $x if $tie; $x ++; ok ! uninitialized, "postinc$tie"; } { my $x; tiex $x if $tie; $x --; ok ! uninitialized, "postdec$tie"; } { my $x; tiex $x if $tie; ++ $x; ok ! uninitialized, "preinc$tie"; } { my $x; tiex $x if $tie; -- $x; ok ! uninitialized, "predec$tie"; } { my $x; tiex $x if $tie; $x **= 1; ok uninitialized, "**=$tie"; } { local $TODO = $tie && '[perl #17809] pp_add & pp_subtract'; { my $x; tiex $x if $tie; $x += 1; ok ! uninitialized, "+=$tie"; } { my $x; tiex $x if $tie; $x -= 1; ok ! uninitialized, "-=$tie"; } } { my $x; tiex $x if $tie; $x .= 1; ok ! uninitialized, ".=$tie"; } { my $x; tiex $x if $tie; $x *= 1; ok uninitialized, "*=$tie"; } { my $x; tiex $x if $tie; $x /= 1; ok uninitialized, "/=$tie"; } { my $x; tiex $x if $tie; $x %= 1; ok uninitialized, "\%=$tie"; } { my $x; tiex $x if $tie; $x x= 1; ok uninitialized, "x=$tie"; } { my $x; tiex $x if $tie; $x &= 1; ok uninitialized, "&=$tie"; } { local $TODO = $tie && '[perl #17809] pp_bit_or & pp_bit_xor'; { my $x; tiex $x if $tie; $x |= 1; ok ! uninitialized, "|=$tie"; } { my $x; tiex $x if $tie; $x ^= 1; ok ! uninitialized, "^=$tie"; } } { my $x; tiex $x if $tie; $x &&= 1; ok ! uninitialized, "&&=$tie"; } { my $x; tiex $x if $tie; $x ||= 1; ok ! uninitialized, "||=$tie"; } { my $x; tiex $x if $tie; $x <<= 1; ok uninitialized, "<<=$tie"; } { my $x; tiex $x if $tie; $x >>= 1; ok uninitialized, ">>=$tie"; } { my $x; tiex $x if $tie; $x &= "x"; ok uninitialized, "&=$tie, string"; } { local $TODO = $tie && '[perl #17809] pp_bit_or & pp_bit_xor'; { my $x; tiex $x if $tie; $x |= "x"; ok ! uninitialized, "|=$tie, string"; } { my $x; tiex $x if $tie; $x ^= "x"; ok ! uninitialized, "^=$tie, string"; } } { use integer; { local $TODO = $tie && '[perl #17809] pp_i_add & pp_i_subtract'; { my $x; tiex $x if $tie; $x += 1; ok ! uninitialized, "+=$tie, int"; } { my $x; tiex $x if $tie; $x -= 1; ok ! uninitialized, "-=$tie, int"; } } { my $x; tiex $x if $tie; $x *= 1; ok uninitialized, "*=$tie, int"; } { my $x; tiex $x if $tie; $x /= 1; ok uninitialized, "/=$tie, int"; } { my $x; tiex $x if $tie; $x %= 1; ok uninitialized, "\%=$tie, int"; } { my $x; tiex $x if $tie; $x ++; ok ! uninitialized, "postinc$tie, int"; } { my $x; tiex $x if $tie; $x --; ok ! uninitialized, "postdec$tie, int"; } { my $x; tiex $x if $tie; ++ $x; ok ! uninitialized, "preinc$tie, int"; } { my $x; tiex $x if $tie; -- $x; ok ! uninitialized, "predec$tie, int"; } } # end of use integer; } # end of for $tie is $warn, '', "no spurious warnings"; perl-5.12.0-RC0/t/op/sleep.t0000555000175000017500000000072411325125742014313 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = qw(. ../lib); } require "test.pl"; plan( tests => 4 ); use strict; use warnings; my $start = time; my $sleep_says = sleep 3; my $diff = time - $start; cmp_ok( $sleep_says, '>=', 2, 'Sleep says it slept at least 2 seconds' ); cmp_ok( $sleep_says, '<=', 10, '... and no more than 10' ); cmp_ok( $diff, '>=', 2, 'Actual time diff is at least 2 seconds' ); cmp_ok( $diff, '<=', 10, '... and no more than 10' ); perl-5.12.0-RC0/t/op/yadayada.t0000555000175000017500000000160711330371434014756 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } use strict; plan 5; my $err = "Unimplemented at $0 line " . ( __LINE__ + 2 ) . ".\n"; eval { ... }; is $@, $err; # # Regression tests, making sure ... is still parsable as an operator. # my @lines = split /\n/ => <<'--'; # Check simple range operator. my @arr = 'A' ... 'D'; # Range operator with print. print 'D' ... 'A'; # Without quotes, 'D' could be a file handle. print D ... A ; # Another possible interaction with a file handle. print ${\"D"} ... A ; -- foreach my $line (@lines) { next if $line =~ /^\s*#/ || $line !~ /\S/; my $mess = qq {Parsing '...' in "$line" as a range operator}; eval qq { {local *STDOUT; no strict "subs"; $line;} pass \$mess; 1; } or do { my $err = $@; $err =~ s/\n//g; fail "$mess ($err)"; } } perl-5.12.0-RC0/t/op/grep.t0000555000175000017500000001442211325127001014126 0ustar jessejesse#!./perl # # grep() and map() tests # BEGIN { chdir 't' if -d 't'; @INC = qw(. ../lib); } require "test.pl"; plan( tests => 61 ); { my @lol = ([qw(a b c)], [], [qw(1 2 3)]); my @mapped = map {scalar @$_} @lol; cmp_ok("@mapped", 'eq', "3 0 3", 'map scalar list of list'); my @grepped = grep {scalar @$_} @lol; cmp_ok("@grepped", 'eq', "$lol[0] $lol[2]", 'grep scalar list of list'); $test++; @grepped = grep { $_ } @mapped; cmp_ok( "@grepped", 'eq', "3 3", 'grep basic'); } { my @res; @res = map({$_} ("geronimo")); cmp_ok( scalar(@res), '==', 1, 'basic map nr'); cmp_ok( $res[0], 'eq', 'geronimo', 'basic map is'); @res = map ({$_} ("yoyodyne")); cmp_ok( scalar(@res), '==', 1, 'linefeed map nr'); cmp_ok( $res[0], 'eq', 'yoyodyne', 'linefeed map is'); @res = (map( {a =>$_}, ("chobb")))[0]->{a}; cmp_ok( scalar(@res), '==', 1, 'deref map nr'); cmp_ok( $res[0], 'eq', 'chobb', 'deref map is'); @res = map {$_} ("geronimo"); cmp_ok( scalar(@res), '==', 1, 'no paren basic map nr'); cmp_ok( $res[0], 'eq', 'geronimo', 'no paren basic map is'); @res = map {$_} ("yoyodyne"); cmp_ok( scalar(@res), '==', 1, 'no paren linefeed map nr'); cmp_ok( $res[0], 'eq', 'yoyodyne', 'no paren linefeed map is'); @res = (map {a =>$_}, ("chobb"))[0]->{a}; cmp_ok( scalar(@res), '==', 1, 'no paren deref map nr'); cmp_ok( $res[0], 'eq', 'chobb', 'no paren deref map is'); my $x = "\xFF\xFF\xFF\xFF\xFF\xFF\xFF\n"; @res = map($_&$x,("sferics\n")); cmp_ok( scalar(@res), '==', 1, 'binand map nr 1'); cmp_ok( $res[0], 'eq', "sferics\n", 'binand map is 1'); @res = map ($_ & $x, ("sferics\n")); cmp_ok( scalar(@res), '==', 1, 'binand map nr 2'); cmp_ok( $res[0], 'eq', "sferics\n", 'binand map is 2'); @res = map { $_ & $x } ("sferics\n"); cmp_ok( scalar(@res), '==', 1, 'binand map nr 3'); cmp_ok( $res[0], 'eq', "sferics\n", 'binand map is 3'); @res = map { $_&$x } ("sferics\n"); cmp_ok( scalar(@res), '==', 1, 'binand map nr 4'); cmp_ok( $res[0], 'eq', "sferics\n", 'binand map is 4'); @res = grep({$_} ("geronimo")); cmp_ok( scalar(@res), '==', 1, 'basic grep nr'); cmp_ok( $res[0], 'eq', 'geronimo', 'basic grep is'); @res = grep ({$_} ("yoyodyne")); cmp_ok( scalar(@res), '==', 1, 'linefeed grep nr'); cmp_ok( $res[0], 'eq', 'yoyodyne', 'linefeed grep is'); @res = grep ({a=>$_}->{a}, ("chobb")); cmp_ok( scalar(@res), '==', 1, 'deref grep nr'); cmp_ok( $res[0], 'eq', 'chobb', 'deref grep is'); @res = grep {$_} ("geronimo"); cmp_ok( scalar(@res), '==', 1, 'no paren basic grep nr'); cmp_ok( $res[0], 'eq', 'geronimo', 'no paren basic grep is'); @res = grep {$_} ("yoyodyne"); cmp_ok( scalar(@res), '==', 1, 'no paren linefeed grep nr'); cmp_ok( $res[0], 'eq', 'yoyodyne', 'no paren linefeed grep is'); @res = grep {a=>$_}->{a}, ("chobb"); cmp_ok( scalar(@res), '==', 1, 'no paren deref grep nr'); cmp_ok( $res[0], 'eq', 'chobb', 'no paren deref grep is'); @res = grep {a=>$_}->{a}, ("chobb"); cmp_ok( scalar(@res), '==', 1, 'no paren deref linefeed nr'); cmp_ok( $res[0], 'eq', 'chobb', 'no paren deref linefeed is'); @res = grep($_&"X", ("bodine")); cmp_ok( scalar(@res), '==', 1, 'binand X grep nr'); cmp_ok( $res[0], 'eq', 'bodine', 'binand X grep is'); @res = grep ($_&"X", ("bodine")); cmp_ok( scalar(@res), '==', 1, 'binand X linefeed grep nr'); cmp_ok( $res[0], 'eq', 'bodine', 'binand X linefeed grep is'); @res = grep {$_&"X"} ("bodine"); cmp_ok( scalar(@res), '==', 1, 'no paren binand X grep nr'); cmp_ok( $res[0], 'eq', 'bodine', 'no paren binand X grep is'); @res = grep {$_&"X"} ("bodine"); cmp_ok( scalar(@res), '==', 1, 'no paren binand X linefeed grep nr'); cmp_ok( $res[0], 'eq', 'bodine', 'no paren binand X linefeed grep is'); } { # Tests for "for" in "map" and "grep" # Used to dump core, bug [perl #17771] my @x; my $y = ''; @x = map { $y .= $_ for 1..2; 1 } 3..4; cmp_ok( "@x,$y",'eq',"1 1,1212", '[perl #17771] for in map 1'); $y = ''; @x = map { $y .= $_ for 1..2; $y .= $_ } 3..4; cmp_ok( "@x,$y",'eq',"123 123124,123124", '[perl #17771] for in map 2'); $y = ''; @x = map { for (1..2) { $y .= $_ } $y .= $_ } 3..4; cmp_ok( "@x,$y",'eq',"123 123124,123124", '[perl #17771] for in map 3'); $y = ''; @x = grep { $y .= $_ for 1..2; 1 } 3..4; cmp_ok( "@x,$y",'eq',"3 4,1212", '[perl #17771] for in grep 1'); $y = ''; @x = grep { for (1..2) { $y .= $_ } 1 } 3..4; cmp_ok( "@x,$y",'eq',"3 4,1212", '[perl #17771] for in grep 2'); # Add also a sample test from [perl #18153]. (The same bug). $a = 1; map {if ($a){}} (2); pass( '[perl #18153] (not dead yet)' ); # no core dump is all we need } { sub add_an_x(@){ map {"${_}x"} @_; }; cmp_ok( join("-",add_an_x(1,2,3,4)), 'eq', "1x-2x-3x-4x", 'add-an-x'); } { my $gimme; sub gimme { my $want = wantarray(); if (defined $want) { $gimme = $want ? 'list' : 'scalar'; } else { $gimme = 'void'; } } my @list = 0..9; undef $gimme; gimme for @list; cmp_ok($gimme, 'eq', 'void', 'gimme a V!'); undef $gimme; grep { gimme } @list; cmp_ok($gimme, 'eq', 'scalar', 'gimme an S!'); undef $gimme; map { gimme } @list; cmp_ok($gimme, 'eq', 'list', 'gimme an L!'); } { # test scalar context return my @list = (7, 14, 21); my $x = map {$_ *= 2} @list; cmp_ok("@list", 'eq', "14 28 42", 'map scalar return'); cmp_ok($x, '==', 3, 'map scalar count'); @list = (9, 16, 25, 36); $x = grep {$_ % 2} @list; cmp_ok($x, '==', 2, 'grep scalar count'); my @res = grep {$_ % 2} @list; cmp_ok("@res", 'eq', "9 25", 'grep extract'); } { # This shouldn't loop indefinitively. my @empty = map { while (1) {} } (); cmp_ok("@empty", 'eq', '', 'staying alive'); } { my $x; eval 'grep $x (1,2,3);'; like($@, qr/Missing comma after first argument to grep function/, "proper error on variable as block. [perl #37314]"); } perl-5.12.0-RC0/t/op/closure.t0000555000175000017500000004072311325125742014662 0ustar jessejesse#!./perl # -*- Mode: Perl -*- # closure.t: # Original written by Ulrich Pfeifer on 2 Jan 1997. # Greatly extended by Tom Phoenix on 28 Jan 1997. # # Run with -debug for debugging output. BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } use Config; require './test.pl'; # for runperl() print "1..188\n"; my $test = 1; sub test (&) { my $ok = &{$_[0]}; print $ok ? "ok $test\n" : "not ok $test\n"; printf "# Failed at line %d\n", (caller)[2] unless $ok; $test++; } my $i = 1; sub foo { $i = shift if @_; $i } # no closure test { foo == 1 }; foo(2); test { foo == 2 }; # closure: lexical outside sub my $foo = sub {$i = shift if @_; $i }; my $bar = sub {$i = shift if @_; $i }; test {&$foo() == 2 }; &$foo(3); test {&$foo() == 3 }; # did the lexical change? test { foo == 3 and $i == 3}; # did the second closure notice? test {&$bar() == 3 }; # closure: lexical inside sub sub bar { my $i = shift; sub { $i = shift if @_; $i } } $foo = bar(4); $bar = bar(5); test {&$foo() == 4 }; &$foo(6); test {&$foo() == 6 }; test {&$bar() == 5 }; # nested closures sub bizz { my $i = 7; if (@_) { my $i = shift; sub {$i = shift if @_; $i }; } else { my $i = $i; sub {$i = shift if @_; $i }; } } $foo = bizz(); $bar = bizz(); test {&$foo() == 7 }; &$foo(8); test {&$foo() == 8 }; test {&$bar() == 7 }; $foo = bizz(9); $bar = bizz(10); test {&$foo(11)-1 == &$bar()}; my @foo; for (qw(0 1 2 3 4)) { my $i = $_; $foo[$_] = sub {$i = shift if @_; $i }; } test { &{$foo[0]}() == 0 and &{$foo[1]}() == 1 and &{$foo[2]}() == 2 and &{$foo[3]}() == 3 and &{$foo[4]}() == 4 }; for (0 .. 4) { &{$foo[$_]}(4-$_); } test { &{$foo[0]}() == 4 and &{$foo[1]}() == 3 and &{$foo[2]}() == 2 and &{$foo[3]}() == 1 and &{$foo[4]}() == 0 }; sub barf { my @foo; for (qw(0 1 2 3 4)) { my $i = $_; $foo[$_] = sub {$i = shift if @_; $i }; } @foo; } @foo = barf(); test { &{$foo[0]}() == 0 and &{$foo[1]}() == 1 and &{$foo[2]}() == 2 and &{$foo[3]}() == 3 and &{$foo[4]}() == 4 }; for (0 .. 4) { &{$foo[$_]}(4-$_); } test { &{$foo[0]}() == 4 and &{$foo[1]}() == 3 and &{$foo[2]}() == 2 and &{$foo[3]}() == 1 and &{$foo[4]}() == 0 }; # test if closures get created in optimized for loops my %foo; for my $n ('A'..'E') { $foo{$n} = sub { $n eq $_[0] }; } test { &{$foo{A}}('A') and &{$foo{B}}('B') and &{$foo{C}}('C') and &{$foo{D}}('D') and &{$foo{E}}('E') }; for my $n (0..4) { $foo[$n] = sub { $n == $_[0] }; } test { &{$foo[0]}(0) and &{$foo[1]}(1) and &{$foo[2]}(2) and &{$foo[3]}(3) and &{$foo[4]}(4) }; for my $n (0..4) { $foo[$n] = sub { # no intervening reference to $n here sub { $n == $_[0] } }; } test { $foo[0]->()->(0) and $foo[1]->()->(1) and $foo[2]->()->(2) and $foo[3]->()->(3) and $foo[4]->()->(4) }; { my $w; $w = sub { my ($i) = @_; test { $i == 10 }; sub { $w }; }; $w->(10); } # Additional tests by Tom Phoenix . { use strict; use vars qw!$test!; my($debugging, %expected, $inner_type, $where_declared, $within); my($nc_attempt, $call_outer, $call_inner, $undef_outer); my($code, $inner_sub_test, $expected, $line, $errors, $output); my(@inners, $sub_test, $pid); $debugging = 1 if defined($ARGV[0]) and $ARGV[0] eq '-debug'; # The expected values for these tests %expected = ( 'global_scalar' => 1001, 'global_array' => 2101, 'global_hash' => 3004, 'fs_scalar' => 4001, 'fs_array' => 5101, 'fs_hash' => 6004, 'sub_scalar' => 7001, 'sub_array' => 8101, 'sub_hash' => 9004, 'foreach' => 10011, ); # Our innermost sub is either named or anonymous for $inner_type (qw!named anon!) { # And it may be declared at filescope, within a named # sub, or within an anon sub for $where_declared (qw!filescope in_named in_anon!) { # And that, in turn, may be within a foreach loop, # a naked block, or another named sub for $within (qw!foreach naked other_sub!) { # Here are a number of variables which show what's # going on, in a way. $nc_attempt = 0+ # Named closure attempted ( ($inner_type eq 'named') || ($within eq 'other_sub') ) ; $call_inner = 0+ # Need to call &inner ( ($inner_type eq 'anon') && ($within eq 'other_sub') ) ; $call_outer = 0+ # Need to call &outer or &$outer ( ($inner_type eq 'anon') && ($within ne 'other_sub') ) ; $undef_outer = 0+ # $outer is created but unused ( ($where_declared eq 'in_anon') && (not $call_outer) ) ; $code = "# This is a test script built by t/op/closure.t\n\n"; print <<"DEBUG_INFO" if $debugging; # inner_type: $inner_type # where_declared: $where_declared # within: $within # nc_attempt: $nc_attempt # call_inner: $call_inner # call_outer: $call_outer # undef_outer: $undef_outer DEBUG_INFO $code .= <<"END_MARK_ONE"; BEGIN { \$SIG{__WARN__} = sub { my \$msg = \$_[0]; END_MARK_ONE $code .= <<"END_MARK_TWO" if $nc_attempt; return if index(\$msg, 'will not stay shared') != -1; return if index(\$msg, 'is not available') != -1; END_MARK_TWO $code .= <<"END_MARK_THREE"; # Backwhack a lot! print "not ok: got unexpected warning \$msg\\n"; } } { my \$test = $test; sub test (&) { my \$ok = &{\$_[0]}; print \$ok ? "ok \$test\n" : "not ok \$test\n"; printf "# Failed at line %d\n", (caller)[2] unless \$ok; \$test++; } } # some of the variables which the closure will access \$global_scalar = 1000; \@global_array = (2000, 2100, 2200, 2300); %global_hash = 3000..3009; my \$fs_scalar = 4000; my \@fs_array = (5000, 5100, 5200, 5300); my %fs_hash = 6000..6009; END_MARK_THREE if ($where_declared eq 'filescope') { # Nothing here } elsif ($where_declared eq 'in_named') { $code .= <<'END'; sub outer { my $sub_scalar = 7000; my @sub_array = (8000, 8100, 8200, 8300); my %sub_hash = 9000..9009; END # } } elsif ($where_declared eq 'in_anon') { $code .= <<'END'; $outer = sub { my $sub_scalar = 7000; my @sub_array = (8000, 8100, 8200, 8300); my %sub_hash = 9000..9009; END # } } else { die "What was $where_declared?" } if ($within eq 'foreach') { $code .= " my \$foreach = 12000; my \@list = (10000, 10010); foreach \$foreach (\@list) { " # } } elsif ($within eq 'naked') { $code .= " { # naked block\n" # } } elsif ($within eq 'other_sub') { $code .= " sub inner_sub {\n" # } } else { die "What was $within?" } $sub_test = $test; @inners = ( qw!global_scalar global_array global_hash! , qw!fs_scalar fs_array fs_hash! ); push @inners, 'foreach' if $within eq 'foreach'; if ($where_declared ne 'filescope') { push @inners, qw!sub_scalar sub_array sub_hash!; } for $inner_sub_test (@inners) { if ($inner_type eq 'named') { $code .= " sub named_$sub_test " } elsif ($inner_type eq 'anon') { $code .= " \$anon_$sub_test = sub " } else { die "What was $inner_type?" } # Now to write the body of the test sub if ($inner_sub_test eq 'global_scalar') { $code .= '{ ++$global_scalar }' } elsif ($inner_sub_test eq 'fs_scalar') { $code .= '{ ++$fs_scalar }' } elsif ($inner_sub_test eq 'sub_scalar') { $code .= '{ ++$sub_scalar }' } elsif ($inner_sub_test eq 'global_array') { $code .= '{ ++$global_array[1] }' } elsif ($inner_sub_test eq 'fs_array') { $code .= '{ ++$fs_array[1] }' } elsif ($inner_sub_test eq 'sub_array') { $code .= '{ ++$sub_array[1] }' } elsif ($inner_sub_test eq 'global_hash') { $code .= '{ ++$global_hash{3002} }' } elsif ($inner_sub_test eq 'fs_hash') { $code .= '{ ++$fs_hash{6002} }' } elsif ($inner_sub_test eq 'sub_hash') { $code .= '{ ++$sub_hash{9002} }' } elsif ($inner_sub_test eq 'foreach') { $code .= '{ ++$foreach }' } else { die "What was $inner_sub_test?" } # Close up if ($inner_type eq 'anon') { $code .= ';' } $code .= "\n"; $sub_test++; # sub name sequence number } # End of foreach $inner_sub_test # Close up $within block # { $code .= " }\n\n"; # Close up $where_declared block if ($where_declared eq 'in_named') { # { $code .= "}\n\n"; } elsif ($where_declared eq 'in_anon') { # { $code .= "};\n\n"; } # We may need to do something with the sub we just made... $code .= "undef \$outer;\n" if $undef_outer; $code .= "&inner_sub;\n" if $call_inner; if ($call_outer) { if ($where_declared eq 'in_named') { $code .= "&outer;\n\n"; } elsif ($where_declared eq 'in_anon') { $code .= "&\$outer;\n\n" } } # Now, we can actually prep to run the tests. for $inner_sub_test (@inners) { $expected = $expected{$inner_sub_test} or die "expected $inner_sub_test missing"; # Named closures won't access the expected vars if ( $nc_attempt and substr($inner_sub_test, 0, 4) eq "sub_" ) { $expected = 1; } # If you make a sub within a foreach loop, # what happens if it tries to access the # foreach index variable? If it's a named # sub, it gets the var from "outside" the loop, # but if it's anon, it gets the value to which # the index variable is aliased. # # Of course, if the value was set only # within another sub which was never called, # the value has not been set yet. # if ($inner_sub_test eq 'foreach') { if ($inner_type eq 'named') { if ($call_outer || ($where_declared eq 'filescope')) { $expected = 12001 } else { $expected = 1 } } } # Here's the test: if ($inner_type eq 'anon') { $code .= "test { &\$anon_$test == $expected };\n" } else { $code .= "test { &named_$test == $expected };\n" } $test++; } if ($Config{d_fork} and $^O ne 'VMS' and $^O ne 'MSWin32' and $^O ne 'NetWare') { # Fork off a new perl to run the tests. # (This is so we can catch spurious warnings.) $| = 1; print ""; $| = 0; # flush output before forking pipe READ, WRITE or die "Can't make pipe: $!"; pipe READ2, WRITE2 or die "Can't make second pipe: $!"; die "Can't fork: $!" unless defined($pid = open PERL, "|-"); unless ($pid) { # Child process here. We're going to send errors back # through the extra pipe. close READ; close READ2; open STDOUT, ">&WRITE" or die "Can't redirect STDOUT: $!"; open STDERR, ">&WRITE2" or die "Can't redirect STDERR: $!"; exec which_perl(), '-w', '-' or die "Can't exec perl: $!"; } else { # Parent process here. close WRITE; close WRITE2; print PERL $code; close PERL; { local $/; $output = join '', ; $errors = join '', ; } close READ; close READ2; } } else { # No fork(). Do it the hard way. my $cmdfile = tempfile(); my $errfile = tempfile(); open CMD, ">$cmdfile"; print CMD $code; close CMD; my $cmd = which_perl(); $cmd .= " -w $cmdfile 2>$errfile"; if ($^O eq 'VMS' or $^O eq 'MSWin32' or $^O eq 'NetWare') { # Use pipe instead of system so we don't inherit STD* from # this process, and then foul our pipe back to parent by # redirecting output in the child. open PERL,"$cmd |" or die "Can't open pipe: $!\n"; { local $/; $output = join '', } close PERL; } else { my $outfile = tempfile(); system "$cmd >$outfile"; { local $/; open IN, $outfile; $output = ; close IN } } if ($?) { printf "not ok: exited with error code %04X\n", $?; exit; } { local $/; open IN, $errfile; $errors = ; close IN } } print $output; print STDERR $errors; if ($debugging && ($errors || $? || ($output =~ /not ok/))) { my $lnum = 0; for $line (split '\n', $code) { printf "%3d: %s\n", ++$lnum, $line; } } printf "not ok: exited with error code %04X\n", $? if $?; print '#', "-" x 30, "\n" if $debugging; } # End of foreach $within } # End of foreach $where_declared } # End of foreach $inner_type } # The following dumps core with perl <= 5.8.0 (bugid 9535) ... BEGIN { $vanishing_pad = sub { eval $_[0] } } $some_var = 123; test { $vanishing_pad->( '$some_var' ) == 123 }; # ... and here's another coredump variant - this time we explicitly # delete the sub rather than using a BEGIN ... sub deleteme { $a = sub { eval '$newvar' } } deleteme(); *deleteme = sub {}; # delete the sub $newvar = 123; # realloc the SV of the freed CV test { $a->() == 123 }; # ... and a further coredump variant - the fixup of the anon sub's # CvOUTSIDE pointer when the middle eval is freed, wasn't good enough to # survive the outer eval also being freed. $x = 123; $a = eval q( eval q[ sub { eval '$x' } ] ); @a = ('\1\1\1\1\1\1\1') x 100; # realloc recently-freed CVs test { $a->() == 123 }; # this coredumped on <= 5.8.0 because evaling the closure caused # an SvFAKE to be added to the outer anon's pad, which was then grown. my $outer; sub { my $x; $x = eval 'sub { $outer }'; $x->(); $a = [ 99 ]; $x->(); }->(); test {1}; # [perl #17605] found that an empty block called in scalar context # can lead to stack corruption { my $x = "foooobar"; $x =~ s/o//eg; test { $x eq 'fbar' } } # DAPM 24-Nov-02 # SvFAKE lexicals should be visible thoughout a function. # On <= 5.8.0, the third test failed, eg bugid #18286 { my $x = 1; sub fake { test { sub {eval'$x'}->() == 1 }; { $x; test { sub {eval'$x'}->() == 1 } } test { sub {eval'$x'}->() == 1 }; } } fake(); # undefining a sub shouldn't alter visibility of outer lexicals { $x = 1; my $x = 2; sub tmp { sub { eval '$x' } } my $a = tmp(); undef &tmp; test { $a->() == 2 }; } # handy class: $x = Watch->new(\$foo,'bar') # causes 'bar' to be appended to $foo when $x is destroyed sub Watch::new { bless [ $_[1], $_[2] ], $_[0] } sub Watch::DESTROY { ${$_[0][0]} .= $_[0][1] } # bugid 1028: # nested anon subs (and associated lexicals) not freed early enough sub linger { my $x = Watch->new($_[0], '2'); sub { $x; my $y; sub { $y; }; }; } { my $watch = '1'; linger(\$watch); test { $watch eq '12' } } # bugid 10085 # obj not freed early enough sub linger2 { my $obj = Watch->new($_[0], '2'); sub { sub { $obj } }; } { my $watch = '1'; linger2(\$watch); test { $watch eq '12' } } # bugid 16302 - named subs didn't capture lexicals on behalf of inner subs { my $x = 1; sub f16302 { sub { test { defined $x and $x == 1 } }->(); } } f16302(); # The presence of an eval should turn cloneless anon subs into clonable # subs - otherwise the CvOUTSIDE of that sub may be wrong { my %a; for my $x (7,11) { $a{$x} = sub { $x=$x; sub { eval '$x' } }; } test { $a{7}->()->() + $a{11}->()->() == 18 }; } { # bugid #23265 - this used to coredump during destruction of PL_maincv # and its children my $progfile = "b23265.pl"; open(T, ">$progfile") or die "$0: $!\n"; print T << '__EOF__'; print sub {$_[0]->(@_)} -> ( sub { $_[1] ? $_[0]->($_[0], $_[1] - 1) . sub {"x"}->() : "y" }, 2 ) , "\n" ; __EOF__ close T; my $got = runperl(progfile => $progfile); test { chomp $got; $got eq "yxx" }; END { 1 while unlink $progfile } } { # bugid #24914 = used to coredump restoring PL_comppad in the # savestack, due to the early freeing of the anon closure my $got = runperl(stderr => 1, prog => 'sub d {die} my $f; $f = sub {my $x=1; $f = 0; d}; eval{$f->()}; print qq(ok\n)' ); test { $got eq "ok\n" }; } # After newsub is redefined outside the BEGIN, it's CvOUTSIDE should point # to main rather than BEGIN, and BEGIN should be freed. { my $flag = 0; sub X::DESTROY { $flag = 1 } { my $x; BEGIN {$x = \&newsub } sub newsub {}; $x = bless {}, 'X'; } test { $flag == 1 }; } # don't copy a stale lexical; crate a fresh undef one instead sub f { my $x if $_[0]; sub { \$x } } { f(1); my $c1= f(0); my $c2= f(0); my $r1 = $c1->(); my $r2 = $c2->(); test { $r1 != $r2 }; } perl-5.12.0-RC0/t/op/auto.t0000555000175000017500000000426211325127001014142 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = qw(. ../lib); } require "test.pl"; plan( tests => 39 ); $x = 10000; cmp_ok(0 + ++$x - 1,'==',10000,'scalar ++x - 1'); cmp_ok(0 + $x-- - 1,'==',10000,'scalar x-- - 1'); cmp_ok(1 * $x, '==',10000,'scalar 1 * x'); cmp_ok(0 + $x-- - 0,'==',10000,'scalar x-- - 0'); cmp_ok(1 + $x, '==',10000,'scalar 1 + x'); cmp_ok(1 + $x++, '==',10000,'scalar 1 + x++'); cmp_ok(0 + $x, '==',10000,'scalar x'); cmp_ok(0 + --$x + 1,'==',10000,'scalar --x + 1'); cmp_ok(0 + ++$x + 0,'==',10000,'scalar ++x + 0'); cmp_ok($x, '==',10000,'scalar x final'); $x[0] = 10000; cmp_ok(0 + ++$x[0] - 1,'==',10000,'aelem ++x - 1'); cmp_ok(0 + $x[0]-- - 1,'==',10000,'aelem x-- - 1'); cmp_ok(1 * $x[0], '==',10000,'aelem 1 * x'); cmp_ok(0 + $x[0]-- - 0,'==',10000,'aelem x-- - 0'); cmp_ok(1 + $x[0], '==',10000,'aelem 1 + x'); cmp_ok(1 + $x[0]++, '==',10000,'aelem 1 + x++'); cmp_ok(0 + $x[0], '==',10000,'aelem x'); cmp_ok(0 + --$x[0] + 1,'==',10000,'aelem --x + 1'); cmp_ok(0 + ++$x[0] + 0,'==',10000,'aelem ++x + 0'); cmp_ok($x[0], '==',10000,'aelem x final'); $x{0} = 10000; cmp_ok(0 + ++$x{0} - 1,'==',10000,'helem ++x - 1'); cmp_ok(0 + $x{0}-- - 1,'==',10000,'helem x-- - 1'); cmp_ok(1 * $x{0}, '==',10000,'helem 1 * x'); cmp_ok(0 + $x{0}-- - 0,'==',10000,'helem x-- - 0'); cmp_ok(1 + $x{0}, '==',10000,'helem 1 + x'); cmp_ok(1 + $x{0}++, '==',10000,'helem 1 + x++'); cmp_ok(0 + $x{0}, '==',10000,'helem x'); cmp_ok(0 + --$x{0} + 1,'==',10000,'helem --x + 1'); cmp_ok(0 + ++$x{0} + 0,'==',10000,'helem ++x + 0'); cmp_ok($x{0}, '==',10000,'helem x final'); # test magical autoincrement cmp_ok(++($foo = '99'), 'eq','100','99 incr 100'); cmp_ok(++($foo = "99a"), 'eq','100','99a incr 100'); cmp_ok(++($foo = "99\0a"), 'eq','100','99\0a incr 100'); cmp_ok(++($foo = 'a0'), 'eq','a1','a0 incr a1'); cmp_ok(++($foo = 'Az'), 'eq','Ba','Az incr Ba'); cmp_ok(++($foo = 'zz'), 'eq','aaa','zzz incr aaa'); cmp_ok(++($foo = 'A99'),'eq','B00','A99 incr B00'); cmp_ok(++($foo = 'zi'), 'eq','zj','zi incr zj (EBCDIC i,j non-contiguous check)'); cmp_ok(++($foo = 'zr'), 'eq','zs','zr incr zs (EBCDIC r,s non-contiguous check)'); perl-5.12.0-RC0/t/op/quotemeta.t0000555000175000017500000000346111325125742015210 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = qw(../lib .); require Config; import Config; require "test.pl"; } plan tests => 22; if ($Config{ebcdic} eq 'define') { $_ = join "", map chr($_), 129..233; # 105 characters - 52 letters = 53 backslashes # 105 characters + 53 backslashes = 158 characters $_ = quotemeta $_; is(length($_), 158, "quotemeta string"); # 104 non-backslash characters is(tr/\\//cd, 104, "tr count non-backslashed"); } else { # some ASCII descendant, then. $_ = join "", map chr($_), 32..127; # 96 characters - 52 letters - 10 digits - 1 underscore = 33 backslashes # 96 characters + 33 backslashes = 129 characters $_ = quotemeta $_; is(length($_), 129, "quotemeta string"); # 95 non-backslash characters is(tr/\\//cd, 95, "tr count non-backslashed"); } is(length(quotemeta ""), 0, "quotemeta empty string"); is("aA\UbB\LcC\EdD", "aABBccdD", 'aA\UbB\LcC\EdD'); is("aA\LbB\UcC\EdD", "aAbbCCdD", 'aA\LbB\UcC\EdD'); is("\L\upERL", "Perl", '\L\upERL'); is("\u\LpERL", "Perl", '\u\LpERL'); is("\U\lPerl", "pERL", '\U\lPerl'); is("\l\UPerl", "pERL", '\l\UPerl'); is("\u\LpE\Q#X#\ER\EL", "Pe\\#x\\#rL", '\u\LpE\Q#X#\ER\EL'); is("\l\UPe\Q!x!\Er\El", "pE\\!X\\!Rl", '\l\UPe\Q!x!\Er\El'); is("\Q\u\LpE.X.R\EL\E.", "Pe\\.x\\.rL.", '\Q\u\LpE.X.R\EL\E.'); is("\Q\l\UPe*x*r\El\E*", "pE\\*X\\*Rl*", '\Q\l\UPe*x*r\El\E*'); is("\U\lPerl\E\E\E\E", "pERL", '\U\lPerl\E\E\E\E'); is("\l\UPerl\E\E\E\E", "pERL", '\l\UPerl\E\E\E\E'); is(quotemeta("\x{263a}"), "\x{263a}", "quotemeta Unicode"); is(length(quotemeta("\x{263a}")), 1, "quotemeta Unicode length"); $a = "foo|bar"; is("a\Q\Ec$a", "acfoo|bar", '\Q\E'); is("a\L\Ec$a", "acfoo|bar", '\L\E'); is("a\l\Ec$a", "acfoo|bar", '\l\E'); is("a\U\Ec$a", "acfoo|bar", '\U\E'); is("a\u\Ec$a", "acfoo|bar", '\u\E'); perl-5.12.0-RC0/t/op/bop.t0000555000175000017500000002704111325125742013764 0ustar jessejesse#!./perl # # test the bit operators '&', '|', '^', '~', '<<', and '>>' # BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require "./test.pl"; require Config; } # Tests don't have names yet. # If you find tests are failing, please try adding names to tests to track # down where the failure is, and supply your new names as a patch. # (Just-in-time test naming) plan tests => 161 + (10*13*2) + 4; # numerics ok ((0xdead & 0xbeef) == 0x9ead); ok ((0xdead | 0xbeef) == 0xfeef); ok ((0xdead ^ 0xbeef) == 0x6042); ok ((~0xdead & 0xbeef) == 0x2042); # shifts ok ((257 << 7) == 32896); ok ((33023 >> 7) == 257); # signed vs. unsigned ok ((~0 > 0 && do { use integer; ~0 } == -1)); my $bits = 0; for (my $i = ~0; $i; $i >>= 1) { ++$bits; } my $cusp = 1 << ($bits - 1); ok (($cusp & -1) > 0 && do { use integer; $cusp & -1 } < 0); ok (($cusp | 1) > 0 && do { use integer; $cusp | 1 } < 0); ok (($cusp ^ 1) > 0 && do { use integer; $cusp ^ 1 } < 0); ok ((1 << ($bits - 1)) == $cusp && do { use integer; 1 << ($bits - 1) } == -$cusp); ok (($cusp >> 1) == ($cusp / 2) && do { use integer; abs($cusp >> 1) } == ($cusp / 2)); $Aaz = chr(ord("A") & ord("z")); $Aoz = chr(ord("A") | ord("z")); $Axz = chr(ord("A") ^ ord("z")); # short strings is (("AAAAA" & "zzzzz"), ($Aaz x 5)); is (("AAAAA" | "zzzzz"), ($Aoz x 5)); is (("AAAAA" ^ "zzzzz"), ($Axz x 5)); # long strings $foo = "A" x 150; $bar = "z" x 75; $zap = "A" x 75; # & truncates is (($foo & $bar), ($Aaz x 75 )); # | does not truncate is (($foo | $bar), ($Aoz x 75 . $zap)); # ^ does not truncate is (($foo ^ $bar), ($Axz x 75 . $zap)); # is ("ok \xFF\xFF\n" & "ok 19\n", "ok 19\n"); is ("ok 20\n" | "ok \0\0\n", "ok 20\n"); is ("o\000 \0001\000" ^ "\000k\0002\000\n", "ok 21\n"); # is ("ok \x{FF}\x{FF}\n" & "ok 22\n", "ok 22\n"); is ("ok 23\n" | "ok \x{0}\x{0}\n", "ok 23\n"); is ("o\x{0} \x{0}4\x{0}" ^ "\x{0}k\x{0}2\x{0}\n", "ok 24\n"); # is (sprintf("%vd", v4095 & v801), 801); is (sprintf("%vd", v4095 | v801), 4095); is (sprintf("%vd", v4095 ^ v801), 3294); # is (sprintf("%vd", v4095.801.4095 & v801.4095), '801.801'); is (sprintf("%vd", v4095.801.4095 | v801.4095), '4095.4095.4095'); is (sprintf("%vd", v801.4095 ^ v4095.801.4095), '3294.3294.4095'); # is (sprintf("%vd", v120.300 & v200.400), '72.256'); is (sprintf("%vd", v120.300 | v200.400), '248.444'); is (sprintf("%vd", v120.300 ^ v200.400), '176.188'); # my $a = v120.300; my $b = v200.400; $a ^= $b; is (sprintf("%vd", $a), '176.188'); my $a = v120.300; my $b = v200.400; $a |= $b; is (sprintf("%vd", $a), '248.444'); # # UTF8 ~ behaviour # my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0; my @not36; for (0x100...0xFFF) { $a = ~(chr $_); if ($Is_EBCDIC) { push @not36, sprintf("%#03X", $_) if $a ne chr(~$_) or length($a) != 1; } else { push @not36, sprintf("%#03X", $_) if $a ne chr(~$_) or length($a) != 1 or ~$a ne chr($_); } } is (join (', ', @not36), ''); my @not37; for my $i (0xEEE...0xF00) { for my $j (0x0..0x120) { $a = ~(chr ($i) . chr $j); if ($Is_EBCDIC) { push @not37, sprintf("%#03X %#03X", $i, $j) if $a ne chr(~$i).chr(~$j) or length($a) != 2; } else { push @not37, sprintf("%#03X %#03X", $i, $j) if $a ne chr(~$i).chr(~$j) or length($a) != 2 or ~$a ne chr($i).chr($j); } } } is (join (', ', @not37), ''); SKIP: { skip "EBCDIC" if $Is_EBCDIC; is (~chr(~0), "\0"); } my @not39; for my $i (0x100..0x120) { for my $j (0x100...0x120) { push @not39, sprintf("%#03X %#03X", $i, $j) if ~(chr($i)|chr($j)) ne (~chr($i)&~chr($j)); } } is (join (', ', @not39), ''); my @not40; for my $i (0x100..0x120) { for my $j (0x100...0x120) { push @not40, sprintf("%#03X %#03X", $i, $j) if ~(chr($i)&chr($j)) ne (~chr($i)|~chr($j)); } } is (join (', ', @not40), ''); # More variations on 19 and 22. is ("ok \xFF\x{FF}\n" & "ok 41\n", "ok 41\n"); is ("ok \x{FF}\xFF\n" & "ok 42\n", "ok 42\n"); # Tests to see if you really can do casts negative floats to unsigned properly $neg1 = -1.0; ok (~ $neg1 == 0); $neg7 = -7.0; ok (~ $neg7 == 6); # double magic tests sub TIESCALAR { bless { value => $_[1], orig => $_[1] } } sub STORE { $_[0]{store}++; $_[0]{value} = $_[1] } sub FETCH { $_[0]{fetch}++; $_[0]{value} } sub stores { tied($_[0])->{value} = tied($_[0])->{orig}; delete(tied($_[0])->{store}) || 0 } sub fetches { delete(tied($_[0])->{fetch}) || 0 } # numeric double magic tests tie $x, "main", 1; tie $y, "main", 3; is(($x | $y), 3); is(fetches($x), 1); is(fetches($y), 1); is(stores($x), 0); is(stores($y), 0); is(($x & $y), 1); is(fetches($x), 1); is(fetches($y), 1); is(stores($x), 0); is(stores($y), 0); is(($x ^ $y), 2); is(fetches($x), 1); is(fetches($y), 1); is(stores($x), 0); is(stores($y), 0); is(($x |= $y), 3); is(fetches($x), 2); is(fetches($y), 1); is(stores($x), 1); is(stores($y), 0); is(($x &= $y), 1); is(fetches($x), 2); is(fetches($y), 1); is(stores($x), 1); is(stores($y), 0); is(($x ^= $y), 2); is(fetches($x), 2); is(fetches($y), 1); is(stores($x), 1); is(stores($y), 0); is(~~$y, 3); is(fetches($y), 1); is(stores($y), 0); { use integer; is(($x | $y), 3); is(fetches($x), 1); is(fetches($y), 1); is(stores($x), 0); is(stores($y), 0); is(($x & $y), 1); is(fetches($x), 1); is(fetches($y), 1); is(stores($x), 0); is(stores($y), 0); is(($x ^ $y), 2); is(fetches($x), 1); is(fetches($y), 1); is(stores($x), 0); is(stores($y), 0); is(($x |= $y), 3); is(fetches($x), 2); is(fetches($y), 1); is(stores($x), 1); is(stores($y), 0); is(($x &= $y), 1); is(fetches($x), 2); is(fetches($y), 1); is(stores($x), 1); is(stores($y), 0); is(($x ^= $y), 2); is(fetches($x), 2); is(fetches($y), 1); is(stores($x), 1); is(stores($y), 0); is(~$y, -4); is(fetches($y), 1); is(stores($y), 0); } # end of use integer; # stringwise double magic tests tie $x, "main", "a"; tie $y, "main", "c"; is(($x | $y), ("a" | "c")); is(fetches($x), 1); is(fetches($y), 1); is(stores($x), 0); is(stores($y), 0); is(($x & $y), ("a" & "c")); is(fetches($x), 1); is(fetches($y), 1); is(stores($x), 0); is(stores($y), 0); is(($x ^ $y), ("a" ^ "c")); is(fetches($x), 1); is(fetches($y), 1); is(stores($x), 0); is(stores($y), 0); is(($x |= $y), ("a" | "c")); is(fetches($x), 2); is(fetches($y), 1); is(stores($x), 1); is(stores($y), 0); is(($x &= $y), ("a" & "c")); is(fetches($x), 2); is(fetches($y), 1); is(stores($x), 1); is(stores($y), 0); is(($x ^= $y), ("a" ^ "c")); is(fetches($x), 2); is(fetches($y), 1); is(stores($x), 1); is(stores($y), 0); is(~~$y, "c"); is(fetches($y), 1); is(stores($y), 0); $a = "\0\x{100}"; chop($a); ok(utf8::is_utf8($a)); # make sure UTF8 flag is still there $a = ~$a; is($a, "\xFF", "~ works with utf-8"); # [rt.perl.org 33003] # This would cause a segfault without malloc wrap SKIP: { skip "No malloc wrap checks" unless $Config::Config{usemallocwrap}; like( runperl(prog => 'eval q($#a>>=1); print 1'), "^1\n?" ); } # [perl #37616] Bug in &= (string) and/or m// { $a = "aa"; $a &= "a"; ok($a =~ /a+$/, 'ASCII "a" is NUL-terminated'); $b = "bb\x{100}"; $b &= "b"; ok($b =~ /b+$/, 'Unicode "b" is NUL-terminated'); } { $a = chr(0x101) x 0x101; $b = chr(0x0FF) x 0x0FF; $c = $a | $b; is($c, chr(0x1FF) x 0xFF . chr(0x101) x 2); $c = $b | $a; is($c, chr(0x1FF) x 0xFF . chr(0x101) x 2); $c = $a & $b; is($c, chr(0x001) x 0x0FF); $c = $b & $a; is($c, chr(0x001) x 0x0FF); $c = $a ^ $b; is($c, chr(0x1FE) x 0x0FF . chr(0x101) x 2); $c = $b ^ $a; is($c, chr(0x1FE) x 0x0FF . chr(0x101) x 2); } { $a = chr(0x101) x 0x101; $b = chr(0x0FF) x 0x0FF; $a |= $b; is($a, chr(0x1FF) x 0xFF . chr(0x101) x 2); } { $a = chr(0x101) x 0x101; $b = chr(0x0FF) x 0x0FF; $b |= $a; is($b, chr(0x1FF) x 0xFF . chr(0x101) x 2); } { $a = chr(0x101) x 0x101; $b = chr(0x0FF) x 0x0FF; $a &= $b; is($a, chr(0x001) x 0x0FF); } { $a = chr(0x101) x 0x101; $b = chr(0x0FF) x 0x0FF; $b &= $a; is($b, chr(0x001) x 0x0FF); } { $a = chr(0x101) x 0x101; $b = chr(0x0FF) x 0x0FF; $a ^= $b; is($a, chr(0x1FE) x 0x0FF . chr(0x101) x 2); } { $a = chr(0x101) x 0x101; $b = chr(0x0FF) x 0x0FF; $b ^= $a; is($b, chr(0x1FE) x 0x0FF . chr(0x101) x 2); } # update to pp_complement() via Coverity SKIP: { # UTF-EBCDIC is limited to 0x7fffffff and can't encode ~0. skip "EBCDIC" if $Is_EBCDIC; my $str = "\x{10000}\x{800}"; # U+10000 is four bytes in UTF-8/UTF-EBCDIC. # U+0800 is three bytes in UTF-8/UTF-EBCDIC. no warnings "utf8"; { use bytes; $str =~ s/\C\C\z//; } # it's really bogus that (~~malformed) is \0. my $ref = "\x{10000}\0"; is(~~$str, $ref); } # ref tests my %res; for my $str ("x", "\x{100}") { for my $chr (qw/S A H G X ( * F/) { for my $op (qw/| & ^/) { my $co = ord $chr; my $so = ord $str; $res{"$chr$op$str"} = eval qq/chr($co $op $so)/; } } $res{"undef|$str"} = $str; $res{"undef&$str"} = ""; $res{"undef^$str"} = $str; } sub PVBM () { "X" } index "foo", PVBM; my $warn = 0; local $^W = 1; local $SIG{__WARN__} = sub { $warn++ }; sub is_first { my ($got, $orig, $op, $str, $name) = @_; is(substr($got, 0, 1), $res{"$orig$op$str"}, $name); } for ( # [object to test, first char of stringification, name] [undef, "undef", "undef" ], [\1, "S", "scalar ref" ], [[], "A", "array ref" ], [{}, "H", "hash ref" ], [qr/x/, "(", "qr//" ], [*foo, "*", "glob" ], [\*foo, "G", "glob ref" ], [PVBM, "X", "PVBM" ], [\PVBM, "S", "PVBM ref" ], [bless([], "Foo"), "F", "object" ], ) { my ($val, $orig, $type) = @$_; for (["x", "string"], ["\x{100}", "utf8"]) { my ($str, $desc) = @$_; $warn = 0; is_first($val | $str, $orig, "|", $str, "$type | $desc"); is_first($val & $str, $orig, "&", $str, "$type & $desc"); is_first($val ^ $str, $orig, "^", $str, "$type ^ $desc"); is_first($str | $val, $orig, "|", $str, "$desc | $type"); is_first($str & $val, $orig, "&", $str, "$desc & $type"); is_first($str ^ $val, $orig, "^", $str, "$desc ^ $type"); my $new; ($new = $val) |= $str; is_first($new, $orig, "|", $str, "$type |= $desc"); ($new = $val) &= $str; is_first($new, $orig, "&", $str, "$type &= $desc"); ($new = $val) ^= $str; is_first($new, $orig, "^", $str, "$type ^= $desc"); ($new = $str) |= $val; is_first($new, $orig, "|", $str, "$desc |= $type"); ($new = $str) &= $val; is_first($new, $orig, "&", $str, "$desc &= $type"); ($new = $str) ^= $val; is_first($new, $orig, "^", $str, "$desc ^= $type"); if ($orig eq "undef") { # undef |= and undef ^= don't warn is($warn, 10, "no duplicate warnings"); } else { is($warn, 0, "no warnings"); } } } my $strval; { package Bar; use overload q/""/ => sub { $strval }; package Baz; use overload q/|/ => sub { "y" }; } ok(!eval { bless([], "Bar") | "x"; 1 }, "string overload can't use |"); like($@, qr/no method found/, "correct error"); is(eval { bless([], "Baz") | "x" }, "y", "| overload works"); my $obj = bless [], "Bar"; $strval = "x"; eval { $obj |= "Q" }; $strval = "z"; is("$obj", "z", "|= doesn't break string overload"); perl-5.12.0-RC0/t/op/each.t0000555000175000017500000001321011325127001014063 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } plan tests => 52; $h{'abc'} = 'ABC'; $h{'def'} = 'DEF'; $h{'jkl','mno'} = "JKL\034MNO"; $h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); $h{'a'} = 'A'; $h{'b'} = 'B'; $h{'c'} = 'C'; $h{'d'} = 'D'; $h{'e'} = 'E'; $h{'f'} = 'F'; $h{'g'} = 'G'; $h{'h'} = 'H'; $h{'i'} = 'I'; $h{'j'} = 'J'; $h{'k'} = 'K'; $h{'l'} = 'L'; $h{'m'} = 'M'; $h{'n'} = 'N'; $h{'o'} = 'O'; $h{'p'} = 'P'; $h{'q'} = 'Q'; $h{'r'} = 'R'; $h{'s'} = 'S'; $h{'t'} = 'T'; $h{'u'} = 'U'; $h{'v'} = 'V'; $h{'w'} = 'W'; $h{'x'} = 'X'; $h{'y'} = 'Y'; $h{'z'} = 'Z'; @keys = keys %h; @values = values %h; is ($#keys, 29, "keys"); is ($#values, 29, "values"); $i = 0; # stop -w complaints while (($key,$value) = each(%h)) { if ($key eq $keys[$i] && $value eq $values[$i] && (('a' lt 'A' && $key lt $value) || $key gt $value)) { $key =~ y/a-z/A-Z/; $i++ if $key eq $value; } } is ($i, 30, "each count"); @keys = ('blurfl', keys(%h), 'dyick'); is ($#keys, 31, "added a key"); $size = ((split('/',scalar %h))[1]); keys %h = $size * 5; $newsize = ((split('/',scalar %h))[1]); is ($newsize, $size * 8, "resize"); keys %h = 1; $size = ((split('/',scalar %h))[1]); is ($size, $newsize, "same size"); %h = (1,1); $size = ((split('/',scalar %h))[1]); is ($size, $newsize, "still same size"); undef %h; %h = (1,1); $size = ((split('/',scalar %h))[1]); is ($size, 8, "size 8"); # test scalar each %hash = 1..20; $total = 0; $total += $key while $key = each %hash; is ($total, 100, "test scalar each"); for (1..3) { @foo = each %hash } keys %hash; $total = 0; $total += $key while $key = each %hash; is ($total, 100, "test scalar keys resets iterator"); for (1..3) { @foo = each %hash } $total = 0; $total += $key while $key = each %hash; isnt ($total, 100, "test iterator of each is being maintained"); for (1..3) { @foo = each %hash } values %hash; $total = 0; $total += $key while $key = each %hash; is ($total, 100, "test values keys resets iterator"); $size = (split('/', scalar %hash))[1]; keys(%hash) = $size / 2; is ($size, (split('/', scalar %hash))[1]); keys(%hash) = $size + 100; isnt ($size, (split('/', scalar %hash))[1]); is (keys(%hash), 10, "keys (%hash)"); { no warnings 'deprecated'; is (keys(hash), 10, "keys (hash)"); } $i = 0; %h = (a => A, b => B, c=> C, d => D, abc => ABC); { no warnings 'deprecated'; @keys = keys(h); @values = values(h); while (($key, $value) = each(h)) { if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { $i++; } } } is ($i, 5); @tests = (&next_test, &next_test, &next_test); { package Obj; sub DESTROY { print "ok $::tests[1] # DESTROY called\n"; } { my $h = { A => bless [], __PACKAGE__ }; while (my($k,$v) = each %$h) { print "ok $::tests[0]\n" if $k eq 'A' and ref($v) eq 'Obj'; } } print "ok $::tests[2]\n"; } # Check for Unicode hash keys. %u = ("\x{12}", "f", "\x{123}", "fo", "\x{1234}", "foo"); $u{"\x{12345}"} = "bar"; @u{"\x{10FFFD}"} = "zap"; my %u2; foreach (keys %u) { is (length(), 1, "Check length of " . _qq $_); $u2{$_} = $u{$_}; } ok (eq_hash(\%u, \%u2), "copied unicode hash keys correctly?"); $a = "\xe3\x81\x82"; $A = "\x{3042}"; %b = ( $a => "non-utf8"); %u = ( $A => "utf8"); is (exists $b{$A}, '', "utf8 key in bytes hash"); is (exists $u{$a}, '', "bytes key in utf8 hash"); print "# $b{$_}\n" for keys %b; # Used to core dump before change #8056. pass ("if we got here change 8056 worked"); print "# $u{$_}\n" for keys %u; # Used to core dump before change #8056. pass ("change 8056 is thanks to Inaba Hiroto"); # on EBCDIC chars are mapped differently so pick something that needs encoding # there too. $d = pack("U*", 0xe3, 0x81, 0xAF); { use bytes; $ol = bytes::length($d) } cmp_ok ($ol, '>', 3, "check encoding on EBCDIC"); %u = ($d => "downgrade"); for (keys %u) { is (length, 3, "check length"); is ($_, pack("U*", 0xe3, 0x81, 0xAF), "check value"); } { { use bytes; is (bytes::length($d), $ol) } } { my %u; my $u0 = pack("U0U", 0x00FF); my $b0 = "\xC3\xBF"; # 0xCB 0xBF is U+00FF in UTF-8 my $u1 = pack("U0U", 0x0100); my $b1 = "\xC4\x80"; # 0xC4 0x80 is U+0100 in UTF-8 $u{$u0} = 1; $u{$b0} = 2; $u{$u1} = 3; $u{$b1} = 4; is(scalar keys %u, 4, "four different Unicode keys"); is($u{$u0}, 1, "U+00FF -> 1"); is($u{$b0}, 2, "U+00C3 U+00BF -> 2"); is($u{$u1}, 3, "U+0100 -> 3 "); is($u{$b1}, 4, "U+00C4 U+0080 -> 4"); } # test for syntax errors for my $k (qw(each keys values)) { eval $k; like($@, qr/^Not enough arguments for $k/, "$k demands argument"); } { my %foo=(1..10); my ($k,$v); my $count=keys %foo; my ($k1,$v1)=each(%foo); my $yes = 0; if (%foo) { $yes++ } my ($k2,$v2)=each(%foo); my $rest=0; while (each(%foo)) {$rest++}; is($yes,1,"if(%foo) was true"); isnt($k1,$k2,"if(%foo) didnt mess with each (key)"); isnt($v1,$v2,"if(%foo) didnt mess with each (value)"); is($rest,3,"Got the expect number of keys"); my $hsv=1 && %foo; like($hsv,'/',"Got bucket stats from %foo in scalar assignment context"); } { our %foo=(1..10); my ($k,$v); my $count=keys %foo; my ($k1,$v1)=each(%foo); my $yes = 0; if (%foo) { $yes++ } my ($k2,$v2)=each(%foo); my $rest=0; while (each(%foo)) {$rest++}; is($yes,1,"if(%foo) was true"); isnt($k1,$k2,"if(%foo) didnt mess with each (key)"); isnt($v1,$v2,"if(%foo) didnt mess with each (value)"); is($rest,3,"Got the expect number of keys"); my $hsv=1 && %foo; like($hsv,'/',"Got bucket stats from %foo in scalar assignment context"); } perl-5.12.0-RC0/t/op/threads_create.pl0000444000175000017500000000005211325125742016317 0ustar jessejessethreads->create( sub { } )->join; "ok\n"; perl-5.12.0-RC0/t/op/lex_assign.t0000555000175000017500000001627711325125742015351 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } $| = 1; umask 0; $xref = \ ""; $runme = $^X; @a = (1..5); %h = (1..6); $aref = \@a; $href = \%h; open OP, qq{$runme -le "print 'aaa Ok ok' for 1..100"|}; $chopit = 'aaaaaa'; @chopar = (113 .. 119); $posstr = '123456'; $cstr = 'aBcD.eF'; pos $posstr = 3; $nn = $n = 2; sub subb {"in s"} @INPUT = ; @simple_input = grep /^\s*\w+\s*\$\w+\s*[#\n]/, @INPUT; print "1..", (11 + @INPUT + @simple_input), "\n"; $ord = 0; sub wrn {"@_"} # Check correct optimization of ucfirst etc $ord++; my $a = "AB"; my $b = "\u\L$a"; print "not " unless $b eq 'Ab'; print "ok $ord\n"; # Check correct destruction of objects: my $dc = 0; sub A::DESTROY {$dc += 1} $a=8; my $b; { my $c = 6; $b = bless \$c, "A"} $ord++; print "not " unless $dc == 0; print "ok $ord\n"; $b = $a+5; $ord++; print "not " unless $dc == 1; print "ok $ord\n"; $ord++; my $xxx = 'b'; $xxx = 'c' . ($xxx || 'e'); print "not " unless $xxx eq 'cb'; print "ok $ord\n"; { # Check calling STORE my $sc = 0; sub B::TIESCALAR {bless [11], 'B'} sub B::FETCH { -(shift->[0]) } sub B::STORE { $sc++; my $o = shift; $o->[0] = 17 + shift } my $m; tie $m, 'B'; $m = 100; $ord++; print "not " unless $sc == 1; print "ok $ord\n"; my $t = 11; $m = $t + 89; $ord++; print "not " unless $sc == 2; print "ok $ord\n"; $ord++; print "# $m\nnot " unless $m == -117; print "ok $ord\n"; $m += $t; $ord++; print "not " unless $sc == 3; print "ok $ord\n"; $ord++; print "# $m\nnot " unless $m == 89; print "ok $ord\n"; } # Chains of assignments my ($l1, $l2, $l3, $l4); my $zzzz = 12; $zzz1 = $l1 = $l2 = $zzz2 = $l3 = $l4 = 1 + $zzzz; $ord++; print "# $zzz1 = $l1 = $l2 = $zzz2 = $l3 = $l4 = 13\nnot " unless $zzz1 == 13 and $zzz2 == 13 and $l1 == 13 and $l2 == 13 and $l3 == 13 and $l4 == 13; print "ok $ord\n"; for (@INPUT) { $ord++; ($op, undef, $comment) = /^([^\#]+)(\#\s+(.*))?/; $comment = $op unless defined $comment; chomp; $op = "$op==$op" unless $op =~ /==/; ($op, $expectop) = $op =~ /(.*)==(.*)/; $skip = ($op =~ /^'\?\?\?'/ or $comment =~ /skip\(.*\Q$^O\E.*\)/i) ? "skip" : "# '$_'\nnot"; $integer = ($comment =~ /^i_/) ? "use integer" : '' ; (print "#skipping $comment:\nok $ord\n"), next if $skip eq 'skip'; eval < # glob # readline 'faked' # rcatline (@z = (1 .. 3)) # aassign chop $chopit # chop (chop (@x=@chopar)) # schop chomp $chopit # chomp (chop (@x=@chopar)) # schomp pos $posstr # pos pos $chopit # pos returns undef $nn++==2 # postinc $nn++==3 # i_postinc $nn--==4 # postdec $nn--==3 # i_postdec $n ** $n # pow $n * $n # multiply $n * $n # i_multiply $n / $n # divide $n / $n # i_divide $n % $n # modulo $n % $n # i_modulo $n x $n # repeat $n + $n # add $n + $n # i_add $n - $n # subtract $n - $n # i_subtract $n . $n # concat $n . $a=='2fake' # concat with self "3$a"=='3fake' # concat with self in stringify "$n" # stringify $n << $n # left_shift $n >> $n # right_shift $n <=> $n # ncmp $n <=> $n # i_ncmp $n cmp $n # scmp $n & $n # bit_and $n ^ $n # bit_xor $n | $n # bit_or -$n # negate -$n # i_negate ~$n # complement atan2 $n,$n # atan2 sin $n # sin cos $n # cos '???' # rand exp $n # exp log $n # log sqrt $n # sqrt int $n # int hex $n # hex oct $n # oct abs $n # abs length $posstr # length substr $posstr, 2, 2 # substr vec("abc",2,8) # vec index $posstr, 2 # index rindex $posstr, 2 # rindex sprintf "%i%i", $n, $n # sprintf ord $n # ord chr $n # chr crypt $n, $n # crypt ucfirst ($cstr . "a") # ucfirst padtmp ucfirst $cstr # ucfirst lcfirst $cstr # lcfirst uc $cstr # uc lc $cstr # lc quotemeta $cstr # quotemeta @$aref # rv2av @$undefed # rv2av undef (each %h) % 2 == 1 # each values %h # values keys %h # keys %$href # rv2hv pack "C2", $n,$n # pack split /a/, "abad" # split join "a"; @a # join push @a,3==6 # push unshift @aaa # unshift reverse @a # reverse reverse $cstr # reverse - scal grep $_, 1,0,2,0,3 # grepwhile map "x$_", 1,0,2,0,3 # mapwhile subb() # entersub caller # caller warn "ignore this\n" # warn 'faked' # die open BLAH, " 0; } continue { print("not "), last unless $i > 0; } print "ok 23\n"; $j = 5; for (my $i = 0; (my $k = $i) < $j; ++$i) { print("not "), last unless $i >= 0 && $i < $j && $i == $k; } print "ok 24\n"; print "not " if defined $k; print "ok 25\n"; foreach my $i (26, 27) { print "ok $i\n"; } print "not " if $i ne "outer"; print "ok 28\n"; # Ensure that C (without parens) doesn't force scalar context. my @x; { @x = my @y } print +(@x ? "not " : ""), "ok 29\n"; { @x = my %y } print +(@x ? "not " : ""), "ok 30\n"; # Found in HTML::FormatPS my %fonts = qw(nok 31); for my $full (keys %fonts) { $full =~ s/^n//; # Supposed to be copy-on-write via force_normal after a THINKFIRST check. print "$full $fonts{nok}\n"; } # [perl #29340] optimising away the = () left the padav returning the # array rather than the contents, leading to 'Bizarre copy of array' error sub opta { my @a=() } sub opth { my %h=() } eval { my $x = opta }; print "not " if $@; print "ok 32\n"; eval { my $x = opth }; print "not " if $@; print "ok 33\n"; sub foo3 { ++my $x->{foo}; print "not " if defined $x->{bar}; ++$x->{bar}; } eval { foo3(); foo3(); }; print "not " if $@; print "ok 34\n"; # my $foo = undef should always assign [perl #37776] { my $count = 35; loop: my $test = undef; print "not " if defined $test; print "ok $count\n"; $test = 42; goto loop if ++$count < 37; } perl-5.12.0-RC0/t/op/gmagic.t0000555000175000017500000000330211325125742014425 0ustar jessejesse#!./perl -w BEGIN { $| = 1; chdir 't' if -d 't'; @INC = '../lib'; } print "1..20\n"; my $t = 1; tie my $c => 'Tie::Monitor'; sub ok { my($ok, $got, $exp, $rexp, $wexp) = @_; my($rgot, $wgot) = (tied $c)->init(0); print $ok ? "ok $t\n" : "# expected $exp, got $got\nnot ok $t\n"; ++$t; if ($rexp == $rgot && $wexp == $wgot) { print "ok $t\n"; } else { print "# read $rgot expecting $rexp\n" if $rgot != $rexp; print "# wrote $wgot expecting $wexp\n" if $wgot != $wexp; print "not ok $t\n"; } ++$t; } sub ok_undef { ok(!defined($_[0]), shift, "undef", @_) } sub ok_numeric { ok($_[0] == $_[1], @_) } sub ok_string { ok($_[0] eq $_[1], @_) } my($r, $s); # the thing itself ok_numeric($r = $c + 0, 0, 1, 0); ok_string($r = "$c", '0', 1, 0); # concat ok_string($c . 'x', '0x', 1, 0); ok_string('x' . $c, 'x0', 1, 0); $s = $c . $c; ok_string($s, '00', 2, 0); $r = 'x'; $s = $c = $r . 'y'; ok_string($s, 'xy', 1, 1); $s = $c = $c . 'x'; ok_string($s, '0x', 2, 1); $s = $c = 'x' . $c; ok_string($s, 'x0', 2, 1); $s = $c = $c . $c; ok_string($s, '00', 3, 1); # multiple magic in core functions $s = chop($c); ok_string($s, '0', 1, 1); # adapted from Tie::Counter by Abigail package Tie::Monitor; sub TIESCALAR { my($class, $value) = @_; bless { read => 0, write => 0, values => [ 0 ], }; } sub FETCH { my $self = shift; ++$self->{read}; $self->{values}[$#{ $self->{values} }]; } sub STORE { my($self, $value) = @_; ++$self->{write}; push @{ $self->{values} }, $value; } sub init { my $self = shift; my @results = ($self->{read}, $self->{write}); $self->{read} = $self->{write} = 0; $self->{values} = [ 0 ]; @results; } perl-5.12.0-RC0/t/op/tr.t0000555000175000017500000002716011325125742013633 0ustar jessejesse# tr.t BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } plan tests => 119; my $Is_EBCDIC = (ord('i') == 0x89 & ord('J') == 0xd1); $_ = "abcdefghijklmnopqrstuvwxyz"; tr/a-z/A-Z/; is($_, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", 'uc'); tr/A-Z/a-z/; is($_, "abcdefghijklmnopqrstuvwxyz", 'lc'); tr/b-y/B-Y/; is($_, "aBCDEFGHIJKLMNOPQRSTUVWXYz", 'partial uc'); # In EBCDIC 'I' is \xc9 and 'J' is \0xd1, 'i' is \x89 and 'j' is \x91. # Yes, discontinuities. Regardless, the \xca in the below should stay # untouched (and not became \x8a). { no utf8; $_ = "I\xcaJ"; tr/I-J/i-j/; is($_, "i\xcaj", 'EBCDIC discontinuity'); } # ($x = 12) =~ tr/1/3/; (my $y = 12) =~ tr/1/3/; ($f = 1.5) =~ tr/1/3/; (my $g = 1.5) =~ tr/1/3/; is($x + $y + $f + $g, 71, 'tr cancels IOK and NOK'); # perlbug [ID 20000511.005] $_ = 'fred'; /([a-z]{2})/; $1 =~ tr/A-Z//; s/^(\s*)f/$1F/; is($_, 'Fred', 'harmless if explicitly not updating'); # A variant of the above, added in 5.7.2 $_ = 'fred'; /([a-z]{2})/; eval '$1 =~ tr/A-Z/A-Z/;'; s/^(\s*)f/$1F/; is($_, 'Fred', 'harmless if implicitly not updating'); is($@, '', ' no error'); # check tr handles UTF8 correctly ($x = 256.65.258) =~ tr/a/b/; is($x, 256.65.258, 'handles UTF8'); is(length $x, 3); $x =~ tr/A/B/; is(length $x, 3); if (ord("\t") == 9) { # ASCII is($x, 256.66.258); } else { is($x, 256.65.258); } # EBCDIC variants of the above tests ($x = 256.193.258) =~ tr/a/b/; is(length $x, 3); is($x, 256.193.258); $x =~ tr/A/B/; is(length $x, 3); if (ord("\t") == 9) { # ASCII is($x, 256.193.258); } else { is($x, 256.194.258); } { my $l = chr(300); my $r = chr(400); $x = 200.300.400; $x =~ tr/\x{12c}/\x{190}/; is($x, 200.400.400, 'changing UTF8 chars in a UTF8 string, same length'); is(length $x, 3); $x = 200.300.400; $x =~ tr/\x{12c}/\x{be8}/; is($x, 200.3048.400, ' more bytes'); is(length $x, 3); $x = 100.125.60; $x =~ tr/\x{64}/\x{190}/; is($x, 400.125.60, 'Putting UT8 chars into a non-UTF8 string'); is(length $x, 3); $x = 400.125.60; $x =~ tr/\x{190}/\x{64}/; is($x, 100.125.60, 'Removing UTF8 chars from UTF8 string'); is(length $x, 3); $x = 400.125.60.400; $y = $x =~ tr/\x{190}/\x{190}/; is($y, 2, 'Counting UTF8 chars in UTF8 string'); $x = 60.400.125.60.400; $y = $x =~ tr/\x{3c}/\x{3c}/; is($y, 2, ' non-UTF8 chars in UTF8 string'); # 17 - counting UTF8 chars in non-UTF8 string $x = 200.125.60; $y = $x =~ tr/\x{190}/\x{190}/; is($y, 0, ' UTF8 chars in non-UTFs string'); } $_ = "abcdefghijklmnopqrstuvwxyz"; eval 'tr/a-z-9/ /'; like($@, qr/^Ambiguous range in transliteration operator/, 'tr/a-z-9//'); # 19-21: Make sure leading and trailing hyphens still work $_ = "car-rot9"; tr/-a-m/./; is($_, '..r.rot9', 'hyphens, leading'); $_ = "car-rot9"; tr/a-m-/./; is($_, '..r.rot9', ' trailing'); $_ = "car-rot9"; tr/-a-m-/./; is($_, '..r.rot9', ' both'); $_ = "abcdefghijklmnop"; tr/ae-hn/./; is($_, '.bcd....ijklm.op'); $_ = "abcdefghijklmnop"; tr/a-cf-kn-p/./; is($_, '...de......lm...'); $_ = "abcdefghijklmnop"; tr/a-ceg-ikm-o/./; is($_, '...d.f...j.l...p'); # 20000705 MJD eval "tr/m-d/ /"; like($@, qr/^Invalid range "m-d" in transliteration operator/, 'reversed range check'); 'abcdef' =~ /(bcd)/; is(eval '$1 =~ tr/abcd//', 3, 'explicit read-only count'); is($@, '', ' no error'); 'abcdef' =~ /(bcd)/; is(eval '$1 =~ tr/abcd/abcd/', 3, 'implicit read-only count'); is($@, '', ' no error'); is(eval '"123" =~ tr/12//', 2, 'LHS of non-updating tr'); eval '"123" =~ tr/1/2/'; like($@, qr|^Can't modify constant item in transliteration \(tr///\)|, 'LHS bad on updating tr'); # v300 (0x12c) is UTF-8-encoded as 196 172 (0xc4 0xac) # v400 (0x190) is UTF-8-encoded as 198 144 (0xc6 0x90) # Transliterate a byte to a byte, all four ways. ($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/; is($a, v300.197.172.300.197.172, 'byte2byte transliteration'); ($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{c5}/; is($a, v300.197.172.300.197.172); ($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\xc5/; is($a, v300.197.172.300.197.172); ($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\x{c5}/; is($a, v300.197.172.300.197.172); ($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/; is($a, v300.301.172.300.301.172, 'byte2wide transliteration'); ($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc3/; is($a, v195.196.172.195.196.172, ' wide2byte'); ($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/; is($a, v301.196.172.301.196.172, ' wide2wide'); ($a = v300.196.172.300.196.172) =~ tr/\xc4\x{12c}/\x{12d}\xc3/; is($a, v195.301.172.195.301.172, 'byte2wide & wide2byte'); ($a = v300.196.172.300.196.172.400.198.144) =~ tr/\xac\xc4\x{12c}\x{190}/\xad\x{12d}\xc5\x{191}/; is($a, v197.301.173.197.301.173.401.198.144, 'all together now!'); is((($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/), 2, 'transliterate and count'); is((($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/), 2); ($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/c; is($a, v301.196.301.301.196.301, 'translit w/complement'); ($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc5/c; is($a, v300.197.197.300.197.197); ($a = v300.196.172.300.196.172) =~ tr/\xc4//d; is($a, v300.172.300.172, 'translit w/deletion'); ($a = v300.196.172.300.196.172) =~ tr/\x{12c}//d; is($a, v196.172.196.172); ($a = v196.196.172.300.300.196.172) =~ tr/\xc4/\xc5/s; is($a, v197.172.300.300.197.172, 'translit w/squeeze'); ($a = v196.172.300.300.196.172.172) =~ tr/\x{12c}/\x{12d}/s; is($a, v196.172.301.196.172.172); # Tricky cases (When Simon Cozens Attacks) ($a = v196.172.200) =~ tr/\x{12c}/a/; is(sprintf("%vd", $a), '196.172.200'); ($a = v196.172.200) =~ tr/\x{12c}/\x{12c}/; is(sprintf("%vd", $a), '196.172.200'); ($a = v196.172.200) =~ tr/\x{12c}//d; is(sprintf("%vd", $a), '196.172.200'); # UTF8 range tests from Inaba Hiroto # Not working in EBCDIC as of 12674. ($a = v300.196.172.302.197.172) =~ tr/\x{12c}-\x{130}/\xc0-\xc4/; is($a, v192.196.172.194.197.172, 'UTF range'); ($a = v300.196.172.302.197.172) =~ tr/\xc4-\xc8/\x{12c}-\x{130}/; is($a, v300.300.172.302.301.172); # UTF8 range tests from Karsten Sperling (patch #9008 required) ($a = "\x{0100}") =~ tr/\x00-\x{100}/X/; is($a, "X"); ($a = "\x{0100}") =~ tr/\x{0000}-\x{00ff}/X/c; is($a, "X"); ($a = "\x{0100}") =~ tr/\x{0000}-\x{00ff}\x{0101}/X/c; is($a, "X"); ($a = v256) =~ tr/\x{0000}-\x{00ff}\x{0101}/X/c; is($a, "X"); # UTF8 range tests from Inaba Hiroto ($a = "\x{200}") =~ tr/\x00-\x{100}/X/c; is($a, "X"); ($a = "\x{200}") =~ tr/\x00-\x{100}/X/cs; is($a, "X"); # Tricky on EBCDIC: while [a-z] [A-Z] must not match the gap characters, # (i-j, r-s, I-J, R-S), [\x89-\x91] [\xc9-\xd1] has to match them, # from Karsten Sperling. $c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/\x89-\x91/X/; is($c, 8); is($a, "XXXXXXXX"); $c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/\xc9-\xd1/X/; is($c, 8); is($a, "XXXXXXXX"); SKIP: { skip "not EBCDIC", 4 unless $Is_EBCDIC; $c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/i-j/X/; is($c, 2); is($a, "X\x8a\x8b\x8c\x8d\x8f\x90X"); $c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/I-J/X/; is($c, 2); is($a, "X\xca\xcb\xcc\xcd\xcf\xd0X"); } ($a = "\x{100}") =~ tr/\x00-\xff/X/c; is(ord($a), ord("X")); ($a = "\x{100}") =~ tr/\x00-\xff/X/cs; is(ord($a), ord("X")); ($a = "\x{100}\x{100}") =~ tr/\x{101}-\x{200}//c; is($a, "\x{100}\x{100}"); ($a = "\x{100}\x{100}") =~ tr/\x{101}-\x{200}//cs; is($a, "\x{100}"); $a = "\xfe\xff"; $a =~ tr/\xfe\xff/\x{1ff}\x{1fe}/; is($a, "\x{1ff}\x{1fe}"); # From David Dyck ($a = "R0_001") =~ tr/R_//d; is(hex($a), 1); # From Inaba Hiroto @a = (1,2); map { y/1/./ for $_ } @a; is("@a", ". 2"); @a = (1,2); map { y/1/./ for $_.'' } @a; is("@a", "1 2"); # Additional test for Inaba Hiroto patch (robin@kitsite.com) ($a = "\x{100}\x{102}\x{101}") =~ tr/\x00-\377/XYZ/c; is($a, "XZY"); # Used to fail with "Modification of a read-only value attempted" %a = (N=>1); foreach (keys %a) { eval 'tr/N/n/'; is($_, 'n', 'pp_trans needs to unshare shared hash keys'); is($@, '', ' no error'); } $x = eval '"1213" =~ tr/1/1/'; is($x, 2, 'implicit count on constant'); is($@, '', ' no error'); my @foo = (); eval '$foo[-1] =~ tr/N/N/'; is( $@, '', 'implicit count outside array bounds, index negative' ); is( scalar @foo, 0, " doesn't extend the array"); eval '$foo[1] =~ tr/N/N/'; is( $@, '', 'implicit count outside array bounds, index positive' ); is( scalar @foo, 0, " doesn't extend the array"); my %foo = (); eval '$foo{bar} =~ tr/N/N/'; is( $@, '', 'implicit count outside hash bounds' ); is( scalar keys %foo, 0, " doesn't extend the hash"); $x = \"foo"; is( $x =~ tr/A/A/, 2, 'non-modifying tr/// on a scalar ref' ); is( ref $x, 'SCALAR', " doesn't stringify its argument" ); # rt.perl.org 36622. Perl didn't like a y/// at end of file. No trailing # newline allowed. fresh_perl_is(q[$_ = "foo"; y/A-Z/a-z/], ''); { # [perl #38293] chr(65535) should be allowed in regexes no warnings 'utf8'; # to allow non-characters $s = "\x{d800}\x{ffff}"; $s =~ tr/\0/A/; is($s, "\x{d800}\x{ffff}", "do_trans_simple"); $s = "\x{d800}\x{ffff}"; $i = $s =~ tr/\0//; is($i, 0, "do_trans_count"); $s = "\x{d800}\x{ffff}"; $s =~ tr/\0/A/s; is($s, "\x{d800}\x{ffff}", "do_trans_complex, SQUASH"); $s = "\x{d800}\x{ffff}"; $s =~ tr/\0/A/c; is($s, "AA", "do_trans_complex, COMPLEMENT"); $s = "A\x{ffff}B"; $s =~ tr/\x{ffff}/\x{1ffff}/; is($s, "A\x{1ffff}B", "utf8, SEARCHLIST"); $s = "\x{fffd}\x{fffe}\x{ffff}"; $s =~ tr/\x{fffd}-\x{ffff}/ABC/; is($s, "ABC", "utf8, SEARCHLIST range"); $s = "ABC"; $s =~ tr/ABC/\x{ffff}/; is($s, "\x{ffff}"x3, "utf8, REPLACEMENTLIST"); $s = "ABC"; $s =~ tr/ABC/\x{fffd}-\x{ffff}/; is($s, "\x{fffd}\x{fffe}\x{ffff}", "utf8, REPLACEMENTLIST range"); $s = "A\x{ffff}B\x{100}\0\x{fffe}\x{ffff}"; $i = $s =~ tr/\x{ffff}//; is($i, 2, "utf8, count"); $s = "A\x{ffff}\x{ffff}C"; $s =~ tr/\x{ffff}/\x{100}/s; is($s, "A\x{100}C", "utf8, SQUASH"); $s = "A\x{ffff}\x{ffff}\x{fffe}\x{fffe}\x{fffe}C"; $s =~ tr/\x{fffe}\x{ffff}//s; is($s, "A\x{ffff}\x{fffe}C", "utf8, SQUASH"); $s = "xAABBBy"; $s =~ tr/AB/\x{ffff}/s; is($s, "x\x{ffff}y", "utf8, SQUASH"); $s = "xAABBBy"; $s =~ tr/AB/\x{fffe}\x{ffff}/s; is($s, "x\x{fffe}\x{ffff}y", "utf8, SQUASH"); $s = "A\x{ffff}B\x{fffe}C"; $s =~ tr/\x{fffe}\x{ffff}/x/c; is($s, "x\x{ffff}x\x{fffe}x", "utf8, COMPLEMENT"); $s = "A\x{10000}B\x{2abcd}C"; $s =~ tr/\0-\x{ffff}/x/c; is($s, "AxBxC", "utf8, COMPLEMENT range"); $s = "A\x{fffe}B\x{ffff}C"; $s =~ tr/\x{fffe}\x{ffff}/x/d; is($s, "AxBC", "utf8, DELETE"); } # non-characters end { # related to [perl #27940] my $c; ($c = "\x20\c@\x30\cA\x40\cZ\x50\c_\x60") =~ tr/\c@-\c_//d; is($c, "\x20\x30\x40\x50\x60", "tr/\\c\@-\\c_//d"); ($c = "\x20\x00\x30\x01\x40\x1A\x50\x1F\x60") =~ tr/\x00-\x1f//d; is($c, "\x20\x30\x40\x50\x60", "tr/\\x00-\\x1f//d"); } ($s) = keys %{{pie => 3}}; my $wasro = Internals::SvREADONLY($s); { $wasro or local $TODO = "didn't have a COW"; $s =~ tr/i//; ok( Internals::SvREADONLY($s), "count-only tr doesn't deCOW COWs" ); } # [ RT #61520 ] # # under threads, unicode tr within a cloned closure would SEGV or assert # fail, since the pointer in the pad to the swash was getting zeroed out # in the proto-CV { my $x = "\x{142}"; sub { $x =~ tr[\x{142}][\x{143}]; }->(); is($x,"\x{143}", "utf8 + closure"); } perl-5.12.0-RC0/t/op/dor.t0000555000175000017500000000332011325125742013762 0ustar jessejesse#!./perl # Test // and friends. BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } package main; require './test.pl'; plan( tests => 31 ); my($x); $x=1; is($x // 0, 1, ' // : left-hand operand defined'); $x = undef; is($x // 1, 1, ' // : left-hand operand undef'); $x=''; is($x // 0, '', ' // : left-hand operand defined but empty'); like([] // 0, qr/^ARRAY/, ' // : left-hand operand a referece'); $x=undef; $x //= 1; is($x, 1, ' //=: left-hand operand undefined'); $x //= 0; is($x, 1, '//=: left-hand operand defined'); $x = ''; $x //= 0; is($x, '', '//=: left-hand operand defined but empty'); @ARGV = (undef, 0, 3); is(shift // 7, 7, 'shift // ... works'); is(shift() // 7, 0, 'shift() // ... works'); is(shift @ARGV // 7, 3, 'shift @array // ... works'); @ARGV = (3, 0, undef); is(pop // 7, 7, 'pop // ... works'); is(pop() // 7, 0, 'pop() // ... works'); is(pop @ARGV // 7, 3, 'pop @array // ... works'); # Test that various syntaxes are allowed for (qw(getc pos readline readlink undef umask <> <$foo> -f)) { eval "sub { $_ // 0 }"; is($@, '', "$_ // ... compiles"); } # Test for some ambiguous syntaxes eval q# sub f ($) { } f $x / 2; #; is( $@, '' ); eval q# sub f ($):lvalue { $y } f $x /= 2; #; is( $@, '' ); eval q# sub f ($) { } f $x /2; #; like( $@, qr/^Search pattern not terminated/ ); eval q# sub { print $fh / 2 } #; is( $@, '' ); eval q# sub { print $fh /2 } #; like( $@, qr/^Search pattern not terminated/ ); # [perl #28123] Perl optimizes // away incorrectly is(0 // 2, 0, ' // : left-hand operand not optimized away'); is('' // 2, '', ' // : left-hand operand not optimized away'); is(undef // 2, 2, ' // : left-hand operand optimized away'); perl-5.12.0-RC0/t/op/hash.t0000555000175000017500000000574711325125742014140 0ustar jessejesse#!./perl -w BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } use strict; plan tests => 6; my %h; ok (!Internals::HvREHASH(%h), "hash doesn't start with rehash flag on"); foreach (1..10) { $h{"\0"x$_}++; } ok (!Internals::HvREHASH(%h), "10 entries doesn't trigger rehash"); foreach (11..20) { $h{"\0"x$_}++; } ok (Internals::HvREHASH(%h), "20 entries triggers rehash"); # second part using an emulation of the PERL_HASH in perl, mounting an # attack on a pre-populated hash. This is also useful if you need normal # keys which don't contain \0 -- suitable for stashes use constant MASK_U32 => 2**32; use constant HASH_SEED => 0; use constant THRESHOLD => 14; use constant START => "a"; # some initial hash data my %h2 = map {$_ => 1} 'a'..'cc'; ok (!Internals::HvREHASH(%h2), "starting with pre-populated non-pathological hash (rehash flag if off)"); my @keys = get_keys(\%h2); $h2{$_}++ for @keys; ok (Internals::HvREHASH(%h2), scalar(@keys) . " colliding into the same bucket keys are triggering rehash"); sub get_keys { my $hr = shift; # the minimum of bits required to mount the attack on a hash my $min_bits = log(THRESHOLD)/log(2); # if the hash has already been populated with a significant amount # of entries the number of mask bits can be higher my $keys = scalar keys %$hr; my $bits = $keys ? log($keys)/log(2) : 0; $bits = $min_bits if $min_bits > $bits; $bits = int($bits) < $bits ? int($bits) + 1 : int($bits); # need to add 2 bits to cover the internal split cases $bits += 2; my $mask = 2**$bits-1; print "# using mask: $mask ($bits)\n"; my @keys; my $s = START; my $c = 0; # get 2 keys on top of the THRESHOLD my $hash; while (@keys < THRESHOLD+2) { # next if exists $hash->{$s}; $hash = hash($s); next unless ($hash & $mask) == 0; $c++; printf "# %2d: %5s, %10s\n", $c, $s, $hash; push @keys, $s; } continue { $s++; } return @keys; } # trying to provide the fastest equivalent of C macro's PERL_HASH in # Perl - the main complication is that it uses U32 integer, which we # can't do it perl, without doing some tricks sub hash { my $s = shift; my @c = split //, $s; my $u = HASH_SEED; for (@c) { # (A % M) + (B % M) == (A + B) % M # This works because '+' produces a NV, which is big enough to hold # the intermediate result. We only need the % before any "^" and "&" # to get the result in the range for an I32. # and << doesn't work on NV, so using 1 << 10 $u += ord; $u += $u * (1 << 10); $u %= MASK_U32; $u ^= $u >> 6; } $u += $u << 3; $u %= MASK_U32; $u ^= $u >> 11; $u %= MASK_U32; $u += $u << 15; $u %= MASK_U32; $u; } # This will crash perl if it fails use constant PVBM => 'foo'; my $dummy = index 'foo', PVBM; eval { my %h = (a => PVBM); 1 }; ok (!$@, 'fbm scalar can be inserted into a hash'); perl-5.12.0-RC0/t/op/stat.t0000555000175000017500000003665311325127001014156 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; # for which_perl() etc } use Config; use File::Spec; plan tests => 107; my $Perl = which_perl(); $Is_Amiga = $^O eq 'amigaos'; $Is_Cygwin = $^O eq 'cygwin'; $Is_Darwin = $^O eq 'darwin'; $Is_Dos = $^O eq 'dos'; $Is_MPE = $^O eq 'mpeix'; $Is_MSWin32 = $^O eq 'MSWin32'; $Is_NetWare = $^O eq 'NetWare'; $Is_OS2 = $^O eq 'os2'; $Is_Solaris = $^O eq 'solaris'; $Is_VMS = $^O eq 'VMS'; $Is_DGUX = $^O eq 'dgux'; $Is_MPRAS = $^O =~ /svr4/ && -f '/etc/.relid'; $Is_Rhapsody= $^O eq 'rhapsody'; $Is_Dosish = $Is_Dos || $Is_OS2 || $Is_MSWin32 || $Is_NetWare; $Is_UFS = $Is_Darwin && (() = `df -t ufs . 2>/dev/null`) == 2; if ($Is_Cygwin) { require Win32; Win32->import; } my($DEV, $INO, $MODE, $NLINK, $UID, $GID, $RDEV, $SIZE, $ATIME, $MTIME, $CTIME, $BLKSIZE, $BLOCKS) = (0..12); my $Curdir = File::Spec->curdir; my $tmpfile = tempfile(); my $tmpfile_link = tempfile(); chmod 0666, $tmpfile; 1 while unlink $tmpfile; open(FOO, ">$tmpfile") || DIE("Can't open temp test file: $!"); close FOO; open(FOO, ">$tmpfile") || DIE("Can't open temp test file: $!"); my($nlink, $mtime, $ctime) = (stat(FOO))[$NLINK, $MTIME, $CTIME]; # The clock on a network filesystem might be different from the # system clock. my $Filesystem_Time_Offset = abs($mtime - time); #nlink should if link support configured in Perl. SKIP: { skip "No link count - Hard link support not built in.", 1 unless $Config{d_link}; is($nlink, 1, 'nlink on regular file'); } SKIP: { skip "mtime and ctime not reliable", 2 if $Is_MSWin32 or $Is_NetWare or $Is_Cygwin or $Is_Dos or $Is_Darwin; ok( $mtime, 'mtime' ); is( $mtime, $ctime, 'mtime == ctime' ); } # Cygwin seems to have a 3 second granularity on its timestamps. my $funky_FAT_timestamps = $Is_Cygwin; sleep 3 if $funky_FAT_timestamps; print FOO "Now is the time for all good men to come to.\n"; close(FOO); sleep 2; SKIP: { unlink $tmpfile_link; my $lnk_result = eval { link $tmpfile, $tmpfile_link }; skip "link() unimplemented", 6 if $@ =~ /unimplemented/; is( $@, '', 'link() implemented' ); ok( $lnk_result, 'linked tmp testfile' ); ok( chmod(0644, $tmpfile), 'chmoded tmp testfile' ); my($nlink, $mtime, $ctime) = (stat($tmpfile))[$NLINK, $MTIME, $CTIME]; SKIP: { skip "No link count", 1 if $Config{dont_use_nlink}; skip "Cygwin9X fakes hard links by copying", 1 if $Config{myuname} =~ /^cygwin_(?:9\d|me)\b/i; is($nlink, 2, 'Link count on hard linked file' ); } SKIP: { my $cwd = File::Spec->rel2abs($Curdir); skip "Solaris tmpfs has different mtime/ctime link semantics", 2 if $Is_Solaris and $cwd =~ m#^/tmp# and $mtime && $mtime == $ctime; skip "AFS has different mtime/ctime link semantics", 2 if $cwd =~ m#$Config{'afsroot'}/#; skip "AmigaOS has different mtime/ctime link semantics", 2 if $Is_Amiga; # Win32 could pass $mtime test but as FAT and NTFS have # no ctime concept $ctime is ALWAYS == $mtime # expect netware to be the same ... skip "No ctime concept on this OS", 2 if $Is_MSWin32 || ($Is_Darwin && $Is_UFS); if( !ok($mtime, 'hard link mtime') || !isnt($mtime, $ctime, 'hard link ctime != mtime') ) { print STDERR <$tmpfile") || DIE("Can't open temp test file: $!"); ok(-z \*F, '-z on empty filehandle'); ok(! -s \*F, ' and -s'); close F; ok(-z $tmpfile, '-z on empty file'); ok(! -s $tmpfile, ' and -s'); open(F, ">$tmpfile") || DIE("Can't open temp test file: $!"); print F "hi\n"; close F; open(F, "<$tmpfile") || DIE("Can't open temp test file: $!"); ok(!-z *F, '-z on empty filehandle'); ok( -s *F, ' and -s'); close F; ok(! -z $tmpfile, '-z on non-empty file'); ok(-s $tmpfile, ' and -s'); # Strip all access rights from the file. ok( chmod(0000, $tmpfile), 'chmod 0000' ); SKIP: { skip "-r, -w and -x have different meanings on VMS", 3 if $Is_VMS; SKIP: { # Going to try to switch away from root. Might not work. my $olduid = $>; eval { $> = 1; }; skip "Can't test -r or -w meaningfully if you're superuser", 2 if ($Is_Cygwin ? Win32::IsAdminUser : $> == 0); SKIP: { skip "Can't test -r meaningfully?", 1 if $Is_Dos; ok(!-r $tmpfile, " -r"); } ok(!-w $tmpfile, " -w"); # switch uid back (may not be implemented) eval { $> = $olduid; }; } ok(! -x $tmpfile, ' -x'); } ok(chmod(0700,$tmpfile), 'chmod 0700'); ok(-r $tmpfile, ' -r'); ok(-w $tmpfile, ' -w'); SKIP: { skip "-x simply determines if a file ends in an executable suffix", 1 if $Is_Dosish; ok(-x $tmpfile, ' -x'); } ok( -f $tmpfile, ' -f'); ok(! -d $tmpfile, ' !-d'); # Is this portable? ok( -d $Curdir, '-d cwd' ); ok(! -f $Curdir, '!-f cwd' ); SKIP: { unlink($tmpfile_link); my $symlink_rslt = eval { symlink $tmpfile, $tmpfile_link }; skip "symlink not implemented", 3 if $@ =~ /unimplemented/; is( $@, '', 'symlink() implemented' ); ok( $symlink_rslt, 'symlink() ok' ); ok(-l $tmpfile_link, '-l'); } ok(-o $tmpfile, '-o'); ok(-e $tmpfile, '-e'); unlink($tmpfile_link); ok(! -e $tmpfile_link, ' -e on unlinked file'); SKIP: { skip "No character, socket or block special files", 6 if $Is_MSWin32 || $Is_NetWare || $Is_Dos; skip "/dev isn't available to test against", 6 unless -d '/dev' && -r '/dev' && -x '/dev'; skip "Skipping: unexpected ls output in MP-RAS", 6 if $Is_MPRAS; # VMS problem: If GNV or other UNIX like tool is installed, then # sometimes Perl will find /bin/ls, and will try to run it. # But since Perl on VMS does not know to run it under Bash, it will # try to run the DCL verb LS. And if the VMS product Language # Sensitive Editor is installed, or some other LS verb, that will # be run instead. So do not do this until we can teach Perl # when to use BASH on VMS. skip "ls command not available to Perl in OpenVMS right now.", 6 if $Is_VMS; my $LS = $Config{d_readlink} ? "ls -lL" : "ls -l"; my $CMD = "$LS /dev 2>/dev/null"; my $DEV = qx($CMD); skip "$CMD failed", 6 if $DEV eq ''; my @DEV = do { my $dev; opendir($dev, "/dev") ? readdir($dev) : () }; skip "opendir failed: $!", 6 if @DEV == 0; # /dev/stdout might be either character special or a named pipe, # or a symlink, or a socket, depending on which OS and how are # you running the test, so let's censor that one away. # Similar remarks hold for stderr. $DEV =~ s{^[cpls].+?\sstdout$}{}m; @DEV = grep { $_ ne 'stdout' } @DEV; $DEV =~ s{^[cpls].+?\sstderr$}{}m; @DEV = grep { $_ ne 'stderr' } @DEV; # /dev/printer is also naughty: in IRIX it shows up as # Srwx-----, not srwx------. $DEV =~ s{^.+?\sprinter$}{}m; @DEV = grep { $_ ne 'printer' } @DEV; # If running as root, we will see .files in the ls result, # and readdir() will see them always. Potential for conflict, # so let's weed them out. $DEV =~ s{^.+?\s\..+?$}{}m; @DEV = grep { ! m{^\..+$} } @DEV; # Irix ls -l marks sockets with 'S' while 's' is a 'XENIX semaphore'. if ($^O eq 'irix') { $DEV =~ s{^S(.+?)}{s$1}mg; } my $try = sub { my @c1 = eval qq[\$DEV =~ /^$_[0].*/mg]; my @c2 = eval qq[grep { $_[1] "/dev/\$_" } \@DEV]; my $c1 = scalar @c1; my $c2 = scalar @c2; is($c1, $c2, "ls and $_[1] agreeing on /dev ($c1 $c2)"); }; SKIP: { skip("DG/UX ls -L broken", 3) if $Is_DGUX; $try->('b', '-b'); $try->('c', '-c'); $try->('s', '-S'); } ok(! -b $Curdir, '!-b cwd'); ok(! -c $Curdir, '!-c cwd'); ok(! -S $Curdir, '!-S cwd'); } SKIP: { my($cnt, $uid); $cnt = $uid = 0; # Find a set of directories that's very likely to have setuid files # but not likely to be *all* setuid files. my @bin = grep {-d && -r && -x} qw(/sbin /usr/sbin /bin /usr/bin); skip "Can't find a setuid file to test with", 3 unless @bin; for my $bin (@bin) { opendir BIN, $bin or die "Can't opendir $bin: $!"; while (defined($_ = readdir BIN)) { $_ = "$bin/$_"; $cnt++; $uid++ if -u; last if $uid && $uid < $cnt; } } closedir BIN; skip "No setuid programs", 3 if $uid == 0; isnt($cnt, 0, 'found some programs'); isnt($uid, 0, ' found some setuid programs'); ok($uid < $cnt, " they're not all setuid"); } # To assist in automated testing when a controlling terminal (/dev/tty) # may not be available (at, cron rsh etc), the PERL_SKIP_TTY_TEST env var # can be set to skip the tests that need a tty. SKIP: { skip "These tests require a TTY", 4 if $ENV{PERL_SKIP_TTY_TEST}; my $TTY = $Is_Rhapsody ? "/dev/ttyp0" : "/dev/tty"; SKIP: { skip "Test uses unixisms", 2 if $Is_MSWin32 || $Is_NetWare; skip "No TTY to test -t with", 2 unless -e $TTY; open(TTY, $TTY) || warn "Can't open $TTY--run t/TEST outside of make.\n"; ok(-t TTY, '-t'); ok(-c TTY, 'tty is -c'); close(TTY); } ok(! -t TTY, '!-t on closed TTY filehandle'); { local $TODO = 'STDIN not a tty when output is to pipe' if $Is_VMS; ok(-t, '-t on STDIN'); } } my $Null = File::Spec->devnull; SKIP: { skip "No null device to test with", 1 unless -e $Null; skip "We know Win32 thinks '$Null' is a TTY", 1 if $Is_MSWin32; open(NULL, $Null) or DIE("Can't open $Null: $!"); ok(! -t NULL, 'null device is not a TTY'); close(NULL); } # These aren't strictly "stat" calls, but so what? my $statfile = File::Spec->catfile($Curdir, 'op', 'stat.t'); ok( -T $statfile, '-T'); ok(! -B $statfile, '!-B'); SKIP: { skip("DG/UX", 1) if $Is_DGUX; ok(-B $Perl, '-B'); } ok(! -T $Perl, '!-T'); open(FOO,$statfile); SKIP: { eval { -T FOO; }; skip "-T/B on filehandle not implemented", 15 if $@ =~ /not implemented/; is( $@, '', '-T on filehandle causes no errors' ); ok(-T FOO, ' -T'); ok(! -B FOO, ' !-B'); $_ = ; like($_, qr/perl/, 'after readline'); ok(-T FOO, ' still -T'); ok(! -B FOO, ' still -B'); close(FOO); open(FOO,$statfile); $_ = ; like($_, qr/perl/, 'reopened and after readline'); ok(-T FOO, ' still -T'); ok(! -B FOO, ' still !-B'); ok(seek(FOO,0,0), 'after seek'); ok(-T FOO, ' still -T'); ok(! -B FOO, ' still !-B'); # It's documented this way in perlfunc *shrug* () = ; ok(eof FOO, 'at EOF'); ok(-T FOO, ' still -T'); ok(-B FOO, ' now -B'); } close(FOO); SKIP: { skip "No null device to test with", 2 unless -e $Null; ok(-T $Null, 'null device is -T'); ok(-B $Null, ' and -B'); } # and now, a few parsing tests: $_ = $tmpfile; ok(-f, 'bare -f uses $_'); ok(-f(), ' -f() "'); unlink $tmpfile or print "# unlink failed: $!\n"; # bug id 20011101.069 my @r = \stat($Curdir); is(scalar @r, 13, 'stat returns full 13 elements'); stat $0; eval { lstat _ }; like( $@, qr/^The stat preceding lstat\(\) wasn't an lstat/, 'lstat _ croaks after stat' ); eval { -l _ }; like( $@, qr/^The stat preceding -l _ wasn't an lstat/, '-l _ croaks after stat' ); lstat $0; eval { lstat _ }; is( "$@", "", "lstat _ ok after lstat" ); eval { -l _ }; is( "$@", "", "-l _ ok after lstat" ); SKIP: { skip "No lstat", 2 unless $Config{d_lstat}; # bug id 20020124.004 # If we have d_lstat, we should have symlink() my $linkname = 'dolzero'; symlink $0, $linkname or die "# Can't symlink $0: $!"; lstat $linkname; -T _; eval { lstat _ }; like( $@, qr/^The stat preceding lstat\(\) wasn't an lstat/, 'lstat croaks after -T _' ); eval { -l _ }; like( $@, qr/^The stat preceding -l _ wasn't an lstat/, '-l _ croaks after -T _' ); unlink $linkname or print "# unlink $linkname failed: $!\n"; } SKIP: { skip "Too much clock skew between system and filesystem", 5 if ($Filesystem_Time_Offset > 5); print "# Zzz...\n"; sleep($Filesystem_Time_Offset+1); my $f = 'tstamp.tmp'; unlink $f; ok (open(S, "> $f"), 'can create tmp file'); close S or die; my @a = stat $f; print "# time=$^T, stat=(@a)\n"; my @b = (-M _, -A _, -C _); print "# -MAC=(@b)\n"; ok( (-M _) < 0, 'negative -M works'); ok( (-A _) < 0, 'negative -A works'); ok( (-C _) < 0, 'negative -C works'); ok(unlink($f), 'unlink tmp file'); } { ok(open(F, ">", $tmpfile), 'can create temp file'); close F; chmod 0077, $tmpfile; my @a = stat($tmpfile); my $s1 = -s _; -T _; my $s2 = -s _; is($s1, $s2, q(-T _ doesn't break the statbuffer)); unlink $tmpfile; } SKIP: { skip "No dirfd()", 9 unless $Config{d_dirfd} || $Config{d_dir_dd_fd}; ok(opendir(DIR, "."), 'Can open "." dir') || diag "Can't open '.': $!"; ok(stat(DIR), "stat() on dirhandle works"); ok(-d -r _ , "chained -x's on dirhandle"); ok(-d DIR, "-d on a dirhandle works"); # And now for the ambigious bareword case { no warnings 'deprecated'; ok(open(DIR, "TEST"), 'Can open "TEST" dir') || diag "Can't open 'TEST': $!"; } my $size = (stat(DIR))[7]; ok(defined $size, "stat() on bareword works"); is($size, -s "TEST", "size returned by stat of bareword is for the file"); ok(-f _, "ambiguous bareword uses file handle, not dir handle"); ok(-f DIR); closedir DIR or die $!; close DIR or die $!; } { # RT #8244: *FILE{IO} does not behave like *FILE for stat() and -X() operators ok(open(F, ">", $tmpfile), 'can create temp file'); my @thwap = stat *F{IO}; ok(@thwap, "stat(*F{IO}) works"); ok( -f *F{IO} , "single file tests work with *F{IO}"); close F; unlink $tmpfile; #PVIO's hold dirhandle information, so let's test them too. SKIP: { skip "No dirfd()", 9 unless $Config{d_dirfd} || $Config{d_dir_dd_fd}; ok(opendir(DIR, "."), 'Can open "." dir') || diag "Can't open '.': $!"; ok(stat(*DIR{IO}), "stat() on *DIR{IO} works"); ok(-d _ , "The special file handle _ is set correctly"); ok(-d -r *DIR{IO} , "chained -x's on *DIR{IO}"); # And now for the ambigious bareword case { no warnings 'deprecated'; ok(open(DIR, "TEST"), 'Can open "TEST" dir') || diag "Can't open 'TEST': $!"; } my $size = (stat(*DIR{IO}))[7]; ok(defined $size, "stat() on *THINGY{IO} works"); is($size, -s "TEST", "size returned by stat of *THINGY{IO} is for the file"); ok(-f _, "ambiguous *THINGY{IO} uses file handle, not dir handle"); ok(-f *DIR{IO}); closedir DIR or die $!; close DIR or die $!; } } END { chmod 0666, $tmpfile; 1 while unlink $tmpfile; } perl-5.12.0-RC0/t/op/list.t0000555000175000017500000001114511325127001014143 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = qw(. ../lib); } require "test.pl"; plan( tests => 58 ); @foo = (1, 2, 3, 4); cmp_ok($foo[0], '==', 1, 'first elem'); cmp_ok($foo[3], '==', 4, 'last elem'); $_ = join(':',@foo); cmp_ok($_, 'eq', '1:2:3:4', 'join list'); ($a,$b,$c,$d) = (1,2,3,4); cmp_ok("$a;$b;$c;$d", 'eq', '1;2;3;4', 'list assign'); ($c,$b,$a) = split(/ /,"111 222 333"); cmp_ok("$a;$b;$c",'eq','333;222;111','list split on space'); ($a,$b,$c) = ($c,$b,$a); cmp_ok("$a;$b;$c",'eq','111;222;333','trio rotate'); ($a, $b) = ($b, $a); cmp_ok("$a-$b",'eq','222-111','duo swap'); ($a, $b) = ($b, $a) = ($a, $b); cmp_ok("$a-$b",'eq','222-111','duo swap swap'); ($a, $b[1], $c{2}, $d) = (1, 2, 3, 4); cmp_ok($a,'==',1,'assign scalar in list'); cmp_ok($b[1],'==',2,'assign aelem in list'); cmp_ok($c{2},'==',3,'assign helem in list'); cmp_ok($d,'==',4,'assign last scalar in list'); @foo = (1,2,3,4,5,6,7,8); ($a, $b, $c, $d) = @foo; cmp_ok("$a/$b/$c/$d",'eq','1/2/3/4','long list assign'); @foo = (1,2); ($a, $b, $c, $d) = @foo; cmp_ok($a,'==',1,'short list 1 defined'); cmp_ok($b,'==',2,'short list 2 defined'); ok(!defined($c),'short list 3 undef'); ok(!defined($d),'short list 4 undef'); @foo = @bar = (1); cmp_ok(join(':',@foo,@bar),'eq','1:1','list reassign'); @foo = @bar = (2,3); cmp_ok(join(':',join('+',@foo),join('-',@bar)),'eq','2+3:2-3','long list reassign'); @foo = (); @foo = 1+2+3; cmp_ok(join(':',@foo),'eq','6','scalar assign to array'); { my ($a, $b, $c); for ($x = 0; $x < 3; $x = $x + 1) { ($a, $b, $c) = $x == 0 ? ('a','b','c') : $x == 1 ? ('d','e','f') : ('g','h','i') ; if ($x == 0) { cmp_ok($a,'eq','a','ternary for a 1'); cmp_ok($b,'eq','b','ternary for b 1'); cmp_ok($c,'eq','c','ternary for c 1'); } if ($x == 1) { cmp_ok($a,'eq','d','ternary for a 2'); cmp_ok($b,'eq','e','ternary for b 2'); cmp_ok($c,'eq','f','ternary for c 2'); } if ($x == 2) { cmp_ok($a,'eq','g','ternary for a 3'); cmp_ok($b,'eq','h','ternary for b 3'); cmp_ok($c,'eq','i','ternary for c 3'); } } } { my ($a, $b, $c); for ($x = 0; $x < 3; $x = $x + 1) { ($a, $b, $c) = do { if ($x == 0) { ('a','b','c'); } elsif ($x == 1) { ('d','e','f'); } else { ('g','h','i'); } }; if ($x == 0) { cmp_ok($a,'eq','a','block for a 1'); cmp_ok($b,'eq','b','block for b 1'); cmp_ok($c,'eq','c','block for c 1'); } if ($x == 1) { cmp_ok($a,'eq','d','block for a 2'); cmp_ok($b,'eq','e','block for b 2'); cmp_ok($c,'eq','f','block for c 2'); } if ($x == 2) { cmp_ok($a,'eq','g','block for a 3'); cmp_ok($b,'eq','h','block for b 3'); cmp_ok($c,'eq','i','block for c 3'); } } } $x = 666; @a = ($x == 12345 || (1,2,3)); cmp_ok(join('*',@a),'eq','1*2*3','logical or f'); @a = ($x == $x || (4,5,6)); cmp_ok(join('*',@a),'eq','1','logical or t'); cmp_ok(join('',1,2,(3,4,5)),'eq','12345','list ..(...)'); cmp_ok(join('',(1,2,3,4,5)),'eq','12345','list (.....)'); cmp_ok(join('',(1,2,3,4),5),'eq','12345','list (....).'); cmp_ok(join('',1,(2,3,4),5),'eq','12345','list .(...).'); cmp_ok(join('',1,2,(3,4),5),'eq','12345','list ..(..).'); cmp_ok(join('',1,2,3,(4),5),'eq','12345','list ...(.).'); cmp_ok(join('',(1,2),3,(4,5)),'eq','12345','list (..).(..)'); { my @a = (0, undef, undef, 3); my @b = @a[1,2]; my @c = (0, undef, undef, 3)[1, 2]; cmp_ok(scalar(@b),'==',scalar(@c),'slice and slice'); cmp_ok(scalar(@c),'==',2,'slice len'); @b = (29, scalar @c[()]); cmp_ok(join(':',@b),'eq','29:','slice ary nil'); my %h = (a => 1); @b = (30, scalar @h{()}); cmp_ok(join(':',@b),'eq','30:','slice hash nil'); my $size = scalar(()[1..1]); cmp_ok($size,'==','0','size nil'); } { # perl #39882 sub test_zero_args { my $test_name = shift; is(scalar(@_), 0, $test_name); } test_zero_args("simple list slice", (10,11)[2,3]); test_zero_args("grepped list slice", grep(1, (10,11)[2,3])); test_zero_args("sorted list slice", sort((10,11)[2,3])); test_zero_args("assigned list slice", my @tmp = (10,11)[2,3]); test_zero_args("do-returned list slice", do { (10,11)[2,3]; }); } { # perl #20321 is (join('', @{[('abc'=~/./g)[0,1,2,1,0]]}), "abcba"); } perl-5.12.0-RC0/t/op/universal.t0000555000175000017500000001575511325127002015214 0ustar jessejesse#!./perl # # check UNIVERSAL # BEGIN { chdir 't' if -d 't'; @INC = '../lib'; $| = 1; require "./test.pl"; } plan tests => 124; $a = {}; bless $a, "Bob"; ok $a->isa("Bob"); package Human; sub eat {} package Female; @ISA=qw(Human); package Alice; @ISA=qw(Bob Female); sub sing; sub drink { return "drinking " . $_[1] } sub new { bless {} } $Alice::VERSION = 2.718; { package Cedric; our @ISA; use base qw(Human); } { package Programmer; our $VERSION = 1.667; sub write_perl { 1 } } package main; $a = new Alice; ok $a->isa("Alice"); ok $a->isa("main::Alice"); # check that alternate class names work ok(("main::Alice"->new)->isa("Alice")); ok $a->isa("Bob"); ok $a->isa("main::Bob"); ok $a->isa("Female"); ok $a->isa("Human"); ok ! $a->isa("Male"); ok ! $a->isa('Programmer'); ok $a->isa("HASH"); ok $a->can("eat"); ok ! $a->can("sleep"); ok my $ref = $a->can("drink"); # returns a coderef is $a->$ref("tea"), "drinking tea"; # ... which works ok $ref = $a->can("sing"); eval { $a->$ref() }; ok $@; # ... but not if no actual subroutine ok (!Cedric->isa('Programmer')); ok (Cedric->isa('Human')); push(@Cedric::ISA,'Programmer'); ok (Cedric->isa('Programmer')); { package Alice; base::->import('Programmer'); } ok $a->isa('Programmer'); ok $a->isa("Female"); @Cedric::ISA = qw(Bob); ok (!Cedric->isa('Programmer')); my $b = 'abc'; my @refs = qw(SCALAR SCALAR LVALUE GLOB ARRAY HASH CODE); my @vals = ( \$b, \3.14, \substr($b,1,1), \*b, [], {}, sub {} ); for ($p=0; $p < @refs; $p++) { for ($q=0; $q < @vals; $q++) { is UNIVERSAL::isa($vals[$p], $refs[$q]), ($p==$q or $p+$q==1); }; }; ok ! UNIVERSAL::can(23, "can"); ok $a->can("VERSION"); ok $a->can("can"); ok ! $a->can("export_tags"); # a method in Exporter cmp_ok eval { $a->VERSION }, '==', 2.718; ok ! (eval { $a->VERSION(2.719) }); like $@, qr/^Alice version 2.719 required--this is only version 2.718 at /; ok (eval { $a->VERSION(2.718) }); is $@, ''; my $subs = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; ## The test for import here is *not* because we want to ensure that UNIVERSAL ## can always import; it is an historical accident that UNIVERSAL can import. if ('a' lt 'A') { is $subs, "can import isa DOES VERSION"; } else { is $subs, "DOES VERSION can import isa"; } ok $a->isa("UNIVERSAL"); ok ! UNIVERSAL::isa([], "UNIVERSAL"); ok ! UNIVERSAL::can({}, "can"); ok UNIVERSAL::isa(Alice => "UNIVERSAL"); cmp_ok UNIVERSAL::can(Alice => "can"), '==', \&UNIVERSAL::can; # now use UNIVERSAL.pm and see what changes eval "use UNIVERSAL"; ok $a->isa("UNIVERSAL"); my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; # XXX import being here is really a bug if ('a' lt 'A') { is $sub2, "can import isa DOES VERSION"; } else { is $sub2, "DOES VERSION can import isa"; } eval 'sub UNIVERSAL::sleep {}'; ok $a->can("sleep"); ok ! UNIVERSAL::can($b, "can"); ok ! $a->can("export_tags"); # a method in Exporter ok ! UNIVERSAL::isa("\xff\xff\xff\0", 'HASH'); { package Pickup; use UNIVERSAL qw( isa can VERSION ); ::ok isa "Pickup", UNIVERSAL; ::cmp_ok can( "Pickup", "can" ), '==', \&UNIVERSAL::can; ::ok VERSION "UNIVERSAL" ; } { # test isa() and can() on magic variables "Human" =~ /(.*)/; ok $1->isa("Human"); ok $1->can("eat"); package HumanTie; sub TIESCALAR { bless {} } sub FETCH { "Human" } tie my($x), "HumanTie"; ::ok $x->isa("Human"); ::ok $x->can("eat"); } # bugid 3284 # a second call to isa('UNIVERSAL') when @ISA is null failed due to caching @X::ISA=(); my $x = {}; bless $x, 'X'; ok $x->isa('UNIVERSAL'); ok $x->isa('UNIVERSAL'); # Check that the "historical accident" of UNIVERSAL having an import() # method doesn't effect anyone else. eval { Some::Package->import("bar") }; is $@, ''; # This segfaulted in a blead. fresh_perl_is('package Foo; Foo->VERSION; print "ok"', 'ok'); package Foo; sub DOES { 1 } package Bar; @Bar::ISA = 'Foo'; package Baz; package main; ok( Foo->DOES( 'bar' ), 'DOES() should call DOES() on class' ); ok( Bar->DOES( 'Bar' ), '... and should fall back to isa()' ); ok( Bar->DOES( 'Foo' ), '... even when inherited' ); ok( Baz->DOES( 'Baz' ), '... even without inheriting any other DOES()' ); ok( ! Baz->DOES( 'Foo' ), '... returning true or false appropriately' ); package Pig; package Bodine; Bodine->isa('Pig'); *isa = \&UNIVERSAL::isa; eval { isa({}, 'HASH') }; ::is($@, '', "*isa correctly found"); package main; eval { UNIVERSAL::DOES([], "foo") }; like( $@, qr/Can't call method "DOES" on unblessed reference/, 'DOES call error message says DOES, not isa' ); # Tests for can seem to be split between here and method.t # Add the verbatim perl code mentioned in the comments of # http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2001-05/msg01710.html # but never actually tested. is(UNIVERSAL->can("NoSuchPackage::foo"), undef); @splatt::ISA = 'zlopp'; ok (splatt->isa('zlopp')); ok (!splatt->isa('plop')); # This should reset the ->isa lookup cache @splatt::ISA = 'plop'; # And here is the new truth. ok (!splatt->isa('zlopp')); ok (splatt->isa('plop')); use warnings "deprecated"; { my $m; local $SIG{__WARN__} = sub { $m = $_[0] }; eval "use UNIVERSAL 'can'"; like($m, qr/^UNIVERSAL->import is deprecated/, "deprecation warning for UNIVERSAL->import('can')"); undef $m; eval "use UNIVERSAL"; is($m, undef, "no deprecation warning for UNIVERSAL->import"); } # Test: [perl #66112]: change @ISA inside sub isa { package RT66112::A; package RT66112::B; sub isa { my $self = shift; @ISA = qw/RT66112::A/; return $self->SUPER::isa(@_); } package RT66112::C; package RT66112::D; sub isa { my $self = shift; @RT66112::E::ISA = qw/RT66112::A/; return $self->SUPER::isa(@_); } package RT66112::E; package main; @RT66112::B::ISA = qw//; @RT66112::C::ISA = qw/RT66112::B/; @RT66112::T1::ISA = qw/RT66112::C/; ok(RT66112::T1->isa('RT66112::C'), "modify \@ISA in isa (RT66112::T1 isa RT66112::C)"); @RT66112::B::ISA = qw//; @RT66112::C::ISA = qw/RT66112::B/; @RT66112::T2::ISA = qw/RT66112::C/; ok(RT66112::T2->isa('RT66112::B'), "modify \@ISA in isa (RT66112::T2 isa RT66112::B)"); @RT66112::B::ISA = qw//; @RT66112::C::ISA = qw/RT66112::B/; @RT66112::T3::ISA = qw/RT66112::C/; ok(RT66112::T3->isa('RT66112::A'), "modify \@ISA in isa (RT66112::T3 isa RT66112::A)"); @RT66112::E::ISA = qw/RT66112::D/; @RT66112::T4::ISA = qw/RT66112::E/; ok(RT66112::T4->isa('RT66112::E'), "modify \@ISA in isa (RT66112::T4 isa RT66112::E)"); @RT66112::E::ISA = qw/RT66112::D/; @RT66112::T5::ISA = qw/RT66112::E/; ok(! RT66112::T5->isa('RT66112::D'), "modify \@ISA in isa (RT66112::T5 not isa RT66112::D)"); @RT66112::E::ISA = qw/RT66112::D/; @RT66112::T6::ISA = qw/RT66112::E/; ok(RT66112::T6->isa('RT66112::A'), "modify \@ISA in isa (RT66112::T6 isa RT66112::A)"); } perl-5.12.0-RC0/t/op/readline.t0000555000175000017500000000506411325125742014770 0ustar jessejesse#!./perl BEGIN { chdir 't'; @INC = '../lib'; require './test.pl'; } plan tests => 18; eval { for (\2) { $_ = } }; like($@, 'Modification of a read-only value attempted', '[perl #19566]'); { my $file = tempfile(); open A,'+>',$file; $a = 3; is($a .= , 3, '#21628 - $a .= , A eof'); close A; $a = 4; is($a .= , 4, '#21628 - $a .= , A closed'); } # 82 is chosen to exceed the length for sv_grow in do_readline (80) foreach my $k (1, 82) { my $result = runperl (stdin => '', stderr => 1, prog => "\$x = q(k) x $k; \$a{\$x} = qw(v); \$_ = <> foreach keys %a; print qw(end)", ); $result =~ s/\n\z// if $^O eq 'VMS'; is ($result, "end", '[perl #21614] for length ' . length('k' x $k)); } foreach my $k (1, 21) { my $result = runperl (stdin => ' rules', stderr => 1, prog => "\$x = q(perl) x $k; \$a{\$x} = q(v); foreach (keys %a) {\$_ .= <>; print}", ); $result =~ s/\n\z// if $^O eq 'VMS'; is ($result, ('perl' x $k) . " rules", 'rcatline to shared sv for length ' . length('perl' x $k)); } foreach my $l (1, 82) { my $k = $l; $k = 'k' x $k; my $copy = $k; $k = ; is ($k, "moo\n", 'catline to COW sv for length ' . length $copy); } foreach my $l (1, 21) { my $k = $l; $k = 'perl' x $k; my $perl = $k; $k .= ; is ($k, "$perl rules\n", 'rcatline to COW sv for length ' . length $perl); } use strict; use File::Spec; open F, File::Spec->curdir and sysread F, $_, 1; my $err = $! + 0; close F; SKIP: { skip "you can read directories as plain files", 2 unless( $err ); $!=0; open F, File::Spec->curdir and $_=; ok( $!==$err && !defined($_) => 'readline( DIRECTORY )' ); close F; $!=0; { local $/; open F, File::Spec->curdir and $_=; ok( $!==$err && !defined($_) => 'readline( DIRECTORY ) slurp mode' ); close F; } } fresh_perl_is('BEGIN{<>}', '', { switches => ['-w'], stdin => '', stderr => 1 }, 'No ARGVOUT used only once warning'); fresh_perl_is('print readline', 'foo', { switches => ['-w'], stdin => 'foo', stderr => 1 }, 'readline() defaults to *ARGV'); my $obj = bless []; $obj .= ; like($obj, qr/main=ARRAY.*world/, 'rcatline and refs'); # bug #38631 require Tie::Scalar; tie our $one, 'Tie::StdScalar', "A: "; tie our $two, 'Tie::StdScalar', "B: "; my $junk = $one; $one .= ; $two .= ; is( $one, "A: One\n", "rcatline works with tied scalars" ); is( $two, "B: Two\n", "rcatline works with tied scalars" ); __DATA__ moo moo rules rules world One Two perl-5.12.0-RC0/t/op/chop.t0000555000175000017500000001161311325127001014121 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } plan tests => 139; $_ = 'abc'; $c = foo(); is ($c . $_, 'cab', 'optimized'); $_ = 'abc'; $c = chop($_); is ($c . $_ , 'cab', 'unoptimized'); sub foo { chop; } @foo = ("hi \n","there\n","!\n"); @bar = @foo; chop(@bar); is (join('',@bar), 'hi there!'); $foo = "\n"; chop($foo,@foo); is (join('',$foo,@foo), 'hi there!'); $_ = "foo\n\n"; $got = chomp(); ok ($got == 1) or print "# got $got\n"; is ($_, "foo\n"); $_ = "foo\n"; $got = chomp(); ok ($got == 1) or print "# got $got\n"; is ($_, "foo"); $_ = "foo"; $got = chomp(); ok ($got == 0) or print "# got $got\n"; is ($_, "foo"); $_ = "foo"; $/ = "oo"; $got = chomp(); ok ($got == 2) or print "# got $got\n"; is ($_, "f"); $_ = "bar"; $/ = "oo"; $got = chomp(); ok ($got == 0) or print "# got $got\n"; is ($_, "bar"); $_ = "f\n\n\n\n\n"; $/ = ""; $got = chomp(); ok ($got == 5) or print "# got $got\n"; is ($_, "f"); $_ = "f\n\n"; $/ = ""; $got = chomp(); ok ($got == 2) or print "# got $got\n"; is ($_, "f"); $_ = "f\n"; $/ = ""; $got = chomp(); ok ($got == 1) or print "# got $got\n"; is ($_, "f"); $_ = "f"; $/ = ""; $got = chomp(); ok ($got == 0) or print "# got $got\n"; is ($_, "f"); $_ = "xx"; $/ = "xx"; $got = chomp(); ok ($got == 2) or print "# got $got\n"; is ($_, ""); $_ = "axx"; $/ = "xx"; $got = chomp(); ok ($got == 2) or print "# got $got\n"; is ($_, "a"); $_ = "axx"; $/ = "yy"; $got = chomp(); ok ($got == 0) or print "# got $got\n"; is ($_, "axx"); # This case once mistakenly behaved like paragraph mode. $_ = "ab\n"; $/ = \3; $got = chomp(); ok ($got == 0) or print "# got $got\n"; is ($_, "ab\n"); # Go Unicode. $_ = "abc\x{1234}"; chop; is ($_, "abc", "Go Unicode"); $_ = "abc\x{1234}d"; chop; is ($_, "abc\x{1234}"); $_ = "\x{1234}\x{2345}"; chop; is ($_, "\x{1234}"); my @stuff = qw(this that); is (chop(@stuff[0,1]), 't'); # bug id 20010305.012 @stuff = qw(ab cd ef); is (chop(@stuff = @stuff), 'f'); @stuff = qw(ab cd ef); is (chop(@stuff[0, 2]), 'f'); my %stuff = (1..4); is (chop(@stuff{1, 3}), '4'); # chomp should not stringify references unless it decides to modify them $_ = []; $/ = "\n"; $got = chomp(); ok ($got == 0) or print "# got $got\n"; is (ref($_), "ARRAY", "chomp ref (modify)"); $/ = ")"; # the last char of something like "ARRAY(0x80ff6e4)" $got = chomp(); ok ($got == 1) or print "# got $got\n"; ok (!ref($_), "chomp ref (no modify)"); $/ = "\n"; %chomp = ("One" => "One", "Two\n" => "Two", "" => ""); %chop = ("One" => "On", "Two\n" => "Two", "" => ""); foreach (keys %chomp) { my $key = $_; eval {chomp $_}; if ($@) { my $err = $@; $err =~ s/\n$//s; fail ("\$\@ = \"$err\""); } else { is ($_, $chomp{$key}, "chomp hash key"); } } foreach (keys %chop) { my $key = $_; eval {chop $_}; if ($@) { my $err = $@; $err =~ s/\n$//s; fail ("\$\@ = \"$err\""); } else { is ($_, $chop{$key}, "chop hash key"); } } # chop and chomp can't be lvalues eval 'chop($x) = 1;'; ok($@ =~ /Can\'t modify.*chop.*in.*assignment/); eval 'chomp($x) = 1;'; ok($@ =~ /Can\'t modify.*chom?p.*in.*assignment/); eval 'chop($x, $y) = (1, 2);'; ok($@ =~ /Can\'t modify.*chop.*in.*assignment/); eval 'chomp($x, $y) = (1, 2);'; ok($@ =~ /Can\'t modify.*chom?p.*in.*assignment/); my @chars = ("N", ord('A') == 193 ? "\xee" : "\xd3", substr ("\xd4\x{100}", 0, 1), chr 1296); foreach my $start (@chars) { foreach my $end (@chars) { local $/ = $end; my $message = "start=" . ord ($start) . " end=" . ord $end; my $string = $start . $end; is (chomp ($string), 1, "$message [returns 1]"); is ($string, $start, $message); my $end_utf8 = $end; utf8::encode ($end_utf8); next if $end_utf8 eq $end; # $end ne $end_utf8, so these should not chomp. $string = $start . $end_utf8; my $chomped = $string; is (chomp ($chomped), 0, "$message (end as bytes) [returns 0]"); is ($chomped, $string, "$message (end as bytes)"); $/ = $end_utf8; $string = $start . $end; $chomped = $string; is (chomp ($chomped), 0, "$message (\$/ as bytes) [returns 0]"); is ($chomped, $string, "$message (\$/ as bytes)"); } } { # returns length in characters, but not in bytes. $/ = "\x{100}"; $a = "A$/"; $b = chomp $a; is ($b, 1); $/ = "\x{100}\x{101}"; $a = "A$/"; $b = chomp $a; is ($b, 2); } { # [perl #36569] chop fails on decoded string with trailing nul my $asc = "perl\0"; my $utf = "perl".pack('U',0); # marked as utf8 is(chop($asc), "\0", "chopping ascii NUL"); is(chop($utf), "\0", "chopping utf8 NUL"); is($asc, "perl", "chopped ascii NUL"); is($utf, "perl", "chopped utf8 NUL"); } { # Change 26011: Re: A surprising segfault # to make sure only that these obfuscated sentences will not crash. map chop(+()), ('')x68; ok(1, "extend sp in pp_chop"); map chomp(+()), ('')x68; ok(1, "extend sp in pp_chomp"); } perl-5.12.0-RC0/t/op/push.t0000555000175000017500000000303111325127001014142 0ustar jessejesse#!./perl @tests = split(/\n/, <, "foo"; eval { $fh->seek(0, 0); is $fh->tell, 0; is <$fh>, "foo"; }; is $@, ''; perl-5.12.0-RC0/t/op/write.t0000555000175000017500000003752111325127002014331 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } use strict; # Amazed that this hackery can be made strict ... # read in a file sub cat { my $file = shift; local $/; open my $fh, $file or die "can't open '$file': $!"; my $data = <$fh>; close $fh; $data; } #-- testing numeric fields in all variants (WL) sub swrite { my $format = shift; local $^A = ""; # don't litter, use a local bin formline( $format, @_ ); return $^A; } my @NumTests = ( # [ format, value1, expected1, value2, expected2, .... ] [ '@###', 0, ' 0', 1, ' 1', 9999.6, '####', 9999.4999, '9999', -999.6, '####', 1e+100, '####' ], [ '@0##', 0, '0000', 1, '0001', 9999.6, '####', -999.4999, '-999', -999.6, '####', 1e+100, '####' ], [ '^###', 0, ' 0', undef, ' ' ], [ '^0##', 0, '0000', undef, ' ' ], [ '@###.', 0, ' 0.', 1, ' 1.', 9999.6, '#####', 9999.4999, '9999.', -999.6, '#####' ], [ '@##.##', 0, ' 0.00', 1, ' 1.00', 999.996, '######', 999.99499, '999.99', -100, '######' ], [ '@0#.##', 0, '000.00', 1, '001.00', 10, '010.00', -0.0001, qr/^[\-0]00\.00$/ ], ); my $num_tests = 0; for my $tref ( @NumTests ){ $num_tests += (@$tref - 1)/2; } #--------------------------------------------------------- # number of tests in section 1 my $bas_tests = 20; # number of tests in section 3 my $bug_tests = 4 + 3 * 3 * 5 * 2 * 3 + 2 + 1 + 1; # number of tests in section 4 my $hmb_tests = 35; my $tests = $bas_tests + $num_tests + $bug_tests + $hmb_tests; plan $tests; ############ ## Section 1 ############ use vars qw($fox $multiline $foo $good); format OUT = the quick brown @<< $fox jumped @* $multiline ^<<<<<<<<< $foo ^<<<<<<<<< $foo ^<<<<<<... $foo now @<>>> for all@|||||men to come @<<<< { 'i' . 's', "time\n", $good, 'to' } . open(OUT, '>Op_write.tmp') || die "Can't create Op_write.tmp"; END { 1 while unlink 'Op_write.tmp' } $fox = 'foxiness'; $good = 'good'; $multiline = "forescore\nand\nseven years\n"; $foo = 'when in the course of human events it becomes necessary'; write(OUT); close OUT or die "Could not close: $!"; my $right = "the quick brown fox jumped forescore and seven years when in the course of huma... now is the time for all good men to come to\n"; is cat('Op_write.tmp'), $right and do { 1 while unlink 'Op_write.tmp'; }; $fox = 'wolfishness'; my $fox = 'foxiness'; # Test a lexical variable. format OUT2 = the quick brown @<< $fox jumped @* $multiline ^<<<<<<<<< ~~ $foo now @<>>> for all@|||||men to come @<<<< 'i' . 's', "time\n", $good, 'to' . open OUT2, '>Op_write.tmp' or die "Can't create Op_write.tmp"; $good = 'good'; $multiline = "forescore\nand\nseven years\n"; $foo = 'when in the course of human events it becomes necessary'; write(OUT2); close OUT2 or die "Could not close: $!"; $right = "the quick brown fox jumped forescore and seven years when in the course of human events it becomes necessary now is the time for all good men to come to\n"; is cat('Op_write.tmp'), $right and do { 1 while unlink 'Op_write.tmp'; }; eval <<'EOFORMAT'; format OUT2 = the brown quick @<< $fox jumped @* $multiline and ^<<<<<<<<< ~~ $foo now @<>>> for all@|||||men to come @<<<< 'i' . 's', "time\n", $good, 'to' . EOFORMAT open(OUT2, '>Op_write.tmp') || die "Can't create Op_write.tmp"; $fox = 'foxiness'; $good = 'good'; $multiline = "forescore\nand\nseven years\n"; $foo = 'when in the course of human events it becomes necessary'; write(OUT2); close OUT2 or die "Could not close: $!"; $right = "the brown quick fox jumped forescore and seven years and when in the course of human events it becomes necessary now is the time for all good men to come to\n"; is cat('Op_write.tmp'), $right and do { 1 while unlink 'Op_write.tmp' }; # formline tests $right = < ab @>> abc @>>> abc @>>>> abc @>>>>> abc @>>>>>> abc @>>>>>>> abc @>>>>>>>> abc @>>>>>>>>> abc @>>>>>>>>>> abc EOT my $was1 = my $was2 = ''; use vars '$format2'; for (0..10) { # lexical picture $^A = ''; my $format1 = '@' . '>' x $_; formline $format1, 'abc'; $was1 .= "$format1 $^A\n"; # global $^A = ''; local $format2 = '@' . '>' x $_; formline $format2, 'abc'; $was2 .= "$format2 $^A\n"; } is $was1, $right; is $was2, $right; $^A = ''; # more test format OUT3 = ^<<<<<<... $foo . open(OUT3, '>Op_write.tmp') || die "Can't create Op_write.tmp"; $foo = 'fit '; write(OUT3); close OUT3 or die "Could not close: $!"; $right = "fit\n"; is cat('Op_write.tmp'), $right and do { 1 while unlink 'Op_write.tmp' }; # test lexicals and globals { my $test = curr_test(); my $this = "ok"; our $that = $test; format LEX = @<<@| $this,$that . open(LEX, ">&STDOUT") or die; write LEX; $that = ++$test; write LEX; close LEX or die "Could not close: $!"; curr_test($test + 1); } # LEX_INTERPNORMAL test my %e = ( a => 1 ); format OUT4 = @<<<<<< "$e{a}" . open OUT4, ">Op_write.tmp" or die "Can't create Op_write.tmp"; write (OUT4); close OUT4 or die "Could not close: $!"; is cat('Op_write.tmp'), "1\n" and do { 1 while unlink "Op_write.tmp" }; eval <<'EOFORMAT'; format OUT10 = @####.## @0###.## $test1, $test1 . EOFORMAT open(OUT10, '>Op_write.tmp') || die "Can't create Op_write.tmp"; use vars '$test1'; $test1 = 12.95; write(OUT10); close OUT10 or die "Could not close: $!"; $right = " 12.95 00012.95\n"; is cat('Op_write.tmp'), $right and do { 1 while unlink 'Op_write.tmp' }; eval <<'EOFORMAT'; format OUT11 = @0###.## $test1 @ 0# $test1 @0 # $test1 . EOFORMAT open(OUT11, '>Op_write.tmp') || die "Can't create Op_write.tmp"; $test1 = 12.95; write(OUT11); close OUT11 or die "Could not close: $!"; $right = "00012.95 1 0# 10 #\n"; is cat('Op_write.tmp'), $right and do { 1 while unlink 'Op_write.tmp' }; { my $test = curr_test(); my $el; format OUT12 = ok ^<<<<<<<<<<<<<<~~ # sv_chop() naze $el . my %hash = ($test => 3); open(OUT12, '>Op_write.tmp') || die "Can't create Op_write.tmp"; for $el (keys %hash) { write(OUT12); } close OUT12 or die "Could not close: $!"; print cat('Op_write.tmp'); curr_test($test + 1); } { my $test = curr_test(); # Bug report and testcase by Alexey Tourbin use Tie::Scalar; my $v; tie $v, 'Tie::StdScalar'; $v = $test; format OUT13 = ok ^<<<<<<<<< ~~ $v . open(OUT13, '>Op_write.tmp') || die "Can't create Op_write.tmp"; write(OUT13); close OUT13 or die "Could not close: $!"; print cat('Op_write.tmp'); curr_test($test + 1); } { # test 14 # Bug #24774 format without trailing \n failed assertion, but this # must fail since we have a trailing ; in the eval'ed string (WL) my @v = ('k'); eval "format OUT14 = \n@\n\@v"; like $@, qr/Format not terminated/; } { # test 15 # text lost in ^<<< field with \r in value (WL) my $txt = "line 1\rline 2"; format OUT15 = ^<<<<<<<<<<<<<<<<<< $txt ^<<<<<<<<<<<<<<<<<< $txt . open(OUT15, '>Op_write.tmp') || die "Can't create Op_write.tmp"; write(OUT15); close OUT15 or die "Could not close: $!"; my $res = cat('Op_write.tmp'); is $res, "line 1\nline 2\n"; } { # test 16: multiple use of a variable in same line with ^< my $txt = "this_is_block_1 this_is_block_2 this_is_block_3 this_is_block_4"; format OUT16 = ^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<< $txt, $txt ^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<< $txt, $txt . open(OUT16, '>Op_write.tmp') || die "Can't create Op_write.tmp"; write(OUT16); close OUT16 or die "Could not close: $!"; my $res = cat('Op_write.tmp'); is $res, <Op_write.tmp') || die "Can't create Op_write.tmp"; write(OUT17); close OUT17 or die "Could not close: $!"; my $res = cat('Op_write.tmp'); chomp( $txt ); my $exp = <Op_write.tmp') || die "Can't create Op_write.tmp"; eval { write(OUT18); }; like $@, qr/Repeated format line will never terminate/; close OUT18 or die "Could not close: $!"; } { # test 19: \0 in an evel'ed format, doesn't cause empty lines (WL) my $v = 'gaga'; eval "format OUT19 = \n" . '@<<<' . "\0\n" . '$v' . "\n" . '@<<<' . "\0\n" . '$v' . "\n.\n"; open(OUT19, '>Op_write.tmp') || die "Can't create Op_write.tmp"; write(OUT19); close OUT19 or die "Could not close: $!"; my $res = cat('Op_write.tmp'); is $res, < 'xval', ykey => 'yval' ); format OUT20 = @>>>> @<<<< ~~ each %h @>>>> @<<<< $h{xkey}, $h{ykey} @>>>> @<<<< { $h{xkey}, $h{ykey} } } . my $exp = ''; while( my( $k, $v ) = each( %h ) ){ $exp .= sprintf( "%5s %s\n", $k, $v ); } $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} ); $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} ); $exp .= "}\n"; open(OUT20, '>Op_write.tmp') || die "Can't create Op_write.tmp"; write(OUT20); close OUT20 or die "Could not close: $!"; my $res = cat('Op_write.tmp'); is $res, $exp; } ##################### ## Section 2 ## numeric formatting ##################### curr_test($bas_tests + 1); for my $tref ( @NumTests ){ my $writefmt = shift( @$tref ); while (@$tref) { my $val = shift @$tref; my $expected = shift @$tref; my $writeres = swrite( $writefmt, $val ); if (ref $expected) { like $writeres, $expected, $writefmt; } else { is $writeres, $expected, $writefmt; } } } ##################################### ## Section 3 ## Easiest to add new tests just here ##################################### # DAPM. Exercise a couple of error codepaths { local $~ = ''; eval { write }; like $@, qr/Not a format reference/, 'format reference'; $~ = "NOSUCHFORMAT"; eval { write }; like $@, qr/Undefined format/, 'no such format'; } { package Count; sub TIESCALAR { my $class = shift; bless [shift, 0, 0], $class; } sub FETCH { my $self = shift; ++$self->[1]; $self->[0]; } sub STORE { my $self = shift; ++$self->[2]; $self->[0] = shift; } } { my ($pound_utf8, $pm_utf8) = map { my $a = "$_\x{100}"; chop $a; $a} my ($pound, $pm) = ("\xA3", "\xB1"); foreach my $first ('N', $pound, $pound_utf8) { foreach my $base ('N', $pm, $pm_utf8) { foreach my $second ($base, "$base\n", "$base\nMoo!", "$base\nMoo!\n", "$base\nMoo!\n",) { foreach (['^*', qr/(.+)/], ['@*', qr/(.*?)$/s]) { my ($format, $re) = @$_; foreach my $class ('', 'Count') { my $name = "$first, $second $format $class"; $name =~ s/\n/\\n/g; $first =~ /(.+)/ or die $first; my $expect = "1${1}2"; $second =~ $re or die $second; $expect .= " 3${1}4"; if ($class) { my $copy1 = $first; my $copy2; tie $copy2, $class, $second; is swrite("1^*2 3${format}4", $copy1, $copy2), $expect, $name; my $obj = tied $copy2; is $obj->[1], 1, 'value read exactly once'; } else { my ($copy1, $copy2) = ($first, $second); is swrite("1^*2 3${format}4", $copy1, $copy2), $expect, $name; } } } } } } } { # This will fail an assertion in 5.10.0 built with -DDEBUGGING (because # pp_formline attempts to set SvCUR() on an SVt_RV). I suspect that it will # be doing something similarly out of bounds on everything from 5.000 my $ref = []; is swrite('>^*<', $ref), ">$ref<"; is swrite('>@*<', $ref), ">$ref<"; } format EMPTY = . my $test = curr_test(); format Comment = ok @<<<<< $test . # [ID 20020227.005] format bug with undefined _TOP open STDOUT_DUP, ">&STDOUT"; my $oldfh = select STDOUT_DUP; $= = 10; { local $~ = "Comment"; write; curr_test($test + 1); { local $::TODO = '[ID 20020227.005] format bug with undefined _TOP'; is $-, 9; } is $^, "STDOUT_DUP_TOP"; } select $oldfh; close STDOUT_DUP; *CmT = *{$::{Comment}}{FORMAT}; ok defined *{$::{CmT}}{FORMAT}, "glob assign"; fresh_perl_like(<<'EOP', qr/^Format STDOUT redefined at/, {stderr => 1}, '#64562 - Segmentation fault with redefined formats and warnings'); #!./perl use strict; use warnings; # crashes! format = . write; format = . write; EOP ############################# ## Section 4 ## Add new tests *above* here ############################# # scary format testing from H.Merijn Brand # Just a complete test for format, including top-, left- and bottom marging # and format detection through glob entries if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' || ($^O eq 'os2' and not eval '$OS2::can_fork')) { $test = curr_test(); SKIP: { skip "'|-' and '-|' not supported", $tests - $test + 1; } exit(0); } $^ = "STDOUT_TOP"; $= = 7; # Page length $- = 0; # Lines left my $ps = $^L; $^L = ""; # Catch the page separator my $tm = 1; # Top margin (empty lines before first output) my $bm = 2; # Bottom marging (empty lines between last text and footer) my $lm = 4; # Left margin (indent in spaces) # ----------------------------------------------------------------------- # # execute the rest of the script in a child process. The parent reads the # output from the child and compares it with . my @data = ; select ((select (STDOUT), $| = 1)[0]); # flush STDOUT my $opened = open FROM_CHILD, "-|"; unless (defined $opened) { fail "open gave $!"; exit 0; } if ($opened) { # in parent here pass 'open'; my $s = " " x $lm; while () { unless (@data) { fail 'too much output'; exit; } s/^/$s/; my $exp = shift @data; is $_, $exp; } close FROM_CHILD; is "@data", "", "correct length of output"; exit; } # in child here $::NO_ENDING = 1; select ((select (STDOUT), $| = 1)[0]); $tm = "\n" x $tm; $= -= $bm + 1; # count one for the trailing "----" my $lastmin = 0; my @E; sub wryte { $lastmin = $-; write; } # wryte; sub footer { $% == 1 and return ""; $lastmin < $= and print "\n" x $lastmin; print "\n" x $bm, "----\n", $ps; $lastmin = $-; ""; } # footer # Yes, this is sick ;-) format TOP = @* ~ @{[footer]} @* ~ $tm . format ENTRY = @ @<<<<~~ @{(shift @E)||["",""]} . format EOR = - ----- . sub has_format ($) { my $fmt = shift; exists $::{$fmt} or return 0; $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT}; open my $null, "> /dev/null" or die; my $fh = select $null; local $~ = $fmt; eval "write"; select $fh; $@?0:1; } # has_format $^ = has_format ("TOP") ? "TOP" : "EMPTY"; has_format ("ENTRY") or die "No format defined for ENTRY"; foreach my $e ( [ map { [ $_, "Test$_" ] } 1 .. 7 ], [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) { @E = @$e; local $~ = "ENTRY"; wryte; has_format ("EOR") or next; local $~ = "EOR"; wryte; } if (has_format ("EOF")) { local $~ = "EOF"; wryte; } close STDOUT; # That was test 48. __END__ 1 Test1 2 Test2 3 Test3 ---- 4 Test4 5 Test5 6 Test6 ---- 7 Test7 - ----- ---- 1 1tseT 2 2tseT 3 3tseT ---- 4 4tseT 5 5tseT - ----- perl-5.12.0-RC0/t/op/sprintf.t0000555000175000017500000006555011325127001014666 0ustar jessejesse#!./perl # Tests sprintf, excluding handling of 64-bit integers or long # doubles (if supported), of machine-specific short and long # integers, machine-specific floating point exceptions (infinity, # not-a-number ...), of the effects of locale, and of features # specific to multi-byte characters (under the utf8 pragma and such). BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } use warnings; use version; use Config; use strict; my @tests = (); my ($i, $template, $data, $result, $comment, $w, $x, $evalData, $n, $p); my $Is_VMS_VAX = 0; # We use HW_MODEL since ARCH_NAME was not in VMS V5.* if ($^O eq 'VMS') { my $hw_model; chomp($hw_model = `write sys\$output f\$getsyi("HW_MODEL")`); $Is_VMS_VAX = $hw_model < 1024 ? 1 : 0; } # No %Config. my $Is_Ultrix_VAX = $^O eq 'ultrix' && `uname -m` =~ /^VAX$/; while () { s/^\s*>//; s/<\s*$//; ($template, $data, $result, $comment) = split(/<\s*>/, $_, 4); if ($^O eq 'os390' || $^O eq 's390') { # non-IEEE (s390 is UTS) $data =~ s/([eE])96$/${1}63/; # smaller exponents $result =~ s/([eE]\+)102$/${1}69/; # " " $data =~ s/([eE])\-101$/${1}-56/; # larger exponents $result =~ s/([eE])\-102$/${1}-57/; # " " } if ($Is_VMS_VAX || $Is_Ultrix_VAX) { # VAX DEC C 5.3 at least since there is no # ccflags =~ /float=ieee/ on VAX. # AXP is unaffected whether or not it's using ieee. $data =~ s/([eE])96$/${1}26/; # smaller exponents $result =~ s/([eE]\+)102$/${1}32/; # " " $data =~ s/([eE])\-101$/${1}-24/; # larger exponents $result =~ s/([eE])\-102$/${1}-25/; # " " } $evalData = eval $data; $evalData = ref $evalData ? $evalData : [$evalData]; push @tests, [$template, $evalData, $result, $comment, $data]; } print '1..', scalar @tests, "\n"; $SIG{__WARN__} = sub { if ($_[0] =~ /^Invalid conversion/) { $w = ' INVALID'; } elsif ($_[0] =~ /^Use of uninitialized value/) { $w = ' UNINIT'; } elsif ($_[0] =~ /^Missing argument/) { $w = ' MISSING'; } else { warn @_; } }; for ($i = 1; @tests; $i++) { ($template, $evalData, $result, $comment, $data) = @{shift @tests}; $w = undef; $x = sprintf(">$template<", @$evalData); substr($x, -1, 0) = $w if $w; # $x may have 3 exponent digits, not 2 my $y = $x; if ($y =~ s/([Ee][-+])0(\d)/$1$2/) { # if result is left-adjusted, append extra space if ($template =~ /%\+?\-/ and $result =~ / $/) { $y =~ s/<$/ 0/>00/; } # if result is right-adjusted, prepend extra space elsif ($result =~ /^ /) { $y =~ s/^>/> /; } } my $skip = 0; if ($comment =~ s/\s+skip:\s*(.*)//) { my $os = $1; my $osv = exists $Config{osvers} ? $Config{osvers} : "0"; # >comment skip: all< if ($os =~ /\ball\b/i) { $skip = 1; # >comment skip: VMS hpux:10.20< } elsif ($os =~ /\b$^O(?::(\S+))?\b/i) { my $vsn = defined $1 ? $1 : "0"; # Only compare on the the first pair of digits, as numeric # compares don't like 2.6.10-3mdksmp or 2.6.8-24.10-default s/^(\d+(\.\d+)?).*/$1/ for $osv, $vsn; $skip = $vsn ? ($osv <= $vsn ? 1 : 0) : 1; } $skip and $comment =~ s/$/, failure expected on $^O $osv/; } if ($x eq ">$result<") { print "ok $i\n"; } elsif ($skip) { print "ok $i # skip $comment\n"; } elsif ($y eq ">$result<") # Some C libraries always give { # three-digit exponent print("ok $i # >$result< $x three-digit exponent accepted\n"); } elsif ($result =~ /[-+]\d{3}$/ && # Suppress tests with modulo of exponent >= 100 on platforms # which can't handle such magnitudes (or where we can't tell). ((!eval {require POSIX}) || # Costly: only do this if we must! (length(&POSIX::DBL_MAX) - rindex(&POSIX::DBL_MAX, '+')) == 3)) { print("ok $i # >$template< >$data< >$result<", " Suppressed: exponent out of range?\n"); } else { $y = ($x eq $y ? "" : " => $y"); print("not ok $i >$template< >$data< >$result< $x$y", $comment ? " # $comment\n" : "\n"); } } # In each of the following lines, there are three required fields: # printf template, data to be formatted (as a Perl expression), and # expected result of formatting. An optional fourth field can contain # a comment. Each field is delimited by a starting '>' and a # finishing '<'; any whitespace outside these start and end marks is # not part of the field. If formatting requires more than one data # item (for example, if variable field widths are used), the Perl data # expression should return a reference to an array having the requisite # number of elements. Even so, subterfuge is sometimes required: see # tests for %n and %p. # # Tests that are expected to fail on a certain OS can be marked as such # by trailing the comment with a skip: section. Skips are tags separated # bu space consisting of a $^O optionally trailed with :osvers. In the # latter case, all os-levels below that are expected to fail. A special # tag 'all' is allowed for todo tests that should fail on any system # # >%G< >1234567e96< >1.23457E+102< >exponent too big skip: os390< # >%.0g< >-0.0< >-0< >No minus skip: MSWin32 VMS hpux:10.20< # >%d< >4< >1< >4 != 1 skip: all< # # The following tests are not currently run, for the reasons stated: =pod =begin problematic >%.0f< >1.5< >2< >Standard vague: no rounding rules< >%.0f< >2.5< >2< >Standard vague: no rounding rules< =end problematic =cut # template data result __END__ >%6. 6s< >''< >%6. 6s INVALID< >(See use of $w in code above)< >%6 .6s< >''< >%6 .6s INVALID< >%6.6 s< >''< >%6.6 s INVALID< >%A< >''< >%A INVALID< >%B< >2**32-1< >11111111111111111111111111111111< >%+B< >2**32-1< >11111111111111111111111111111111< >%#B< >2**32-1< >0B11111111111111111111111111111111< >%C< >''< >%C INVALID< >%D< >0x7fffffff< >2147483647< >Synonym for %ld< >%E< >123456.789< >1.234568E+05< >Like %e, but using upper-case "E"< >%F< >123456.789< >123456.789000< >Synonym for %f< >%G< >1234567.89< >1.23457E+06< >Like %g, but using upper-case "E"< >%G< >1234567e96< >1.23457E+102< >%G< >.1234567e-101< >1.23457E-102< >%G< >12345.6789< >12345.7< >%G< >1234567e96< >1.23457E+102< >exponent too big skip: os390< >%G< >.1234567e-101< >1.23457E-102< >exponent too small skip: os390< >%H< >''< >%H INVALID< >%I< >''< >%I INVALID< >%J< >''< >%J INVALID< >%K< >''< >%K INVALID< >%L< >''< >%L INVALID< >%M< >''< >%M INVALID< >%N< >''< >%N INVALID< >%O< >2**32-1< >37777777777< >Synonym for %lo< >%P< >''< >%P INVALID< >%Q< >''< >%Q INVALID< >%R< >''< >%R INVALID< >%S< >''< >%S INVALID< >%T< >''< >%T INVALID< >%U< >2**32-1< >4294967295< >Synonym for %lu< >%V< >''< >%V INVALID< >%W< >''< >%W INVALID< >%X< >2**32-1< >FFFFFFFF< >Like %x, but with u/c letters< >%#X< >2**32-1< >0XFFFFFFFF< >%Y< >''< >%Y INVALID< >%Z< >''< >%Z INVALID< >%a< >''< >%a INVALID< >%b< >2**32-1< >11111111111111111111111111111111< >%+b< >2**32-1< >11111111111111111111111111111111< >%#b< >2**32-1< >0b11111111111111111111111111111111< >%34b< >2**32-1< > 11111111111111111111111111111111< >%034b< >2**32-1< >0011111111111111111111111111111111< >%-34b< >2**32-1< >11111111111111111111111111111111 < >%-034b< >2**32-1< >11111111111111111111111111111111 < >%6b< >12< > 1100< >%6.5b< >12< > 01100< >%-6.5b< >12< >01100 < >%+6.5b< >12< > 01100< >% 6.5b< >12< > 01100< >%06.5b< >12< > 01100< >0 flag with precision: no effect< >%.5b< >12< >01100< >%.0b< >0< >< >%+.0b< >0< >< >% .0b< >0< >< >%-.0b< >0< >< >%#.0b< >0< >< >%#3.0b< >0< > < >%#3.1b< >0< > 0< >%#3.2b< >0< > 00< >%#3.3b< >0< >000< >%#3.4b< >0< >0000< >%.0b< >1< >1< >%+.0b< >1< >1< >% .0b< >1< >1< >%-.0b< >1< >1< >%#.0b< >1< >0b1< >%#3.0b< >1< >0b1< >%#3.1b< >1< >0b1< >%#3.2b< >1< >0b01< >%#3.3b< >1< >0b001< >%#3.4b< >1< >0b0001< >%c< >ord('A')< >A< >%10c< >ord('A')< > A< >%#10c< >ord('A')< > A< ># modifier: no effect< >%010c< >ord('A')< >000000000A< >%10lc< >ord('A')< > A< >l modifier: no effect< >%10hc< >ord('A')< > A< >h modifier: no effect< >%10.5c< >ord('A')< > A< >precision: no effect< >%-10c< >ord('A')< >A < >%d< >123456.789< >123456< >%d< >-123456.789< >-123456< >%d< >0< >0< >%-d< >0< >0< >%+d< >0< >+0< >% d< >0< > 0< >%0d< >0< >0< >%-3d< >1< >1 < >%+3d< >1< > +1< >% 3d< >1< > 1< >%03d< >1< >001< >%+ 3d< >1< > +1< >% +3d< >1< > +1< >%.0d< >0< >< >%+.0d< >0< >+< >% .0d< >0< > < >%-.0d< >0< >< >%#.0d< >0< >< >%.0d< >1< >1< >%d< >1< >1< >%+d< >1< >+1< >%#3.2d< >1< > 01< ># modifier: no effect< >%3.2d< >1< > 01< >%03.2d< >1< > 01< >0 flag with precision: no effect< >%-3.2d< >1< >01 < >%+3.2d< >1< >+01< >% 3.2d< >1< > 01< >%-03.2d< >1< >01 < >zero pad + left just.: no effect< >%3.*d< >[2,1]< > 01< >%3.*d< >[1,1]< > 1< >%3.*d< >[0,1]< > 1< >%3.*d< >[-1,1]< > 1< >%.*d< >[0,0]< >< >%-.*d< >[0,0]< >< >%+.*d< >[0,0]< >+< >% .*d< >[0,0]< > < >%0.*d< >[0,0]< >< >%.*d< >[-2,0]< >0< >%-.*d< >[-2,0]< >0< >%+.*d< >[-2,0]< >+0< >% .*d< >[-2,0]< > 0< >%0.*d< >[-2,0]< >0< >%d< >-1< >-1< >%-d< >-1< >-1< >%+d< >-1< >-1< >% d< >-1< >-1< >%-3d< >-1< >-1 < >%+3d< >-1< > -1< >% 3d< >-1< > -1< >%03d< >-1< >-01< >%hd< >1< >1< >More extensive testing of< >%ld< >1< >1< >length modifiers would be< >%Vd< >1< >1< >platform-specific< >%vd< >chr(1)< >1< >%+vd< >chr(1)< >+1< >%#vd< >chr(1)< >1< >%vd< >"\01\02\03"< >1.2.3< >%vd< >v1.2.3< >1.2.3< >%vd< >[version::qv("1.2.3")]< >1.2.3< >%vd< >[version->new("1.2")]< >1.2< >%vd< >[version->new("1.02")]< >1.2< >%vd< >[version->new("1.002")]< >1.2< >%vd< >[version->new("1048576.5")]< >1048576.5< >%vd< >[version->new("50")]< >50< >%v.3d< >"\01\02\03"< >001.002.003< >%0v3d< >"\01\02\03"< >001.002.003< >%v.3d< >[version::qv("1.2.3")]< >001.002.003< >%-v3d< >"\01\02\03"< >1 .2 .3 < >%+-v3d< >"\01\02\03"< >+1 .2 .3 < >%+-v3d< >[version::qv("1.2.3")]< >+1 .2 .3 < >%v4.3d< >"\01\02\03"< > 001. 002. 003< >%0v4.3d< >"\01\02\03"< > 001. 002. 003< >%0*v2d< >['-', "\0\7\14"]< >00-07-12< >%v.*d< >["\01\02\03", 3]< >001.002.003< >%0v*d< >["\01\02\03", 3]< >001.002.003< >%-v*d< >["\01\02\03", 3]< >1 .2 .3 < >%+-v*d< >["\01\02\03", 3]< >+1 .2 .3 < >%v*.*d< >["\01\02\03", 4, 3]< > 001. 002. 003< >%0v*.*d< >["\01\02\03", 4, 3]< > 001. 002. 003< >%0*v*d< >['-', "\0\7\13", 2]< >00-07-11< >%0*v*d< >['-', version::qv("0.7.11"), 2]< >00-07-11< >%e< >1234.875< >1.234875e+03< >%e< >0.000012345< >1.234500e-05< >%e< >1234567E96< >1.234567e+102< >%e< >0< >0.000000e+00< >%e< >.1234567E-101< >1.234567e-102< >%+e< >1234.875< >+1.234875e+03< >%#e< >1234.875< >1.234875e+03< >%e< >-1234.875< >-1.234875e+03< >%+e< >-1234.875< >-1.234875e+03< >%#e< >-1234.875< >-1.234875e+03< >%.0e< >1234.875< >1e+03< >%#.0e< >1234.875< >1.e+03< >%.0e< >1.875< >2e+00< >%.0e< >0.875< >9e-01< >%.*e< >[0, 1234.875]< >1e+03< >%.1e< >1234.875< >1.2e+03< >%-12.4e< >1234.875< >1.2349e+03 < >%12.4e< >1234.875< > 1.2349e+03< >%+-12.4e< >1234.875< >+1.2349e+03 < >%+12.4e< >1234.875< > +1.2349e+03< >%+-12.4e< >-1234.875< >-1.2349e+03 < >%+12.4e< >-1234.875< > -1.2349e+03< >%e< >1234567E96< >1.234567e+102< >exponent too big skip: os390< >%e< >.1234567E-101< >1.234567e-102< >exponent too small skip: os390< >%f< >1234.875< >1234.875000< >%+f< >1234.875< >+1234.875000< >%#f< >1234.875< >1234.875000< >%f< >-1234.875< >-1234.875000< >%+f< >-1234.875< >-1234.875000< >%#f< >-1234.875< >-1234.875000< >%6f< >1234.875< >1234.875000< >%*f< >[6, 1234.875]< >1234.875000< >%.0f< >-0.1< >-0< >C library bug: no minus skip: VMS< >%.0f< >1234.875< >1235< >%.1f< >1234.875< >1234.9< >%-8.1f< >1234.875< >1234.9 < >%8.1f< >1234.875< > 1234.9< >%+-8.1f< >1234.875< >+1234.9 < >%+8.1f< >1234.875< > +1234.9< >%+-8.1f< >-1234.875< >-1234.9 < >%+8.1f< >-1234.875< > -1234.9< >%*.*f< >[5, 2, 12.3456]< >12.35< >%f< >0< >0.000000< >%.0f< >0< >0< >%.0f< >2**38< >274877906944< >Should have exact int'l rep'n< >%.0f< >0.1< >0< >%.0f< >0.6< >1< >Known to fail with sfio, (irix|nonstop-ux|powerux); -DHAS_LDBL_SPRINTF_BUG may fix< >%.0f< >-0.6< >-1< >Known to fail with sfio, (irix|nonstop-ux|powerux); -DHAS_LDBL_SPRINTF_BUG may fix< >%.0f< >1.6< >2< >%.0f< >-1.6< >-2< >%.0f< >1< >1< >%#.0f< >1< >1.< >%.0lf< >1< >1< >'l' should have no effect< >%.0hf< >1< >%.0hf INVALID< >'h' should be rejected< >%g< >12345.6789< >12345.7< >%+g< >12345.6789< >+12345.7< >%#g< >12345.6789< >12345.7< >%.0g< >-0.0< >-0< >C99 standard mandates minus sign but C89 does not skip: MSWin32 VMS hpux:10.20 openbsd netbsd:1.5 irix darwin< >%.0g< >12345.6789< >1e+04< >%#.0g< >12345.6789< >1.e+04< >%.2g< >12345.6789< >1.2e+04< >%.*g< >[2, 12345.6789]< >1.2e+04< >%.9g< >12345.6789< >12345.6789< >%12.9g< >12345.6789< > 12345.6789< >%012.9g< >12345.6789< >0012345.6789< >%-12.9g< >12345.6789< >12345.6789 < >%*.*g< >[-12, 9, 12345.6789]< >12345.6789 < >%-012.9g< >12345.6789< >12345.6789 < >%g< >-12345.6789< >-12345.7< >%+g< >-12345.6789< >-12345.7< >%g< >1234567.89< >1.23457e+06< >%+g< >1234567.89< >+1.23457e+06< >%#g< >1234567.89< >1.23457e+06< >%g< >-1234567.89< >-1.23457e+06< >%+g< >-1234567.89< >-1.23457e+06< >%#g< >-1234567.89< >-1.23457e+06< >%g< >0.00012345< >0.00012345< >%g< >0.000012345< >1.2345e-05< >%g< >1234567E96< >1.23457e+102< >%g< >.1234567E-101< >1.23457e-102< >%g< >0< >0< >%13g< >1234567.89< > 1.23457e+06< >%+13g< >1234567.89< > +1.23457e+06< >%013g< >1234567.89< >001.23457e+06< >%-13g< >1234567.89< >1.23457e+06 < >%g< >.1234567E-101< >1.23457e-102< >exponent too small skip: os390< >%g< >1234567E96< >1.23457e+102< >exponent too big skip: os390< >%h< >''< >%h INVALID< >%i< >123456.789< >123456< >Synonym for %d< >%j< >''< >%j INVALID< >%k< >''< >%k INVALID< >%l< >''< >%l INVALID< >%m< >''< >%m INVALID< >%s< >sprintf('%%n%n %d', $n, $n)< >%n 2< >Slight sneakiness to test %n< >%o< >2**32-1< >37777777777< >%+o< >2**32-1< >37777777777< >%#o< >2**32-1< >037777777777< >%o< >642< >1202< >check smaller octals across platforms< >%+o< >642< >1202< >% o< >642< >1202< >%#o< >642< >01202< >%4o< >18< > 22< >%4.3o< >18< > 022< >%-4.3o< >18< >022 < >%+4.3o< >18< > 022< >% 4.3o< >18< > 022< >%04.3o< >18< > 022< >0 flag with precision: no effect< >%4.o< >36< > 44< >%-4.o< >36< >44 < >%+4.o< >36< > 44< >% 4.o< >36< > 44< >%04.o< >36< > 44< >0 flag with precision: no effect< >%.3o< >18< >022< >%.0o< >0< >< >%+.0o< >0< >< >% .0o< >0< >< >%-.0o< >0< >< >%#.0o< >0< >0< >%#3.0o< >0< > 0< >%#3.1o< >0< > 0< >%#3.2o< >0< > 00< >%#3.3o< >0< >000< >%#3.4o< >0< >0000< >%.0o< >1< >1< >%+.0o< >1< >1< >% .0o< >1< >1< >%-.0o< >1< >1< >%#.0o< >1< >01< >%#3.0o< >1< > 01< >%#3.1o< >1< > 01< >%#3.2o< >1< > 01< >%#3.3o< >1< >001< >%#3.4o< >1< >0001< >%#.5o< >012345< >012345< >%#.5o< >012< >00012< >%#4o< >17< > 021< >%#-4o< >17< >021 < >%-#4o< >17< >021 < >%#+4o< >17< > 021< >%# 4o< >17< > 021< >%#04o< >17< >0021< >%#4.o< >16< > 020< >%#-4.o< >16< >020 < >%-#4.o< >16< >020 < >%#+4.o< >16< > 020< >%# 4.o< >16< > 020< >%#04.o< >16< > 020< >0 flag with precision: no effect< >%#4.3o< >18< > 022< >%#-4.3o< >18< >022 < >%-#4.3o< >18< >022 < >%#+4.3o< >18< > 022< >%# 4.3o< >18< > 022< >%#04.3o< >18< > 022< >0 flag with precision: no effect< >%#6.4o< >18< > 0022< >%#-6.4o< >18< >0022 < >%-#6.4o< >18< >0022 < >%#+6.4o< >18< > 0022< >%# 6.4o< >18< > 0022< >%#06.4o< >18< > 0022< >0 flag with precision: no effect< >%d< >$p=sprintf('%p',$p);$p=~/^[0-9a-f]+$/< >1< >Coarse hack: hex from %p?< >%d< >$p=sprintf('%-8p',$p);$p=~/^[0-9a-f]+\s*$/< >1< >Coarse hack: hex from %p?< >%#p< >''< >%#p INVALID< >%q< >''< >%q INVALID< >%r< >''< >%r INVALID< >%s< >'string'< >string< >%10s< >'string'< > string< >%+10s< >'string'< > string< >%#10s< >'string'< > string< >%010s< >'string'< >0000string< >%0*s< >[10, 'string']< >0000string< >%-10s< >'string'< >string < >%3s< >'string'< >string< >%.3s< >'string'< >str< >%.*s< >[3, 'string']< >str< >%.*s< >[2, 'string']< >st< >%.*s< >[1, 'string']< >s< >%.*s< >[0, 'string']< >< >%.*s< >[-1,'string']< >string< >negative precision to be ignored< >%3.*s< >[3, 'string']< >str< >%3.*s< >[2, 'string']< > st< >%3.*s< >[1, 'string']< > s< >%3.*s< >[0, 'string']< > < >%3.*s< >[-1,'string']< >string< >negative precision to be ignored< >%t< >''< >%t INVALID< >%u< >2**32-1< >4294967295< >%+u< >2**32-1< >4294967295< >%#u< >2**32-1< >4294967295< >%12u< >2**32-1< > 4294967295< >%012u< >2**32-1< >004294967295< >%-12u< >2**32-1< >4294967295 < >%-012u< >2**32-1< >4294967295 < >%4u< >18< > 18< >%4.3u< >18< > 018< >%-4.3u< >18< >018 < >%+4.3u< >18< > 018< >% 4.3u< >18< > 018< >%04.3u< >18< > 018< >0 flag with precision: no effect< >%.3u< >18< >018< >%v< >''< >%v INVALID< >%w< >''< >%w INVALID< >%x< >2**32-1< >ffffffff< >%+x< >2**32-1< >ffffffff< >%#x< >2**32-1< >0xffffffff< >%10x< >2**32-1< > ffffffff< >%010x< >2**32-1< >00ffffffff< >%-10x< >2**32-1< >ffffffff < >%-010x< >2**32-1< >ffffffff < >%0-10x< >2**32-1< >ffffffff < >%4x< >18< > 12< >%4.3x< >18< > 012< >%-4.3x< >18< >012 < >%+4.3x< >18< > 012< >% 4.3x< >18< > 012< >%04.3x< >18< > 012< >0 flag with precision: no effect< >%.3x< >18< >012< >%4X< >28< > 1C< >%4.3X< >28< > 01C< >%-4.3X< >28< >01C < >%+4.3X< >28< > 01C< >% 4.3X< >28< > 01C< >%04.3X< >28< > 01C< >0 flag with precision: no effect< >%.3X< >28< >01C< >%.0x< >0< >< >%+.0x< >0< >< >% .0x< >0< >< >%-.0x< >0< >< >%#.0x< >0< >< >%#3.0x< >0< > < >%#3.1x< >0< > 0< >%#3.2x< >0< > 00< >%#3.3x< >0< >000< >%#3.4x< >0< >0000< >%.0x< >1< >1< >%+.0x< >1< >1< >% .0x< >1< >1< >%-.0x< >1< >1< >%#.0x< >1< >0x1< >%#3.0x< >1< >0x1< >%#3.1x< >1< >0x1< >%#3.2x< >1< >0x01< >%#3.3x< >1< >0x001< >%#3.4x< >1< >0x0001< >%#.5x< >0x12345< >0x12345< >%#.5x< >0x12< >0x00012< >%#4x< >28< >0x1c< >%#4.3x< >28< >0x01c< >%#-4.3x< >28< >0x01c< >%#+4.3x< >28< >0x01c< >%# 4.3x< >28< >0x01c< >%#04.3x< >28< >0x01c< >0 flag with precision: no effect< >%#.3x< >28< >0x01c< >%#6.3x< >28< > 0x01c< >%#-6.3x< >28< >0x01c < >%-#6.3x< >28< >0x01c < >%#+6.3x< >28< > 0x01c< >%+#6.3x< >28< > 0x01c< >%# 6.3x< >28< > 0x01c< >% #6.3x< >28< > 0x01c< >%0*x< >[-10, ,2**32-1]< >ffffffff < >%vx< >[version::qv("1.2.3")]< >1.2.3< >%vx< >[version::qv("1.20.300")]< >1.14.12c< >%.*x< >[0,0]< >< >%-.*x< >[0,0]< >< >%+.*x< >[0,0]< >< >% .*x< >[0,0]< >< >%0.*x< >[0,0]< >< >%.*x< >[-3,0]< >0< >%-.*x< >[-3,0]< >0< >%+.*x< >[-3,0]< >0< >% .*x< >[-3,0]< >0< >%0.*x< >[-3,0]< >0< >%#.*x< >[0,0]< >< >%#-.*x< >[0,0]< >< >%#+.*x< >[0,0]< >< >%# .*x< >[0,0]< >< >%#0.*x< >[0,0]< >< >%#.*x< >[-1,0]< >0< >%#-.*x< >[-1,0]< >0< >%#+.*x< >[-1,0]< >0< >%# .*x< >[-1,0]< >0< >%#0.*x< >[-1,0]< >0< >%y< >''< >%y INVALID< >%z< >''< >%z INVALID< >%2$d %1$d< >[12, 34]< >34 12< >%*2$d< >[12, 3]< > 12< >%2$d %d< >[12, 34]< >34 12< >%2$d %d %d< >[12, 34]< >34 12 34< >%3$d %d %d< >[12, 34, 56]< >56 12 34< >%2$*3$d %d< >[12, 34, 3]< > 34 12< >%*3$2$d %d< >[12, 34, 3]< >%*3$2$d 12 INVALID< >%2$d< >12< >0 MISSING< >%0$d< >12< >%0$d INVALID< >%1$$d< >12< >%1$$d INVALID< >%1$1$d< >12< >%1$1$d INVALID< >%*2$*2$d< >[12, 3]< >%*2$*2$d INVALID< >%*2*2$d< >[12, 3]< >%*2*2$d INVALID< >%*2$1d< >[12, 3]< >%*2$1d INVALID< >%0v2.2d< >''< >< >%vc,%d< >[63, 64, 65]< >%vc,63 INVALID< >%v%,%d< >[63, 64, 65]< >%v%,63 INVALID< >%vd,%d< >["\x1", 2, 3]< >1,2< >%vf,%d< >[1, 2, 3]< >%vf,1 INVALID< >%vF,%d< >[1, 2, 3]< >%vF,1 INVALID< >%ve,%d< >[1, 2, 3]< >%ve,1 INVALID< >%vE,%d< >[1, 2, 3]< >%vE,1 INVALID< >%vg,%d< >[1, 2, 3]< >%vg,1 INVALID< >%vG,%d< >[1, 2, 3]< >%vG,1 INVALID< >%vp< >''< >%vp INVALID< >%vn< >''< >%vn INVALID< >%vs,%d< >[1, 2, 3]< >%vs,1 INVALID< >%v_< >''< >%v_ INVALID< >%v#x< >''< >%v#x INVALID< >%v02x< >"\x66\x6f\x6f\012"< >66.6f.6f.0a< >%#v.8b< >"\141\000\142"< >0b01100001.00000000.0b01100010< >perl #39530< >%#v.0o< >"\001\000\002\000"< >01.0.02.0< >%#v.1o< >"\001\000\002\000"< >01.0.02.0< >%#v.4o< >"\141\000\142"< >0141.0000.0142< >perl #39530< >%#v.3i< >"\141\000\142"< >097.000.098< >perl #39530< >%#v.0x< >"\001\000\002\000"< >0x1..0x2.< >%#v.1x< >"\001\000\002\000"< >0x1.0.0x2.0< >%#v.2x< >"\141\000\142"< >0x61.00.0x62< >perl #39530< >%#v.2X< >"\141\000\142"< >0X61.00.0X62< >perl #39530< >%#v.8b< >"\141\017\142"< >0b01100001.0b00001111.0b01100010< >perl #39530< >%#v.4o< >"\141\017\142"< >0141.0017.0142< >perl #39530< >%#v.3i< >"\141\017\142"< >097.015.098< >perl #39530< >%#v.2x< >"\141\017\142"< >0x61.0x0f.0x62< >perl #39530< >%#v.2X< >"\141\017\142"< >0X61.0X0F.0X62< >perl #39530< >%#*v.8b< >["][", "\141\000\142"]< >0b01100001][00000000][0b01100010< >perl #39530< >%#*v.4o< >["][", "\141\000\142"]< >0141][0000][0142< >perl #39530< >%#*v.3i< >["][", "\141\000\142"]< >097][000][098< >perl #39530< >%#*v.2x< >["][", "\141\000\142"]< >0x61][00][0x62< >perl #39530< >%#*v.2X< >["][", "\141\000\142"]< >0X61][00][0X62< >perl #39530< >%#*v.8b< >["][", "\141\017\142"]< >0b01100001][0b00001111][0b01100010< >perl #39530< >%#*v.4o< >["][", "\141\017\142"]< >0141][0017][0142< >perl #39530< >%#*v.3i< >["][", "\141\017\142"]< >097][015][098< >perl #39530< >%#*v.2x< >["][", "\141\017\142"]< >0x61][0x0f][0x62< >perl #39530< >%#*v.2X< >["][", "\141\017\142"]< >0X61][0X0F][0X62< >perl #39530< >%#v.8b< >"\141\x{1e01}\000\142\x{1e03}"< >0b01100001.0b1111000000001.00000000.0b01100010.0b1111000000011< >perl #39530< >%#v.4o< >"\141\x{1e01}\000\142\x{1e03}"< >0141.017001.0000.0142.017003< >perl #39530< >%#v.3i< >"\141\x{1e01}\000\142\x{1e03}"< >097.7681.000.098.7683< >perl #39530< >%#v.2x< >"\141\x{1e01}\000\142\x{1e03}"< >0x61.0x1e01.00.0x62.0x1e03< >perl #39530< >%#v.2X< >"\141\x{1e01}\000\142\x{1e03}"< >0X61.0X1E01.00.0X62.0X1E03< >perl #39530< >%#v.8b< >"\141\x{1e01}\017\142\x{1e03}"< >0b01100001.0b1111000000001.0b00001111.0b01100010.0b1111000000011< >perl #39530< >%#v.4o< >"\141\x{1e01}\017\142\x{1e03}"< >0141.017001.0017.0142.017003< >perl #39530< >%#v.3i< >"\141\x{1e01}\017\142\x{1e03}"< >097.7681.015.098.7683< >perl #39530< >%#v.2x< >"\141\x{1e01}\017\142\x{1e03}"< >0x61.0x1e01.0x0f.0x62.0x1e03< >perl #39530< >%#v.2X< >"\141\x{1e01}\017\142\x{1e03}"< >0X61.0X1E01.0X0F.0X62.0X1E03< >perl #39530< >%V-%s< >["Hello"]< >%V-Hello INVALID< >%K %d %d< >[13, 29]< >%K 13 29 INVALID< >%*.*K %d< >[13, 29, 76]< >%*.*K 13 INVALID< >%4$K %d< >[45, 67]< >%4$K 45 INVALID< >%d %K %d< >[23, 45]< >23 %K 45 INVALID< >%*v*999\$d %d %d< >[11, 22, 33]< >%*v*999\$d 11 22 INVALID< >%#b< >0< >0< >%#o< >0< >0< >%#x< >0< >0< >%2147483647$v2d< >''< >< >%*2147483647$v2d< >''< > MISSING< perl-5.12.0-RC0/t/op/switch.t0000555000175000017500000005127111325127002014476 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } use strict; use warnings; plan tests => 132; # The behaviour of the feature pragma should be tested by lib/switch.t # using the tests in t/lib/switch/*. This file tests the behaviour of # the switch ops themselves. use feature 'switch'; eval { continue }; like($@, qr/^Can't "continue" outside/, "continue outside"); eval { break }; like($@, qr/^Can't "break" outside/, "break outside"); # Scoping rules { my $x = "foo"; given(my $x = "bar") { is($x, "bar", "given scope starts"); } is($x, "foo", "given scope ends"); } sub be_true {1} given(my $x = "foo") { when(be_true(my $x = "bar")) { is($x, "bar", "given scope starts"); } is($x, "foo", "given scope ends"); } $_ = "outside"; given("inside") { check_outside1() } sub check_outside1 { is($_, "outside", "\$_ lexically scoped") } { my $_ = "outside"; given("inside") { check_outside2() } sub check_outside2 { is($_, "outside", "\$_ lexically scoped (lexical \$_)") } } # Basic string/numeric comparisons and control flow { my $ok; given(3) { when(2) { $ok = 'two'; } when(3) { $ok = 'three'; } when(4) { $ok = 'four'; } default { $ok = 'd'; } } is($ok, 'three', "numeric comparison"); } { my $ok; use integer; given(3.14159265) { when(2) { $ok = 'two'; } when(3) { $ok = 'three'; } when(4) { $ok = 'four'; } default { $ok = 'd'; } } is($ok, 'three', "integer comparison"); } { my ($ok1, $ok2); given(3) { when(3.1) { $ok1 = 'n'; } when(3.0) { $ok1 = 'y'; continue } when("3.0") { $ok2 = 'y'; } default { $ok2 = 'n'; } } is($ok1, 'y', "more numeric (pt. 1)"); is($ok2, 'y', "more numeric (pt. 2)"); } { my $ok; given("c") { when("b") { $ok = 'B'; } when("c") { $ok = 'C'; } when("d") { $ok = 'D'; } default { $ok = 'def'; } } is($ok, 'C', "string comparison"); } { my $ok; given("c") { when("b") { $ok = 'B'; } when("c") { $ok = 'C'; continue } when("c") { $ok = 'CC'; } default { $ok = 'D'; } } is($ok, 'CC', "simple continue"); } # Definedness { my $ok = 1; given (0) { when(undef) {$ok = 0} } is($ok, 1, "Given(0) when(undef)"); } { my $undef; my $ok = 1; given (0) { when($undef) {$ok = 0} } is($ok, 1, 'Given(0) when($undef)'); } { my $undef; my $ok = 0; given (0) { when($undef++) {$ok = 1} } is($ok, 1, "Given(0) when($undef++)"); } { no warnings "uninitialized"; my $ok = 1; given (undef) { when(0) {$ok = 0} } is($ok, 1, "Given(undef) when(0)"); } { no warnings "uninitialized"; my $undef; my $ok = 1; given ($undef) { when(0) {$ok = 0} } is($ok, 1, 'Given($undef) when(0)'); } ######## { my $ok = 1; given ("") { when(undef) {$ok = 0} } is($ok, 1, 'Given("") when(undef)'); } { my $undef; my $ok = 1; given ("") { when($undef) {$ok = 0} } is($ok, 1, 'Given("") when($undef)'); } { no warnings "uninitialized"; my $ok = 1; given (undef) { when("") {$ok = 0} } is($ok, 1, 'Given(undef) when("")'); } { no warnings "uninitialized"; my $undef; my $ok = 1; given ($undef) { when("") {$ok = 0} } is($ok, 1, 'Given($undef) when("")'); } ######## { my $ok = 0; given (undef) { when(undef) {$ok = 1} } is($ok, 1, "Given(undef) when(undef)"); } { my $undef; my $ok = 0; given (undef) { when($undef) {$ok = 1} } is($ok, 1, 'Given(undef) when($undef)'); } { my $undef; my $ok = 0; given ($undef) { when(undef) {$ok = 1} } is($ok, 1, 'Given($undef) when(undef)'); } { my $undef; my $ok = 0; given ($undef) { when($undef) {$ok = 1} } is($ok, 1, 'Given($undef) when($undef)'); } # Regular expressions { my ($ok1, $ok2); given("Hello, world!") { when(/lo/) { $ok1 = 'y'; continue} when(/no/) { $ok1 = 'n'; continue} when(/^(Hello,|Goodbye cruel) world[!.?]/) { $ok2 = 'Y'; continue} when(/^(Hello cruel|Goodbye,) world[!.?]/) { $ok2 = 'n'; continue} } is($ok1, 'y', "regex 1"); is($ok2, 'Y', "regex 2"); } # Comparisons { my $test = "explicit numeric comparison (<)"; my $twenty_five = 25; my $ok; given($twenty_five) { when ($_ < 10) { $ok = "ten" } when ($_ < 20) { $ok = "twenty" } when ($_ < 30) { $ok = "thirty" } when ($_ < 40) { $ok = "forty" } default { $ok = "default" } } is($ok, "thirty", $test); } { use integer; my $test = "explicit numeric comparison (integer <)"; my $twenty_five = 25; my $ok; given($twenty_five) { when ($_ < 10) { $ok = "ten" } when ($_ < 20) { $ok = "twenty" } when ($_ < 30) { $ok = "thirty" } when ($_ < 40) { $ok = "forty" } default { $ok = "default" } } is($ok, "thirty", $test); } { my $test = "explicit numeric comparison (<=)"; my $twenty_five = 25; my $ok; given($twenty_five) { when ($_ <= 10) { $ok = "ten" } when ($_ <= 20) { $ok = "twenty" } when ($_ <= 30) { $ok = "thirty" } when ($_ <= 40) { $ok = "forty" } default { $ok = "default" } } is($ok, "thirty", $test); } { use integer; my $test = "explicit numeric comparison (integer <=)"; my $twenty_five = 25; my $ok; given($twenty_five) { when ($_ <= 10) { $ok = "ten" } when ($_ <= 20) { $ok = "twenty" } when ($_ <= 30) { $ok = "thirty" } when ($_ <= 40) { $ok = "forty" } default { $ok = "default" } } is($ok, "thirty", $test); } { my $test = "explicit numeric comparison (>)"; my $twenty_five = 25; my $ok; given($twenty_five) { when ($_ > 40) { $ok = "forty" } when ($_ > 30) { $ok = "thirty" } when ($_ > 20) { $ok = "twenty" } when ($_ > 10) { $ok = "ten" } default { $ok = "default" } } is($ok, "twenty", $test); } { my $test = "explicit numeric comparison (>=)"; my $twenty_five = 25; my $ok; given($twenty_five) { when ($_ >= 40) { $ok = "forty" } when ($_ >= 30) { $ok = "thirty" } when ($_ >= 20) { $ok = "twenty" } when ($_ >= 10) { $ok = "ten" } default { $ok = "default" } } is($ok, "twenty", $test); } { use integer; my $test = "explicit numeric comparison (integer >)"; my $twenty_five = 25; my $ok; given($twenty_five) { when ($_ > 40) { $ok = "forty" } when ($_ > 30) { $ok = "thirty" } when ($_ > 20) { $ok = "twenty" } when ($_ > 10) { $ok = "ten" } default { $ok = "default" } } is($ok, "twenty", $test); } { use integer; my $test = "explicit numeric comparison (integer >=)"; my $twenty_five = 25; my $ok; given($twenty_five) { when ($_ >= 40) { $ok = "forty" } when ($_ >= 30) { $ok = "thirty" } when ($_ >= 20) { $ok = "twenty" } when ($_ >= 10) { $ok = "ten" } default { $ok = "default" } } is($ok, "twenty", $test); } { my $test = "explicit string comparison (lt)"; my $twenty_five = "25"; my $ok; given($twenty_five) { when ($_ lt "10") { $ok = "ten" } when ($_ lt "20") { $ok = "twenty" } when ($_ lt "30") { $ok = "thirty" } when ($_ lt "40") { $ok = "forty" } default { $ok = "default" } } is($ok, "thirty", $test); } { my $test = "explicit string comparison (le)"; my $twenty_five = "25"; my $ok; given($twenty_five) { when ($_ le "10") { $ok = "ten" } when ($_ le "20") { $ok = "twenty" } when ($_ le "30") { $ok = "thirty" } when ($_ le "40") { $ok = "forty" } default { $ok = "default" } } is($ok, "thirty", $test); } { my $test = "explicit string comparison (gt)"; my $twenty_five = 25; my $ok; given($twenty_five) { when ($_ ge "40") { $ok = "forty" } when ($_ ge "30") { $ok = "thirty" } when ($_ ge "20") { $ok = "twenty" } when ($_ ge "10") { $ok = "ten" } default { $ok = "default" } } is($ok, "twenty", $test); } { my $test = "explicit string comparison (ge)"; my $twenty_five = 25; my $ok; given($twenty_five) { when ($_ ge "40") { $ok = "forty" } when ($_ ge "30") { $ok = "thirty" } when ($_ ge "20") { $ok = "twenty" } when ($_ ge "10") { $ok = "ten" } default { $ok = "default" } } is($ok, "twenty", $test); } # Make sure it still works with a lexical $_: { my $_; my $test = "explicit comparison with lexical \$_"; my $twenty_five = 25; my $ok; given($twenty_five) { when ($_ ge "40") { $ok = "forty" } when ($_ ge "30") { $ok = "thirty" } when ($_ ge "20") { $ok = "twenty" } when ($_ ge "10") { $ok = "ten" } default { $ok = "default" } } is($ok, "twenty", $test); } # Optimized-away comparisons { my $ok; given(23) { when (2 + 2 == 4) { $ok = 'y'; continue } when (2 + 2 == 5) { $ok = 'n' } } is($ok, 'y', "Optimized-away comparison"); } { my $ok; given(23) { when (scalar 24) { $ok = 'n'; continue } default { $ok = 'y' } } is($ok,'y','scalar()'); } # File tests # (How to be both thorough and portable? Pinch a few ideas # from t/op/filetest.t. We err on the side of portability for # the time being.) { my ($ok_d, $ok_f, $ok_r); given("op") { when(-d) {$ok_d = 1; continue} when(!-f) {$ok_f = 1; continue} when(-r) {$ok_r = 1; continue} } ok($ok_d, "Filetest -d"); ok($ok_f, "Filetest -f"); ok($ok_r, "Filetest -r"); } # Sub and method calls sub notfoo {"bar"} { my $ok = 0; given("foo") { when(notfoo()) {$ok = 1} } ok($ok, "Sub call acts as boolean") } { my $ok = 0; given("foo") { when(main->notfoo()) {$ok = 1} } ok($ok, "Class-method call acts as boolean") } { my $ok = 0; my $obj = bless []; given("foo") { when($obj->notfoo()) {$ok = 1} } ok($ok, "Object-method call acts as boolean") } # Other things that should not be smart matched { my $ok = 0; given(12) { when( /(\d+)/ and ( 1 <= $1 and $1 <= 12 ) ) { $ok = 1; } } ok($ok, "bool not smartmatches"); } { my $ok = 0; given(0) { when(eof(DATA)) { $ok = 1; } } ok($ok, "eof() not smartmatched"); } { my $ok = 0; my %foo = ("bar", 0); given(0) { when(exists $foo{bar}) { $ok = 1; } } ok($ok, "exists() not smartmatched"); } { my $ok = 0; given(0) { when(defined $ok) { $ok = 1; } } ok($ok, "defined() not smartmatched"); } { my $ok = 1; given("foo") { when((1 == 1) && "bar") { $ok = 0; } when((1 == 1) && $_ eq "foo") { $ok = 2; } } is($ok, 2, "((1 == 1) && \"bar\") not smartmatched"); } { my $n = 0; for my $l qw(a b c d) { given ($l) { when ($_ eq "b" .. $_ eq "c") { $n = 1 } default { $n = 0 } } ok(($n xor $l =~ /[ad]/), 'when(E1..E2) evaluates in boolean context'); } } { my $n = 0; for my $l qw(a b c d) { given ($l) { when ($_ eq "b" ... $_ eq "c") { $n = 1 } default { $n = 0 } } ok(($n xor $l =~ /[ad]/), 'when(E1...E2) evaluates in boolean context'); } } { my $ok = 0; given("foo") { when((1 == $ok) || "foo") { $ok = 1; } } ok($ok, '((1 == $ok) || "foo") smartmatched'); } { my $ok = 0; given("foo") { when((1 == $ok || undef) // "foo") { $ok = 1; } } ok($ok, '((1 == $ok || undef) // "foo") smartmatched'); } # Make sure we aren't invoking the get-magic more than once { # A helper class to count the number of accesses. package FetchCounter; sub TIESCALAR { my ($class) = @_; bless {value => undef, count => 0}, $class; } sub STORE { my ($self, $val) = @_; $self->{count} = 0; $self->{value} = $val; } sub FETCH { my ($self) = @_; # Avoid pre/post increment here $self->{count} = 1 + $self->{count}; $self->{value}; } sub count { my ($self) = @_; $self->{count}; } } my $f = tie my $v, "FetchCounter"; { my $test_name = "Only one FETCH (in given)"; my $ok; given($v = 23) { when(undef) {} when(sub{0}->()) {} when(21) {} when("22") {} when(23) {$ok = 1} when(/24/) {$ok = 0} } is($ok, 1, "precheck: $test_name"); is($f->count(), 1, $test_name); } { my $test_name = "Only one FETCH (numeric when)"; my $ok; $v = 23; is($f->count(), 0, "Sanity check: $test_name"); given(23) { when(undef) {} when(sub{0}->()) {} when(21) {} when("22") {} when($v) {$ok = 1} when(/24/) {$ok = 0} } is($ok, 1, "precheck: $test_name"); is($f->count(), 1, $test_name); } { my $test_name = "Only one FETCH (string when)"; my $ok; $v = "23"; is($f->count(), 0, "Sanity check: $test_name"); given("23") { when(undef) {} when(sub{0}->()) {} when("21") {} when("22") {} when($v) {$ok = 1} when(/24/) {$ok = 0} } is($ok, 1, "precheck: $test_name"); is($f->count(), 1, $test_name); } { my $test_name = "Only one FETCH (undef)"; my $ok; $v = undef; is($f->count(), 0, "Sanity check: $test_name"); no warnings "uninitialized"; given(my $undef) { when(sub{0}->()) {} when("21") {} when("22") {} when($v) {$ok = 1} when(undef) {$ok = 0} } is($ok, 1, "precheck: $test_name"); is($f->count(), 1, $test_name); } # Loop topicalizer { my $first = 1; for (1, "two") { when ("two") { is($first, 0, "Loop: second"); eval {break}; like($@, qr/^Can't "break" in a loop topicalizer/, q{Can't "break" in a loop topicalizer}); } when (1) { is($first, 1, "Loop: first"); $first = 0; # Implicit break is okay } } } { my $first = 1; for $_ (1, "two") { when ("two") { is($first, 0, "Explicit \$_: second"); eval {break}; like($@, qr/^Can't "break" in a loop topicalizer/, q{Can't "break" in a loop topicalizer}); } when (1) { is($first, 1, "Explicit \$_: first"); $first = 0; # Implicit break is okay } } } { my $first = 1; my $_; for (1, "two") { when ("two") { is($first, 0, "Implicitly lexical loop: second"); eval {break}; like($@, qr/^Can't "break" in a loop topicalizer/, q{Can't "break" in a loop topicalizer}); } when (1) { is($first, 1, "Implicitly lexical loop: first"); $first = 0; # Implicit break is okay } } } { my $first = 1; my $_; for $_ (1, "two") { when ("two") { is($first, 0, "Implicitly lexical, explicit \$_: second"); eval {break}; like($@, qr/^Can't "break" in a loop topicalizer/, q{Can't "break" in a loop topicalizer}); } when (1) { is($first, 1, "Implicitly lexical, explicit \$_: first"); $first = 0; # Implicit break is okay } } } { my $first = 1; for my $_ (1, "two") { when ("two") { is($first, 0, "Lexical loop: second"); eval {break}; like($@, qr/^Can't "break" in a loop topicalizer/, q{Can't "break" in a loop topicalizer}); } when (1) { is($first, 1, "Lexical loop: first"); $first = 0; # Implicit break is okay } } } # Code references { my $called_foo = 0; sub foo {$called_foo = 1; "@_" eq "foo"} my $called_bar = 0; sub bar {$called_bar = 1; "@_" eq "bar"} my ($matched_foo, $matched_bar) = (0, 0); given("foo") { when(\&bar) {$matched_bar = 1} when(\&foo) {$matched_foo = 1} } is($called_foo, 1, "foo() was called"); is($called_bar, 1, "bar() was called"); is($matched_bar, 0, "bar didn't match"); is($matched_foo, 1, "foo did match"); } sub contains_x { my $x = shift; return ($x =~ /x/); } { my ($ok1, $ok2) = (0,0); given("foxy!") { when(contains_x($_)) { $ok1 = 1; continue } when(\&contains_x) { $ok2 = 1; continue } } is($ok1, 1, "Calling sub directly (true)"); is($ok2, 1, "Calling sub indirectly (true)"); given("foggy") { when(contains_x($_)) { $ok1 = 2; continue } when(\&contains_x) { $ok2 = 2; continue } } is($ok1, 1, "Calling sub directly (false)"); is($ok2, 1, "Calling sub indirectly (false)"); } SKIP: { skip "Scalar/Util.pm not yet available", 20 unless -r "$INC[0]/Scalar/Util.pm"; # Test overloading { package OverloadTest; use overload '""' => sub{"string value of obj"}; use overload 'eq' => sub{"$_[0]" eq "$_[1]"}; use overload "~~" => sub { my ($self, $other, $reversed) = @_; if ($reversed) { $self->{left} = $other; $self->{right} = $self; $self->{reversed} = 1; } else { $self->{left} = $self; $self->{right} = $other; $self->{reversed} = 0; } $self->{called} = 1; return $self->{retval}; }; sub new { my ($pkg, $retval) = @_; bless { called => 0, retval => $retval, }, $pkg; } } { my $test = "Overloaded obj in given (true)"; my $obj = OverloadTest->new(1); my $matched; given($obj) { when ("other arg") {$matched = 1} default {$matched = 0} } is($obj->{called}, 1, "$test: called"); ok($matched, "$test: matched"); } { my $test = "Overloaded obj in given (false)"; my $obj = OverloadTest->new(0); my $matched; given($obj) { when ("other arg") {$matched = 1} } is($obj->{called}, 1, "$test: called"); ok(!$matched, "$test: not matched"); } { my $test = "Overloaded obj in when (true)"; my $obj = OverloadTest->new(1); my $matched; given("topic") { when ($obj) {$matched = 1} default {$matched = 0} } is($obj->{called}, 1, "$test: called"); ok($matched, "$test: matched"); is($obj->{left}, "topic", "$test: left"); is($obj->{right}, "string value of obj", "$test: right"); ok($obj->{reversed}, "$test: reversed"); } { my $test = "Overloaded obj in when (false)"; my $obj = OverloadTest->new(0); my $matched; given("topic") { when ($obj) {$matched = 1} default {$matched = 0} } is($obj->{called}, 1, "$test: called"); ok(!$matched, "$test: not matched"); is($obj->{left}, "topic", "$test: left"); is($obj->{right}, "string value of obj", "$test: right"); ok($obj->{reversed}, "$test: reversed"); } } # Postfix when { my $ok; given (undef) { $ok = 1 when undef; } is($ok, 1, "postfix undef"); } { my $ok; given (2) { $ok += 1 when 7; $ok += 2 when 9.1685; $ok += 4 when $_ > 4; $ok += 8 when $_ < 2.5; } is($ok, 8, "postfix numeric"); } { my $ok; given ("apple") { $ok = 1, continue when $_ eq "apple"; $ok += 2; $ok = 0 when "banana"; } is($ok, 3, "postfix string"); } { my $ok; given ("pear") { do { $ok = 1; continue } when /pea/; $ok += 2; $ok = 0 when /pie/; default { $ok += 4 } $ok = 0; } is($ok, 7, "postfix regex"); } # be_true is defined at the beginning of the file { my $x = "what"; given(my $x = "foo") { do { is($x, "foo", "scope inside ... when my \$x = ..."); continue; } when be_true(my $x = "bar"); is($x, "bar", "scope after ... when my \$x = ..."); } } { my $x = 0; given(my $x = 1) { my $x = 2, continue when be_true(); is($x, undef, "scope after my \$x = ... when ..."); } } # Tests for last and next in when clauses my $letter; $letter = ''; for ("a".."e") { given ($_) { $letter = $_; when ("b") { last } } $letter = "z"; } is($letter, "b", "last in when"); $letter = ''; LETTER1: for ("a".."e") { given ($_) { $letter = $_; when ("b") { last LETTER1 } } $letter = "z"; } is($letter, "b", "last LABEL in when"); $letter = ''; for ("a".."e") { given ($_) { when (/b|d/) { next } $letter .= $_; } $letter .= ','; } is($letter, "a,c,e,", "next in when"); $letter = ''; LETTER2: for ("a".."e") { given ($_) { when (/b|d/) { next LETTER2 } $letter .= $_; } $letter .= ','; } is($letter, "a,c,e,", "next LABEL in when"); # Test goto with given/when { my $flag = 0; goto GIVEN1; $flag = 1; GIVEN1: given ($flag) { when (0) { break; } $flag = 2; } is($flag, 0, "goto GIVEN1"); } { my $flag = 0; given ($flag) { when (0) { $flag = 1; } goto GIVEN2; $flag = 2; } GIVEN2: is($flag, 1, "goto inside given"); } { my $flag = 0; given ($flag) { when (0) { $flag = 1; goto GIVEN3; $flag = 2; } $flag = 3; } GIVEN3: is($flag, 1, "goto inside given and when"); } { my $flag = 0; for ($flag) { when (0) { $flag = 1; goto GIVEN4; $flag = 2; } $flag = 3; } GIVEN4: is($flag, 1, "goto inside for and when"); } { my $flag = 0; GIVEN5: given ($flag) { when (0) { $flag = 1; goto GIVEN5; $flag = 2; } when (1) { break; } $flag = 3; } is($flag, 1, "goto inside given and when to the given stmt"); } # test with unreified @_ in smart match [perl #71078] sub unreified_check { ok([@_] ~~ \@_) } # should always match unreified_check(1,2,"lala"); unreified_check(1,2,undef); unreified_check(undef); unreified_check(undef,""); # Okay, that'll do for now. The intricacies of the smartmatch # semantics are tested in t/op/smartmatch.t __END__ perl-5.12.0-RC0/t/op/caller.pl0000444000175000017500000000737311325125742014621 0ustar jessejesse# tests shared between t/op/caller.t and ext/XS-APItest/t/op.t use strict; use warnings; sub dooot { is(hint_fetch('dooot'), undef); is(hint_fetch('thikoosh'), undef); ok(!hint_exists('dooot')); ok(!hint_exists('thikoosh')); if ($::testing_caller) { is(hint_fetch('dooot', 1), 54); } BEGIN { $^H{dooot} = 42; } is(hint_fetch('dooot'), 6 * 7); if ($::testing_caller) { is(hint_fetch('dooot', 1), 54); } BEGIN { $^H{dooot} = undef; } is(hint_fetch('dooot'), undef); ok(hint_exists('dooot')); BEGIN { delete $^H{dooot}; } is(hint_fetch('dooot'), undef); ok(!hint_exists('dooot')); if ($::testing_caller) { is(hint_fetch('dooot', 1), 54); } } { is(hint_fetch('dooot'), undef); is(hint_fetch('thikoosh'), undef); BEGIN { $^H{dooot} = 1; $^H{thikoosh} = "SKREECH"; } if ($::testing_caller) { is(hint_fetch('dooot'), 1); } is(hint_fetch('thikoosh'), "SKREECH"); BEGIN { $^H{dooot} = 42; } { { BEGIN { $^H{dooot} = 6 * 9; } is(hint_fetch('dooot'), 54); is(hint_fetch('thikoosh'), "SKREECH"); { BEGIN { delete $^H{dooot}; } is(hint_fetch('dooot'), undef); ok(!hint_exists('dooot')); is(hint_fetch('thikoosh'), "SKREECH"); } dooot(); } is(hint_fetch('dooot'), 6 * 7); is(hint_fetch('thikoosh'), "SKREECH"); } is(hint_fetch('dooot'), 6 * 7); is(hint_fetch('thikoosh'), "SKREECH"); } print "# which now works inside evals\n"; { BEGIN { $^H{dooot} = 42; } is(hint_fetch('dooot'), 6 * 7); eval "is(hint_fetch('dooot'), 6 * 7); 1" or die $@; eval <<'EOE' or die $@; is(hint_fetch('dooot'), 6 * 7); eval "is(hint_fetch('dooot'), 6 * 7); 1" or die $@; BEGIN { $^H{dooot} = 54; } is(hint_fetch('dooot'), 54); eval "is(hint_fetch('dooot'), 54); 1" or die $@; eval 'BEGIN { $^H{dooot} = -1; }; 1' or die $@; is(hint_fetch('dooot'), 54); eval "is(hint_fetch('dooot'), 54); 1" or die $@; EOE } { BEGIN { $^H{dooot} = "FIP\0FOP\0FIDDIT\0FAP"; } is(hint_fetch('dooot'), "FIP\0FOP\0FIDDIT\0FAP", "Can do embedded 0 bytes"); BEGIN { $^H{dooot} = chr 256; } is(hint_fetch('dooot'), chr 256, "Can do Unicode"); BEGIN { $^H{dooot} = -42; } is(hint_fetch('dooot'), -42, "Can do IVs"); BEGIN { $^H{dooot} = ~0; } cmp_ok(hint_fetch('dooot'), '>', 42, "Can do UVs"); } { my ($k1, $k2, $k3, $k4); BEGIN { $k1 = chr 163; $k2 = $k1; $k3 = chr 256; $k4 = $k3; utf8::upgrade $k2; utf8::encode $k4; $^H{$k1} = 1; $^H{$k2} = 2; $^H{$k3} = 3; $^H{$k4} = 4; } is(hint_fetch($k1), 2, "UTF-8 or not, it's the same"); if ($::testing_caller) { # Perl_refcounted_he_fetch() insists that you have the key correctly # normalised for the way hashes store them. As this one isn't # normalised down to bytes, it won't t work with # Perl_refcounted_he_fetch() is(hint_fetch($k2), 2, "UTF-8 or not, it's the same"); } is(hint_fetch($k3), 3, "Octect sequences and UTF-8 are distinct"); is(hint_fetch($k4), 4, "Octect sequences and UTF-8 are distinct"); } { my ($k1, $k2, $k3); BEGIN { ($k1, $k2, $k3) = ("\0", "\0\0", "\0\0\0"); $^H{$k1} = 1; $^H{$k2} = 2; $^H{$k3} = 3; } is(hint_fetch($k1), 1, "Keys with the same hash value don't clash"); is(hint_fetch($k2), 2, "Keys with the same hash value don't clash"); is(hint_fetch($k3), 3, "Keys with the same hash value don't clash"); BEGIN { $^H{$k1} = "a"; $^H{$k2} = "b"; $^H{$k3} = "c"; } is(hint_fetch($k1), "a", "Keys with the same hash value don't clash"); is(hint_fetch($k2), "b", "Keys with the same hash value don't clash"); is(hint_fetch($k3), "c", "Keys with the same hash value don't clash"); } 1; perl-5.12.0-RC0/t/op/sprintf2.t0000555000175000017500000001224311325127001014737 0ustar jessejesse#!./perl -w BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } plan tests => 1368; use strict; use Config; is( sprintf("%.40g ",0.01), sprintf("%.40g", 0.01)." ", q(the sprintf "%.g" optimization) ); is( sprintf("%.40f ",0.01), sprintf("%.40f", 0.01)." ", q(the sprintf "%.f" optimization) ); # cases of $i > 1 are against [perl #39126] for my $i (1, 5, 10, 20, 50, 100) { chop(my $utf8_format = "%-*s\x{100}"); my $string = "\xB4"x$i; # latin1 ACUTE or ebcdic COPYRIGHT my $expect = $string." "x$i; # followed by 2*$i spaces is(sprintf($utf8_format, 3*$i, $string), $expect, "width calculation under utf8 upgrade, length=$i"); } # check simultaneous width & precision with wide characters for my $i (1, 3, 5, 10) { my $string = "\x{0410}"x($i+10); # cyrillic capital A my $expect = "\x{0410}"x$i; # cut down to exactly $i characters my $format = "%$i.${i}s"; is(sprintf($format, $string), $expect, "width & precision interplay with utf8 strings, length=$i"); } # Used to mangle PL_sv_undef fresh_perl_like( 'print sprintf "xxx%n\n"; print undef', 'Modification of a read-only value attempted at - line 1\.', { switches => [ '-w' ] }, q(%n should not be able to modify read-only constants), ); # check overflows for (int(~0/2+1), ~0, "9999999999999999999") { is(eval {sprintf "%${_}d", 0}, undef, "no sprintf result expected %${_}d"); like($@, qr/^Integer overflow in format string for sprintf /, "overflow in sprintf"); is(eval {printf "%${_}d\n", 0}, undef, "no printf result expected %${_}d"); like($@, qr/^Integer overflow in format string for prtf /, "overflow in printf"); } # check %NNN$ for range bounds { my ($warn, $bad) = (0,0); local $SIG{__WARN__} = sub { if ($_[0] =~ /missing argument/i) { $warn++ } else { $bad++ } }; my $fmt = join('', map("%$_\$s%" . ((1 << 31)-$_) . '$s', 1..20)); my $result = sprintf $fmt, qw(a b c d); is($result, "abcd", "only four valid values in $fmt"); is($warn, 36, "expected warnings"); is($bad, 0, "unexpected warnings"); } { foreach my $ord (0 .. 255) { my $bad = 0; local $SIG{__WARN__} = sub { if ($_[0] !~ /^Invalid conversion in sprintf/) { warn $_[0]; $bad++; } }; my $r = eval {sprintf '%v' . chr $ord}; is ($bad, 0, "pattern '%v' . chr $ord"); } } sub mysprintf_int_flags { my ($fmt, $num) = @_; die "wrong format $fmt" if $fmt !~ /^%([-+ 0]+)([1-9][0-9]*)d\z/; my $flag = $1; my $width = $2; my $sign = $num < 0 ? '-' : $flag =~ /\+/ ? '+' : $flag =~ /\ / ? ' ' : ''; my $abs = abs($num); my $padlen = $width - length($sign.$abs); return $flag =~ /0/ && $flag !~ /-/ # do zero padding ? $sign . '0' x $padlen . $abs : $flag =~ /-/ # left or right ? $sign . $abs . ' ' x $padlen : ' ' x $padlen . $sign . $abs; } # Whole tests for "%4d" with 2 to 4 flags; # total counts: 3 * (4**2 + 4**3 + 4**4) == 1008 my @flags = ("-", "+", " ", "0"); for my $num (0, -1, 1) { for my $f1 (@flags) { for my $f2 (@flags) { for my $f3 ('', @flags) { # '' for doubled flags my $flag = $f1.$f2.$f3; my $width = 4; my $fmt = '%'."${flag}${width}d"; my $result = sprintf($fmt, $num); my $expect = mysprintf_int_flags($fmt, $num); is($result, $expect, qq/sprintf("$fmt",$num)/); next if $f3 eq ''; for my $f4 (@flags) { # quadrupled flags my $flag = $f1.$f2.$f3.$f4; my $fmt = '%'."${flag}${width}d"; my $result = sprintf($fmt, $num); my $expect = mysprintf_int_flags($fmt, $num); is($result, $expect, qq/sprintf("$fmt",$num)/); } } } } } # test that %f doesn't panic with +Inf, -Inf, NaN [perl #45383] foreach my $n (2**1e100, -2**1e100, 2**1e100/2**1e100) { # +Inf, -Inf, NaN eval { my $f = sprintf("%f", $n); }; is $@, "", "sprintf(\"%f\", $n)"; } # test %ll formats with and without HAS_QUAD eval { my $q = pack "q", 0 }; my $Q = $@ eq ''; my @tests = ( [ '%lld' => [qw( 4294967296 -100000000000000 )] ], [ '%lli' => [qw( 4294967296 -100000000000000 )] ], [ '%llu' => [qw( 4294967296 100000000000000 )] ], [ '%Ld' => [qw( 4294967296 -100000000000000 )] ], [ '%Li' => [qw( 4294967296 -100000000000000 )] ], [ '%Lu' => [qw( 4294967296 100000000000000 )] ], ); for my $t (@tests) { my($fmt, $nums) = @$t; for my $num (@$nums) { my $w; local $SIG{__WARN__} = sub { $w = shift }; is(sprintf($fmt, $num), $Q ? $num : $fmt, "quad: $fmt -> $num"); like($w, $Q ? '' : qr/Invalid conversion in sprintf: "$fmt"/, "warning: $fmt"); } } # Check unicode vs byte length for my $width (1,2,3,4,5,6,7) { for my $precis (1,2,3,4,5,6,7) { my $v = "\x{20ac}\x{20ac}"; my $format = "%" . $width . "." . $precis . "s"; my $chars = ($precis > 2 ? 2 : $precis); my $space = ($width < 2 ? 0 : $width - $chars); fresh_perl_is( 'my $v = "\x{20ac}\x{20ac}"; my $x = sprintf "'.$format.'", $v; $x =~ /^(\s*)(\S*)$/; print "$_" for map {length} $1, $2', "$space$chars", {}, q(sprintf ").$format.q(", "\x{20ac}\x{20ac}"), ); } } perl-5.12.0-RC0/t/re/0000755000175000017500000000000011351321567013004 5ustar jessejesseperl-5.12.0-RC0/t/re/subst_amp.t0000555000175000017500000000400111325127002015147 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require Config; import Config; } print "1..13\n"; $_ = 'x' x 20; s/\d*|x/<$&>/g; $foo = '<>' . ('<>' x 20) ; print ($_ eq $foo ? "ok 1\n" : "not ok 1\n#'$_'\n#'$foo'\n"); $t = 'aaa'; $_ = $t; @res = (); pos = 1; s/\Ga(?{push @res, $_, $`})/xx/g; print "not " unless "$_ @res" eq 'axxxx aaa a aaa aa'; print "ok 2\n"; $_ = $t; @res = (); pos = 1; s/\Ga(?{push @res, $_, $`})/x/g; print "not " unless "$_ @res" eq 'axx aaa a aaa aa'; print "ok 3\n"; $_ = $t; @res = (); pos = 1; s/\Ga(?{push @res, $_, $`})/xx/; print "not " unless "$_ @res" eq 'axxa aaa a'; print "ok 4\n"; $_ = $t; @res = (); pos = 1; s/\Ga(?{push @res, $_, $`})/x/; print "not " unless "$_ @res" eq 'axa aaa a'; print "ok 5\n"; $a = $t; @res = (); pos ($a) = 1; $a =~ s/\Ga(?{push @res, $_, $`})/xx/g; print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxxx aaa a aaa aa'; print "ok 6\n"; $a = $t; @res = (); pos ($a) = 1; $a =~ s/\Ga(?{push @res, $_, $`})/x/g; print "#'$a' '@res'\nnot " unless "$a @res" eq 'axx aaa a aaa aa'; print "ok 7\n"; $a = $t; @res = (); pos ($a) = 1; $a =~ s/\Ga(?{push @res, $_, $`})/xx/; print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxa aaa a'; print "ok 8\n"; $a = $t; @res = (); pos ($a) = 1; $a =~ s/\Ga(?{push @res, $_, $`})/x/; print "#'$a' '@res'\nnot " unless "$a @res" eq 'axa aaa a'; print "ok 9\n"; sub x2 {'xx'} sub x1 {'x'} $a = $t; @res = (); pos ($a) = 1; $a =~ s/\Ga(?{push @res, $_, $`})/x2/ge; print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxxx aaa a aaa aa'; print "ok 10\n"; $a = $t; @res = (); pos ($a) = 1; $a =~ s/\Ga(?{push @res, $_, $`})/x1/ge; print "#'$a' '@res'\nnot " unless "$a @res" eq 'axx aaa a aaa aa'; print "ok 11\n"; $a = $t; @res = (); pos ($a) = 1; $a =~ s/\Ga(?{push @res, $_, $`})/x2/e; print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxa aaa a'; print "ok 12\n"; $a = $t; @res = (); pos ($a) = 1; $a =~ s/\Ga(?{push @res, $_, $`})/x1/e; print "#'$a' '@res'\nnot " unless "$a @res" eq 'axa aaa a'; print "ok 13\n"; perl-5.12.0-RC0/t/re/rxcode.t0000555000175000017500000000516711325127002014454 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } plan tests => 38; $^R = undef; like( 'a', qr/^a(?{1})(?:b(?{2}))?/, 'a =~ ab?' ); cmp_ok( $^R, '==', 1, '..$^R after a =~ ab?' ); $^R = undef; unlike( 'abc', qr/^a(?{3})(?:b(?{4}))$/, 'abc !~ a(?:b)$' ); ok( !defined $^R, '..$^R after abc !~ a(?:b)$' ); $^R = undef; like( 'ab', qr/^a(?{5})b(?{6})/, 'ab =~ ab' ); cmp_ok( $^R, '==', 6, '..$^R after ab =~ ab' ); $^R = undef; like( 'ab', qr/^a(?{7})(?:b(?{8}))?/, 'ab =~ ab?' ); cmp_ok( $^R, '==', 8, '..$^R after ab =~ ab?' ); $^R = undef; like( 'ab', qr/^a(?{9})b?(?{10})/, 'ab =~ ab? (2)' ); cmp_ok( $^R, '==', 10, '..$^R after ab =~ ab? (2)' ); $^R = undef; like( 'ab', qr/^(a(?{11})(?:b(?{12})))?/, 'ab =~ (ab)? (3)' ); cmp_ok( $^R, '==', 12, '..$^R after ab =~ ab? (3)' ); $^R = undef; unlike( 'ac', qr/^a(?{13})b(?{14})/, 'ac !~ ab' ); ok( !defined $^R, '..$^R after ac !~ ab' ); $^R = undef; like( 'ac', qr/^a(?{15})(?:b(?{16}))?/, 'ac =~ ab?' ); cmp_ok( $^R, '==', 15, '..$^R after ac =~ ab?' ); my @ar; like( 'ab', qr/^a(?{push @ar,101})(?:b(?{push @ar,102}))?/, 'ab =~ ab? with code push' ); cmp_ok( scalar(@ar), '==', 2, '..@ar pushed' ); cmp_ok( $ar[0], '==', 101, '..first element pushed' ); cmp_ok( $ar[1], '==', 102, '..second element pushed' ); $^R = undef; unlike( 'a', qr/^a(?{103})b(?{104})/, 'a !~ ab with code push' ); ok( !defined $^R, '..$^R after a !~ ab with code push' ); @ar = (); unlike( 'a', qr/^a(?{push @ar,105})b(?{push @ar,106})/, 'a !~ ab (push)' ); cmp_ok( scalar(@ar), '==', 0, '..nothing pushed' ); @ar = (); unlike( 'abc', qr/^a(?{push @ar,107})b(?{push @ar,108})$/, 'abc !~ ab$ (push)' ); cmp_ok( scalar(@ar), '==', 0, '..still nothing pushed' ); use vars '@var'; like( 'ab', qr/^a(?{push @var,109})(?:b(?{push @var,110}))?/, 'ab =~ ab? push to package var' ); cmp_ok( scalar(@var), '==', 2, '..@var pushed' ); cmp_ok( $var[0], '==', 109, '..first element pushed (package)' ); cmp_ok( $var[1], '==', 110, '..second element pushed (package)' ); @var = (); unlike( 'a', qr/^a(?{push @var,111})b(?{push @var,112})/, 'a !~ ab (push package var)' ); cmp_ok( scalar(@var), '==', 0, '..nothing pushed (package)' ); @var = (); unlike( 'abc', qr/^a(?{push @var,113})b(?{push @var,114})$/, 'abc !~ ab$ (push package var)' ); cmp_ok( scalar(@var), '==', 0, '..still nothing pushed (package)' ); { local $^R = undef; ok( 'ac' =~ /^a(?{30})(?:b(?{31})|c(?{32}))?/, 'ac =~ a(?:b|c)?' ); ok( $^R == 32, '$^R == 32' ); } { local $^R = undef; ok( 'abbb' =~ /^a(?{36})(?:b(?{37})|c(?{38}))+/, 'abbbb =~ a(?:b|c)+' ); ok( $^R == 37, '$^R == 37' ) or print "# \$^R=$^R\n"; } perl-5.12.0-RC0/t/re/regexp_qr.t0000555000175000017500000000030211325127002015146 0ustar jessejesse#!./perl $qr = 1; for $file ('./re/regexp.t', './t/re/regexp.t', ':re:regexp.t') { if (-r $file) { do $file or die $@; exit; } } die "Cannot find ./re/regexp.t or ./t/re/regexp.t\n"; perl-5.12.0-RC0/t/re/pat_rt_report_thr.t0000555000175000017500000000016311325127002016720 0ustar jessejesse#!./perl chdir 't' if -d 't'; @INC = ('../lib', '.'); require 'thread_it.pl'; thread_it(qw(re pat_rt_report.t)); perl-5.12.0-RC0/t/re/reg_nc_tie.t0000555000175000017500000000341211325127002015255 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } # Do a basic test on all the tied methods of Tie::Hash::NamedCapture plan(tests => 21); # PL_curpm->paren_names can be a null pointer. See that this succeeds anyway. 'x' =~ /(.)/; () = %+; pass( 'still alive' ); "hlagh" =~ / (?.) (?.) (?.) .* (?$) /x; # FETCH is($+{a}, "h", "FETCH"); is($+{b}, "l", "FETCH"); is($-{a}[0], "h", "FETCH"); is($-{a}[1], "a", "FETCH"); # STORE eval { $+{a} = "yon" }; ok(index($@, "read-only") != -1, "STORE"); # DELETE eval { delete $+{a} }; ok(index($@, "read-only") != -1, "DELETE"); # CLEAR eval { %+ = () }; ok(index($@, "read-only") != -1, "CLEAR"); # EXISTS ok(exists $+{e}, "EXISTS"); ok(!exists $+{d}, "EXISTS"); # FIRSTKEY/NEXTKEY is(join('|', sort keys %+), "a|b|e", "FIRSTKEY/NEXTKEY"); # SCALAR is(scalar(%+), 3, "SCALAR"); is(scalar(%-), 3, "SCALAR"); # Abuse all methods with undef as the first argument (RT #71828 and then some): is(Tie::Hash::NamedCapture::FETCH(undef, undef), undef, 'FETCH with undef'); eval {Tie::Hash::NamedCapture::STORE(undef, undef, undef)}; like($@, qr/Modification of a read-only value attempted/, 'STORE with undef'); eval {Tie::Hash::NamedCapture::DELETE(undef, undef)}; like($@, , qr/Modification of a read-only value attempted/, 'DELETE with undef'); eval {Tie::Hash::NamedCapture::CLEAR(undef)}; like($@, qr/Modification of a read-only value attempted/, 'CLEAR with undef'); is(Tie::Hash::NamedCapture::EXISTS(undef, undef), undef, 'EXISTS with undef'); is(Tie::Hash::NamedCapture::FIRSTKEY(undef), undef, 'FIRSTKEY with undef'); is(Tie::Hash::NamedCapture::NEXTKEY(undef, undef), undef, 'NEXTKEY with undef'); is(Tie::Hash::NamedCapture::SCALAR(undef), undef, 'SCALAR with undef'); perl-5.12.0-RC0/t/re/pat_special_cc.t0000555000175000017500000000312111325127002016105 0ustar jessejesse#!./perl # # This test file is used to bulk check that /\s/ and /[\s]/ # test the same and that /\s/ and /\S/ are opposites, and that # /[\s]/ and /[\S]/ are also opposites, for \s/\S and \d/\D and # \w/\W. use strict; use warnings; use 5.010; sub run_tests; $| = 1; BEGIN { chdir 't' if -d 't'; @INC = ('../lib','.'); do "re/ReTest.pl" or die $@; } plan tests => 9; # Update this when adding/deleting tests. run_tests() unless caller; # # Tests start here. # sub run_tests { my $upper_bound= 10_000; for my $special (qw(\s \w \d)) { my $upper= uc($special); my @cc_plain_failed; my @cc_complement_failed; my @plain_complement_failed; for my $ord (0 .. $upper_bound) { my $ch= chr $ord; my $plain= $ch=~/$special/ ? 1 : 0; my $plain_u= $ch=~/$upper/ ? 1 : 0; push @plain_complement_failed, "$ord-$plain-$plain_u" if $plain == $plain_u; my $cc= $ch=~/[$special]/ ? 1 : 0; my $cc_u= $ch=~/[$upper]/ ? 1 : 0; push @cc_complement_failed, "$ord-$cc-$cc_u" if $cc == $cc_u; push @cc_plain_failed, "$ord-$plain-$cc" if $plain != $cc; } iseq(join(" | ",@cc_plain_failed),"", "Check that /$special/ and /[$special]/ match same things (ord-plain-cc)"); iseq(join(" | ",@plain_complement_failed),"", "Check that /$special/ and /$upper/ are complements (ord-plain-plain_u)"); iseq(join(" | ",@cc_complement_failed),"", "Check that /[$special]/ and /[$upper]/ are complements (ord-cc-cc_u)"); } } # End of sub run_tests 1; perl-5.12.0-RC0/t/re/uniprops.t0000555000175000017500000000023011325127002015031 0ustar jessejesseuse strict; use warnings; # This is just a wrapper for a generated file. Asssumes being run from 't' # directory do '../lib/unicore/TestProp.pl'; 0 perl-5.12.0-RC0/t/re/pat_re_eval_thr.t0000555000175000017500000000016111325127002016313 0ustar jessejesse#!./perl chdir 't' if -d 't'; @INC = ('../lib', '.'); require 'thread_it.pl'; thread_it(qw(re pat_re_eval.t)); perl-5.12.0-RC0/t/re/reg_email_thr.t0000555000175000017500000000015711325127002015763 0ustar jessejesse#!./perl chdir 't' if -d 't'; @INC = ('../lib', '.'); require 'thread_it.pl'; thread_it(qw(re reg_email.t)); perl-5.12.0-RC0/t/re/pat_psycho_thr.t0000555000175000017500000000016011325127002016202 0ustar jessejesse#!./perl chdir 't' if -d 't'; @INC = ('../lib', '.'); require 'thread_it.pl'; thread_it(qw(re pat_psycho.t)); perl-5.12.0-RC0/t/re/regexp_unicode_prop_thr.t0000555000175000017500000000017111325127002020073 0ustar jessejesse#!./perl chdir 't' if -d 't'; @INC = ('../lib', '.'); require 'thread_it.pl'; thread_it(qw(re regexp_unicode_prop.t)); perl-5.12.0-RC0/t/re/pat_re_eval.t0000555000175000017500000003036211325127002015444 0ustar jessejesse#!./perl # # This is a home for regular expression tests that don't fit into # the format supported by re/regexp.t. If you want to add a test # that does fit that format, add it to re/re_tests, not here. use strict; use warnings; use 5.010; sub run_tests; $| = 1; BEGIN { chdir 't' if -d 't'; @INC = ('../lib','.'); do "re/ReTest.pl" or die $@; } plan tests => 123; # Update this when adding/deleting tests. run_tests() unless caller; # # Tests start here. # sub run_tests { { local $Message = "Call code from qr //"; local $_ = 'var="foo"'; $a = qr/(?{++$b})/; $b = 7; ok /$a$a/ && $b eq '9'; my $c="$a"; ok /$a$a/ && $b eq '11'; undef $@; eval {/$c/}; ok $@ && $@ =~ /not allowed at runtime/; use re "eval"; /$a$c$a/; iseq $b, '14'; our $lex_a = 43; our $lex_b = 17; our $lex_c = 27; my $lex_res = ($lex_b =~ qr/$lex_b(?{ $lex_c = $lex_a++ })/); iseq $lex_res, 1; iseq $lex_a, 44; iseq $lex_c, 43; no re "eval"; undef $@; my $match = eval { /$a$c$a/ }; ok $@ && $@ =~ /Eval-group not allowed/ && !$match; iseq $b, '14'; $lex_a = 2; $lex_a = 43; $lex_b = 17; $lex_c = 27; $lex_res = ($lex_b =~ qr/17(?{ $lex_c = $lex_a++ })/); iseq $lex_res, 1; iseq $lex_a, 44; iseq $lex_c, 43; } { our $a = bless qr /foo/ => 'Foo'; ok 'goodfood' =~ $a, "Reblessed qr // matches"; iseq $a, '(?-xism:foo)', "Reblessed qr // stringifies"; my $x = "\x{3fe}"; my $z = my $y = "\317\276"; # Byte representation of $x $a = qr /$x/; ok $x =~ $a, "UTF-8 interpolation in qr //"; ok "a$a" =~ $x, "Stringified qr // preserves UTF-8"; ok "a$x" =~ /^a$a\z/, "Interpolated qr // preserves UTF-8"; ok "a$x" =~ /^a(??{$a})\z/, "Postponed interpolation of qr // preserves UTF-8"; { local $BugId = '17776'; iseq length qr /##/x, 12, "## in qr // doesn't corrupt memory"; } { use re 'eval'; ok "$x$x" =~ /^$x(??{$x})\z/, "Postponed UTF-8 string in UTF-8 re matches UTF-8"; ok "$y$x" =~ /^$y(??{$x})\z/, "Postponed UTF-8 string in non-UTF-8 re matches UTF-8"; ok "$y$x" !~ /^$y(??{$y})\z/, "Postponed non-UTF-8 string in non-UTF-8 re doesn't match UTF-8"; ok "$x$x" !~ /^$x(??{$y})\z/, "Postponed non-UTF-8 string in UTF-8 re doesn't match UTF-8"; ok "$y$y" =~ /^$y(??{$y})\z/, "Postponed non-UTF-8 string in non-UTF-8 re matches non-UTF8"; ok "$x$y" =~ /^$x(??{$y})\z/, "Postponed non-UTF-8 string in UTF-8 re matches non-UTF8"; $y = $z; # Reset $y after upgrade. ok "$x$y" !~ /^$x(??{$x})\z/, "Postponed UTF-8 string in UTF-8 re doesn't match non-UTF-8"; ok "$y$y" !~ /^$y(??{$x})\z/, "Postponed UTF-8 string in non-UTF-8 re doesn't match non-UTF-8"; } } { use re 'eval'; local $Message = 'Test if $^N and $+ work in (?{{})'; our @ctl_n = (); our @plus = (); our $nested_tags; $nested_tags = qr{ < ((\w)+) (?{ push @ctl_n, (defined $^N ? $^N : "undef"); push @plus, (defined $+ ? $+ : "undef"); }) > (??{$nested_tags})* }x; my $c = 0; for my $test ( # Test structure: # [ Expected result, Regex, Expected value(s) of $^N, Expected value(s) of $+ ] [ 1, qr#^$nested_tags$#, "bla blubb bla", "a b a" ], [ 1, qr#^($nested_tags)$#, "bla blubb ", "a b a" ], [ 1, qr#^(|)$nested_tags$#, "bla blubb bla", "a b a" ], [ 1, qr#^(?:|)$nested_tags$#, "bla blubb bla", "a b a" ], [ 1, qr#^<(bl|bla)>$nested_tags<(/\1)>$#, "blubb /bla", "b /bla" ], [ 1, qr#(??{"(|)"})$nested_tags$#, "bla blubb bla", "a b a" ], [ 1, qr#^(??{"(bla|)"})$nested_tags$#, "bla blubb bla", "a b a" ], [ 1, qr#^(??{"(|)"})(??{$nested_tags})$#, "bla blubb undef", "a b undef" ], [ 1, qr#^(??{"(?:|)"})$nested_tags$#, "bla blubb bla", "a b a" ], [ 1, qr#^((??{"(?:bla|)"}))((??{$nested_tags}))$#, "bla blubb ", "a b " ], [ 1, qr#^((??{"(?!)?"}))((??{$nested_tags}))$#, "bla blubb ", "a b " ], [ 1, qr#^((??{"(?:|<(/?bla)>)"}))((??{$nested_tags}))\1$#, "bla blubb ", "a b " ], [ 0, qr#^((??{"(?!)"}))?((??{$nested_tags}))(?!)$#, "bla blubb undef", "a b undef" ], ) { #"#silence vim highlighting $c++; @ctl_n = (); @plus = (); my $match = (("" =~ $test->[1]) ? 1 : 0); push @ctl_n, (defined $^N ? $^N : "undef"); push @plus, (defined $+ ? $+ : "undef"); ok($test->[0] == $match, "match $c"); if ($test->[0] != $match) { # unset @ctl_n and @plus @ctl_n = @plus = (); } iseq("@ctl_n", $test->[2], "ctl_n $c"); iseq("@plus", $test->[3], "plus $c"); } } { use re 'eval'; local $BugId = '56194'; our $f; local $f; $f = sub { defined $_[0] ? $_[0] : "undef"; }; ok("123" =~ m/^(\d)(((??{1 + $^N})))+$/); our @ctl_n; our @plus; my $re = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))*(?{$^N})#; my $re2 = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))*(?{$^N})(|a(b)c|def)(??{"$^R"})#; my $re3 = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})){2}(?{$^N})(|a(b)c|def)(??{"$^R"})#; our $re5; local $re5 = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})){2}(?{$^N})#; my $re6 = qr#(??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})#; my $re7 = qr#(??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})#; my $re8 = qr/(\d+)/; my $c = 0; for my $test ( # Test structure: # [ # String to match # Regex too match # Expected values of $^N # Expected values of $+ # Expected values of $1, $2, $3, $4 and $5 # ] [ "1233", qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(??{$^N})$#, "1 2 3 3", "1 2 3 3", "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef", ], [ "1233", qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(abc|def|)?(??{$+})$#, "1 2 3 3", "1 2 3 3", "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef", ], [ "1233", qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(|abc|def)?(??{$+})$#, "1 2 3 3", "1 2 3 3", "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef", ], [ "1233", qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(abc|def|)?(??{$^N})$#, "1 2 3 3", "1 2 3 3", "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef", ], [ "1233", qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(|abc|def)?(??{$^N})$#, "1 2 3 3", "1 2 3 3", "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef", ], [ "123abc3", qr#^($re)(|a(b)c|def)(??{$^R})$#, "1 2 3 abc", "1 2 3 b", "\$1 = 123, \$2 = 1, \$3 = 3, \$4 = abc, \$5 = b", ], [ "123abc3", qr#^($re2)$#, "1 2 3 123abc3", "1 2 3 b", "\$1 = 123abc3, \$2 = 1, \$3 = 3, \$4 = abc, \$5 = b", ], [ "123abc3", qr#^($re3)$#, "1 2 123abc3", "1 2 b", "\$1 = 123abc3, \$2 = 1, \$3 = 3, \$4 = abc, \$5 = b", ], [ "123abc3", qr#^(??{$re5})(|abc|def)(??{"$^R"})$#, "1 2 abc", "1 2 abc", "\$1 = abc, \$2 = undef, \$3 = undef, \$4 = undef, \$5 = undef", ], [ "123abc3", qr#^(??{$re5})(|a(b)c|def)(??{"$^R"})$#, "1 2 abc", "1 2 b", "\$1 = abc, \$2 = b, \$3 = undef, \$4 = undef, \$5 = undef", ], [ "1234", qr#^((\d+)((??{push @ctl_n, $f->($^N); push @plus, $f->($+);$^N + 1}))((??{push @ctl_n, $f->($^N); push @plus, $f->($+);$^N + 1}))((??{push @ctl_n, $f->($^N); push @plus, $f->($+);$^N + 1})))$#, "1234 123 12 1 2 3 1234", "1234 123 12 1 2 3 4", "\$1 = 1234, \$2 = 1, \$3 = 2, \$4 = 3, \$5 = 4", ], [ "1234556", qr#^(\d+)($re6)($re6)($re6)$re6(($re6)$re6)$#, "1234556 123455 12345 1234 123 12 1 2 3 4 4 5 56", "1234556 123455 12345 1234 123 12 1 2 3 4 4 5 5", "\$1 = 1, \$2 = 2, \$3 = 3, \$4 = 4, \$5 = 56", ], [ "12345562", qr#^((??{$re8}))($re7)($re7)($re7)$re7($re7)($re7(\2))$#, "12345562 1234556 123455 12345 1234 123 12 1 2 3 4 4 5 62", "12345562 1234556 123455 12345 1234 123 12 1 2 3 4 4 5 2", "\$1 = 1, \$2 = 2, \$3 = 3, \$4 = 4, \$5 = 5", ], ) { $c++; @ctl_n = (); @plus = (); undef $^R; my $match = $test->[0] =~ $test->[1]; my $str = join(", ", '$1 = '.$f->($1), '$2 = '.$f->($2), '$3 = '.$f->($3), '$4 = '.$f->($4),'$5 = '.$f->($5)); push @ctl_n, $f->($^N); push @plus, $f->($+); ok($match, "match $c"); if (not $match) { # unset $str, @ctl_n and @plus $str = ""; @ctl_n = @plus = (); } iseq("@ctl_n", $test->[2], "ctl_n $c"); iseq("@plus", $test->[3], "plus $c"); iseq($str, $test->[4], "str $c"); } SKIP: { if ($] le '5.010') { skip "test segfaults on perl < 5.10", 4; } @ctl_n = (); @plus = (); our $re4; local $re4 = qr#(1)((??{push @ctl_n, $f->($^N); push @plus, $f->($+);$^N + 1})){2}(?{$^N})(|abc|def)(??{"$^R"})#; undef $^R; my $match = "123abc3" =~ m/^(??{$re4})$/; my $str = join(", ", '$1 = '.$f->($1), '$2 = '.$f->($2), '$3 = '.$f->($3), '$4 = '.$f->($4),'$5 = '.$f->($5),'$^R = '.$f->($^R)); push @ctl_n, $f->($^N); push @plus, $f->($+); ok($match); if (not $match) { # unset $str @ctl_n = (); @plus = (); $str = ""; } iseq("@ctl_n", "1 2 undef"); iseq("@plus", "1 2 undef"); iseq($str, "\$1 = undef, \$2 = undef, \$3 = undef, \$4 = undef, \$5 = undef, \$^R = undef"); } } } # End of sub run_tests 1; perl-5.12.0-RC0/t/re/pat_advanced_thr.t0000555000175000017500000000016211325127002016444 0ustar jessejesse#!./perl chdir 't' if -d 't'; @INC = ('../lib', '.'); require 'thread_it.pl'; thread_it(qw(re pat_advanced.t)); perl-5.12.0-RC0/t/re/substr.t0000555000175000017500000004154311336536210014517 0ustar jessejesse#!./perl #P = start of string Q = start of substr R = end of substr S = end of string BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } use warnings ; no warnings 'deprecated'; $a = 'abcdefxyz'; $SIG{__WARN__} = sub { if ($_[0] =~ /^substr outside of string/) { $w++; } elsif ($_[0] =~ /^Attempt to use reference as lvalue in substr/) { $w += 2; } elsif ($_[0] =~ /^Use of uninitialized value/) { $w += 3; } else { warn $_[0]; } }; require './test.pl'; plan(360); run_tests() unless caller; my $krunch = "a"; sub run_tests { $FATAL_MSG = qr/^substr outside of string/; is(substr($a,0,3), 'abc'); # P=Q R S is(substr($a,3,3), 'def'); # P Q R S is(substr($a,6,999), 'xyz'); # P Q S R $b = substr($a,999,999) ; # warn # P R Q S is ($w--, 1); eval{substr($a,999,999) = "" ; };# P R Q S like ($@, $FATAL_MSG); is(substr($a,0,-6), 'abc'); # P=Q R S is(substr($a,-3,1), 'x'); # P Q R S $[ = 1; is(substr($a,1,3), 'abc' ); # P=Q R S is(substr($a,4,3), 'def' ); # P Q R S is(substr($a,7,999), 'xyz');# P Q S R $b = substr($a,999,999) ; # warn # P R Q S is($w--, 1); eval{substr($a,999,999) = "" ; } ; # P R Q S like ($@, $FATAL_MSG); is(substr($a,1,-6), 'abc' );# P=Q R S is(substr($a,-3,1), 'x' ); # P Q R S $[ = 0; substr($a,3,3) = 'XYZ'; is($a, 'abcXYZxyz' ); substr($a,0,2) = ''; is($a, 'cXYZxyz' ); substr($a,0,0) = 'ab'; is($a, 'abcXYZxyz' ); substr($a,0,0) = '12345678'; is($a, '12345678abcXYZxyz' ); substr($a,-3,3) = 'def'; is($a, '12345678abcXYZdef'); substr($a,-3,3) = '<'; is($a, '12345678abcXYZ<' ); substr($a,-1,1) = '12345678'; is($a, '12345678abcXYZ12345678' ); $a = 'abcdefxyz'; is(substr($a,6), 'xyz' ); # P Q R=S is(substr($a,-3), 'xyz' ); # P Q R=S $b = substr($a,999,999) ; # warning # P R=S Q is($w--, 1); eval{substr($a,999,999) = "" ; } ; # P R=S Q like($@, $FATAL_MSG); is(substr($a,0), 'abcdefxyz'); # P=Q R=S is(substr($a,9), ''); # P Q=R=S is(substr($a,-11), 'abcdefxyz'); # Q P R=S is(substr($a,-9), 'abcdefxyz'); # P=Q R=S $a = '54321'; $b = substr($a,-7, 1) ; # warn # Q R P S is($w--, 1); eval{substr($a,-7, 1) = "" ; }; # Q R P S like($@, $FATAL_MSG); $b = substr($a,-7,-6) ; # warn # Q R P S is($w--, 1); eval{substr($a,-7,-6) = "" ; }; # Q R P S like($@, $FATAL_MSG); is(substr($a,-5,-7), ''); # R P=Q S is(substr($a, 2,-7), ''); # R P Q S is(substr($a,-3,-7), ''); # R P Q S is(substr($a, 2,-5), ''); # P=R Q S is(substr($a,-3,-5), ''); # P=R Q S is(substr($a, 2,-4), ''); # P R Q S is(substr($a,-3,-4), ''); # P R Q S is(substr($a, 5,-6), ''); # R P Q=S is(substr($a, 5,-5), ''); # P=R Q S is(substr($a, 5,-3), ''); # P R Q=S $b = substr($a, 7,-7) ; # warn # R P S Q is($w--, 1); eval{substr($a, 7,-7) = "" ; }; # R P S Q like($@, $FATAL_MSG); $b = substr($a, 7,-5) ; # warn # P=R S Q is($w--, 1); eval{substr($a, 7,-5) = "" ; }; # P=R S Q like($@, $FATAL_MSG); $b = substr($a, 7,-3) ; # warn # P Q S Q is($w--, 1); eval{substr($a, 7,-3) = "" ; }; # P Q S Q like($@, $FATAL_MSG); $b = substr($a, 7, 0) ; # warn # P S Q=R is($w--, 1); eval{substr($a, 7, 0) = "" ; }; # P S Q=R like($@, $FATAL_MSG); is(substr($a,-7,2), ''); # Q P=R S is(substr($a,-7,4), '54'); # Q P R S is(substr($a,-7,7), '54321');# Q P R=S is(substr($a,-7,9), '54321');# Q P S R is(substr($a,-5,0), ''); # P=Q=R S is(substr($a,-5,3), '543');# P=Q R S is(substr($a,-5,5), '54321');# P=Q R=S is(substr($a,-5,7), '54321');# P=Q S R is(substr($a,-3,0), ''); # P Q=R S is(substr($a,-3,3), '321');# P Q R=S is(substr($a,-2,3), '21'); # P Q S R is(substr($a,0,-5), ''); # P=Q=R S is(substr($a,2,-3), ''); # P Q=R S is(substr($a,0,0), ''); # P=Q=R S is(substr($a,0,5), '54321');# P=Q R=S is(substr($a,0,7), '54321');# P=Q S R is(substr($a,2,0), ''); # P Q=R S is(substr($a,2,3), '321'); # P Q R=S is(substr($a,5,0), ''); # P Q=R=S is(substr($a,5,2), ''); # P Q=S R is(substr($a,-7,-5), ''); # Q P=R S is(substr($a,-7,-2), '543');# Q P R S is(substr($a,-5,-5), ''); # P=Q=R S is(substr($a,-5,-2), '543');# P=Q R S is(substr($a,-3,-3), ''); # P Q=R S is(substr($a,-3,-1), '32');# P Q R S $a = ''; is(substr($a,-2,2), ''); # Q P=R=S is(substr($a,0,0), ''); # P=Q=R=S is(substr($a,0,1), ''); # P=Q=S R is(substr($a,-2,3), ''); # Q P=S R is(substr($a,-2), ''); # Q P=R=S is(substr($a,0), ''); # P=Q=R=S is(substr($a,0,-1), ''); # R P=Q=S $b = substr($a,-2, 0) ; # warn # Q=R P=S is($w--, 1); eval{substr($a,-2, 0) = "" ; }; # Q=R P=S like($@, $FATAL_MSG); $b = substr($a,-2, 1) ; # warn # Q R P=S is($w--, 1); eval{substr($a,-2, 1) = "" ; }; # Q R P=S like($@, $FATAL_MSG); $b = substr($a,-2,-1) ; # warn # Q R P=S is($w--, 1); eval{substr($a,-2,-1) = "" ; }; # Q R P=S like($@, $FATAL_MSG); $b = substr($a,-2,-2) ; # warn # Q=R P=S is($w--, 1); eval{substr($a,-2,-2) = "" ; }; # Q=R P=S like($@, $FATAL_MSG); $b = substr($a, 1,-2) ; # warn # R P=S Q is($w--, 1); eval{substr($a, 1,-2) = "" ; }; # R P=S Q like($@, $FATAL_MSG); $b = substr($a, 1, 1) ; # warn # P=S Q R is($w--, 1); eval{substr($a, 1, 1) = "" ; }; # P=S Q R like($@, $FATAL_MSG); $b = substr($a, 1, 0) ;# warn # P=S Q=R is($w--, 1); eval{substr($a, 1, 0) = "" ; }; # P=S Q=R like($@, $FATAL_MSG); $b = substr($a,1) ; # warning # P=R=S Q is($w--, 1); eval{substr($a,1) = "" ; }; # P=R=S Q like($@, $FATAL_MSG); $b = substr($a,-7,-6) ; # warn # Q R P S is($w--, 1); eval{substr($a,-7,-6) = "" ; }; # Q R P S like($@, $FATAL_MSG); my $a = 'zxcvbnm'; substr($a,2,0) = ''; is($a, 'zxcvbnm'); substr($a,7,0) = ''; is($a, 'zxcvbnm'); substr($a,5,0) = ''; is($a, 'zxcvbnm'); substr($a,0,2) = 'pq'; is($a, 'pqcvbnm'); substr($a,2,0) = 'r'; is($a, 'pqrcvbnm'); substr($a,8,0) = 'asd'; is($a, 'pqrcvbnmasd'); substr($a,0,2) = 'iop'; is($a, 'ioprcvbnmasd'); substr($a,0,5) = 'fgh'; is($a, 'fghvbnmasd'); substr($a,3,5) = 'jkl'; is($a, 'fghjklsd'); substr($a,3,2) = '1234'; is($a, 'fgh1234lsd'); # with lexicals (and in re-entered scopes) for (0,1) { my $txt; unless ($_) { $txt = "Foo"; substr($txt, -1) = "X"; is($txt, "FoX"); } else { substr($txt, 0, 1) = "X"; is($txt, "X"); } } $w = 0 ; # coercion of references { my $s = []; substr($s, 0, 1) = 'Foo'; is (substr($s,0,7), "FooRRAY"); is ($w,2); $w = 0; } # check no spurious warnings is($w, 0); # check new 4 arg replacement syntax $a = "abcxyz"; $w = 0; is(substr($a, 0, 3, ""), "abc"); is($a, "xyz"); is(substr($a, 0, 0, "abc"), ""); is($a, "abcxyz"); is(substr($a, 3, -1, ""), "xy"); is($a, "abcz"); is(substr($a, 3, undef, "xy"), ""); is($a, "abcxyz"); is($w, 3); $w = 0; is(substr($a, 3, 9999999, ""), "xyz"); is($a, "abc"); eval{substr($a, -99, 0, "") }; like($@, $FATAL_MSG); eval{substr($a, 99, 3, "") }; like($@, $FATAL_MSG); substr($a, 0, length($a), "foo"); is ($a, "foo"); is ($w, 0); # using 4 arg substr as lvalue is a compile time error eval 'substr($a,0,0,"") = "abc"'; like ($@, qr/Can't modify substr/); is ($a, "foo"); $a = "abcdefgh"; is(sub { shift }->(substr($a, 0, 4, "xxxx")), 'abcd'); is($a, 'xxxxefgh'); { my $y = 10; $y = "2" . $y; is ($y, 210); } # utf8 sanity { my $x = substr("a\x{263a}b",0); is(length($x), 3); $x = substr($x,1,1); is($x, "\x{263a}"); $x = $x x 2; is(length($x), 2); substr($x,0,1) = "abcd"; is($x, "abcd\x{263a}"); is(length($x), 5); $x = reverse $x; is(length($x), 5); is($x, "\x{263a}dcba"); my $z = 10; $z = "21\x{263a}" . $z; is(length($z), 5); is($z, "21\x{263a}10"); } # replacement should work on magical values require Tie::Scalar; my %data; tie $data{'a'}, 'Tie::StdScalar'; # makes $data{'a'} magical $data{a} = "firstlast"; is(substr($data{'a'}, 0, 5, ""), "first"); is($data{'a'}, "last"); # more utf8 # The following two originally from Ignasi Roca. $x = "\xF1\xF2\xF3"; substr($x, 0, 1) = "\x{100}"; # Ignasi had \x{FF} is(length($x), 3); is($x, "\x{100}\xF2\xF3"); is(substr($x, 0, 1), "\x{100}"); is(substr($x, 1, 1), "\x{F2}"); is(substr($x, 2, 1), "\x{F3}"); $x = "\xF1\xF2\xF3"; substr($x, 0, 1) = "\x{100}\x{FF}"; # Ignasi had \x{FF} is(length($x), 4); is($x, "\x{100}\x{FF}\xF2\xF3"); is(substr($x, 0, 1), "\x{100}"); is(substr($x, 1, 1), "\x{FF}"); is(substr($x, 2, 1), "\x{F2}"); is(substr($x, 3, 1), "\x{F3}"); # more utf8 lval exercise $x = "\xF1\xF2\xF3"; substr($x, 0, 2) = "\x{100}\xFF"; is(length($x), 3); is($x, "\x{100}\xFF\xF3"); is(substr($x, 0, 1), "\x{100}"); is(substr($x, 1, 1), "\x{FF}"); is(substr($x, 2, 1), "\x{F3}"); $x = "\xF1\xF2\xF3"; substr($x, 1, 1) = "\x{100}\xFF"; is(length($x), 4); is($x, "\xF1\x{100}\xFF\xF3"); is(substr($x, 0, 1), "\x{F1}"); is(substr($x, 1, 1), "\x{100}"); is(substr($x, 2, 1), "\x{FF}"); is(substr($x, 3, 1), "\x{F3}"); $x = "\xF1\xF2\xF3"; substr($x, 2, 1) = "\x{100}\xFF"; is(length($x), 4); is($x, "\xF1\xF2\x{100}\xFF"); is(substr($x, 0, 1), "\x{F1}"); is(substr($x, 1, 1), "\x{F2}"); is(substr($x, 2, 1), "\x{100}"); is(substr($x, 3, 1), "\x{FF}"); $x = "\xF1\xF2\xF3"; substr($x, 3, 1) = "\x{100}\xFF"; is(length($x), 5); is($x, "\xF1\xF2\xF3\x{100}\xFF"); is(substr($x, 0, 1), "\x{F1}"); is(substr($x, 1, 1), "\x{F2}"); is(substr($x, 2, 1), "\x{F3}"); is(substr($x, 3, 1), "\x{100}"); is(substr($x, 4, 1), "\x{FF}"); $x = "\xF1\xF2\xF3"; substr($x, -1, 1) = "\x{100}\xFF"; is(length($x), 4); is($x, "\xF1\xF2\x{100}\xFF"); is(substr($x, 0, 1), "\x{F1}"); is(substr($x, 1, 1), "\x{F2}"); is(substr($x, 2, 1), "\x{100}"); is(substr($x, 3, 1), "\x{FF}"); $x = "\xF1\xF2\xF3"; substr($x, -1, 0) = "\x{100}\xFF"; is(length($x), 5); is($x, "\xF1\xF2\x{100}\xFF\xF3"); is(substr($x, 0, 1), "\x{F1}"); is(substr($x, 1, 1), "\x{F2}"); is(substr($x, 2, 1), "\x{100}"); is(substr($x, 3, 1), "\x{FF}"); is(substr($x, 4, 1), "\x{F3}"); $x = "\xF1\xF2\xF3"; substr($x, 0, -1) = "\x{100}\xFF"; is(length($x), 3); is($x, "\x{100}\xFF\xF3"); is(substr($x, 0, 1), "\x{100}"); is(substr($x, 1, 1), "\x{FF}"); is(substr($x, 2, 1), "\x{F3}"); $x = "\xF1\xF2\xF3"; substr($x, 0, -2) = "\x{100}\xFF"; is(length($x), 4); is($x, "\x{100}\xFF\xF2\xF3"); is(substr($x, 0, 1), "\x{100}"); is(substr($x, 1, 1), "\x{FF}"); is(substr($x, 2, 1), "\x{F2}"); is(substr($x, 3, 1), "\x{F3}"); $x = "\xF1\xF2\xF3"; substr($x, 0, -3) = "\x{100}\xFF"; is(length($x), 5); is($x, "\x{100}\xFF\xF1\xF2\xF3"); is(substr($x, 0, 1), "\x{100}"); is(substr($x, 1, 1), "\x{FF}"); is(substr($x, 2, 1), "\x{F1}"); is(substr($x, 3, 1), "\x{F2}"); is(substr($x, 4, 1), "\x{F3}"); $x = "\xF1\xF2\xF3"; substr($x, 1, -1) = "\x{100}\xFF"; is(length($x), 4); is($x, "\xF1\x{100}\xFF\xF3"); is(substr($x, 0, 1), "\x{F1}"); is(substr($x, 1, 1), "\x{100}"); is(substr($x, 2, 1), "\x{FF}"); is(substr($x, 3, 1), "\x{F3}"); $x = "\xF1\xF2\xF3"; substr($x, -1, -1) = "\x{100}\xFF"; is(length($x), 5); is($x, "\xF1\xF2\x{100}\xFF\xF3"); is(substr($x, 0, 1), "\x{F1}"); is(substr($x, 1, 1), "\x{F2}"); is(substr($x, 2, 1), "\x{100}"); is(substr($x, 3, 1), "\x{FF}"); is(substr($x, 4, 1), "\x{F3}"); # And tests for already-UTF8 one $x = "\x{101}\x{F2}\x{F3}"; substr($x, 0, 1) = "\x{100}"; is(length($x), 3); is($x, "\x{100}\xF2\xF3"); is(substr($x, 0, 1), "\x{100}"); is(substr($x, 1, 1), "\x{F2}"); is(substr($x, 2, 1), "\x{F3}"); $x = "\x{101}\x{F2}\x{F3}"; substr($x, 0, 1) = "\x{100}\x{FF}"; is(length($x), 4); is($x, "\x{100}\x{FF}\xF2\xF3"); is(substr($x, 0, 1), "\x{100}"); is(substr($x, 1, 1), "\x{FF}"); is(substr($x, 2, 1), "\x{F2}"); is(substr($x, 3, 1), "\x{F3}"); $x = "\x{101}\x{F2}\x{F3}"; substr($x, 0, 2) = "\x{100}\xFF"; is(length($x), 3); is($x, "\x{100}\xFF\xF3"); is(substr($x, 0, 1), "\x{100}"); is(substr($x, 1, 1), "\x{FF}"); is(substr($x, 2, 1), "\x{F3}"); $x = "\x{101}\x{F2}\x{F3}"; substr($x, 1, 1) = "\x{100}\xFF"; is(length($x), 4); is($x, "\x{101}\x{100}\xFF\xF3"); is(substr($x, 0, 1), "\x{101}"); is(substr($x, 1, 1), "\x{100}"); is(substr($x, 2, 1), "\x{FF}"); is(substr($x, 3, 1), "\x{F3}"); $x = "\x{101}\x{F2}\x{F3}"; substr($x, 2, 1) = "\x{100}\xFF"; is(length($x), 4); is($x, "\x{101}\xF2\x{100}\xFF"); is(substr($x, 0, 1), "\x{101}"); is(substr($x, 1, 1), "\x{F2}"); is(substr($x, 2, 1), "\x{100}"); is(substr($x, 3, 1), "\x{FF}"); $x = "\x{101}\x{F2}\x{F3}"; substr($x, 3, 1) = "\x{100}\xFF"; is(length($x), 5); is($x, "\x{101}\x{F2}\x{F3}\x{100}\xFF"); is(substr($x, 0, 1), "\x{101}"); is(substr($x, 1, 1), "\x{F2}"); is(substr($x, 2, 1), "\x{F3}"); is(substr($x, 3, 1), "\x{100}"); is(substr($x, 4, 1), "\x{FF}"); $x = "\x{101}\x{F2}\x{F3}"; substr($x, -1, 1) = "\x{100}\xFF"; is(length($x), 4); is($x, "\x{101}\xF2\x{100}\xFF"); is(substr($x, 0, 1), "\x{101}"); is(substr($x, 1, 1), "\x{F2}"); is(substr($x, 2, 1), "\x{100}"); is(substr($x, 3, 1), "\x{FF}"); $x = "\x{101}\x{F2}\x{F3}"; substr($x, -1, 0) = "\x{100}\xFF"; is(length($x), 5); is($x, "\x{101}\xF2\x{100}\xFF\xF3"); is(substr($x, 0, 1), "\x{101}"); is(substr($x, 1, 1), "\x{F2}"); is(substr($x, 2, 1), "\x{100}"); is(substr($x, 3, 1), "\x{FF}"); is(substr($x, 4, 1), "\x{F3}"); $x = "\x{101}\x{F2}\x{F3}"; substr($x, 0, -1) = "\x{100}\xFF"; is(length($x), 3); is($x, "\x{100}\xFF\xF3"); is(substr($x, 0, 1), "\x{100}"); is(substr($x, 1, 1), "\x{FF}"); is(substr($x, 2, 1), "\x{F3}"); $x = "\x{101}\x{F2}\x{F3}"; substr($x, 0, -2) = "\x{100}\xFF"; is(length($x), 4); is($x, "\x{100}\xFF\xF2\xF3"); is(substr($x, 0, 1), "\x{100}"); is(substr($x, 1, 1), "\x{FF}"); is(substr($x, 2, 1), "\x{F2}"); is(substr($x, 3, 1), "\x{F3}"); $x = "\x{101}\x{F2}\x{F3}"; substr($x, 0, -3) = "\x{100}\xFF"; is(length($x), 5); is($x, "\x{100}\xFF\x{101}\x{F2}\x{F3}"); is(substr($x, 0, 1), "\x{100}"); is(substr($x, 1, 1), "\x{FF}"); is(substr($x, 2, 1), "\x{101}"); is(substr($x, 3, 1), "\x{F2}"); is(substr($x, 4, 1), "\x{F3}"); $x = "\x{101}\x{F2}\x{F3}"; substr($x, 1, -1) = "\x{100}\xFF"; is(length($x), 4); is($x, "\x{101}\x{100}\xFF\xF3"); is(substr($x, 0, 1), "\x{101}"); is(substr($x, 1, 1), "\x{100}"); is(substr($x, 2, 1), "\x{FF}"); is(substr($x, 3, 1), "\x{F3}"); $x = "\x{101}\x{F2}\x{F3}"; substr($x, -1, -1) = "\x{100}\xFF"; is(length($x), 5); is($x, "\x{101}\xF2\x{100}\xFF\xF3"); is(substr($x, 0, 1), "\x{101}"); is(substr($x, 1, 1), "\x{F2}"); is(substr($x, 2, 1), "\x{100}"); is(substr($x, 3, 1), "\x{FF}"); is(substr($x, 4, 1), "\x{F3}"); substr($x = "ab", 0, 0, "\x{100}\x{200}"); is($x, "\x{100}\x{200}ab"); substr($x = "\x{100}\x{200}", 0, 0, "ab"); is($x, "ab\x{100}\x{200}"); substr($x = "ab", 1, 0, "\x{100}\x{200}"); is($x, "a\x{100}\x{200}b"); substr($x = "\x{100}\x{200}", 1, 0, "ab"); is($x, "\x{100}ab\x{200}"); substr($x = "ab", 2, 0, "\x{100}\x{200}"); is($x, "ab\x{100}\x{200}"); substr($x = "\x{100}\x{200}", 2, 0, "ab"); is($x, "\x{100}\x{200}ab"); substr($x = "\xFFb", 0, 0, "\x{100}\x{200}"); is($x, "\x{100}\x{200}\xFFb"); substr($x = "\x{100}\x{200}", 0, 0, "\xFFb"); is($x, "\xFFb\x{100}\x{200}"); substr($x = "\xFFb", 1, 0, "\x{100}\x{200}"); is($x, "\xFF\x{100}\x{200}b"); substr($x = "\x{100}\x{200}", 1, 0, "\xFFb"); is($x, "\x{100}\xFFb\x{200}"); substr($x = "\xFFb", 2, 0, "\x{100}\x{200}"); is($x, "\xFFb\x{100}\x{200}"); substr($x = "\x{100}\x{200}", 2, 0, "\xFFb"); is($x, "\x{100}\x{200}\xFFb"); # [perl #20933] { my $s = "ab"; my @r; $r[$_] = \ substr $s, $_, 1 for (0, 1); is(join("", map { $$_ } @r), "ab"); } # [perl #23207] { sub ss { substr($_[0],0,1) ^= substr($_[0],1,1) ^= substr($_[0],0,1) ^= substr($_[0],1,1); } my $x = my $y = 'AB'; ss $x; ss $y; is($x, $y); } # [perl #24605] { my $x = "0123456789\x{500}"; my $y = substr $x, 4; is(substr($x, 7, 1), "7"); } # multiple assignments to lvalue [perl #24346] { my $x = "abcdef"; for (substr($x,1,3)) { is($_, 'bcd'); $_ = 'XX'; is($_, 'XX'); is($x, 'aXXef'); $_ = "\xFF"; is($_, "\xFF"); is($x, "a\xFFef"); $_ = "\xF1\xF2\xF3\xF4\xF5\xF6"; is($_, "\xF1\xF2\xF3\xF4\xF5\xF6"); is($x, "a\xF1\xF2\xF3\xF4\xF5\xF6ef"); $_ = 'YYYY'; is($_, 'YYYY'); is($x, 'aYYYYef'); } } # [perl #24200] string corruption with lvalue sub { sub bar: lvalue { substr $krunch, 0 } bar = "XXX"; is(bar, 'XXX'); $krunch = '123456789'; is(bar, '123456789'); } # [perl #29149] { my $text = "0123456789\xED "; utf8::upgrade($text); my $pos = 5; pos($text) = $pos; my $a = substr($text, $pos, $pos); is(substr($text,$pos,1), $pos); } # [perl #23765] { my $a = pack("C", 0xbf); substr($a, -1) &= chr(0xfeff); is($a, "\xbf"); } # [perl #34976] incorrect caching of utf8 substr length { my $a = "abcd\x{100}"; is(substr($a,1,2), 'bc'); is(substr($a,1,1), 'b'); } # [perl #62646] offsets exceeding 32 bits on 64-bit system SKIP: { skip("32-bit system", 24) unless ~0 > 0xffffffff; my $a = "abc"; my $s; my $r; utf8::downgrade($a); for (1..2) { $w = 0; $r = substr($a, 0xffffffff, 1); is($r, undef); is($w, 1); $w = 0; $r = substr($a, 0xffffffff+1, 1); is($r, undef); is($w, 1); $w = 0; ok( !eval { $r = substr($s=$a, 0xffffffff, 1, "_"); 1 } ); is($r, undef); is($s, $a); is($w, 0); $w = 0; ok( !eval { $r = substr($s=$a, 0xffffffff+1, 1, "_"); 1 } ); is($r, undef); is($s, $a); is($w, 0); utf8::upgrade($a); } } } perl-5.12.0-RC0/t/re/regexp_trielist.t0000555000175000017500000000044111325127002016367 0ustar jessejesse#!./perl #use re 'debug'; BEGIN { ${^RE_TRIE_MAXBUFF}=0; #${^RE_DEBUG_FLAGS}=0; } $qr = 1; for $file ('./re/regexp.t', './t/re/regexp.t', ':re:regexp.t') { if (-r $file) { do $file or die $@; exit; } } die "Cannot find ./re/regexp.t or ./t/re/regexp.t\n"; perl-5.12.0-RC0/t/re/reg_unsafe.t0000555000175000017500000000057111325127002015300 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } print "1..1\n"; # there is an equivelent test in t/re/pat.t which does NOT fail # its not clear why it doesnt fail, so this todo gets its own test # file until we can work it out. my $x; ($x='abc')=~/(abc)/g; $x='123'; print "not " if $1 ne 'abc'; print "ok 1 # TODO safe match vars make /g slow\n"; perl-5.12.0-RC0/t/re/reg_fold.t0000555000175000017500000000550611340037012014744 0ustar jessejesse#!perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } use strict; use warnings; my $count=1; my @tests; my %todo_pass = map { $_ => 1 } qw(00DF 1E9E FB00 FB01 FB02 FB03 FB04 FB05 FB06); my $file="../lib/unicore/CaseFolding.txt"; open my $fh,"<",$file or die "Failed to read '$file': $!"; while (<$fh>) { chomp; my ($line,$comment)= split/\s+#\s+/, $_; my ($cp,$type,@folded)=split/[\s;]+/,$line||''; next unless $type and ($type eq 'F' or $type eq 'C'); my $fold_above_latin1 = grep { hex("0x$_") > 255 } @folded; $_="\\x{$_}" for @folded; my $cpv=hex("0x$cp"); my $chr="\\x{$cp}"; my @str; foreach my $swap (0, 1) { # swap lhs and rhs, or not. foreach my $charclass (0, 1) { # Put rhs in [...], or not my $lhs; my $rhs; if ($swap) { $lhs = join "", @folded; $rhs = $chr; $rhs = "[$rhs]" if $charclass; } else { $lhs = $chr; $rhs = ""; foreach my $rhs_char (@folded) { $rhs .= '[' if $charclass; $rhs .= $rhs_char; $rhs .= ']' if $charclass; } } $lhs = "\"$lhs\""; $rhs = "/^$rhs\$/i"; # Try both Latin1 and Unicode for code points below 256 foreach my $upgrade ("", 'utf8::upgrade($c); ') { if ($upgrade) { next if $swap && $fold_above_latin1; next if !$swap && $cpv > 255; } my $eval = "my \$c = $lhs; $upgrade\$c =~ $rhs"; #print __LINE__, ": $eval\n"; push @tests, qq[ok(eval '$eval', '$eval - $comment')]; if (! $swap && ($cp eq '0390' || $cp eq '03B0')) { $tests[-1]="TODO: { local \$::TODO='[13:41] cue *It is all Greek to me* joke.';\n$tests[-1] }" } elsif ($charclass && @folded > 1 && $swap && ! $upgrade && ! $fold_above_latin1) { $tests[-1]="TODO: { local \$::TODO='Multi-char, non-utf8 folded inside character class [ ] doesnt work';\n$tests[-1] }" } elsif (! $upgrade && $cpv >= 128 && $cpv <= 255 && $cpv != 0xb5) { $tests[-1]="TODO: { local \$::TODO='Most non-utf8 latin1 doesnt work';\n$tests[-1] }" } elsif (! $swap && $charclass && @folded > 1 && ! $todo_pass{$cp}) { # There are a few of these that pass; most fail. $tests[-1]="TODO: { local \$::TODO='Some multi-char, f8 folded inside character class [ ] doesnt work';\n$tests[-1] }" } $count++; } } } } eval join ";\n","plan tests=>".($count-1),@tests,"1" or die $@; __DATA__ perl-5.12.0-RC0/t/re/reg_pmod.t0000555000175000017500000000253011325127002014753 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } use strict; use warnings; our @tests = ( # /p Pattern PRE MATCH POST [ '/p', "456", "123-", "456", "-789"], [ '(?p)', "456", "123-", "456", "-789"], [ '', "(456)", "123-", "456", "-789"], [ '', "456", undef, undef, undef ], ); plan tests => 4 * @tests + 2; my $W = ""; $SIG{__WARN__} = sub { $W.=join("",@_); }; sub _u($$) { "$_[0] is ".(defined $_[1] ? "'$_[1]'" : "undef") } $_ = '123-456-789'; foreach my $test (@tests) { my ($p, $pat,$l,$m,$r) = @$test; my $test_name = $p eq '/p' ? "/$pat/p" : $p eq '(?p)' ? "/(?p)$pat/" : "/$pat/"; # # Cannot use if/else due to the scope invalidating ${^MATCH} and friends. # my $ok = ok $p eq '/p' ? /$pat/p : $p eq '(?p)' ? /(?p)$pat/ : /$pat/ => $test_name; SKIP: { skip "/$pat/$p failed to match", 3 unless $ok; is(${^PREMATCH}, $l,_u "$test_name: ^PREMATCH",$l); is(${^MATCH}, $m,_u "$test_name: ^MATCH",$m ); is(${^POSTMATCH}, $r,_u "$test_name: ^POSTMATCH",$r ); } } is($W,"","No warnings should be produced"); ok(!defined ${^MATCH}, "No /p in scope so ^MATCH is undef"); perl-5.12.0-RC0/t/re/pat_special_cc_thr.t0000555000175000017500000000016411325127002016766 0ustar jessejesse#!./perl chdir 't' if -d 't'; @INC = ('../lib', '.'); require 'thread_it.pl'; thread_it(qw(re pat_special_cc.t)); perl-5.12.0-RC0/t/re/pat_thr.t0000555000175000017500000000015111325127002014615 0ustar jessejesse#!./perl chdir 't' if -d 't'; @INC = ('../lib', '.'); require 'thread_it.pl'; thread_it(qw(re pat.t)); perl-5.12.0-RC0/t/re/qr_gc.t0000555000175000017500000000064011325127002014252 0ustar jessejesse#!./perl -w BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; undef &Regexp::DESTROY; } plan tests => 2; my $destroyed; { sub Regexp::DESTROY { $destroyed++ } } { my $rx = qr//; } is( $destroyed, 1, "destroyed regexp" ); undef $destroyed; { my $var = bless {}, "Foo"; my $rx = qr/(?{ $var })/; } is( $destroyed, 1, "destroyed regexp with closure capture" ); perl-5.12.0-RC0/t/re/regexp_qr_embed.t0000555000175000017500000000032111325127002016303 0ustar jessejesse#!./perl $qr = 1; $qr_embed = 1; for $file ('./re/regexp.t', './t/re/regexp.t', ':re:regexp.t') { if (-r $file) { do $file or die $@; exit; } } die "Cannot find ./re/regexp.t or ./t/re/regexp.t\n"; perl-5.12.0-RC0/t/re/regexp_unicode_prop.t0000555000175000017500000002227111325127002017223 0ustar jessejesse#!./perl # # Tests that have to do with checking whether characters have (or not have) # certain Unicode properties; belong (or not belong) to blocks, scripts, etc. # use strict; use warnings; use 5.010; my $IS_EBCDIC = ord ('A') == 193; sub run_tests; # # This is the data to test. # # This is a hash; keys are the property to test. # Values are arrays containing characters to test. The characters can # have the following formats: # '\N{CHARACTER NAME}' - Use character with that name # '\x{1234}' - Use character with that hex escape # '0x1234' - Use chr() to get that character # "a" - Character to use # # If a character entry starts with ! the character does not belong to the class # # If the class is just single letter, we use both \pL and \p{L} # use charnames ':full'; my @CLASSES = ( L => ["a", "A"], Ll => ["b", "!B"], Lu => ["!c", "C"], IsLl => ["d", "!D"], IsLu => ["!e", "E"], LC => ["f", "!1"], 'L&' => ["g", "!2"], 'Lowercase Letter' => ["h", "!H"], Common => ["!i", "3"], Inherited => ["!j", '\x{300}'], InBasicLatin => ['\N{LATIN CAPITAL LETTER A}'], InLatin1Supplement => ['\N{LATIN CAPITAL LETTER A WITH GRAVE}'], InLatinExtendedA => ['\N{LATIN CAPITAL LETTER A WITH MACRON}'], InLatinExtendedB => ['\N{LATIN SMALL LETTER B WITH STROKE}'], InKatakana => ['\N{KATAKANA LETTER SMALL A}'], IsLatin => ["0x100", "0x212b"], IsHebrew => ["0x5d0", "0xfb4f"], IsGreek => ["0x37a", "0x386", "!0x387", "0x388", "0x38a", "!0x38b", "0x38c"], HangulSyllables => ['\x{AC00}'], 'Script=Latin' => ['\x{0100}'], 'Block=LatinExtendedA' => ['\x{0100}'], 'Category=UppercaseLetter' => ['\x{0100}'], # # It's ok to repeat class names. # InLatin1Supplement => $IS_EBCDIC ? ['!\x{7f}', '\x{80}', '!\x{100}'] : ['!\x{7f}', '\x{80}', '\x{ff}', '!\x{100}'], InLatinExtendedA => ['!\x{7f}', '!\x{80}', '!\x{ff}', '\x{100}'], # # Properties are case-insensitive, and may have whitespace, # dashes and underscores. # 'in-latin1_SUPPLEMENT' => ['\x{80}', '\N{LATIN SMALL LETTER Y WITH DIAERESIS}'], ' ^ In Latin 1 Supplement ' => ['!\x{80}', '\N{COFFIN}'], 'latin-1 supplement' => ['\x{80}', "0xDF"], ); my @USER_DEFINED_PROPERTIES = ( # # User defined properties # InKana1 => ['\x{3040}', '!\x{303F}'], InKana2 => ['\x{3040}', '!\x{303F}'], InKana3 => ['\x{3041}', '!\x{3040}'], InNotKana => ['\x{3040}', '!\x{3041}'], InConsonant => ['d', '!e'], IsSyriac1 => ['\x{0712}', '!\x{072F}'], Syriac1 => ['\x{0712}', '!\x{072F}'], '# User-defined character properties my lack \n at the end', InGreekSmall => ['\N{GREEK SMALL LETTER PI}', '\N{GREEK SMALL LETTER FINAL SIGMA}'], InGreekCapital => ['\N{GREEK CAPITAL LETTER PI}', '!\x{03A2}'], Dash => ['-'], ASCII_Hex_Digit => ['!-', 'A'], AsciiHexAndDash => ['-', 'A'], ); # # From the short properties we populate POSIX-like classes. # my %SHORT_PROPERTIES = ( 'Ll' => ['m', '\N{CYRILLIC SMALL LETTER A}'], 'Lu' => ['M', '\N{GREEK CAPITAL LETTER ALPHA}'], 'Lo' => ['\N{HIRAGANA LETTER SMALL A}'], # is also in other alphabetic 'Mn' => ['\N{HEBREW POINT RAFE}'], 'Nd' => ["0", '\N{ARABIC-INDIC DIGIT ZERO}'], 'Pc' => ["_"], 'Po' => ["!"], 'Zs' => [" "], 'Cc' => ['\x{00}'], ); # # Illegal properties # my @ILLEGAL_PROPERTIES = qw [q qrst]; my %d; while (my ($class, $chars) = each %SHORT_PROPERTIES) { push @{$d {IsAlpha}} => map {$class =~ /^[LM]/ ? $_ : "!$_"} @$chars; push @{$d {IsAlnum}} => map {$class =~ /^[LMN]./ ? $_ : "!$_"} @$chars; push @{$d {IsASCII}} => map {length ($_) == 1 || $_ eq '\x{00}' ? $_ : "!$_"} @$chars; push @{$d {IsCntrl}} => map {$class =~ /^C/ ? $_ : "!$_"} @$chars; push @{$d {IsBlank}} => map {$class =~ /^Z[lps]/ ? $_ : "!$_"} @$chars; push @{$d {IsDigit}} => map {$class =~ /^Nd$/ ? $_ : "!$_"} @$chars; push @{$d {IsGraph}} => map {$class =~ /^([LMNPS]|Co)/ ? $_ : "!$_"} @$chars; push @{$d {IsPrint}} => map {$class =~ /^([LMNPS]|Co|Zs)/ ? $_ : "!$_"} @$chars; push @{$d {IsLower}} => map {$class =~ /^Ll$/ ? $_ : "!$_"} @$chars; push @{$d {IsUpper}} => map {$class =~ /^L[ut]/ ? $_ : "!$_"} @$chars; push @{$d {IsPunct}} => map {$class =~ /^P/ ? $_ : "!$_"} @$chars; push @{$d {IsWord}} => map {$class =~ /^[LMN]/ || $_ eq "_" ? $_ : "!$_"} @$chars; push @{$d {IsSpace}} => map {$class =~ /^Z/ || length ($_) == 1 && ord ($_) >= 0x09 && ord ($_) <= 0x0D ? $_ : "!$_"} @$chars; } delete $d {IsASCII} if $IS_EBCDIC; push @CLASSES => "# Short properties" => %SHORT_PROPERTIES, "# POSIX like properties" => %d, "# User defined properties" => @USER_DEFINED_PROPERTIES; # # Calculate the number of tests. # my $count = 0; for (my $i = 0; $i < @CLASSES; $i += 2) { $i ++, redo if $CLASSES [$i] =~ /^\h*#\h*(.*)/; $count += (length $CLASSES [$i] == 1 ? 4 : 2) * @{$CLASSES [$i + 1]}; } $count += 2 * @ILLEGAL_PROPERTIES; $count += 2 * grep {length $_ == 1} @ILLEGAL_PROPERTIES; my $tests = 0; say "1..$count"; run_tests unless caller (); sub match { my ($char, $match, $nomatch) = @_; my ($str, $name); given ($char) { when (/^\\/) { $str = eval qq ["$char"]; $name = qq ["$char"]; } when (/^0x([0-9A-Fa-f]+)$/) { $str = chr hex $1; $name = "chr ($char)"; } default { $str = $char; $name = qq ["$char"]; } } print "not " unless $str =~ /$match/; print "ok ", ++ $tests, " - $name =~ /$match/\n"; print "not " unless $str !~ /$nomatch/; print "ok ", ++ $tests, " - $name !~ /$nomatch/\n"; } sub run_tests { while (@CLASSES) { my $class = shift @CLASSES; if ($class =~ /^\h*#\h*(.*)/) { print "# $1\n"; next; } last unless @CLASSES; my $chars = shift @CLASSES; my @in = grep {!/^!./} @$chars; my @out = map {s/^!(?=.)//; $_} grep { /^!./} @$chars; my $in_pat = eval qq ['\\p{$class}']; my $out_pat = eval qq ['\\P{$class}']; match $_, $in_pat, $out_pat for @in; match $_, $out_pat, $in_pat for @out; if (1 == length $class) { my $in_pat = eval qq ['\\p$class']; my $out_pat = eval qq ['\\P$class']; match $_, $in_pat, $out_pat for @in; match $_, $out_pat, $in_pat for @out; } } my $pat = qr /^Can't find Unicode property definition/; print "# Illegal properties\n"; foreach my $p (@ILLEGAL_PROPERTIES) { undef $@; my $r = eval "'a' =~ /\\p{$p}/; 1"; print "not " unless !$r && $@ && $@ =~ $pat; print "ok ", ++ $tests, " - Unknown Unicode property \\p{$p}\n"; undef $@; my $s = eval "'a' =~ /\\P{$p}/; 1"; print "not " unless !$s && $@ && $@ =~ $pat; print "ok ", ++ $tests, " - Unknown Unicode property \\P{$p}\n"; if (length $p == 1) { undef $@; my $r = eval "'a' =~ /\\p$p/; 1"; print "not " unless !$r && $@ && $@ =~ $pat; print "ok ", ++ $tests, " - Unknown Unicode property \\p$p\n"; undef $@; my $s = eval "'a' =~ /\\P$p/; 1"; print "not " unless !$s && $@ && $@ =~ $pat; print "ok ", ++ $tests, " - Unknown Unicode property \\P$p\n"; } } } # # User defined properties # sub InKana1 {<<'--'} 3040 309F 30A0 30FF -- sub InKana2 {<<'--'} +utf8::InHiragana +utf8::InKatakana -- sub InKana3 {<<'--'} +utf8::InHiragana +utf8::InKatakana -utf8::IsCn -- sub InNotKana {<<'--'} !utf8::InHiragana -utf8::InKatakana +utf8::IsCn -- sub InConsonant {<<'--'} # Not EBCDIC-aware. 0061 007f -0061 -0065 -0069 -006f -0075 -- sub IsSyriac1 {<<'--'} 0712 072C 0730 074A -- sub Syriac1 {<<'--'} 0712 072C 0730 074A -- sub InGreekSmall {return "03B1\t03C9"} sub InGreekCapital {return "0391\t03A9\n-03A2"} sub AsciiHexAndDash {<<'--'} +utf8::ASCII_Hex_Digit +utf8::Dash -- __END__ perl-5.12.0-RC0/t/re/ReTest.pl0000444000175000017500000001076611325127002014544 0ustar jessejesse#!./perl # # This is the test subs used for regex testing. # This used to be part of re/pat.t use warnings; use strict; use 5.010; use base qw/Exporter/; use Carp; use vars qw( $EXPECTED_TESTS $TODO $Message $Error $DiePattern $WarnPattern $BugId $PatchId $running_as_thread $IS_ASCII $IS_EBCDIC $ordA ); $| = 1; $Message ||= "Noname test"; our $ordA = ord ('A'); # This defines ASCII/UTF-8 vs EBCDIC/UTF-EBCDIC # This defined the platform. our $IS_ASCII = $ordA == 65; our $IS_EBCDIC = $ordA == 193; use vars '%Config'; eval 'use Config'; # Defaults assumed if this fails my $test = 0; my $done_plan; sub plan { my (undef,$tests)= @_; if (defined $tests) { die "Number of tests already defined! ($EXPECTED_TESTS)" if $EXPECTED_TESTS; $EXPECTED_TESTS= $tests; } if ($EXPECTED_TESTS) { print "1..$EXPECTED_TESTS\n" if !$done_plan++; } else { print "Number of tests not declared!"; } } sub pretty { my ($mess) = @_; $mess =~ s/\n/\\n/g; $mess =~ s/\r/\\r/g; $mess =~ s/\t/\\t/g; $mess =~ s/([\00-\37\177])/sprintf '\%03o', ord $1/eg; $mess =~ s/#/\\#/g; $mess; } sub safe_globals { defined($_) and s/#/\\#/g for $BugId, $PatchId, $TODO; } sub _ok { my ($ok, $mess, $error) = @_; plan(); safe_globals(); $mess = pretty ($mess // $Message); $mess .= "; Bug $BugId" if defined $BugId; $mess .= "; Patch $PatchId" if defined $PatchId; $mess .= " # TODO $TODO" if defined $TODO; my $line_nr = (caller(1)) [2]; printf "%sok %d - %s\n", ($ok ? "" : "not "), ++ $test, "$mess\tLine $line_nr"; unless ($ok) { print "# Failed test at line $line_nr\n" unless defined $TODO; if ($error //= $Error) { no warnings 'utf8'; chomp $error; $error = join "\n#", map {pretty $_} split /\n\h*#/ => $error; $error = "# $error" unless $error =~ /^\h*#/; print $error, "\n"; } } return $ok; } # Force scalar context on the pattern match sub ok ($;$$) {_ok $_ [0], $_ [1], $_ [2]} sub nok ($;$$) {_ok !$_ [0], "Failed: " . ($_ [1] // $Message), $_ [2]} sub skip { my $why = shift; safe_globals(); $why =~ s/\n.*//s; $why .= "; Bug $BugId" if defined $BugId; # seems like the new harness code doesnt like todo and skip to be mixed. # which seems like a bug in the harness to me. -- dmq #$why .= " # TODO $TODO" if defined $TODO; my $n = shift // 1; my $line_nr = (caller(0)) [2]; for (1 .. $n) { ++ $test; #print "not " if defined $TODO; print "ok $test # skip $why\tLine $line_nr\n"; } no warnings "exiting"; last SKIP; } sub iseq ($$;$) { my ($got, $expect, $name) = @_; $_ = defined ($_) ? "'$_'" : "undef" for $got, $expect; my $ok = $got eq $expect; my $error = "# expected: $expect\n" . "# result: $got"; _ok $ok, $name, $error; } sub isneq ($$;$) { my ($got, $expect, $name) = @_; my $todo = $TODO ? " # TODO $TODO" : ''; $_ = defined ($_) ? "'$_'" : "undef" for $got, $expect; my $ok = $got ne $expect; my $error = "# results are equal ($got)"; _ok $ok, $name, $error; } sub eval_ok ($;$) { my ($code, $name) = @_; local $@; if (ref $code) { _ok eval {&$code} && !$@, $name; } else { _ok eval ($code) && !$@, $name; } } sub must_die { my ($code, $pattern, $name) = @_; $pattern //= $DiePattern or Carp::confess("Bad pattern"); undef $@; ref $code ? &$code : eval $code; my $r = $@ && $@ =~ /$pattern/; _ok $r, $name // $Message // "\$\@ =~ /$pattern/"; } sub must_warn { my ($code, $pattern, $name) = @_; $pattern //= $WarnPattern; my $w; local $SIG {__WARN__} = sub {$w .= join "" => @_}; use warnings 'all'; ref $code ? &$code : eval $code; my $r = $w && $w =~ /$pattern/; $w //= "UNDEF"; _ok $r, $name // $Message // "Got warning /$pattern/", "# expected: /$pattern/\n" . "# result: $w"; } sub may_not_warn { my ($code, $name) = @_; my $w; local $SIG {__WARN__} = sub {$w .= join "" => @_}; use warnings 'all'; ref $code ? &$code : eval $code; _ok !$w, $name // ($Message ? "$Message (did not warn)" : "Did not warn"), "Got warning '$w'"; } 1; perl-5.12.0-RC0/t/re/pat_rt_report.t0000555000175000017500000010046711325127002016053 0ustar jessejesse#!./perl # # This is a home for regular expression tests that don't fit into # the format supported by re/regexp.t. If you want to add a test # that does fit that format, add it to re/re_tests, not here. use strict; use warnings; use 5.010; sub run_tests; $| = 1; BEGIN { chdir 't' if -d 't'; @INC = ('../lib','.'); do "re/ReTest.pl" or die $@; } plan tests => 2511; # Update this when adding/deleting tests. run_tests() unless caller; # # Tests start here. # sub run_tests { { local $BugId = '20000731.001'; ok "A \x{263a} B z C" =~ /A . B (??{ "z" }) C/, "Match UTF-8 char in presense of (??{ })"; } { local $BugId = '20001021.005'; no warnings 'uninitialized'; ok undef =~ /^([^\/]*)(.*)$/, "Used to cause a SEGV"; } { local $Message = 'bug id 20001008.001'; my @x = ("stra\337e 138", "stra\337e 138"); for (@x) { ok s/(\d+)\s*([\w\-]+)/$1 . uc $2/e; ok my ($latin) = /^(.+)(?:\s+\d)/; iseq $latin, "stra\337e"; ok $latin =~ s/stra\337e/straße/; # # Previous code follows, but outcommented - there were no tests. # # $latin =~ s/stra\337e/straße/; # \303\237 after the 2nd a # use utf8; # needed for the raw UTF-8 # $latin =~ s!(s)tr(?:aß|s+e)!$1tr.!; # \303\237 after the a } } { local $BugId = '20001028.003'; # Fist half of the bug. local $Message = 'HEBREW ACCENT QADMA matched by .*'; my $X = chr (1448); ok my ($Y) = $X =~ /(.*)/; iseq $Y, v1448; iseq length ($Y), 1; # Second half of the bug. $Message = 'HEBREW ACCENT QADMA in replacement'; $X = ''; $X =~ s/^/chr(1488)/e; iseq length $X, 1; iseq ord ($X), 1488; } { local $BugId = '20001108.001'; local $Message = 'Repeated s///'; my $X = "Szab\x{f3},Bal\x{e1}zs"; my $Y = $X; $Y =~ s/(B)/$1/ for 0 .. 3; iseq $Y, $X; iseq $X, "Szab\x{f3},Bal\x{e1}zs"; } { local $BugId = '20000517.001'; local $Message = 's/// on UTF-8 string'; my $x = "\x{100}A"; $x =~ s/A/B/; iseq $x, "\x{100}B"; iseq length $x, 2; } { local $BugId = '20001230.002'; local $Message = '\C and É'; ok "École" =~ /^\C\C(.)/ && $1 eq 'c'; ok "École" =~ /^\C\C(c)/; } { # The original bug report had 'no utf8' here but that was irrelevant. local $BugId = '20010306.008'; local $Message = "Don't dump core"; my $a = "a\x{1234}"; ok $a =~ m/\w/; # used to core dump. } { local $BugId = '20010410.006'; local $Message = '/g in scalar context'; for my $rx ('/(.*?)\{(.*?)\}/csg', '/(.*?)\{(.*?)\}/cg', '/(.*?)\{(.*?)\}/sg', '/(.*?)\{(.*?)\}/g', '/(.+?)\{(.+?)\}/csg',) { my $i = 0; my $input = "a{b}c{d}"; eval <<" --"; while (eval \$input =~ $rx) { \$i ++; } -- iseq $i, 2; } } { local $BugId = "20010619.003"; # Amazingly vertical tabulator is the same in ASCII and EBCDIC. for ("\n", "\t", "\014", "\r") { ok !/[[:print:]]/, "'$_' not in [[:print:]]"; } for (" ") { ok /[[:print:]]/, "'$_' in [[:print:]]"; } } { # [ID 20010814.004] pos() doesn't work when using =~m// in list context local $BugId = '20010814.004'; $_ = "ababacadaea"; my $a = join ":", /b./gc; my $b = join ":", /a./gc; my $c = pos; iseq "$a $b $c", 'ba:ba ad:ae 10', "pos() works with () = m//"; } { # [ID 20010407.006] matching utf8 return values from # functions does not work local $BugId = '20010407.006'; local $Message = 'UTF-8 return values from functions'; package ID_20010407_006; sub x {"a\x{1234}"} my $x = x; my $y; ::ok $x =~ /(..)/; $y = $1; ::ok length ($y) == 2 && $y eq $x; ::ok x =~ /(..)/; $y = $1; ::ok length ($y) == 2 && $y eq $x; } { # High bit bug -- japhy my $x = "ab\200d"; ok $x =~ /.*?\200/, "High bit fine"; } { local $Message = 'UTF-8 hash keys and /$/'; # http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters # /2002-01/msg01327.html my $u = "a\x{100}"; my $v = substr ($u, 0, 1); my $w = substr ($u, 1, 1); my %u = ($u => $u, $v => $v, $w => $w); for (keys %u) { my $m1 = /^\w*$/ ? 1 : 0; my $m2 = $u {$_} =~ /^\w*$/ ? 1 : 0; iseq $m1, $m2; } } { local $BugId = "20020124.005"; local $PatchId = "14795"; local $Message = "s///eg"; for my $char ("a", "\x{df}", "\x{100}") { my $x = "$char b $char"; $x =~ s{($char)}{ "c" =~ /c/; "x"; }ge; iseq substr ($x, 0, 1), substr ($x, -1, 1); } } { local $BugId = "20020412.005"; local $Message = "Correct pmop flags checked when empty pattern"; # Requires reuse of last successful pattern. my $num = 123; $num =~ /\d/; for (0 .. 1) { my $match = ?? + 0; ok $match != $_, $Message, sprintf "'match one' %s on %s iteration" => $match ? 'succeeded' : 'failed', $_ ? 'second' : 'first'; } $num =~ /(\d)/; my $result = join "" => $num =~ //g; iseq $result, $num; } { local $BugId = '20020630.002'; local $Message = 'UTF-8 regex matches above 32k'; for (['byte', "\x{ff}"], ['utf8', "\x{1ff}"]) { my ($type, $char) = @$_; for my $len (32000, 32768, 33000) { my $s = $char . "f" x $len; my $r = $s =~ /$char([f]*)/gc; ok $r, $Message, "<$type x $len>"; ok !$r || pos ($s) == $len + 1, $Message, "<$type x $len>; pos = @{[pos $s]}"; } } } { local $PatchId = '18179'; my $s = "\x{100}" x 5; my $ok = $s =~ /(\x{100}{4})/; my ($ord, $len) = (ord $1, length $1); ok $ok && $ord == 0x100 && $len == 4, "No panic: end_shift"; } { local $BugId = '15763'; our $a = "x\x{100}"; chop $a; # Leaves the UTF-8 flag $a .= "y"; # 1 byte before 'y'. ok $a =~ /^\C/, 'match one \C on 1-byte UTF-8'; ok $a =~ /^\C{1}/, 'match \C{1}'; ok $a =~ /^\Cy/, 'match \Cy'; ok $a =~ /^\C{1}y/, 'match \C{1}y'; ok $a !~ /^\C\Cy/, q {don't match two \Cy}; ok $a !~ /^\C{2}y/, q {don't match \C{2}y}; $a = "\x{100}y"; # 2 bytes before "y" ok $a =~ /^\C/, 'match one \C on 2-byte UTF-8'; ok $a =~ /^\C{1}/, 'match \C{1}'; ok $a =~ /^\C\C/, 'match two \C'; ok $a =~ /^\C{2}/, 'match \C{2}'; ok $a =~ /^\C\C\C/, 'match three \C on 2-byte UTF-8 and a byte'; ok $a =~ /^\C{3}/, 'match \C{3}'; ok $a =~ /^\C\Cy/, 'match two \C'; ok $a =~ /^\C{2}y/, 'match \C{2}'; ok $a !~ /^\C\C\Cy/, q {don't match three \Cy}; ok $a !~ /^\C{2}\Cy/, q {don't match \C{2}\Cy}; ok $a !~ /^\C{3}y/, q {don't match \C{3}y}; $a = "\x{1000}y"; # 3 bytes before "y" ok $a =~ /^\C/, 'match one \C on three-byte UTF-8'; ok $a =~ /^\C{1}/, 'match \C{1}'; ok $a =~ /^\C\C/, 'match two \C'; ok $a =~ /^\C{2}/, 'match \C{2}'; ok $a =~ /^\C\C\C/, 'match three \C'; ok $a =~ /^\C{3}/, 'match \C{3}'; ok $a =~ /^\C\C\C\C/, 'match four \C on three-byte UTF-8 and a byte'; ok $a =~ /^\C{4}/, 'match \C{4}'; ok $a =~ /^\C\C\Cy/, 'match three \Cy'; ok $a =~ /^\C{3}y/, 'match \C{3}y'; ok $a !~ /^\C\C\C\Cy/, q {don't match four \Cy}; ok $a !~ /^\C{4}y/, q {don't match \C{4}y}; } { local $BugId = '15397'; local $Message = 'UTF-8 matching'; ok "\x{100}" =~ /\x{100}/; ok "\x{100}" =~ /(\x{100})/; ok "\x{100}" =~ /(\x{100}){1}/; ok "\x{100}\x{100}" =~ /(\x{100}){2}/; ok "\x{100}\x{100}" =~ /(\x{100})(\x{100})/; } { local $BugId = '7471'; local $Message = 'Neither ()* nor ()*? sets $1 when matched 0 times'; local $_ = 'CD'; ok /(AB)*?CD/ && !defined $1; ok /(AB)*CD/ && !defined $1; } { local $BugId = '3547'; local $Message = "Caching shouldn't prevent match"; my $pattern = "^(b+?|a){1,2}c"; ok "bac" =~ /$pattern/ && $1 eq 'a'; ok "bbac" =~ /$pattern/ && $1 eq 'a'; ok "bbbac" =~ /$pattern/ && $1 eq 'a'; ok "bbbbac" =~ /$pattern/ && $1 eq 'a'; } { local $BugId = '18232'; local $Message = '$1 should keep UTF-8 ness'; ok "\x{100}" =~ /(.)/; iseq $1, "\x{100}", '$1 is UTF-8'; { 'a' =~ /./; } iseq $1, "\x{100}", '$1 is still UTF-8'; isneq $1, "\xC4\x80", '$1 is not non-UTF-8'; } { local $BugId = '19767'; local $Message = "Optimizer doesn't prematurely reject match"; use utf8; my $attr = 'Name-1'; my $NormalChar = qr /[\p{IsDigit}\p{IsLower}\p{IsUpper}]/; my $NormalWord = qr /${NormalChar}+?/; my $PredNameHyphen = qr /^${NormalWord}(\-${NormalWord})*?$/; $attr =~ /^$/; ok $attr =~ $PredNameHyphen; # Original test. "a" =~ m/[b]/; ok "0" =~ /\p{N}+\z/; # Variant. } { local $BugId = '20683'; local $Message = "(??{ }) doesn't return stale values"; our $p = 1; foreach (1, 2, 3, 4) { $p ++ if /(??{ $p })/ } iseq $p, 5; { package P; $a = 1; sub TIESCALAR {bless []} sub FETCH {$a ++} } tie $p, "P"; foreach (1, 2, 3, 4) { /(??{ $p })/ } iseq $p, 5; } { # Subject: Odd regexp behavior # From: Markus Kuhn # Date: Wed, 26 Feb 2003 16:53:12 +0000 # Message-Id: # To: perl-unicode@perl.org local $Message = 'Markus Kuhn 2003-02-26'; my $x = "\x{2019}\nk"; ok $x =~ s/(\S)\n(\S)/$1 $2/sg; ok $x eq "\x{2019} k"; $x = "b\nk"; ok $x =~ s/(\S)\n(\S)/$1 $2/sg; ok $x eq "b k"; ok "\x{2019}" =~ /\S/; } { local $BugId = '21411'; local $Message = "(??{ .. }) in split doesn't corrupt its stack"; our $i; ok '-1-3-5-' eq join '', split /((??{$i++}))/, '-1-3-5-'; no warnings 'syntax'; @_ = split /(?{'WOW'})/, 'abc'; local $" = "|"; iseq "@_", "a|b|c"; } { # XXX DAPM 13-Apr-06. Recursive split is still broken. It's only luck it # hasn't been crashing. Disable this test until it is fixed properly. # XXX also check what it returns rather than just doing ok(1,...) # split /(?{ split "" })/, "abc"; local $TODO = "Recursive split is still broken"; ok 0, 'cache_re & "(?{": it dumps core in 5.6.1 & 5.8.0'; } { local $BugId = '17757'; $_ = "code: 'x' { '...' }\n"; study; my @x; push @x, $& while m/'[^\']*'/gx; local $" = ":"; iseq "@x", "'x':'...'", "Parse::RecDescent triggered infinite loop"; } { local $BugId = '22354'; sub func ($) { ok "a\nb" !~ /^b/, "Propagated modifier; $_[0]"; ok "a\nb" =~ /^b/m, "Propagated modifier; $_[0] - with /m"; } func "standalone"; $_ = "x"; s/x/func "in subst"/e; $_ = "x"; s/x/func "in multiline subst"/em; # # Next two give 'panic: malloc'. # Outcommented, using two TODOs. # local $TODO = 'panic: malloc'; local $Message = 'Postponed regexp and propaged modifier'; # ok 0 for 1 .. 2; SKIP: { skip "panic: malloc", 2; $_ = "x"; /x(?{func "in regexp"})/; $_ = "x"; /x(?{func "in multiline regexp"})/m; } } { local $BugId = '19049'; $_ = "abcdef\n"; my @x = m/./g; iseq "abcde", $`, 'Global match sets $`'; } { # [perl #23769] Unicode regex broken on simple example # regrepeat() didn't handle UTF-8 EXACT case right. local $BugId = '23769'; my $Mess = 'regrepeat() handles UTF-8 EXACT case right'; local $Message = $Mess; my $s = "\x{a0}\x{a0}\x{a0}\x{100}"; chop $s; ok $s =~ /\x{a0}/; ok $s =~ /\x{a0}+/; ok $s =~ /\x{a0}\x{a0}/; $Message = "$Mess (easy variant)"; ok "aaa\x{100}" =~ /(a+)/; iseq $1, "aaa"; $Message = "$Mess (easy invariant)"; ok "aaa\x{100} " =~ /(a+?)/; iseq $1, "a"; $Message = "$Mess (regrepeat variant)"; ok "\xa0\xa0\xa0\x{100} " =~ /(\xa0+?)/; iseq $1, "\xa0"; $Message = "$Mess (regrepeat invariant)"; ok "\xa0\xa0\xa0\x{100}" =~ /(\xa0+)/; iseq $1, "\xa0\xa0\xa0"; $Message = "$Mess (hard variant)"; ok "\xa0\xa1\xa0\xa1\xa0\xa1\x{100}" =~ /((?:\xa0\xa1)+?)/; iseq $1, "\xa0\xa1"; $Message = "$Mess (hard invariant)"; ok "ababab\x{100} " =~ /((?:ab)+)/; iseq $1, 'ababab'; ok "\xa0\xa1\xa0\xa1\xa0\xa1\x{100}" =~ /((?:\xa0\xa1)+)/; iseq $1, "\xa0\xa1\xa0\xa1\xa0\xa1"; ok "ababab\x{100} " =~ /((?:ab)+?)/; iseq $1, "ab"; $Message = "Don't match first byte of UTF-8 representation"; ok "\xc4\xc4\xc4" !~ /(\x{100}+)/; ok "\xc4\xc4\xc4" !~ /(\x{100}+?)/; ok "\xc4\xc4\xc4" !~ /(\x{100}++)/; } { # perl panic: pp_match start/end pointers local $BugId = '25269'; iseq "a-bc", eval {my ($x, $y) = "bca" =~ /^(?=.*(a)).*(bc)/; "$x-$y"}, 'Captures can move backwards in string'; } { local $BugId = '27940'; # \cA not recognized in character classes ok "a\cAb" =~ /\cA/, '\cA in pattern'; ok "a\cAb" =~ /[\cA]/, '\cA in character class'; ok "a\cAb" =~ /[\cA-\cB]/, '\cA in character class range'; ok "abc" =~ /[^\cA-\cB]/, '\cA in negated character class range'; ok "a\cBb" =~ /[\cA-\cC]/, '\cB in character class range'; ok "a\cCbc" =~ /[^\cA-\cB]/, '\cC in negated character class range'; ok "a\cAb" =~ /(??{"\cA"})/, '\cA in ??{} pattern'; ok "ab" !~ /a\cIb/x, '\cI in pattern'; } { # perl #28532: optional zero-width match at end of string is ignored local $BugId = '28532'; ok "abc" =~ /^abc(\z)?/ && defined($1), 'Optional zero-width match at end of string'; ok "abc" =~ /^abc(\z)??/ && !defined($1), 'Optional zero-width match at end of string'; } { local $BugId = '36207'; my $utf8 = "\xe9\x{100}"; chop $utf8; my $latin1 = "\xe9"; ok $utf8 =~ /\xe9/i, "utf8/latin"; ok $utf8 =~ /$latin1/i, "utf8/latin runtime"; ok $utf8 =~ /(abc|\xe9)/i, "utf8/latin trie"; ok $utf8 =~ /(abc|$latin1)/i, "utf8/latin trie runtime"; ok "\xe9" =~ /$utf8/i, "latin/utf8"; ok "\xe9" =~ /(abc|$utf8)/i, "latin/utf8 trie"; ok $latin1 =~ /$utf8/i, "latin/utf8 runtime"; ok $latin1 =~ /(abc|$utf8)/i, "latin/utf8 trie runtime"; } { local $BugId = '37038'; my $s = "abcd"; $s =~ /(..)(..)/g; $s = $1; $s = $2; iseq $2, 'cd', "Assigning to original string does not corrupt match vars"; } { local $PatchId = '26410'; { package wooosh; sub gloople {"!"} } my $aeek = bless {} => 'wooosh'; eval_ok sub {$aeek -> gloople () =~ /(.)/g}, "//g match against return value of sub"; sub gloople {"!"} eval_ok sub {gloople () =~ /(.)/g}, "26410 didn't affect sub calls for some reason"; } { local $TODO = "See changes 26925-26928, which reverted change 26410"; { package lv; our $var = "abc"; sub variable : lvalue {$var} } my $o = bless [] => 'lv'; my $f = ""; my $r = eval { for (1 .. 2) { $f .= $1 if $o -> variable =~ /(.)/g; } 1; }; if ($r) { iseq $f, "ab", "pos() retained between calls"; } else { local $TODO; ok 0, "Code failed: $@"; } our $var = "abc"; sub variable : lvalue {$var} my $g = ""; my $s = eval { for (1 .. 2) { $g .= $1 if variable =~ /(.)/g; } 1; }; if ($s) { iseq $g, "ab", "pos() retained between calls"; } else { local $TODO; ok 0, "Code failed: $@"; } } SKIP: { local $BugId = '37836'; skip "In EBCDIC" if $IS_EBCDIC; no warnings 'utf8'; $_ = pack 'U0C2', 0xa2, 0xf8; # Ill-formed UTF-8 my $ret = 0; eval_ok sub {!($ret = s/[\0]+//g)}, "Ill-formed UTF-8 doesn't match NUL in class"; } { # chr(65535) should be allowed in regexes local $BugId = '38293'; no warnings 'utf8'; # To allow non-characters my ($c, $r, $s); $c = chr 0xffff; $c =~ s/$c//g; ok $c eq "", "U+FFFF, parsed as atom"; $c = chr 0xffff; $r = "\\$c"; $c =~ s/$r//g; ok $c eq "", "U+FFFF backslashed, parsed as atom"; $c = chr 0xffff; $c =~ s/[$c]//g; ok $c eq "", "U+FFFF, parsed in class"; $c = chr 0xffff; $r = "[\\$c]"; $c =~ s/$r//g; ok $c eq "", "U+FFFF backslashed, parsed in class"; $s = "A\x{ffff}B"; $s =~ s/\x{ffff}//i; ok $s eq "AB", "U+FFFF, EXACTF"; $s = "\x{ffff}A"; $s =~ s/\bA//; ok $s eq "\x{ffff}", "U+FFFF, BOUND"; $s = "\x{ffff}!"; $s =~ s/\B!//; ok $s eq "\x{ffff}", "U+FFFF, NBOUND"; } { local $BugId = '39583'; # The printing characters my @chars = ("A" .. "Z"); my $delim = ","; my $size = 32771 - 4; my $str = ''; # Create some random junk. Inefficient, but it works. for (my $i = 0; $i < $size; $ i++) { $str .= $chars [rand @chars]; } $str .= ($delim x 4); my $res; my $matched; ok $str =~ s/^(.*?)${delim}{4}//s, "Pattern matches"; iseq $str, "", "Empty string"; ok defined $1 && length ($1) == $size, '$1 is correct size'; } { local $BugId = '27940'; ok "\0-A" =~ /\c@-A/, '@- should not be interpolated in a pattern'; ok "\0\0A" =~ /\c@+A/, '@+ should not be interpolated in a pattern'; ok "X\@-A" =~ /X@-A/, '@- should not be interpolated in a pattern'; ok "X\@\@A" =~ /X@+A/, '@+ should not be interpolated in a pattern'; ok "X\0A" =~ /X\c@?A/, '\c@?'; ok "X\0A" =~ /X\c@*A/, '\c@*'; ok "X\0A" =~ /X\c@(A)/, '\c@('; ok "X\0A" =~ /X(\c@)A/, '\c@)'; ok "X\0A" =~ /X\c@|ZA/, '\c@|'; ok "X\@A" =~ /X@?A/, '@?'; ok "X\@A" =~ /X@*A/, '@*'; ok "X\@A" =~ /X@(A)/, '@('; ok "X\@A" =~ /X(@)A/, '@)'; ok "X\@A" =~ /X@|ZA/, '@|'; local $" = ','; # non-whitespace and non-RE-specific ok 'abc' =~ /(.)(.)(.)/, 'The last successful match is bogus'; ok "A@+B" =~ /A@{+}B/, 'Interpolation of @+ in /@{+}/'; ok "A@-B" =~ /A@{-}B/, 'Interpolation of @- in /@{-}/'; ok "A@+B" =~ /A@{+}B/x, 'Interpolation of @+ in /@{+}/x'; ok "A@-B" =~ /A@{-}B/x, 'Interpolation of @- in /@{-}/x'; } { local $BugId = '50496'; my $s = 'foo bar baz'; my (@k, @v, @fetch, $res); my $count = 0; my @names = qw ($+{A} $+{B} $+{C}); if ($s =~ /(?foo)\s+(?bar)?\s+(?baz)/) { while (my ($k, $v) = each (%+)) { $count++; } @k = sort keys (%+); @v = sort values (%+); $res = 1; push @fetch, ["$+{A}", "$1"], ["$+{B}", "$2"], ["$+{C}", "$3"], ; } foreach (0 .. 2) { if ($fetch [$_]) { iseq $fetch [$_] [0], $fetch [$_] [1], $names [$_]; } else { ok 0, $names[$_]; } } iseq $res, 1, "'$s' =~ /(?foo)\\s+(?bar)?\\s+(?baz)/"; iseq $count, 3, "Got 3 keys in %+ via each"; iseq 0 + @k, 3, 'Got 3 keys in %+ via keys'; iseq "@k", "A B C", "Got expected keys"; iseq "@v", "bar baz foo", "Got expected values"; eval ' no warnings "uninitialized"; print for $+ {this_key_doesnt_exist}; '; ok !$@, 'lvalue $+ {...} should not throw an exception'; } { # # Almost the same as the block above, except that the capture is nested. # local $BugId = '50496'; my $s = 'foo bar baz'; my (@k, @v, @fetch, $res); my $count = 0; my @names = qw ($+{A} $+{B} $+{C} $+{D}); if ($s =~ /(?(?foo)\s+(?bar)?\s+(?baz))/) { while (my ($k,$v) = each(%+)) { $count++; } @k = sort keys (%+); @v = sort values (%+); $res = 1; push @fetch, ["$+{A}", "$2"], ["$+{B}", "$3"], ["$+{C}", "$4"], ["$+{D}", "$1"], ; } foreach (0 .. 3) { if ($fetch [$_]) { iseq $fetch [$_] [0], $fetch [$_] [1], $names [$_]; } else { ok 0, $names [$_]; } } iseq $res, 1, "'$s' =~ /(?(?foo)\\s+(?bar)?\\s+(?baz))/"; iseq $count, 4, "Got 4 keys in %+ via each"; iseq @k, 4, 'Got 4 keys in %+ via keys'; iseq "@k", "A B C D", "Got expected keys"; iseq "@v", "bar baz foo foo bar baz", "Got expected values"; eval ' no warnings "uninitialized"; print for $+ {this_key_doesnt_exist}; '; ok !$@,'lvalue $+ {...} should not throw an exception'; } { local $BugId = '36046'; my $str = 'abc'; my $count = 0; my $mval = 0; my $pval = 0; while ($str =~ /b/g) {$mval = $#-; $pval = $#+; $count ++} iseq $mval, 0, '@- should be empty'; iseq $pval, 0, '@+ should be empty'; iseq $count, 1, 'Should have matched once only'; } { local $BugId = '40684'; local $Message = '/m in precompiled regexp'; my $s = "abc\ndef"; my $rex = qr'^abc$'m; ok $s =~ m/$rex/; ok $s =~ m/^abc$/m; } { local $BugId = '36909'; local $Message = '(?: ... )? should not lose $^R'; $^R = 'Nothing'; { local $^R = "Bad"; ok 'x foofoo y' =~ m { (foo) # $^R correctly set (?{ "last regexp code result" }) }x; iseq $^R, 'last regexp code result'; } iseq $^R, 'Nothing'; { local $^R = "Bad"; ok 'x foofoo y' =~ m { (?:foo|bar)+ # $^R correctly set (?{ "last regexp code result" }) }x; iseq $^R, 'last regexp code result'; } iseq $^R, 'Nothing'; { local $^R = "Bad"; ok 'x foofoo y' =~ m { (foo|bar)\1+ # $^R undefined (?{ "last regexp code result" }) }x; iseq $^R, 'last regexp code result'; } iseq $^R, 'Nothing'; { local $^R = "Bad"; ok 'x foofoo y' =~ m { (foo|bar)\1 # This time without the + (?{"last regexp code result"}) }x; iseq $^R, 'last regexp code result'; } iseq $^R, 'Nothing'; } { local $BugId = '22395'; local $Message = 'Match is linear, not quadratic'; our $count; for my $l (10, 100, 1000) { $count = 0; ('a' x $l) =~ /(.*)(?{$count++})[bc]/; local $TODO = "Should be L+1 not L*(L+3)/2 (L=$l)"; iseq $count, $l + 1; } } { local $BugId = '22614'; local $Message = '@-/@+ should not have undefined values'; local $_ = 'ab'; our @len = (); /(.){1,}(?{push @len,0+@-})(.){1,}(?{})^/; iseq "@len", "2 2 2"; } { local $BugId = '18209'; local $Message = '$& set on s///'; my $text = ' word1 word2 word3 word4 word5 word6 '; my @words = ('word1', 'word3', 'word5'); my $count; foreach my $word (@words) { $text =~ s/$word\s//gi; # Leave a space to seperate words # in the resultant str. # The following block is not working. if ($&) { $count ++; } # End bad block } iseq $count, 3; iseq $text, ' word2 word4 word6 '; } { # RT#6893 local $BugId = '6893'; local $_ = qq (A\nB\nC\n); my @res; while (m#(\G|\n)([^\n]*)\n#gsx) { push @res, "$2"; last if @res > 3; } iseq "@res", "A B C", "/g pattern shouldn't infinite loop"; } { local $BugId = '41010'; local $Message = 'No optimizer bug'; my @tails = ('', '(?(1))', '(|)', '()?'); my @quants = ('*','+'); my $doit = sub { my $pats = shift; for (@_) { for my $pat (@$pats) { for my $quant (@quants) { for my $tail (@tails) { my $re = "($pat$quant\$)$tail"; ok /$re/ && $1 eq $_, "'$_' =~ /$re/"; ok /$re/m && $1 eq $_, "'$_' =~ /$re/m"; } } } } }; my @dpats = ('\d', '[1234567890]', '(1|[23]|4|[56]|[78]|[90])', '(?:1|[23]|4|[56]|[78]|[90])', '(1|2|3|4|5|6|7|8|9|0)', '(?:1|2|3|4|5|6|7|8|9|0)'); my @spats = ('[ ]', ' ', '( |\t)', '(?: |\t)', '[ \t]', '\s'); my @sstrs = (' '); my @dstrs = ('12345'); $doit -> (\@spats, @sstrs); $doit -> (\@dpats, @dstrs); } { local $BugId = '45605'; # [perl #45605] Regexp failure with utf8-flagged and byte-flagged string my $utf_8 = "\xd6schel"; utf8::upgrade ($utf_8); $utf_8 =~ m {(\xd6|Ö)schel}; iseq $1, "\xd6", "Upgrade error"; } { # Regardless of utf8ness any character matches itself when # doing a case insensitive match. See also [perl #36207] local $BugId = '36207'; for my $o (0 .. 255) { my @ch = (chr ($o), chr ($o)); utf8::upgrade ($ch [1]); for my $u_str (0, 1) { for my $u_pat (0, 1) { ok $ch [$u_str] =~ /\Q$ch[$u_pat]\E/i, "\$c =~ /\$c/i : chr ($o) : u_str = $u_str u_pat = $u_pat"; ok $ch [$u_str] =~ /\Q$ch[$u_pat]\E|xyz/i, "\$c=~/\$c|xyz/i : chr($o) : u_str = $u_str u_pat = $u_pat"; } } } } { local $BugId = '49190'; local $Message = '$REGMARK in replacement'; our $REGMARK; my $_ = "A"; ok s/(*:B)A/$REGMARK/; iseq $_, "B"; $_ = "CCCCBAA"; ok s/(*:X)A+|(*:Y)B+|(*:Z)C+/$REGMARK/g; iseq $_, "ZYX"; } { local $BugId = '52658'; local $Message = 'Substitution evaluation in list context'; my $reg = '../xxx/'; my @te = ($reg =~ m{^(/?(?:\.\./)*)}, $reg =~ s/(x)/'b'/eg > 1 ? '##' : '++'); iseq $reg, '../bbb/'; iseq $te [0], '../'; } # This currently has to come before any "use encoding" in this file. { local $Message; local $BugId = '59342'; must_warn 'qr/\400/', '^Use of octal value above 377'; } { local $BugId = '60034'; my $a = "xyzt" x 8192; ok $a =~ /\A(?>[a-z])*\z/, '(?>) does not cause wrongness on long string'; my $b = $a . chr 256; chop $b; { iseq $a, $b; } ok $b =~ /\A(?>[a-z])*\z/, '(?>) does not cause wrongness on long string with UTF-8'; } # # Keep the following tests last -- they may crash perl # print "# Tests that follow may crash perl\n"; { local $BugId = '19049/38869'; local $Message = 'Pattern in a loop, failure should not ' . 'affect previous success'; my @list = ( 'ab cdef', # Matches regex ('e' x 40000 ) .'ab c' # Matches not, but 'ab c' matches part of it ); my $y; my $x; foreach (@list) { m/ab(.+)cd/i; # The ignore-case seems to be important $y = $1; # Use $1, which might not be from the last match! $x = substr ($list [0], $- [0], $+ [0] - $- [0]); } iseq $y, ' '; iseq $x, 'ab cd'; } { local $BugId = '24274'; ok (("a" x (2 ** 15 - 10)) =~ /^()(a|bb)*$/, "Recursive stack cracker"); ok ((q(a)x 100) =~ /^(??{'(.)'x 100})/, "Regexp /^(??{'(.)'x 100})/ crashes older perls"); } { # [perl #45337] utf8 + "[a]a{2}" + /$.../ = panic: sv_len_utf8 cache local $BugId = '45337'; local ${^UTF8CACHE} = -1; local $Message = "Shouldn't panic"; my $s = "[a]a{2}"; utf8::upgrade $s; ok "aaa" =~ /$s/; } { local $BugId = '57042'; local $Message = "Check if tree logic breaks \$^R"; my $cond_re = qr/\s* \s* (?: \( \s* A (?{1}) | \( \s* B (?{2}) ) /x; my @res; for my $line ("(A)","(B)") { if ($line =~ m/$cond_re/) { push @res, $^R ? "#$^R" : "UNDEF"; } } iseq "@res","#1 #2"; } { no warnings 'closure'; my $re = qr/A(??{"1"})/; ok "A1B" =~ m/^((??{ $re }))((??{"B"}))$/; ok $1 eq "A1"; ok $2 eq "B"; } # This only works under -DEBUGGING because it relies on an assert(). { local $BugId = '60508'; local $Message = "Check capture offset re-entrancy of utf8 code."; sub fswash { $_[0] =~ s/([>X])//g; } my $k1 = "." x 4 . ">>"; fswash($k1); my $k2 = "\x{f1}\x{2022}"; $k2 =~ s/([\360-\362])/>/g; fswash($k2); iseq($k2, "\x{2022}", "utf8::SWASHNEW doesn't cause capture leaks"); } { local $BugId = 65372; # minimal CURLYM limited to 32767 matches my @pat = ( qr{a(x|y)*b}, # CURLYM qr{a(x|y)*?b}, # .. with minmod qr{a([wx]|[yz])*b}, # .. and without tries qr{a([wx]|[yz])*?b}, ); my $len = 32768; my $s = join '', 'a', 'x' x $len, 'b'; for my $pat (@pat) { ok($s =~ $pat, $pat); } } { local $TODO = "[perl #38133]"; "A" =~ /(((?:A))?)+/; my $first = $2; "A" =~ /(((A))?)+/; my $second = $2; iseq($first, $second); } } # End of sub run_tests 1; perl-5.12.0-RC0/t/re/reg_email.t0000555000175000017500000000644211325127002015111 0ustar jessejesse#!./perl # # Tests to make sure the regexp engine doesn't run into limits too soon. # BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } print "1..13\n"; my $email = qr { (?(DEFINE) (?
(?&mailbox) | (?&group)) (? (?&name_addr) | (?&addr_spec)) (? (?&display_name)? (?&angle_addr)) (? (?&CFWS)? < (?&addr_spec) > (?&CFWS)?) (? (?&display_name) : (?:(?&mailbox_list) | (?&CFWS))? ; (?&CFWS)?) (? (?&phrase)) (? (?&mailbox) (?: , (?&mailbox))*) (? (?&local_part) \@ (?&domain)) (? (?&dot_atom) | (?"ed_string)) (? (?&dot_atom) | (?&domain_literal)) (? (?&CFWS)? \[ (?: (?&FWS)? (?&dcontent))* (?&FWS)? \] (?&CFWS)?) (? (?&dtext) | (?"ed_pair)) (? (?&NO_WS_CTL) | [\x21-\x5a\x5e-\x7e]) (? (?&ALPHA) | (?&DIGIT) | [!#\$%&'*+-/=?^_`{|}~]) (? (?&CFWS)? (?&atext)+ (?&CFWS)?) (? (?&CFWS)? (?&dot_atom_text) (?&CFWS)?) (? (?&atext)+ (?: \. (?&atext)+)*) (? [\x01-\x09\x0b\x0c\x0e-\x7f]) (? \\ (?&text)) (? (?&NO_WS_CTL) | [\x21\x23-\x5b\x5d-\x7e]) (? (?&qtext) | (?"ed_pair)) (? (?&CFWS)? (?&DQUOTE) (?:(?&FWS)? (?&qcontent))* (?&FWS)? (?&DQUOTE) (?&CFWS)?) (? (?&atom) | (?"ed_string)) (? (?&word)+) # Folding white space (? (?: (?&WSP)* (?&CRLF))? (?&WSP)+) (? (?&NO_WS_CTL) | [\x21-\x27\x2a-\x5b\x5d-\x7e]) (? (?&ctext) | (?"ed_pair) | (?&comment)) (? \( (?: (?&FWS)? (?&ccontent))* (?&FWS)? \) ) (? (?: (?&FWS)? (?&comment))* (?: (?:(?&FWS)? (?&comment)) | (?&FWS))) # No whitespace control (? [\x01-\x08\x0b\x0c\x0e-\x1f\x7f]) (? [A-Za-z]) (? [0-9]) (? \x0d \x0a) (? ") (? [\x20\x09]) ) (?&address) }x; run_tests() unless caller; sub run_tests { my $count = 0; $| = 1; # rewinding DATA is necessary with PERLIO=stdio when this # test is run from another thread seek *DATA, 0, 0; while () { last if /^__DATA__/ } while () { chomp; next if /^#/; print /^$email$/ ? "ok " : "not ok ", ++ $count, "\n"; } } # # Acme::MetaSyntactic ++ # __DATA__ Jeff_Tracy@thunderbirds.org "Lady Penelope"@thunderbirds.org "The\ Hood"@thunderbirds.org fred @ flintstones.net barney (rubble) @ flintstones.org bammbamm (bam! bam! (bam! bam! (bam!)) bam!) @ flintstones.org Michelangelo@[127.0.0.1] Donatello @ [127.0.0.1] Raphael (He as well) @ [127.0.0.1] "Leonardo" @ [127.0.0.1] Barbapapa "Barba Mama" Barbalala (lalalalalalalala) perl-5.12.0-RC0/t/re/regexp_qr_embed_thr.t0000555000175000017500000000032511325127002017164 0ustar jessejesse#!./perl $qr = 1; $qr_embed_thr = 1; for $file ('./re/regexp.t', './t/re/regexp.t', ':re:regexp.t') { if (-r $file) { do $file or die $@; exit; } } die "Cannot find ./re/regexp.t or ./t/re/regexp.t\n"; perl-5.12.0-RC0/t/re/re.t0000555000175000017500000000314011325127002013563 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } use strict; use warnings; use re qw(is_regexp regexp_pattern regname regnames regnames_count); { my $qr=qr/foo/pi; my $rx = $$qr; ok(is_regexp($qr),'is_regexp(REGEXP ref)'); ok(is_regexp($rx),'is_regexp(REGEXP)'); ok(!is_regexp(''),'is_regexp("")'); is((regexp_pattern($qr))[0],'foo','regexp_pattern[0] (ref)'); is((regexp_pattern($qr))[1],'ip','regexp_pattern[1] (ref)'); is(regexp_pattern($qr),'(?pi-xsm:foo)','scalar regexp_pattern (ref)'); is((regexp_pattern($rx))[0],'foo','regexp_pattern[0] (bare REGEXP)'); is((regexp_pattern($rx))[1],'ip','regexp_pattern[1] (bare REGEXP)'); is(regexp_pattern($rx),'(?pi-xsm:foo)', 'scalar regexp_pattern (bare REGEXP)'); ok(!regexp_pattern(''),'!regexp_pattern("")'); } if ('1234'=~/(?:(?\d)|(?!))(?\d)(?\d)(?\d)/){ my @names = sort +regnames(); is("@names","A B","regnames"); @names = sort +regnames(0); is("@names","A B","regnames"); my $names = regnames(); is($names, "B", "regnames in scalar context"); @names = sort +regnames(1); is("@names","A B C","regnames"); is(join("", @{regname("A",1)}),"13"); is(join("", @{regname("B",1)}),"24"); { if ('foobar'=~/(?foo)(?bar)/) { is(regnames_count(),2); } else { ok(0); ok(0); } } is(regnames_count(),3); } # New tests above this line, don't forget to update the test count below! BEGIN { plan tests => 18 } # No tests here! perl-5.12.0-RC0/t/re/qrstack.t0000555000175000017500000000027711325127002014635 0ustar jessejesse#!./perl -w BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } plan tests => 1; ok(defined [(1)x127,qr//,1]->[127], "qr// should extend the stack properly"); perl-5.12.0-RC0/t/re/regexp_noamp.t0000555000175000017500000000031211325127002015637 0ustar jessejesse#!./perl $skip_amp = 1; for $file ('./re/regexp.t', './t/re/regexp.t', ':re:regexp.t') { if (-r $file) { do $file or die $@; exit; } } die "Cannot find ./re/regexp.t or ./t/re/regexp.t\n"; perl-5.12.0-RC0/t/re/substr_thr.t0000555000175000017500000000015411325127002015356 0ustar jessejesse#!./perl chdir 't' if -d 't'; @INC = ('../lib', '.'); require 'thread_it.pl'; thread_it(qw(re substr.t)); perl-5.12.0-RC0/t/re/subst.t0000555000175000017500000003242611326750237014343 0ustar jessejesse#!./perl -w BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require Config; import Config; } require './test.pl'; plan( tests => 143 ); $x = 'foo'; $_ = "x"; s/x/\$x/; ok( $_ eq '$x', ":$_: eq :\$x:" ); $_ = "x"; s/x/$x/; ok( $_ eq 'foo', ":$_: eq :foo:" ); $_ = "x"; s/x/\$x $x/; ok( $_ eq '$x foo', ":$_: eq :\$x foo:" ); $b = 'cd'; ($a = 'abcdef') =~ s<(b${b}e)>'\n$1'; ok( $1 eq 'bcde' && $a eq 'a\n$1f', ":$1: eq :bcde: ; :$a: eq :a\\n\$1f:" ); $a = 'abacada'; ok( ($a =~ s/a/x/g) == 4 && $a eq 'xbxcxdx' ); ok( ($a =~ s/a/y/g) == 0 && $a eq 'xbxcxdx' ); ok( ($a =~ s/b/y/g) == 1 && $a eq 'xyxcxdx' ); $_ = 'ABACADA'; ok( /a/i && s///gi && $_ eq 'BCD' ); $_ = '\\' x 4; ok( length($_) == 4 ); $snum = s/\\/\\\\/g; ok( $_ eq '\\' x 8 && $snum == 4 ); $_ = '\/' x 4; ok( length($_) == 8 ); $snum = s/\//\/\//g; ok( $_ eq '\\//' x 4 && $snum == 4 ); ok( length($_) == 12 ); $_ = 'aaaXXXXbbb'; s/^a//; ok( $_ eq 'aaXXXXbbb' ); $_ = 'aaaXXXXbbb'; s/a//; ok( $_ eq 'aaXXXXbbb' ); $_ = 'aaaXXXXbbb'; s/^a/b/; ok( $_ eq 'baaXXXXbbb' ); $_ = 'aaaXXXXbbb'; s/a/b/; ok( $_ eq 'baaXXXXbbb' ); $_ = 'aaaXXXXbbb'; s/aa//; ok( $_ eq 'aXXXXbbb' ); $_ = 'aaaXXXXbbb'; s/aa/b/; ok( $_ eq 'baXXXXbbb' ); $_ = 'aaaXXXXbbb'; s/b$//; ok( $_ eq 'aaaXXXXbb' ); $_ = 'aaaXXXXbbb'; s/b//; ok( $_ eq 'aaaXXXXbb' ); $_ = 'aaaXXXXbbb'; s/bb//; ok( $_ eq 'aaaXXXXb' ); $_ = 'aaaXXXXbbb'; s/aX/y/; ok( $_ eq 'aayXXXbbb' ); $_ = 'aaaXXXXbbb'; s/Xb/z/; ok( $_ eq 'aaaXXXzbb' ); $_ = 'aaaXXXXbbb'; s/aaX.*Xbb//; ok( $_ eq 'ab' ); $_ = 'aaaXXXXbbb'; s/bb/x/; ok( $_ eq 'aaaXXXXxb' ); # now for some unoptimized versions of the same. $_ = 'aaaXXXXbbb'; $x ne $x || s/^a//; ok( $_ eq 'aaXXXXbbb' ); $_ = 'aaaXXXXbbb'; $x ne $x || s/a//; ok( $_ eq 'aaXXXXbbb' ); $_ = 'aaaXXXXbbb'; $x ne $x || s/^a/b/; ok( $_ eq 'baaXXXXbbb' ); $_ = 'aaaXXXXbbb'; $x ne $x || s/a/b/; ok( $_ eq 'baaXXXXbbb' ); $_ = 'aaaXXXXbbb'; $x ne $x || s/aa//; ok( $_ eq 'aXXXXbbb' ); $_ = 'aaaXXXXbbb'; $x ne $x || s/aa/b/; ok( $_ eq 'baXXXXbbb' ); $_ = 'aaaXXXXbbb'; $x ne $x || s/b$//; ok( $_ eq 'aaaXXXXbb' ); $_ = 'aaaXXXXbbb'; $x ne $x || s/b//; ok( $_ eq 'aaaXXXXbb' ); $_ = 'aaaXXXXbbb'; $x ne $x || s/bb//; ok( $_ eq 'aaaXXXXb' ); $_ = 'aaaXXXXbbb'; $x ne $x || s/aX/y/; ok( $_ eq 'aayXXXbbb' ); $_ = 'aaaXXXXbbb'; $x ne $x || s/Xb/z/; ok( $_ eq 'aaaXXXzbb' ); $_ = 'aaaXXXXbbb'; $x ne $x || s/aaX.*Xbb//; ok( $_ eq 'ab' ); $_ = 'aaaXXXXbbb'; $x ne $x || s/bb/x/; ok( $_ eq 'aaaXXXXxb' ); $_ = 'abc123xyz'; s/(\d+)/$1*2/e; # yields 'abc246xyz' ok( $_ eq 'abc246xyz' ); s/(\d+)/sprintf("%5d",$1)/e; # yields 'abc 246xyz' ok( $_ eq 'abc 246xyz' ); s/(\w)/$1 x 2/eg; # yields 'aabbcc 224466xxyyzz' ok( $_ eq 'aabbcc 224466xxyyzz' ); $_ = "aaaaa"; ok( y/a/b/ == 5 ); ok( y/a/b/ == 0 ); ok( y/b// == 5 ); ok( y/b/c/s == 5 ); ok( y/c// == 1 ); ok( y/c//d == 1 ); ok( $_ eq "" ); $_ = "Now is the %#*! time for all good men..."; ok( ($x=(y/a-zA-Z //cd)) == 7 ); ok( y/ / /s == 8 ); $_ = 'abcdefghijklmnopqrstuvwxyz0123456789'; tr/a-z/A-Z/; ok( $_ eq 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789' ); # same as tr/A-Z/a-z/; if (defined $Config{ebcdic} && $Config{ebcdic} eq 'define') { # EBCDIC. no utf8; y[\301-\351][\201-\251]; } else { # Ye Olde ASCII. Or something like it. y[\101-\132][\141-\172]; } ok( $_ eq 'abcdefghijklmnopqrstuvwxyz0123456789' ); SKIP: { skip("not ASCII",1) unless (ord("+") == ord(",") - 1 && ord(",") == ord("-") - 1 && ord("a") == ord("b") - 1 && ord("b") == ord("c") - 1); $_ = '+,-'; tr/+--/a-c/; ok( $_ eq 'abc' ); } $_ = '+,-'; tr/+\--/a\/c/; ok( $_ eq 'a,/' ); $_ = '+,-'; tr/-+,/ab\-/; ok( $_ eq 'b-a' ); # test recursive substitutions # code based on the recursive expansion of makefile variables my %MK = ( AAAAA => '$(B)', B=>'$(C)', C => 'D', # long->short E => '$(F)', F=>'p $(G) q', G => 'HHHHH', # short->long DIR => '$(UNDEFINEDNAME)/xxx', ); sub var { my($var,$level) = @_; return "\$($var)" unless exists $MK{$var}; return exp_vars($MK{$var}, $level+1); # can recurse } sub exp_vars { my($str,$level) = @_; $str =~ s/\$\((\w+)\)/var($1, $level+1)/ge; # can recurse #warn "exp_vars $level = '$str'\n"; $str; } ok( exp_vars('$(AAAAA)',0) eq 'D' ); ok( exp_vars('$(E)',0) eq 'p HHHHH q' ); ok( exp_vars('$(DIR)',0) eq '$(UNDEFINEDNAME)/xxx' ); ok( exp_vars('foo $(DIR)/yyy bar',0) eq 'foo $(UNDEFINEDNAME)/xxx/yyy bar' ); $_ = "abcd"; s/(..)/$x = $1, m#.#/eg; ok( $x eq "cd", 'a match nested in the RHS of a substitution' ); # Subst and lookbehind $_="ccccc"; $snum = s/(?/g; $foo = '<>' . ('<>' x 20) ; ok( $_ eq $foo && $snum == 41 ); $t = 'aaaaaaaaa'; $_ = $t; pos = 6; $snum = s/\Ga/xx/g; ok( $_ eq 'aaaaaaxxxxxx' && $snum == 3 ); $_ = $t; pos = 6; $snum = s/\Ga/x/g; ok( $_ eq 'aaaaaaxxx' && $snum == 3 ); $_ = $t; pos = 6; s/\Ga/xx/; ok( $_ eq 'aaaaaaxxaa' ); $_ = $t; pos = 6; s/\Ga/x/; ok( $_ eq 'aaaaaaxaa' ); $_ = $t; $snum = s/\Ga/xx/g; ok( $_ eq 'xxxxxxxxxxxxxxxxxx' && $snum == 9 ); $_ = $t; $snum = s/\Ga/x/g; ok( $_ eq 'xxxxxxxxx' && $snum == 9 ); $_ = $t; s/\Ga/xx/; ok( $_ eq 'xxaaaaaaaa' ); $_ = $t; s/\Ga/x/; ok( $_ eq 'xaaaaaaaa' ); $_ = 'aaaa'; $snum = s/\ba/./g; ok( $_ eq '.aaa' && $snum == 1 ); eval q% s/a/"b"}/e %; ok( $@ =~ /Bad evalled substitution/ ); eval q% ($_ = "x") =~ s/(.)/"$1 "/e %; ok( $_ eq "x " and !length $@ ); $x = $x = 'interp'; eval q% ($_ = "x") =~ s/x(($x)*)/"$1"/e %; ok( $_ eq '' and !length $@ ); $_ = "C:/"; ok( !s/^([a-z]:)/\u$1/ ); $_ = "Charles Bronson"; $snum = s/\B\w//g; ok( $_ eq "C B" && $snum == 12 ); { use utf8; my $s = "H\303\266he"; my $l = my $r = $s; $l =~ s/[^\w]//g; $r =~ s/[^\w\.]//g; is($l, $r, "use utf8 \\w"); } my $pv1 = my $pv2 = "Andreas J. K\303\266nig"; $pv1 =~ s/A/\x{100}/; substr($pv2,0,1) = "\x{100}"; is($pv1, $pv2); SKIP: { skip("EBCDIC", 3) if ord("A") == 193; { # Gregor Chrupala use utf8; $a = 'España'; $a =~ s/ñ/ñ/; like($a, qr/ñ/, "use utf8 RHS"); } { use utf8; $a = 'España España'; $a =~ s/ñ/ñ/; like($a, qr/ñ/, "use utf8 LHS"); } { use utf8; $a = 'España'; $a =~ s/ñ/ñ/; like($a, qr/ñ/, "use utf8 LHS and RHS"); } } { # SADAHIRO Tomoyuki $a = "\x{100}\x{101}"; $a =~ s/\x{101}/\xFF/; like($a, qr/\xFF/); is(length($a), 2, "SADAHIRO utf8 s///"); $a = "\x{100}\x{101}"; $a =~ s/\x{101}/"\xFF"/e; like($a, qr/\xFF/); is(length($a), 2); $a = "\x{100}\x{101}"; $a =~ s/\x{101}/\xFF\xFF\xFF/; like($a, qr/\xFF\xFF\xFF/); is(length($a), 4); $a = "\x{100}\x{101}"; $a =~ s/\x{101}/"\xFF\xFF\xFF"/e; like($a, qr/\xFF\xFF\xFF/); is(length($a), 4); $a = "\xFF\x{101}"; $a =~ s/\xFF/\x{100}/; like($a, qr/\x{100}/); is(length($a), 2); $a = "\xFF\x{101}"; $a =~ s/\xFF/"\x{100}"/e; like($a, qr/\x{100}/); is(length($a), 2); $a = "\xFF"; $a =~ s/\xFF/\x{100}/; like($a, qr/\x{100}/); is(length($a), 1); $a = "\xFF"; $a =~ s/\xFF/"\x{100}"/e; like($a, qr/\x{100}/); is(length($a), 1); } { # subst with mixed utf8/non-utf8 type my($ua, $ub, $uc, $ud) = ("\x{101}", "\x{102}", "\x{103}", "\x{104}"); my($na, $nb) = ("\x{ff}", "\x{fe}"); my $a = "$ua--$ub"; my $b; ($b = $a) =~ s/--/$na/; is($b, "$ua$na$ub", "s///: replace non-utf8 into utf8"); ($b = $a) =~ s/--/--$na--/; is($b, "$ua--$na--$ub", "s///: replace long non-utf8 into utf8"); ($b = $a) =~ s/--/$uc/; is($b, "$ua$uc$ub", "s///: replace utf8 into utf8"); ($b = $a) =~ s/--/--$uc--/; is($b, "$ua--$uc--$ub", "s///: replace long utf8 into utf8"); $a = "$na--$nb"; ($b = $a) =~ s/--/$ua/; is($b, "$na$ua$nb", "s///: replace utf8 into non-utf8"); ($b = $a) =~ s/--/--$ua--/; is($b, "$na--$ua--$nb", "s///: replace long utf8 into non-utf8"); # now with utf8 pattern $a = "$ua--$ub"; ($b = $a) =~ s/-($ud)?-/$na/; is($b, "$ua$na$ub", "s///: replace non-utf8 into utf8 (utf8 pattern)"); ($b = $a) =~ s/-($ud)?-/--$na--/; is($b, "$ua--$na--$ub", "s///: replace long non-utf8 into utf8 (utf8 pattern)"); ($b = $a) =~ s/-($ud)?-/$uc/; is($b, "$ua$uc$ub", "s///: replace utf8 into utf8 (utf8 pattern)"); ($b = $a) =~ s/-($ud)?-/--$uc--/; is($b, "$ua--$uc--$ub", "s///: replace long utf8 into utf8 (utf8 pattern)"); $a = "$na--$nb"; ($b = $a) =~ s/-($ud)?-/$ua/; is($b, "$na$ua$nb", "s///: replace utf8 into non-utf8 (utf8 pattern)"); ($b = $a) =~ s/-($ud)?-/--$ua--/; is($b, "$na--$ua--$nb", "s///: replace long utf8 into non-utf8 (utf8 pattern)"); ($b = $a) =~ s/-($ud)?-/$na/; is($b, "$na$na$nb", "s///: replace non-utf8 into non-utf8 (utf8 pattern)"); ($b = $a) =~ s/-($ud)?-/--$na--/; is($b, "$na--$na--$nb", "s///: replace long non-utf8 into non-utf8 (utf8 pattern)"); } $_ = 'aaaa'; $r = 'x'; $s = s/a(?{})/$r/g; is("<$_> <$s>", " <4>", "[perl #7806]"); $_ = 'aaaa'; $s = s/a(?{})//g; is("<$_> <$s>", "<> <4>", "[perl #7806]"); # [perl #19048] Coredump in silly replacement { local $^W = 0; $_="abcdef\n"; s!.!!eg; is($_, "\n", "[perl #19048]"); } # [perl #17757] interaction between saw_ampersand and study { my $f = eval q{ $& }; $f = "xx"; study $f; $f =~ s/x/y/g; is($f, "yy", "[perl #17757]"); } # [perl #20684] returned a zero count $_ = "1111"; is(s/(??{1})/2/eg, 4, '#20684 s/// with (??{..}) inside'); # [perl #20682] @- not visible in replacement $_ = "123"; /(2)/; # seed @- with something else s/(1)(2)(3)/$#- (@-)/; is($_, "3 (0 0 1 2)", '#20682 @- not visible in replacement'); # [perl #20682] $^N not visible in replacement $_ = "abc"; /(a)/; s/(b)|(c)/-$^N/g; is($_,'a-b-c','#20682 $^N not visible in replacement'); # [perl #22351] perl bug with 'e' substitution modifier my $name = "chris"; { no warnings 'uninitialized'; $name =~ s/hr//e; } is($name, "cis", q[#22351 bug with 'e' substitution modifier]); # [perl #34171] $1 didn't honour 'use bytes' in s//e { my $s="\x{100}"; my $x; { use bytes; $s=~ s/(..)/$x=$1/e } is(length($x), 2, '[perl #34171]'); } { # [perl #27940] perlbug: [\x00-\x1f] works, [\c@-\c_] does not my $c; ($c = "\x20\c@\x30\cA\x40\cZ\x50\c_\x60") =~ s/[\c@-\c_]//g; is($c, "\x20\x30\x40\x50\x60", "s/[\\c\@-\\c_]//g"); ($c = "\x20\x00\x30\x01\x40\x1A\x50\x1F\x60") =~ s/[\x00-\x1f]//g; is($c, "\x20\x30\x40\x50\x60", "s/[\\x00-\\x1f]//g"); } { $_ = "xy"; no warnings 'uninitialized'; /(((((((((x)))))))))(z)/; # clear $10 s/(((((((((x)))))))))(y)/${10}/; is($_,"y","RT#6006: \$_ eq '$_'"); $_ = "xr"; s/(((((((((x)))))))))(r)/fooba${10}/; is($_,"foobar","RT#6006: \$_ eq '$_'"); } { my $want=("\n" x 11).("B\n" x 11)."B"; $_="B"; our $i; for $i(1..11){ s/^.*$/$&/gm; $_="\n$_\n$&"; } is($want,$_,"RT#17542"); } { my @tests = ('ABC', "\xA3\xA4\xA5", "\x{410}\x{411}\x{412}"); foreach (@tests) { my $id = ord $_; s/./pos/ge; is($_, "012", "RT#52104: $id"); } } fresh_perl_is( '$_=q(foo);s/(.)\G//g;print' => 'foo', '[perl #69056] positive GPOS regex segfault' ); fresh_perl_is( '$_="abcef"; s/bc|(.)\G(.)/$1 ? "[$1-$2]" : "XX"/ge; print' => 'aXX[c-e][e-f]f', 'positive GPOS regex substitution failure' ); # [perl #~~~~~] $var =~ s/$qr//e calling get-magic on $_ as well as $var { local *_; my $scratch; sub qrBug::TIESCALAR { bless[pop], 'qrBug' } sub qrBug::FETCH { $scratch .= "[fetching $_[0][0]]"; 'prew' } sub qrBug::STORE{} tie my $kror, qrBug => '$kror'; tie $_, qrBug => '$_'; my $qr = qr/(?:)/; $kror =~ s/$qr/""/e; is( $scratch, '[fetching $kror]', 'bug: $var =~ s/$qr//e calling get-magic on $_ as well as $var', ); } perl-5.12.0-RC0/t/re/substT.t0000555000175000017500000000025211325127002014442 0ustar jessejesse#!perl -wT for $file ('re/subst.t', 't/re/subst.t', ':re:subst.t') { if (-r $file) { do "./$file"; exit; } } die "Cannot find re/subst.t or t/re/subst.t\n"; perl-5.12.0-RC0/t/re/pat_advanced.t0000555000175000017500000016534211340037012015601 0ustar jessejesse#!./perl # # This is a home for regular expression tests that don't fit into # the format supported by re/regexp.t. If you want to add a test # that does fit that format, add it to re/re_tests, not here. use strict; use warnings; use 5.010; sub run_tests; $| = 1; BEGIN { chdir 't' if -d 't'; @INC = ('../lib','.'); do "re/ReTest.pl" or die $@; } plan tests => 1159; # Update this when adding/deleting tests. run_tests() unless caller; # # Tests start here. # sub run_tests { SKIP: { local $Message = '\C matches octet'; $_ = "a\x{100}b"; ok /(.)(\C)(\C)(.)/ or skip q [\C doesn't match], 4; iseq $1, "a"; if ($IS_ASCII) { # ASCII (or equivalent), should be UTF-8 iseq $2, "\xC4"; iseq $3, "\x80"; } elsif ($IS_EBCDIC) { # EBCDIC (or equivalent), should be UTF-EBCDIC iseq $2, "\x8C"; iseq $3, "\x41"; } else { SKIP: { ok 0, "Unexpected platform", "ord ('A') = $ordA"; skip "Unexpected platform"; } } iseq $4, "b"; } SKIP: { local $Message = '\C matches octet'; $_ = "\x{100}"; ok /(\C)/g or skip q [\C doesn't match], 2; if ($IS_ASCII) { iseq $1, "\xC4"; } elsif ($IS_EBCDIC) { iseq $1, "\x8C"; } else { ok 0, "Unexpected platform", "ord ('A') = $ordA"; } ok /(\C)/g or skip q [\C doesn't match]; if ($IS_ASCII) { iseq $1, "\x80"; } elsif ($IS_EBCDIC) { iseq $1, "\x41"; } else { ok 0, "Unexpected platform", "ord ('A') = $ordA"; } } { # Japhy -- added 03/03/2001 () = (my $str = "abc") =~ /(...)/; $str = "def"; iseq $1, "abc", 'Changing subject does not modify $1'; } SKIP: { # The trick is that in EBCDIC the explicit numeric range should # match (as also in non-EBCDIC) but the explicit alphabetic range # should not match. ok "\x8e" =~ /[\x89-\x91]/, '"\x8e" =~ /[\x89-\x91]/'; ok "\xce" =~ /[\xc9-\xd1]/, '"\xce" =~ /[\xc9-\xd1]/'; skip "Not an EBCDIC platform", 2 unless ord ('i') == 0x89 && ord ('J') == 0xd1; # In most places these tests would succeed since \x8e does not # in most character sets match 'i' or 'j' nor would \xce match # 'I' or 'J', but strictly speaking these tests are here for # the good of EBCDIC, so let's test these only there. nok "\x8e" !~ /[i-j]/, '"\x8e" !~ /[i-j]/'; nok "\xce" !~ /[I-J]/, '"\xce" !~ /[I-J]/'; } { ok "\x{ab}" =~ /\x{ab}/, '"\x{ab}" =~ /\x{ab}/ '; ok "\x{abcd}" =~ /\x{abcd}/, '"\x{abcd}" =~ /\x{abcd}/'; } { local $Message = 'bug id 20001008.001'; my @x = ("stra\337e 138", "stra\337e 138"); for (@x) { ok s/(\d+)\s*([\w\-]+)/$1 . uc $2/e; ok my ($latin) = /^(.+)(?:\s+\d)/; iseq $latin, "stra\337e"; ok $latin =~ s/stra\337e/straße/; # # Previous code follows, but outcommented - there were no tests. # # $latin =~ s/stra\337e/straße/; # \303\237 after the 2nd a # use utf8; # needed for the raw UTF-8 # $latin =~ s!(s)tr(?:aß|s+e)!$1tr.!; # \303\237 after the a } } { local $Message = 'Test \x escapes'; ok "ba\xd4c" =~ /([a\xd4]+)/ && $1 eq "a\xd4"; ok "ba\xd4c" =~ /([a\xd4]+)/ && $1 eq "a\x{d4}"; ok "ba\x{d4}c" =~ /([a\xd4]+)/ && $1 eq "a\x{d4}"; ok "ba\x{d4}c" =~ /([a\xd4]+)/ && $1 eq "a\xd4"; ok "ba\xd4c" =~ /([a\x{d4}]+)/ && $1 eq "a\xd4"; ok "ba\xd4c" =~ /([a\x{d4}]+)/ && $1 eq "a\x{d4}"; ok "ba\x{d4}c" =~ /([a\x{d4}]+)/ && $1 eq "a\x{d4}"; ok "ba\x{d4}c" =~ /([a\x{d4}]+)/ && $1 eq "a\xd4"; } SKIP: { local $Message = 'Match code points > 255'; $_ = "abc\x{100}\x{200}\x{300}\x{380}\x{400}defg"; ok /(.\x{300})./ or skip "No match", 4; ok $` eq "abc\x{100}" && length ($`) == 4; ok $& eq "\x{200}\x{300}\x{380}" && length ($&) == 3; ok $' eq "\x{400}defg" && length ($') == 5; ok $1 eq "\x{200}\x{300}" && length ($1) == 2; } { my $x = "\x{10FFFD}"; $x =~ s/(.)/$1/g; ok ord($x) == 0x10FFFD && length($x) == 1, "From Robin Houston"; } { my %d = ( "7f" => [0, 0, 0], "80" => [1, 1, 0], "ff" => [1, 1, 0], "100" => [0, 1, 1], ); SKIP: while (my ($code, $match) = each %d) { local $Message = "Properties of \\x$code"; my $char = eval qq ["\\x{$code}"]; my $i = 0; ok (($char =~ /[\x80-\xff]/) xor !$$match [$i ++]); ok (($char =~ /[\x80-\x{100}]/) xor !$$match [$i ++]); ok (($char =~ /[\x{100}]/) xor !$$match [$i ++]); } } { # From Japhy local $Message; must_warn 'qr/(?c)/', '^Useless \(\?c\)'; must_warn 'qr/(?-c)/', '^Useless \(\?-c\)'; must_warn 'qr/(?g)/', '^Useless \(\?g\)'; must_warn 'qr/(?-g)/', '^Useless \(\?-g\)'; must_warn 'qr/(?o)/', '^Useless \(\?o\)'; must_warn 'qr/(?-o)/', '^Useless \(\?-o\)'; # Now test multi-error regexes must_warn 'qr/(?g-o)/', '^Useless \(\?g\).*\nUseless \(\?-o\)'; must_warn 'qr/(?g-c)/', '^Useless \(\?g\).*\nUseless \(\?-c\)'; # (?c) means (?g) error won't be thrown must_warn 'qr/(?o-cg)/', '^Useless \(\?o\).*\nUseless \(\?-c\)'; must_warn 'qr/(?ogc)/', '^Useless \(\?o\).*\nUseless \(\?g\).*\n' . 'Useless \(\?c\)'; } { local $Message = "/x tests"; $_ = "foo"; eval_ok <<" --"; /f o\r o \$ /x -- eval_ok <<" --"; /f o o \$\r /x -- } { local $Message = "/o feature"; sub test_o {$_ [0] =~ /$_[1]/o; return $1} iseq test_o ('abc', '(.)..'), 'a'; iseq test_o ('abc', '..(.)'), 'a'; } { # Test basic $^N usage outside of a regex local $Message = '$^N usage outside of a regex'; my $x = "abcdef"; ok ($x =~ /cde/ and !defined $^N); ok ($x =~ /(cde)/ and $^N eq "cde"); ok ($x =~ /(c)(d)(e)/ and $^N eq "e"); ok ($x =~ /(c(d)e)/ and $^N eq "cde"); ok ($x =~ /(foo)|(c(d)e)/ and $^N eq "cde"); ok ($x =~ /(c(d)e)|(foo)/ and $^N eq "cde"); ok ($x =~ /(c(d)e)|(abc)/ and $^N eq "abc"); ok ($x =~ /(c(d)e)|(abc)x/ and $^N eq "cde"); ok ($x =~ /(c(d)e)(abc)?/ and $^N eq "cde"); ok ($x =~ /(?:c(d)e)/ and $^N eq "d"); ok ($x =~ /(?:c(d)e)(?:f)/ and $^N eq "d"); ok ($x =~ /(?:([abc])|([def]))*/ and $^N eq "f"); ok ($x =~ /(?:([ace])|([bdf]))*/ and $^N eq "f"); ok ($x =~ /(([ace])|([bd]))*/ and $^N eq "e"); {ok ($x =~ /(([ace])|([bdf]))*/ and $^N eq "f");} ## Test to see if $^N is automatically localized -- it should now ## have the value set in the previous test. iseq $^N, "e", '$^N is automatically localized'; # Now test inside (?{ ... }) local $Message = '$^N usage inside (?{ ... })'; our ($y, $z); ok ($x =~ /a([abc])(?{$y=$^N})c/ and $y eq "b"); ok ($x =~ /a([abc]+)(?{$y=$^N})d/ and $y eq "bc"); ok ($x =~ /a([abcdefg]+)(?{$y=$^N})d/ and $y eq "bc"); ok ($x =~ /(a([abcdefg]+)(?{$y=$^N})d)(?{$z=$^N})e/ and $y eq "bc" and $z eq "abcd"); ok ($x =~ /(a([abcdefg]+)(?{$y=$^N})de)(?{$z=$^N})/ and $y eq "bc" and $z eq "abcde"); } SKIP: { ## Should probably put in tests for all the POSIX stuff, ## but not sure how to guarantee a specific locale...... skip "Not an ASCII platform", 2 unless $IS_ASCII; local $Message = 'Test [[:cntrl:]]'; my $AllBytes = join "" => map {chr} 0 .. 255; (my $x = $AllBytes) =~ s/[[:cntrl:]]//g; iseq $x, join "", map {chr} 0x20 .. 0x7E, 0x80 .. 0xFF; ($x = $AllBytes) =~ s/[^[:cntrl:]]//g; iseq $x, join "", map {chr} 0x00 .. 0x1F, 0x7F; } { # With /s modifier UTF8 chars were interpreted as bytes local $Message = "UTF-8 chars aren't bytes"; my $a = "Hello \x{263A} World"; my @a = ($a =~ /./gs); iseq $#a, 12; } { local $Message = '. matches \n with /s'; my $str1 = "foo\nbar"; my $str2 = "foo\n\x{100}bar"; my ($a, $b) = map {chr} $IS_ASCII ? (0xc4, 0x80) : (0x8c, 0x41); my @a; @a = $str1 =~ /./g; iseq @a, 6; iseq "@a", "f o o b a r"; @a = $str1 =~ /./gs; iseq @a, 7; iseq "@a", "f o o \n b a r"; @a = $str1 =~ /\C/g; iseq @a, 7; iseq "@a", "f o o \n b a r"; @a = $str1 =~ /\C/gs; iseq @a, 7; iseq "@a", "f o o \n b a r"; @a = $str2 =~ /./g; iseq @a, 7; iseq "@a", "f o o \x{100} b a r"; @a = $str2 =~ /./gs; iseq @a, 8; iseq "@a", "f o o \n \x{100} b a r"; @a = $str2 =~ /\C/g; iseq @a, 9; iseq "@a", "f o o \n $a $b b a r"; @a = $str2 =~ /\C/gs; iseq @a, 9; iseq "@a", "f o o \n $a $b b a r"; } { no warnings 'digit'; # Check that \x## works. 5.6.1 and 5.005_03 fail some of these. my $x; $x = "\x4e" . "E"; ok ($x =~ /^\x4EE$/, "Check only 2 bytes of hex are matched."); $x = "\x4e" . "i"; ok ($x =~ /^\x4Ei$/, "Check that invalid hex digit stops it (2)"); $x = "\x4" . "j"; ok ($x =~ /^\x4j$/, "Check that invalid hex digit stops it (1)"); $x = "\x0" . "k"; ok ($x =~ /^\xk$/, "Check that invalid hex digit stops it (0)"); $x = "\x0" . "x"; ok ($x =~ /^\xx$/, "\\xx isn't to be treated as \\0"); $x = "\x0" . "xa"; ok ($x =~ /^\xxa$/, "\\xxa isn't to be treated as \\xa"); $x = "\x9" . "_b"; ok ($x =~ /^\x9_b$/, "\\x9_b isn't to be treated as \\x9b"); # and now again in [] ranges $x = "\x4e" . "E"; ok ($x =~ /^[\x4EE]{2}$/, "Check only 2 bytes of hex are matched."); $x = "\x4e" . "i"; ok ($x =~ /^[\x4Ei]{2}$/, "Check that invalid hex digit stops it (2)"); $x = "\x4" . "j"; ok ($x =~ /^[\x4j]{2}$/, "Check that invalid hex digit stops it (1)"); $x = "\x0" . "k"; ok ($x =~ /^[\xk]{2}$/, "Check that invalid hex digit stops it (0)"); $x = "\x0" . "x"; ok ($x =~ /^[\xx]{2}$/, "\\xx isn't to be treated as \\0"); $x = "\x0" . "xa"; ok ($x =~ /^[\xxa]{3}$/, "\\xxa isn't to be treated as \\xa"); $x = "\x9" . "_b"; ok ($x =~ /^[\x9_b]{3}$/, "\\x9_b isn't to be treated as \\x9b"); # Check that \x{##} works. 5.6.1 fails quite a few of these. $x = "\x9b"; ok ($x =~ /^\x{9_b}$/, "\\x{9_b} is to be treated as \\x9b"); $x = "\x9b" . "y"; ok ($x =~ /^\x{9_b}y$/, "\\x{9_b} is to be treated as \\x9b (again)"); $x = "\x9b" . "y"; ok ($x =~ /^\x{9b_}y$/, "\\x{9b_} is to be treated as \\x9b"); $x = "\x9b" . "y"; ok ($x =~ /^\x{9_bq}y$/, "\\x{9_bc} is to be treated as \\x9b"); $x = "\x0" . "y"; ok ($x =~ /^\x{x9b}y$/, "\\x{x9b} is to be treated as \\x0"); $x = "\x0" . "y"; ok ($x =~ /^\x{0x9b}y$/, "\\x{0x9b} is to be treated as \\x0"); $x = "\x9b" . "y"; ok ($x =~ /^\x{09b}y$/, "\\x{09b} is to be treated as \\x9b"); $x = "\x9b"; ok ($x =~ /^[\x{9_b}]$/, "\\x{9_b} is to be treated as \\x9b"); $x = "\x9b" . "y"; ok ($x =~ /^[\x{9_b}y]{2}$/, "\\x{9_b} is to be treated as \\x9b (again)"); $x = "\x9b" . "y"; ok ($x =~ /^[\x{9b_}y]{2}$/, "\\x{9b_} is to be treated as \\x9b"); $x = "\x9b" . "y"; ok ($x =~ /^[\x{9_bq}y]{2}$/, "\\x{9_bc} is to be treated as \\x9b"); $x = "\x0" . "y"; ok ($x =~ /^[\x{x9b}y]{2}$/, "\\x{x9b} is to be treated as \\x0"); $x = "\x0" . "y"; ok ($x =~ /^[\x{0x9b}y]{2}$/, "\\x{0x9b} is to be treated as \\x0"); $x = "\x9b" . "y"; ok ($x =~ /^[\x{09b}y]{2}$/, "\\x{09b} is to be treated as \\x9b"); } { # High bit bug -- japhy my $x = "ab\200d"; ok $x =~ /.*?\200/, "High bit fine"; } { # The basic character classes and Unicode ok "\x{0100}" =~ /\w/, 'LATIN CAPITAL LETTER A WITH MACRON in /\w/'; ok "\x{0660}" =~ /\d/, 'ARABIC-INDIC DIGIT ZERO in /\d/'; ok "\x{1680}" =~ /\s/, 'OGHAM SPACE MARK in /\s/'; } { local $Message = "Folding matches and Unicode"; ok "a\x{100}" =~ /A/i; ok "A\x{100}" =~ /a/i; ok "a\x{100}" =~ /a/i; ok "A\x{100}" =~ /A/i; ok "\x{101}a" =~ /\x{100}/i; ok "\x{100}a" =~ /\x{100}/i; ok "\x{101}a" =~ /\x{101}/i; ok "\x{100}a" =~ /\x{101}/i; ok "a\x{100}" =~ /A\x{100}/i; ok "A\x{100}" =~ /a\x{100}/i; ok "a\x{100}" =~ /a\x{100}/i; ok "A\x{100}" =~ /A\x{100}/i; ok "a\x{100}" =~ /[A]/i; ok "A\x{100}" =~ /[a]/i; ok "a\x{100}" =~ /[a]/i; ok "A\x{100}" =~ /[A]/i; ok "\x{101}a" =~ /[\x{100}]/i; ok "\x{100}a" =~ /[\x{100}]/i; ok "\x{101}a" =~ /[\x{101}]/i; ok "\x{100}a" =~ /[\x{101}]/i; } { use charnames ':full'; local $Message = "Folding 'LATIN LETTER A WITH GRAVE'"; my $lower = "\N{LATIN SMALL LETTER A WITH GRAVE}"; my $UPPER = "\N{LATIN CAPITAL LETTER A WITH GRAVE}"; ok $lower =~ m/$UPPER/i; ok $UPPER =~ m/$lower/i; ok $lower =~ m/[$UPPER]/i; ok $UPPER =~ m/[$lower]/i; local $Message = "Folding 'GREEK LETTER ALPHA WITH VRACHY'"; $lower = "\N{GREEK CAPITAL LETTER ALPHA WITH VRACHY}"; $UPPER = "\N{GREEK SMALL LETTER ALPHA WITH VRACHY}"; ok $lower =~ m/$UPPER/i; ok $UPPER =~ m/$lower/i; ok $lower =~ m/[$UPPER]/i; ok $UPPER =~ m/[$lower]/i; local $Message = "Folding 'LATIN LETTER Y WITH DIAERESIS'"; $lower = "\N{LATIN SMALL LETTER Y WITH DIAERESIS}"; $UPPER = "\N{LATIN CAPITAL LETTER Y WITH DIAERESIS}"; ok $lower =~ m/$UPPER/i; ok $UPPER =~ m/$lower/i; ok $lower =~ m/[$UPPER]/i; ok $UPPER =~ m/[$lower]/i; } { use charnames ':full'; local $PatchId = "13843"; local $Message = "GREEK CAPITAL LETTER SIGMA vs " . "COMBINING GREEK PERISPOMENI"; my $SIGMA = "\N{GREEK CAPITAL LETTER SIGMA}"; my $char = "\N{COMBINING GREEK PERISPOMENI}"; may_not_warn sub {ok "_:$char:_" !~ m/_:$SIGMA:_/i}; } { local $Message = '\X'; use charnames ':full'; ok "a!" =~ /^(\X)!/ && $1 eq "a"; ok "\xDF!" =~ /^(\X)!/ && $1 eq "\xDF"; ok "\x{100}!" =~ /^(\X)!/ && $1 eq "\x{100}"; ok "\x{100}\x{300}!" =~ /^(\X)!/ && $1 eq "\x{100}\x{300}"; ok "\N{LATIN CAPITAL LETTER E}!" =~ /^(\X)!/ && $1 eq "\N{LATIN CAPITAL LETTER E}"; ok "\N{LATIN CAPITAL LETTER E}\N{COMBINING GRAVE ACCENT}!" =~ /^(\X)!/ && $1 eq "\N{LATIN CAPITAL LETTER E}\N{COMBINING GRAVE ACCENT}"; local $Message = '\C and \X'; ok "!abc!" =~ /a\Cc/; ok "!abc!" =~ /a\Xc/; } { local $Message = "Final Sigma"; my $SIGMA = "\x{03A3}"; # CAPITAL my $Sigma = "\x{03C2}"; # SMALL FINAL my $sigma = "\x{03C3}"; # SMALL ok $SIGMA =~ /$SIGMA/i; ok $SIGMA =~ /$Sigma/i; ok $SIGMA =~ /$sigma/i; ok $Sigma =~ /$SIGMA/i; ok $Sigma =~ /$Sigma/i; ok $Sigma =~ /$sigma/i; ok $sigma =~ /$SIGMA/i; ok $sigma =~ /$Sigma/i; ok $sigma =~ /$sigma/i; ok $SIGMA =~ /[$SIGMA]/i; ok $SIGMA =~ /[$Sigma]/i; ok $SIGMA =~ /[$sigma]/i; ok $Sigma =~ /[$SIGMA]/i; ok $Sigma =~ /[$Sigma]/i; ok $Sigma =~ /[$sigma]/i; ok $sigma =~ /[$SIGMA]/i; ok $sigma =~ /[$Sigma]/i; ok $sigma =~ /[$sigma]/i; local $Message = "More final Sigma"; my $S3 = "$SIGMA$Sigma$sigma"; ok ":$S3:" =~ /:(($SIGMA)+):/i && $1 eq $S3 && $2 eq $sigma; ok ":$S3:" =~ /:(($Sigma)+):/i && $1 eq $S3 && $2 eq $sigma; ok ":$S3:" =~ /:(($sigma)+):/i && $1 eq $S3 && $2 eq $sigma; ok ":$S3:" =~ /:(([$SIGMA])+):/i && $1 eq $S3 && $2 eq $sigma; ok ":$S3:" =~ /:(([$Sigma])+):/i && $1 eq $S3 && $2 eq $sigma; ok ":$S3:" =~ /:(([$sigma])+):/i && $1 eq $S3 && $2 eq $sigma; } { use charnames ':full'; local $Message = "Parlez-Vous " . "Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais?"; ok "Fran\N{LATIN SMALL LETTER C}ais" =~ /Fran.ais/ && $& eq "Francais"; ok "Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" =~ /Fran.ais/ && $& eq "Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais"; ok "Fran\N{LATIN SMALL LETTER C}ais" =~ /Fran\Cais/ && $& eq "Francais"; # COMBINING CEDILLA is two bytes when encoded ok "Franc\N{COMBINING CEDILLA}ais" =~ /Franc\C\Cais/; ok "Fran\N{LATIN SMALL LETTER C}ais" =~ /Fran\Xais/ && $& eq "Francais"; ok "Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" =~ /Fran\Xais/ && $& eq "Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais"; ok "Franc\N{COMBINING CEDILLA}ais" =~ /Fran\Xais/ && $& eq "Franc\N{COMBINING CEDILLA}ais"; ok "Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" =~ /Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais/ && $& eq "Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais"; ok "Franc\N{COMBINING CEDILLA}ais" =~ /Franc\N{COMBINING CEDILLA}ais/ && $& eq "Franc\N{COMBINING CEDILLA}ais"; my @f = ( ["Fran\N{LATIN SMALL LETTER C}ais", "Francais"], ["Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais", "Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais"], ["Franc\N{COMBINING CEDILLA}ais", "Franc\N{COMBINING CEDILLA}ais"], ); foreach my $entry (@f) { my ($subject, $match) = @$entry; ok $subject =~ /Fran(?:c\N{COMBINING CEDILLA}?| \N{LATIN SMALL LETTER C WITH CEDILLA})ais/x && $& eq $match; } } { local $Message = "Lingering (and useless) UTF8 flag doesn't mess up /i"; my $pat = "ABcde"; my $str = "abcDE\x{100}"; chop $str; ok $str =~ /$pat/i; $pat = "ABcde\x{100}"; $str = "abcDE"; chop $pat; ok $str =~ /$pat/i; $pat = "ABcde\x{100}"; $str = "abcDE\x{100}"; chop $pat; chop $str; ok $str =~ /$pat/i; } { use charnames ':full'; local $Message = "LATIN SMALL LETTER SHARP S " . "(\N{LATIN SMALL LETTER SHARP S})"; ok "\N{LATIN SMALL LETTER SHARP S}" =~ /\N{LATIN SMALL LETTER SHARP S}/; ok "\N{LATIN SMALL LETTER SHARP S}" =~ /\N{LATIN SMALL LETTER SHARP S}/i; ok "\N{LATIN SMALL LETTER SHARP S}" =~ /[\N{LATIN SMALL LETTER SHARP S}]/; ok "\N{LATIN SMALL LETTER SHARP S}" =~ /[\N{LATIN SMALL LETTER SHARP S}]/i; ok "ss" =~ /\N{LATIN SMALL LETTER SHARP S}/i; ok "SS" =~ /\N{LATIN SMALL LETTER SHARP S}/i; ok "ss" =~ /[\N{LATIN SMALL LETTER SHARP S}]/i; ok "SS" =~ /[\N{LATIN SMALL LETTER SHARP S}]/i; ok "\N{LATIN SMALL LETTER SHARP S}" =~ /ss/i; ok "\N{LATIN SMALL LETTER SHARP S}" =~ /SS/i; local $Message = "Unoptimized named sequence in class"; ok "ss" =~ /[\N{LATIN SMALL LETTER SHARP S}x]/i; ok "SS" =~ /[\N{LATIN SMALL LETTER SHARP S}x]/i; ok "\N{LATIN SMALL LETTER SHARP S}" =~ /[\N{LATIN SMALL LETTER SHARP S}x]/; ok "\N{LATIN SMALL LETTER SHARP S}" =~ /[\N{LATIN SMALL LETTER SHARP S}x]/i; } { # More whitespace: U+0085, U+2028, U+2029\n"; # U+0085, U+00A0 need to be forced to be Unicode, the \x{100} does that. SKIP: { skip "EBCDIC platform", 4 if $IS_EBCDIC; # Do \x{0015} and \x{0041} match \s in EBCDIC? ok "<\x{100}\x{0085}>" =~ /<\x{100}\s>/, '\x{0085} in \s'; ok "<\x{0085}>" =~ /<\v>/, '\x{0085} in \v'; ok "<\x{100}\x{00A0}>" =~ /<\x{100}\s>/, '\x{00A0} in \s'; ok "<\x{00A0}>" =~ /<\h>/, '\x{00A0} in \h'; } my @h = map {sprintf "%05x" => $_} 0x01680, 0x0180E, 0x02000 .. 0x0200A, 0x0202F, 0x0205F, 0x03000; my @v = map {sprintf "%05x" => $_} 0x02028, 0x02029; my @H = map {sprintf "%05x" => $_} 0x01361, 0x0200B, 0x02408, 0x02420, 0x0303F, 0xE0020; my @V = map {sprintf "%05x" => $_} 0x0008A .. 0x0008D, 0x00348, 0x10100, 0xE005F, 0xE007C; for my $hex (@h) { my $str = eval qq ["<\\x{$hex}>"]; ok $str =~ /<\s>/, "\\x{$hex} in \\s"; ok $str =~ /<\h>/, "\\x{$hex} in \\h"; ok $str !~ /<\v>/, "\\x{$hex} not in \\v"; } for my $hex (@v) { my $str = eval qq ["<\\x{$hex}>"]; ok $str =~ /<\s>/, "\\x{$hex} in \\s"; ok $str =~ /<\v>/, "\\x{$hex} in \\v"; ok $str !~ /<\h>/, "\\x{$hex} not in \\h"; } for my $hex (@H) { my $str = eval qq ["<\\x{$hex}>"]; ok $str =~ /<\S>/, "\\x{$hex} in \\S"; ok $str =~ /<\H>/, "\\x{$hex} in \\H"; } for my $hex (@V) { my $str = eval qq ["<\\x{$hex}>"]; ok $str =~ /<\S>/, "\\x{$hex} in \\S"; ok $str =~ /<\V>/, "\\x{$hex} in \\V"; } } { # . with /s should work on characters, as opposed to bytes local $Message = ". with /s works on characters, not bytes"; my $s = "\x{e4}\x{100}"; # This is not expected to match: the point is that # neither should we get "Malformed UTF-8" warnings. may_not_warn sub {$s =~ /\G(.+?)\n/gcs}, "No 'Malformed UTF-8' warning"; my @c; push @c => $1 while $s =~ /\G(.)/gs; local $" = ""; iseq "@c", $s; # Test only chars < 256 my $t1 = "Q003\n\n\x{e4}\x{f6}\n\nQ004\n\n\x{e7}"; my $r1 = ""; while ($t1 =~ / \G ( .+? ) \n\s+ ( .+? ) ( $ | \n\s+ ) /xgcs) { $r1 .= $1 . $2; } my $t2 = $t1 . "\x{100}"; # Repeat with a larger char my $r2 = ""; while ($t2 =~ / \G ( .+? ) \n\s+ ( .+? ) ( $ | \n\s+ ) /xgcs) { $r2 .= $1 . $2; } $r2 =~ s/\x{100}//; iseq $r1, $r2; } { local $Message = "Unicode lookbehind"; ok "A\x{100}B" =~ /(?<=A.)B/; ok "A\x{200}\x{300}B" =~ /(?<=A..)B/; ok "\x{400}AB" =~ /(?<=\x{400}.)B/; ok "\x{500}\x{600}B" =~ /(?<=\x{500}.)B/; # Original code also contained: # ok "\x{500\x{600}}B" =~ /(?<=\x{500}.)B/; # but that looks like a typo. } { local $Message = 'UTF-8 hash keys and /$/'; # http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters # /2002-01/msg01327.html my $u = "a\x{100}"; my $v = substr ($u, 0, 1); my $w = substr ($u, 1, 1); my %u = ($u => $u, $v => $v, $w => $w); for (keys %u) { my $m1 = /^\w*$/ ? 1 : 0; my $m2 = $u {$_} =~ /^\w*$/ ? 1 : 0; iseq $m1, $m2; } } { local $Message = "No SEGV in s/// and UTF-8"; my $s = "s#\x{100}" x 4; ok $s =~ s/[^\w]/ /g; if ( 1 or $ENV{PERL_TEST_LEGACY_POSIX_CC} ) { iseq $s, "s \x{100}" x 4; } else { iseq $s, "s " x 4; } } { local $Message = "UTF-8 bug (maybe already known?)"; my $u = "foo"; $u =~ s/./\x{100}/g; iseq $u, "\x{100}\x{100}\x{100}"; $u = "foobar"; $u =~ s/[ao]/\x{100}/g; iseq $u, "f\x{100}\x{100}b\x{100}r"; $u =~ s/\x{100}/e/g; iseq $u, "feeber"; } { local $Message = "UTF-8 bug with s///"; # check utf8/non-utf8 mixtures # try to force all float/anchored check combinations my $c = "\x{100}"; my $subst; for my $re ("xx.*$c", "x.*$c$c", "$c.*xx", "$c$c.*x", "xx.*(?=$c)", "(?=$c).*xx",) { ok "xxx" !~ /$re/; ok +($subst = "xxx") !~ s/$re//; } for my $re ("xx.*$c*", "$c*.*xx") { ok "xxx" =~ /$re/; ok +($subst = "xxx") =~ s/$re//; iseq $subst, ""; } for my $re ("xxy*", "y*xx") { ok "xx$c" =~ /$re/; ok +($subst = "xx$c") =~ s/$re//; iseq $subst, $c; ok "xy$c" !~ /$re/; ok +($subst = "xy$c") !~ s/$re//; } for my $re ("xy$c*z", "x$c*yz") { ok "xyz" =~ /$re/; ok +($subst = "xyz") =~ s/$re//; iseq $subst, ""; } } { local $Message = "qr /.../x"; my $R = qr / A B C # D E/x; ok "ABCDE" =~ $R && $& eq "ABC"; ok "ABCDE" =~ /$R/ && $& eq "ABC"; ok "ABCDE" =~ m/$R/ && $& eq "ABC"; ok "ABCDE" =~ /($R)/ && $1 eq "ABC"; ok "ABCDE" =~ m/($R)/ && $1 eq "ABC"; } { local $\; $_ = 'aaaaaaaaaa'; utf8::upgrade($_); chop $_; $\="\n"; ok /[^\s]+/, 'm/[^\s]/ utf8'; ok /[^\d]+/, 'm/[^\d]/ utf8'; ok +($a = $_, $_ =~ s/[^\s]+/./g), 's/[^\s]/ utf8'; ok +($a = $_, $a =~ s/[^\d]+/./g), 's/[^\s]/ utf8'; } { # Subject: Odd regexp behavior # From: Markus Kuhn # Date: Wed, 26 Feb 2003 16:53:12 +0000 # Message-Id: # To: perl-unicode@perl.org local $Message = 'Markus Kuhn 2003-02-26'; my $x = "\x{2019}\nk"; ok $x =~ s/(\S)\n(\S)/$1 $2/sg; ok $x eq "\x{2019} k"; $x = "b\nk"; ok $x =~ s/(\S)\n(\S)/$1 $2/sg; ok $x eq "b k"; ok "\x{2019}" =~ /\S/; } { # XXX DAPM 13-Apr-06. Recursive split is still broken. It's only luck it # hasn't been crashing. Disable this test until it is fixed properly. # XXX also check what it returns rather than just doing ok(1,...) # split /(?{ split "" })/, "abc"; local $TODO = "Recursive split is still broken"; ok 0, 'cache_re & "(?{": it dumps core in 5.6.1 & 5.8.0'; } { ok "\x{100}\n" =~ /\x{100}\n$/, "UTF-8 length cache and fbm_compile"; } { package Str; use overload q /""/ => sub {${$_ [0]};}; sub new {my ($c, $v) = @_; bless \$v, $c;} package main; $_ = Str -> new ("a\x{100}/\x{100}b"); ok join (":", /\b(.)\x{100}/g) eq "a:/", "re_intuit_start and PL_bostr"; } { my $re = qq /^([^X]*)X/; utf8::upgrade ($re); ok "\x{100}X" =~ /$re/, "S_cl_and ANYOF_UNICODE & ANYOF_INVERTED"; } { ok "123\x{100}" =~ /^.*1.*23\x{100}$/, 'UTF-8 + multiple floating substr'; } { local $Message = '<20030808193656.5109.1@llama.ni-s.u-net.com>'; # LATIN SMALL/CAPITAL LETTER A WITH MACRON ok " \x{101}" =~ qr/\x{100}/i; # LATIN SMALL/CAPITAL LETTER A WITH RING BELOW ok " \x{1E01}" =~ qr/\x{1E00}/i; # DESERET SMALL/CAPITAL LETTER LONG I ok " \x{10428}" =~ qr/\x{10400}/i; # LATIN SMALL/CAPITAL LETTER A WITH RING BELOW + 'X' ok " \x{1E01}x" =~ qr/\x{1E00}X/i; } { for (120 .. 130) { my $head = 'x' x $_; local $Message = q [Don't misparse \x{...} in regexp ] . q [near 127 char EXACT limit]; for my $tail ('\x{0061}', '\x{1234}', '\x61') { eval_ok qq ["$head$tail" =~ /$head$tail/]; } local $Message = q [Don't misparse \N{...} in regexp ] . q [near 127 char EXACT limit]; for my $tail ('\N{SNOWFLAKE}') { eval_ok qq [use charnames ':full'; "$head$tail" =~ /$head$tail/]; } } } { # TRIE related our @got = (); "words" =~ /(word|word|word)(?{push @got, $1})s$/; iseq @got, 1, "TRIE optimation"; @got = (); "words" =~ /(word|word|word)(?{push @got,$1})s$/i; iseq @got, 1,"TRIEF optimisation"; my @nums = map {int rand 1000} 1 .. 100; my $re = "(" . (join "|", @nums) . ")"; $re = qr/\b$re\b/; foreach (@nums) { ok $_ =~ /$re/, "Trie nums"; } $_ = join " ", @nums; @got = (); push @got, $1 while /$re/g; my %count; $count {$_} ++ for @got; my $ok = 1; for (@nums) { $ok = 0 if --$count {$_} < 0; } ok $ok, "Trie min count matches"; } { # TRIE related # LATIN SMALL/CAPITAL LETTER A WITH MACRON ok "foba \x{101}foo" =~ qr/(foo|\x{100}foo|bar)/i && $1 eq "\x{101}foo", "TRIEF + LATIN SMALL/CAPITAL LETTER A WITH MACRON"; # LATIN SMALL/CAPITAL LETTER A WITH RING BELOW ok "foba \x{1E01}foo" =~ qr/(foo|\x{1E00}foo|bar)/i && $1 eq "\x{1E01}foo", "TRIEF + LATIN SMALL/CAPITAL LETTER A WITH RING BELOW"; # DESERET SMALL/CAPITAL LETTER LONG I ok "foba \x{10428}foo" =~ qr/(foo|\x{10400}foo|bar)/i && $1 eq "\x{10428}foo", "TRIEF + DESERET SMALL/CAPITAL LETTER LONG I"; # LATIN SMALL/CAPITAL LETTER A WITH RING BELOW + 'X' ok "foba \x{1E01}xfoo" =~ qr/(foo|\x{1E00}Xfoo|bar)/i && $1 eq "\x{1E01}xfoo", "TRIEF + LATIN SMALL/CAPITAL LETTER A WITH RING BELOW + 'X'"; use charnames ':full'; my $s = "\N{LATIN SMALL LETTER SHARP S}"; ok "foba ba$s" =~ qr/(foo|Ba$s|bar)/i && $1 eq "ba$s", "TRIEF + LATIN SMALL LETTER SHARP S =~ ss"; ok "foba ba$s" =~ qr/(Ba$s|foo|bar)/i && $1 eq "ba$s", "TRIEF + LATIN SMALL LETTER SHARP S =~ ss"; ok "foba ba$s" =~ qr/(foo|bar|Ba$s)/i && $1 eq "ba$s", "TRIEF + LATIN SMALL LETTER SHARP S =~ ss"; ok "foba ba$s" =~ qr/(foo|Bass|bar)/i && $1 eq "ba$s", "TRIEF + LATIN SMALL LETTER SHARP S =~ ss"; ok "foba ba$s" =~ qr/(foo|BaSS|bar)/i && $1 eq "ba$s", "TRIEF + LATIN SMALL LETTER SHARP S =~ SS"; ok "foba ba${s}pxySS$s$s" =~ qr/(b(?:a${s}t|a${s}f|a${s}p)[xy]+$s*)/i && $1 eq "ba${s}pxySS$s$s", "COMMON PREFIX TRIEF + LATIN SMALL LETTER SHARP S"; } { BEGIN { unshift @INC, 'lib'; } use Cname; ok 'fooB' =~ /\N{foo}[\N{B}\N{b}]/, "Passthrough charname"; # # Why doesn't must_warn work here? # my $w; local $SIG {__WARN__} = sub {$w .= "@_"}; eval 'q(xxWxx) =~ /[\N{WARN}]/'; ok $w && $w =~ /Using just the first character returned by \\N{} in character class/, "single character in [\\N{}] warning"; undef $w; eval q [ok "\0" !~ /[\N{EMPTY-STR}XY]/, "Zerolength charname in charclass doesn't match \\0"]; ok $w && $w =~ /Ignoring zero length/, 'Ignoring zero length \N{} in character class warning'; ok 'AB' =~ /(\N{EVIL})/ && $1 eq 'A', 'Charname caching $1'; ok 'ABC' =~ /(\N{EVIL})/, 'Charname caching $1'; ok 'xy' =~ /x\N{EMPTY-STR}y/, 'Empty string charname produces NOTHING node'; ok '' =~ /\N{EMPTY-STR}/, 'Empty string charname produces NOTHING node'; ok "\N{LONG-STR}" =~ /^\N{LONG-STR}$/, 'Verify that long string works'; ok "\N{LONG-STR}" =~ /^\N{LONG-STR}$/i, 'Verify under folding that long string works'; # If remove the limitation in regcomp code these should work # differently undef $w; eval q [ok "\N{LONG-STR}" =~ /^\N{TOO-LONG-STR}$/, 'Verify that too long a string fails gracefully']; ok $w && $w =~ /Using just the first characters returned/, 'Verify that got too-long string warning in \N{} that exceeds the limit'; undef $w; eval q [ok "\N{LONG-STR}" =~ /^\N{TOO-LONG-STR}$/i, 'Verify under folding that too long a string fails gracefully']; ok $w && $w =~ /Using just the first characters returned/, 'Verify under folding that got too-long string warning in \N{} that exceeds the limit'; undef $w; eval q [ok "\N{TOO-LONG-STR}" !~ /^\N{TOO-LONG-STR}$/, 'Verify that too long a string doesnt work']; ok $w && $w =~ /Using just the first characters returned/, 'Verify that got too-long string warning in \N{} that exceeds the limit'; undef $w; eval q [ok "\N{TOO-LONG-STR}" !~ /^\N{TOO-LONG-STR}$/i, 'Verify under folding that too long a string doesnt work']; ok $w && $w =~ /Using just the first characters returned/i, 'Verify under folding that got too-long string warning in \N{} that exceeds the limit'; undef $w; eval 'q(syntax error) =~ /\N{MALFORMED}/'; ok $@ && $@ =~ /Malformed/, 'Verify that malformed utf8 gives an error'; undef $w; eval 'q() =~ /\N{4F}/'; ok $w && $w =~ /Deprecated/, 'Verify that leading digit in name gives warning'; undef $w; eval 'q() =~ /\N{COM,MA}/'; ok $w && $w =~ /Deprecated/, 'Verify that comma in name gives warning'; undef $w; my $name = "A\x{D7}O"; eval "q(W) =~ /\\N{$name}/"; ok $w && $w =~ /Deprecated/, 'Verify that latin1 symbol in name gives warning'; undef $w; $name = "A\x{D1}O"; eval "q(W) =~ /\\N{$name}/"; ok ! $w, 'Verify that latin1 letter in name doesnt give warning'; } { use charnames ':full'; ok 'aabc' !~ /a\N{PLUS SIGN}b/, '/a\N{PLUS SIGN}b/ against aabc'; ok 'a+bc' =~ /a\N{PLUS SIGN}b/, '/a\N{PLUS SIGN}b/ against a+bc'; ok ' A B' =~ /\N{SPACE}\N{U+0041}\N{SPACE}\N{U+0042}/, 'Intermixed named and unicode escapes'; ok "\N{SPACE}\N{U+0041}\N{SPACE}\N{U+0042}" =~ /\N{SPACE}\N{U+0041}\N{SPACE}\N{U+0042}/, 'Intermixed named and unicode escapes'; ok "\N{SPACE}\N{U+0041}\N{SPACE}\N{U+0042}" =~ /[\N{SPACE}\N{U+0041}][\N{SPACE}\N{U+0042}]/, 'Intermixed named and unicode escapes'; ok "\0" =~ /^\N{NULL}$/, 'Verify that \N{NULL} works; is not confused with an error'; } { our $brackets; $brackets = qr{ { (?> [^{}]+ | (??{ $brackets }) )* } }x; ok "{b{c}d" !~ m/^((??{ $brackets }))/, "Bracket mismatch"; SKIP: { our @stack = (); my @expect = qw( stuff1 stuff2 and right <> <<>> <and><<<>>> ); local $_ = '<<and><<<>>>>'; ok /^(<((?:(?>[^<>]+)|(?1))*)>(?{push @stack, $2 }))$/, "Recursion matches"; iseq @stack, @expect, "Right amount of matches" or skip "Won't test individual results as count isn't equal", 0 + @expect; my $idx = 0; foreach my $expect (@expect) { iseq $stack [$idx], $expect, "Expecting '$expect' at stack pos #$idx"; $idx ++; } } } { my $s = '123453456'; $s =~ s/(?\d+)\k/$+{digits}/; ok $s eq '123456', 'Named capture (angle brackets) s///'; $s = '123453456'; $s =~ s/(?'digits'\d+)\k'digits'/$+{digits}/; ok $s eq '123456', 'Named capture (single quotes) s///'; } { my @ary = ( pack('U', 0x00F1), # n-tilde '_'.pack('U', 0x00F1), # _ + n-tilde 'c'.pack('U', 0x0327), # c + cedilla pack('U*', 0x00F1, 0x0327), # n-tilde + cedilla pack('U', 0x0391), # ALPHA pack('U', 0x0391).'2', # ALPHA + 2 pack('U', 0x0391).'_', # ALPHA + _ ); for my $uni (@ary) { my ($r1, $c1, $r2, $c2) = eval qq { use utf8; scalar ("..foo foo.." =~ /(?'${uni}'foo) \\k'${uni}'/), \$+{${uni}}, scalar ("..bar bar.." =~ /(?<${uni}>bar) \\k<${uni}>/), \$+{${uni}}; }; ok $r1, "Named capture UTF (?'')"; ok defined $c1 && $c1 eq 'foo', "Named capture UTF \%+"; ok $r2, "Named capture UTF (?<>)"; ok defined $c2 && $c2 eq 'bar', "Named capture UTF \%+"; } } { my $s = 'foo bar baz'; my @res; if ('1234' =~ /(?1)(?2)(?3)(?4)/) { foreach my $name (sort keys(%-)) { my $ary = $- {$name}; foreach my $idx (0 .. $#$ary) { push @res, "$name:$idx:$ary->[$idx]"; } } } my @expect = qw (A:0:1 A:1:3 B:0:2 B:1:4); iseq "@res", "@expect", "Check %-"; eval' no warnings "uninitialized"; print for $- {this_key_doesnt_exist}; '; ok !$@,'lvalue $- {...} should not throw an exception'; } { # \, breaks {3,4} ok "xaaay" !~ /xa{3\,4}y/, '\, in a pattern'; ok "xa{3,4}y" =~ /xa{3\,4}y/, '\, in a pattern'; # \c\ followed by _ ok "x\c_y" !~ /x\c\_y/, '\_ in a pattern'; ok "x\c\_y" =~ /x\c\_y/, '\_ in a pattern'; # \c\ followed by other characters for my $c ("z", "\0", "!", chr(254), chr(256)) { my $targ = "a\034$c"; my $reg = "a\\c\\$c"; ok eval ("qq/$targ/ =~ /$reg/"), "\\c\\ in pattern"; } } { # Test the (*PRUNE) pattern our $count = 0; 'aaab' =~ /a+b?(?{$count++})(*FAIL)/; iseq $count, 9, "Expect 9 for no (*PRUNE)"; $count = 0; 'aaab' =~ /a+b?(*PRUNE)(?{$count++})(*FAIL)/; iseq $count, 3, "Expect 3 with (*PRUNE)"; local $_ = 'aaab'; $count = 0; 1 while /.(*PRUNE)(?{$count++})(*FAIL)/g; iseq $count, 4, "/.(*PRUNE)/"; $count = 0; 'aaab' =~ /a+b?(??{'(*PRUNE)'})(?{$count++})(*FAIL)/; iseq $count, 3, "Expect 3 with (*PRUNE)"; local $_ = 'aaab'; $count = 0; 1 while /.(??{'(*PRUNE)'})(?{$count++})(*FAIL)/g; iseq $count, 4, "/.(*PRUNE)/"; } { # Test the (*SKIP) pattern our $count = 0; 'aaab' =~ /a+b?(*SKIP)(?{$count++})(*FAIL)/; iseq $count, 1, "Expect 1 with (*SKIP)"; local $_ = 'aaab'; $count = 0; 1 while /.(*SKIP)(?{$count++})(*FAIL)/g; iseq $count, 4, "/.(*SKIP)/"; $_ = 'aaabaaab'; $count = 0; our @res = (); 1 while /(a+b?)(*SKIP)(?{$count++; push @res,$1})(*FAIL)/g; iseq $count, 2, "Expect 2 with (*SKIP)"; iseq "@res", "aaab aaab", "Adjacent (*SKIP) works as expected"; } { # Test the (*SKIP) pattern our $count = 0; 'aaab' =~ /a+b?(*MARK:foo)(*SKIP)(?{$count++})(*FAIL)/; iseq $count, 1, "Expect 1 with (*SKIP)"; local $_ = 'aaab'; $count = 0; 1 while /.(*MARK:foo)(*SKIP)(?{$count++})(*FAIL)/g; iseq $count, 4, "/.(*SKIP)/"; $_ = 'aaabaaab'; $count = 0; our @res = (); 1 while /(a+b?)(*MARK:foo)(*SKIP)(?{$count++; push @res,$1})(*FAIL)/g; iseq $count, 2, "Expect 2 with (*SKIP)"; iseq "@res", "aaab aaab", "Adjacent (*SKIP) works as expected"; } { # Test the (*SKIP) pattern our $count = 0; 'aaab' =~ /a*(*MARK:a)b?(*MARK:b)(*SKIP:a)(?{$count++})(*FAIL)/; iseq $count, 3, "Expect 3 with *MARK:a)b?(*MARK:b)(*SKIP:a)"; local $_ = 'aaabaaab'; $count = 0; our @res = (); 1 while /(a*(*MARK:a)b?)(*MARK:x)(*SKIP:a)(?{$count++; push @res,$1})(*FAIL)/g; iseq $count, 5, "Expect 5 with (*MARK:a)b?)(*MARK:x)(*SKIP:a)"; iseq "@res", "aaab b aaab b ", "Adjacent (*MARK:a)b?)(*MARK:x)(*SKIP:a) works as expected"; } { # Test the (*COMMIT) pattern our $count = 0; 'aaabaaab' =~ /a+b?(*COMMIT)(?{$count++})(*FAIL)/; iseq $count, 1, "Expect 1 with (*COMMIT)"; local $_ = 'aaab'; $count = 0; 1 while /.(*COMMIT)(?{$count++})(*FAIL)/g; iseq $count, 1, "/.(*COMMIT)/"; $_ = 'aaabaaab'; $count = 0; our @res = (); 1 while /(a+b?)(*COMMIT)(?{$count++; push @res,$1})(*FAIL)/g; iseq $count, 1, "Expect 1 with (*COMMIT)"; iseq "@res", "aaab", "Adjacent (*COMMIT) works as expected"; } { # Test named commits and the $REGERROR var our $REGERROR; for my $name ('', ':foo') { for my $pat ("(*PRUNE$name)", ($name ? "(*MARK$name)" : "") . "(*SKIP$name)", "(*COMMIT$name)") { for my $suffix ('(*FAIL)', '') { 'aaaab' =~ /a+b$pat$suffix/; iseq $REGERROR, ($suffix ? ($name ? 'foo' : "1") : ""), "Test $pat and \$REGERROR $suffix"; } } } } { # Test named commits and the $REGERROR var package Fnorble; our $REGERROR; for my $name ('', ':foo') { for my $pat ("(*PRUNE$name)", ($name ? "(*MARK$name)" : "") . "(*SKIP$name)", "(*COMMIT$name)") { for my $suffix ('(*FAIL)','') { 'aaaab' =~ /a+b$pat$suffix/; ::iseq $REGERROR, ($suffix ? ($name ? 'foo' : "1") : ""), "Test $pat and \$REGERROR $suffix"; } } } } { # Test named commits and the $REGERROR var local $Message = '$REGERROR'; our $REGERROR; for my $word (qw (bar baz bop)) { $REGERROR = ""; "aaaaa$word" =~ /a+(?:bar(*COMMIT:bar)|baz(*COMMIT:baz)|bop(*COMMIT:bop))(*FAIL)/; iseq $REGERROR, $word; } } { #Mindnumbingly simple test of (*THEN) for ("ABC","BAX") { ok /A (*THEN) X | B (*THEN) C/x, "Simple (*THEN) test"; } } { local $Message = "Relative Recursion"; my $parens = qr/(\((?:[^()]++|(?-1))*+\))/; local $_ = 'foo((2*3)+4-3) + bar(2*(3+4)-1*(2-3))'; my ($all, $one, $two) = ('', '', ''); ok m/foo $parens \s* \+ \s* bar $parens/x; iseq $1, '((2*3)+4-3)'; iseq $2, '(2*(3+4)-1*(2-3))'; iseq $&, 'foo((2*3)+4-3) + bar(2*(3+4)-1*(2-3))'; iseq $&, $_; } { my $spaces=" "; local $_ = join 'bar', $spaces, $spaces; our $count = 0; s/(?>\s+bar)(?{$count++})//g; iseq $_, $spaces, "SUSPEND final string"; iseq $count, 1, "Optimiser should have prevented more than one match"; } { # From Message-ID: <877ixs6oa6.fsf@k75.linux.bogus> my $dow_name = "nada"; my $parser = "(\$dow_name) = \$time_string =~ /(D\x{e9}\\ " . "C\x{e9}adaoin|D\x{e9}\\ Sathairn|\\w+|\x{100})/"; my $time_string = "D\x{e9} C\x{e9}adaoin"; eval $parser; ok !$@, "Test Eval worked"; iseq $dow_name, $time_string, "UTF-8 trie common prefix extraction"; } { my $v; ($v = 'bar') =~ /(\w+)/g; $v = 'foo'; iseq "$1", 'bar', '$1 is safe after /g - may fail due ' . 'to specialized config in pp_hot.c' } { local $Message = "http://nntp.perl.org/group/perl.perl5.porters/118663"; my $qr_barR1 = qr/(bar)\g-1/; ok "foobarbarxyz" =~ $qr_barR1; ok "foobarbarxyz" =~ qr/foo${qr_barR1}xyz/; ok "foobarbarxyz" =~ qr/(foo)${qr_barR1}xyz/; ok "foobarbarxyz" =~ qr/(foo)(bar)\g{-1}xyz/; ok "foobarbarxyz" =~ qr/(foo${qr_barR1})xyz/; ok "foobarbarxyz" =~ qr/(foo(bar)\g{-1})xyz/; } { local $Message = '$REGMARK'; our @r = (); our ($REGMARK, $REGERROR); ok 'foofoo' =~ /foo (*MARK:foo) (?{push @r,$REGMARK}) /x; iseq "@r","foo"; iseq $REGMARK, "foo"; ok 'foofoo' !~ /foo (*MARK:foo) (*FAIL) /x; ok !$REGMARK; iseq $REGERROR, 'foo'; } { local $Message = '\K test'; my $x; $x = "abc.def.ghi.jkl"; $x =~ s/.*\K\..*//; iseq $x, "abc.def.ghi"; $x = "one two three four"; $x =~ s/o+ \Kthree//g; iseq $x, "one two four"; $x = "abcde"; $x =~ s/(.)\K/$1/g; iseq $x, "aabbccddee"; } { sub kt { return '4' if $_[0] eq '09028623'; } # Nested EVAL using PL_curpm (via $1 or friends) my $re; our $grabit = qr/ ([0-6][0-9]{7}) (??{ kt $1 }) [890] /x; $re = qr/^ ( (??{ $grabit }) ) $ /x; my @res = '0902862349' =~ $re; iseq join ("-", @res), "0902862349", 'PL_curpm is set properly on nested eval'; our $qr = qr/ (o) (??{ $1 }) /x; ok 'boob'=~/( b (??{ $qr }) b )/x && 1, "PL_curpm, nested eval"; } { use charnames ":full"; ok "\N{ROMAN NUMERAL ONE}" =~ /\p{Alphabetic}/, "I =~ Alphabetic"; ok "\N{ROMAN NUMERAL ONE}" =~ /\p{Uppercase}/, "I =~ Uppercase"; ok "\N{ROMAN NUMERAL ONE}" !~ /\p{Lowercase}/, "I !~ Lowercase"; ok "\N{ROMAN NUMERAL ONE}" =~ /\p{IDStart}/, "I =~ ID_Start"; ok "\N{ROMAN NUMERAL ONE}" =~ /\p{IDContinue}/, "I =~ ID_Continue"; ok "\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{Alphabetic}/, "i =~ Alphabetic"; ok "\N{SMALL ROMAN NUMERAL ONE}" !~ /\p{Uppercase}/, "i !~ Uppercase"; ok "\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{Lowercase}/, "i =~ Lowercase"; ok "\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{IDStart}/, "i =~ ID_Start"; ok "\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{IDContinue}/, "i =~ ID_Continue" } { # requirement of Unicode Technical Standard #18, 1.7 Code Points # cf. http://www.unicode.org/reports/tr18/#Supplementary_Characters for my $u (0x7FF, 0x800, 0xFFFF, 0x10000) { no warnings 'utf8'; # oops my $c = chr $u; my $x = sprintf '%04X', $u; ok "A${c}B" =~ /A[\0-\x{10000}]B/, "Unicode range - $x"; } } { my $res=""; if ('1' =~ /(?|(?1)|(?2))/) { $res = "@{$- {digit}}"; } iseq $res, "1", "Check that (?|...) doesnt cause dupe entries in the names array"; $res = ""; if ('11' =~ /(?|(?1)|(?2))(?&digit)/) { $res = "@{$- {digit}}"; } iseq $res, "1", "Check that (?&..) to a buffer inside " . "a (?|...) goes to the leftmost"; } { use warnings; local $Message = "ASCII pattern that really is UTF-8"; my @w; local $SIG {__WARN__} = sub {push @w, "@_"}; my $c = qq (\x{DF}); ok $c =~ /${c}|\x{100}/; ok @w == 0; } { local $Message = "Corruption of match results of qr// across scopes"; my $qr = qr/(fo+)(ba+r)/; 'foobar' =~ /$qr/; iseq "$1$2", "foobar"; { 'foooooobaaaaar' =~ /$qr/; iseq "$1$2", 'foooooobaaaaar'; } iseq "$1$2", "foobar"; } { local $Message = "HORIZWS"; local $_ = "\t \r\n \n \t".chr(11)."\n"; s/\H/H/g; s/\h/h/g; iseq $_, "hhHHhHhhHH"; $_ = "\t \r\n \n \t" . chr (11) . "\n"; utf8::upgrade ($_); s/\H/H/g; s/\h/h/g; iseq $_, "hhHHhHhhHH"; } { local $Message = "Various whitespace special patterns"; my @h = map {chr $_} 0x09, 0x20, 0xa0, 0x1680, 0x180e, 0x2000, 0x2001, 0x2002, 0x2003, 0x2004, 0x2005, 0x2006, 0x2007, 0x2008, 0x2009, 0x200a, 0x202f, 0x205f, 0x3000; my @v = map {chr $_} 0x0a, 0x0b, 0x0c, 0x0d, 0x85, 0x2028, 0x2029; my @lb = ("\x0D\x0A", map {chr $_} 0x0A .. 0x0D, 0x85, 0x2028, 0x2029); foreach my $t ([\@h, qr/\h/, qr/\h+/], [\@v, qr/\v/, qr/\v+/], [\@lb, qr/\R/, qr/\R+/],) { my $ary = shift @$t; foreach my $pat (@$t) { foreach my $str (@$ary) { ok $str =~ /($pat)/, $pat; iseq $1, $str, $pat; utf8::upgrade ($str); ok $str =~ /($pat)/, "Upgraded string - $pat"; iseq $1, $str, "Upgraded string - $pat"; } } } } { local $Message = "Check that \\xDF match properly in its various forms"; # Test that \xDF matches properly. this is pretty hacky stuff, # but its actually needed. The malarky with '-' is to prevent # compilation caching from playing any role in the test. my @df = (chr (0xDF), '-', chr (0xDF)); utf8::upgrade ($df [2]); my @strs = ('ss', 'sS', 'Ss', 'SS', chr (0xDF)); my @ss = map {("$_", "$_")} @strs; utf8::upgrade ($ss [$_ * 2 + 1]) for 0 .. $#strs; for my $ssi (0 .. $#ss) { for my $dfi (0 .. $#df) { my $pat = $df [$dfi]; my $str = $ss [$ssi]; my $utf_df = ($dfi > 1) ? 'utf8' : ''; my $utf_ss = ($ssi % 2) ? 'utf8' : ''; (my $sstr = $str) =~ s/\xDF/\\xDF/; if ($utf_df || $utf_ss || length ($ss [$ssi]) == 1) { my $ret = $str =~ /$pat/i; next if $pat eq '-'; ok $ret, "\"$sstr\" =~ /\\xDF/i " . "(str is @{[$utf_ss||'latin']}, pat is " . "@{[$utf_df||'latin']})"; } else { my $ret = $str !~ /$pat/i; next if $pat eq '-'; ok $ret, "\"$sstr\" !~ /\\xDF/i " . "(str is @{[$utf_ss||'latin']}, pat is " . "@{[$utf_df||'latin']})"; } } } } { local $Message = "BBC(Bleadperl Breaks CPAN) Today: String::Multibyte"; my $re = qr/(?:[\x00-\xFF]{4})/; my $hyp = "\0\0\0-"; my $esc = "\0\0\0\\"; my $str = "$esc$hyp$hyp$esc$esc"; my @a = ($str =~ /\G(?:\Q$esc$esc\E|\Q$esc$hyp\E|$re)/g); iseq @a,3; local $" = "="; iseq "@a","$esc$hyp=$hyp=$esc$esc"; } { # Test for keys in %+ and %- local $Message = 'Test keys in %+ and %-'; no warnings 'uninitialized'; my $_ = "abcdef"; /(?a)|(?b)/; iseq ((join ",", sort keys %+), "foo"); iseq ((join ",", sort keys %-), "foo"); iseq ((join ",", sort values %+), "a"); iseq ((join ",", sort map "@$_", values %-), "a "); /(?a)(?b)(?.)/; iseq ((join ",", sort keys %+), "bar,quux"); iseq ((join ",", sort keys %-), "bar,quux"); iseq ((join ",", sort values %+), "a,c"); # leftmost iseq ((join ",", sort map "@$_", values %-), "a b,c"); /(?a)(?c)?/; # second buffer won't capture iseq ((join ",", sort keys %+), "un"); iseq ((join ",", sort keys %-), "deux,un"); iseq ((join ",", sort values %+), "a"); iseq ((join ",", sort map "@$_", values %-), ",a"); } { # length() on captures, the numbered ones end up in Perl_magic_len my $_ = "aoeu \xe6var ook"; /^ \w+ \s (?\S+)/x; iseq length ($`), 0, q[length $`]; iseq length ($'), 4, q[length $']; iseq length ($&), 9, q[length $&]; iseq length ($1), 4, q[length $1]; iseq length ($+{eek}), 4, q[length $+{eek} == length $1]; } { my $ok = -1; $ok = exists ($-{x}) ? 1 : 0 if 'bar' =~ /(?foo)|bar/; iseq $ok, 1, '$-{x} exists after "bar"=~/(?foo)|bar/'; iseq scalar (%+), 0, 'scalar %+ == 0 after "bar"=~/(?foo)|bar/'; iseq scalar (%-), 1, 'scalar %- == 1 after "bar"=~/(?foo)|bar/'; $ok = -1; $ok = exists ($+{x}) ? 1 : 0 if 'bar' =~ /(?foo)|bar/; iseq $ok, 0, '$+{x} not exists after "bar"=~/(?foo)|bar/'; iseq scalar (%+), 0, 'scalar %+ == 0 after "bar"=~/(?foo)|bar/'; iseq scalar (%-), 1, 'scalar %- == 1 after "bar"=~/(?foo)|bar/'; $ok = -1; $ok = exists ($-{x}) ? 1 : 0 if 'foo' =~ /(?foo)|bar/; iseq $ok, 1, '$-{x} exists after "foo"=~/(?foo)|bar/'; iseq scalar (%+), 1, 'scalar %+ == 1 after "foo"=~/(?foo)|bar/'; iseq scalar (%-), 1, 'scalar %- == 1 after "foo"=~/(?foo)|bar/'; $ok = -1; $ok = exists ($+{x}) ? 1 : 0 if 'foo'=~/(?foo)|bar/; iseq $ok, 1, '$+{x} exists after "foo"=~/(?foo)|bar/'; } { local $_; ($_ = 'abc') =~ /(abc)/g; $_ = '123'; iseq "$1", 'abc', "/g leads to unsafe match vars: $1"; } { local $Message = 'Message-ID: <20070818091501.7eff4831@r2d2>'; my $str = ""; for (0 .. 5) { my @x; $str .= "@x"; # this should ALWAYS be the empty string 'a' =~ /(a|)/; push @x, 1; } iseq length ($str), 0, "Trie scope error, string should be empty"; $str = ""; my @foo = ('a') x 5; for (@foo) { my @bar; $str .= "@bar"; s/a|/push @bar, 1/e; } iseq length ($str), 0, "Trie scope error, string should be empty"; } { # more TRIE/AHOCORASICK problems with mixed utf8 / latin-1 and case folding for my $chr (160 .. 255) { my $chr_byte = chr($chr); my $chr_utf8 = chr($chr); utf8::upgrade($chr_utf8); my $rx = qr{$chr_byte|X}i; ok($chr_utf8 =~ $rx, "utf8/latin, codepoint $chr"); } } { our $a = 3; "" =~ /(??{ $a })/; our $b = $a; iseq $b, $a, "Copy of scalar used for postponed subexpression"; } { our @ctl_n = (); our @plus = (); our $nested_tags; $nested_tags = qr{ < (\w+) (?{ push @ctl_n,$^N; push @plus,$+; }) > (??{$nested_tags})* }x; my $match = '' =~ m/^$nested_tags$/; ok $match, 'nested construct matches'; iseq "@ctl_n", "bla blubb", '$^N inside of (?{}) works as expected'; iseq "@plus", "bla blubb", '$+ inside of (?{}) works as expected'; } SKIP: { # XXX: This set of tests is essentially broken, POSIX character classes # should not have differing definitions under Unicode. # There are property names for that. skip "Tests assume ASCII", 4 unless $IS_ASCII; my @notIsPunct = grep {/[[:punct:]]/ and not /\p{IsPunct}/} map {chr} 0x20 .. 0x7f; iseq join ('', @notIsPunct), '$+<=>^`|~', '[:punct:] disagress with IsPunct on Symbols'; my @isPrint = grep {not /[[:print:]]/ and /\p{IsPrint}/} map {chr} 0 .. 0x1f, 0x7f .. 0x9f; iseq join ('', @isPrint), "", 'IsPrint agrees with [:print:] on control characters'; my @isPunct = grep {/[[:punct:]]/ != /\p{IsPunct}/} map {chr} 0x80 .. 0xff; iseq join ('', @isPunct), "\xa1\xab\xb7\xbb\xbf", # ¡ « · » ¿ 'IsPunct disagrees with [:punct:] outside ASCII'; my @isPunctLatin1 = eval q { use encoding 'latin1'; grep {/[[:punct:]]/ != /\p{IsPunct}/} map {chr} 0x80 .. 0xff; }; skip "Eval failed ($@)", 1 if $@; skip "PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS set to 0", 1 if !$ENV{PERL_TEST_LEGACY_POSIX_CC}; iseq join ('', @isPunctLatin1), '', 'IsPunct agrees with [:punct:] with explicit Latin1'; } # # Keep the following tests last -- they may crash perl # print "# Tests that follow may crash perl\n"; { eval '/\k/'; ok $@ =~ /\QSequence \k... not terminated in regex;\E/, 'Lone \k not allowed'; } { local $Message = "Substitution with lookahead (possible segv)"; $_ = "ns1ns1ns1"; s/ns(?=\d)/ns_/g; iseq $_, "ns_1ns_1ns_1"; $_ = "ns1"; s/ns(?=\d)/ns_/; iseq $_, "ns_1"; $_ = "123"; s/(?=\d+)|(?<=\d)/!Bang!/g; iseq $_, "!Bang!1!Bang!2!Bang!3!Bang!"; } { # Earlier versions of Perl said this was fatal. local $Message = "U+0FFFF shouldn't crash the regex engine"; no warnings 'utf8'; my $a = eval "chr(65535)"; use warnings; my $warning_message; local $SIG{__WARN__} = sub { $warning_message = $_[0] }; eval $a =~ /[a-z]/; ok(1); # If it didn't crash, it worked. } } # End of sub run_tests 1; perl-5.12.0-RC0/t/re/qr.t0000555000175000017500000000364111326750237013622 0ustar jessejesse#!./perl -w BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } plan tests => 5; my $rx = qr//; is(ref $rx, "Regexp", "qr// blessed into `Regexp' by default"); # Make sure /$qr/ doesn’t clobber match vars before the match (bug 70764). { my $output = ''; my $rx = qr/o/; my $a = "ooaoaoao"; my $foo = 0; $foo += () = ($a =~ /$rx/g); $output .= "$foo\n"; # correct $foo = 0; for ($foo += ($a =~ /o/); $' && ($' =~ /o/) && ($foo++) ; ) { ; } $output .= "1: $foo\n"; # No error $foo = 0; for ($foo += ($a =~ /$rx/); $' && ($' =~ /$rx/) && ($foo++) ; ) { ; } $output .= "2: $foo\n"; # initialization warning, incorrect results is $output, "5\n1: 5\n2: 5\n", '$a_match_var =~ /$qr/'; } for my $_($'){ my $output = ''; my $rx = qr/o/; my $a = "ooaoaoao"; my $foo = 0; $foo += () = ($a =~ /$rx/g); $output .= "$foo\n"; # correct $foo = 0; for ($foo += ($a =~ /o/); $' && /o/ && ($foo++) ; ) { ; } $output .= "1: $foo\n"; # No error $foo = 0; for ($foo += ($a =~ /$rx/); $' && /$rx/ && ($foo++) ; ) { ; } $output .= "2: $foo\n"; # initialization warning, incorrect results is $output, "5\n1: 5\n2: 5\n", '/$qr/ with my $_ aliased to a match var'; } for($'){ my $output = ''; my $rx = qr/o/; my $a = "ooaoaoao"; my $foo = 0; $foo += () = ($a =~ /$rx/g); $output .= "$foo\n"; # correct $foo = 0; for ($foo += ($a =~ /o/); $' && /o/ && ($foo++) ; ) { ; } $output .= "1: $foo\n"; # No error $foo = 0; for ($foo += ($a =~ /$rx/); $' && /$rx/ && ($foo++) ; ) { ; } $output .= "2: $foo\n"; # initialization warning, incorrect results is $output, "5\n1: 5\n2: 5\n", q|/$qr/ with $'_ aliased to a match var|; } # Make sure /$qr/ calls get-magic on its LHS (bug ~~~~~). { my $scratch; sub qrBug::TIESCALAR{bless[], 'qrBug'} sub qrBug::FETCH { $scratch .= "[fetching]"; 'glat' } tie my $flile, "qrBug"; $flile =~ qr/(?:)/; is $scratch, "[fetching]", '/$qr/ with magical LHS'; } perl-5.12.0-RC0/t/re/reg_mesg.t0000555000175000017500000001415611325127002014756 0ustar jessejesse#!./perl -w BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } my $debug = 1; ## ## If the markers used are changed (search for "MARKER1" in regcomp.c), ## update only these two variables, and leave the {#} in the @death/@warning ## arrays below. The {#} is a meta-marker -- it marks where the marker should ## go. my $marker1 = "<-- HERE"; my $marker2 = " <-- HERE "; ## ## Key-value pairs of code/error of code that should have fatal errors. ## eval 'use Config'; # assume defaults if fail our %Config; my $inf_m1 = ($Config{reg_infty} || 32767) - 1; my $inf_p1 = $inf_m1 + 2; my @death = ( '/[[=foo=]]/' => 'POSIX syntax [= =] is reserved for future extensions in regex; marked by {#} in m/[[=foo=]{#}]/', '/(?<= .*)/' => 'Variable length lookbehind not implemented in regex m/(?<= .*)/', '/(?<= x{1000})/' => 'Lookbehind longer than 255 not implemented in regex m/(?<= x{1000})/', '/(?@)/' => 'Sequence (?@...) not implemented in regex; marked by {#} in m/(?@{#})/', '/(?{ 1/' => 'Sequence (?{...}) not terminated or not {}-balanced in regex; marked by {#} in m/(?{{#} 1/', '/(?(1x))/' => 'Switch condition not recognized in regex; marked by {#} in m/(?(1x{#}))/', '/(?(1)x|y|z)/' => 'Switch (?(condition)... contains too many branches in regex; marked by {#} in m/(?(1)x|y|{#}z)/', '/(?(x)y|x)/' => 'Unknown switch condition (?(x) in regex; marked by {#} in m/(?({#}x)y|x)/', '/(?/' => 'Sequence (? incomplete in regex; marked by {#} in m/(?{#}/', '/(?;x/' => 'Sequence (?;...) not recognized in regex; marked by {#} in m/(?;{#}x/', '/(?<;x/' => 'Sequence (?<;...) not recognized in regex; marked by {#} in m/(?<;{#}x/', '/(?\ix/' => 'Sequence (?\...) not recognized in regex; marked by {#} in m/(?\{#}ix/', '/(?\mx/' => 'Sequence (?\...) not recognized in regex; marked by {#} in m/(?\{#}mx/', '/(?\:x/' => 'Sequence (?\...) not recognized in regex; marked by {#} in m/(?\{#}:x/', '/(?\=x/' => 'Sequence (?\...) not recognized in regex; marked by {#} in m/(?\{#}=x/', '/(?\!x/' => 'Sequence (?\...) not recognized in regex; marked by {#} in m/(?\{#}!x/', '/(?\<=x/' => 'Sequence (?\...) not recognized in regex; marked by {#} in m/(?\{#}<=x/', '/(?\ 'Sequence (?\...) not recognized in regex; marked by {#} in m/(?\{#}x/' => 'Sequence (?\...) not recognized in regex; marked by {#} in m/(?\{#}>x/', '/((x)/' => 'Unmatched ( in regex; marked by {#} in m/({#}(x)/', "/x{$inf_p1}/" => "Quantifier in {,} bigger than $inf_m1 in regex; marked by {#} in m/x{{#}$inf_p1}/", '/x{3,1}/' => 'Can\'t do {n,m} with n > m in regex; marked by {#} in m/x{3,1}{#}/', '/x**/' => 'Nested quantifiers in regex; marked by {#} in m/x**{#}/', '/x[/' => 'Unmatched [ in regex; marked by {#} in m/x[{#}/', '/*/', => 'Quantifier follows nothing in regex; marked by {#} in m/*{#}/', '/\p{x/' => 'Missing right brace on \p{} in regex; marked by {#} in m/\p{{#}x/', '/[\p{x]/' => 'Missing right brace on \p{} in regex; marked by {#} in m/[\p{{#}x]/', '/(x)\2/' => 'Reference to nonexistent group in regex; marked by {#} in m/(x)\2{#}/', 'my $m = "\\\"; $m =~ $m', => 'Trailing \ in regex m/\/', '/\x{1/' => 'Missing right brace on \x{} in regex; marked by {#} in m/\x{{#}1/', '/[\x{X]/' => 'Missing right brace on \x{} in regex; marked by {#} in m/[\x{{#}X]/', '/[[:barf:]]/' => 'POSIX class [:barf:] unknown in regex; marked by {#} in m/[[:barf:]{#}]/', '/[[=barf=]]/' => 'POSIX syntax [= =] is reserved for future extensions in regex; marked by {#} in m/[[=barf=]{#}]/', '/[[.barf.]]/' => 'POSIX syntax [. .] is reserved for future extensions in regex; marked by {#} in m/[[.barf.]{#}]/', '/[z-a]/' => 'Invalid [] range "z-a" in regex; marked by {#} in m/[z-a{#}]/', '/\p/' => 'Empty \p{} in regex; marked by {#} in m/\p{#}/', '/\P{}/' => 'Empty \P{} in regex; marked by {#} in m/\P{{#}}/', ); ## ## Key-value pairs of code/error of code that should have non-fatal warnings. ## @warning = ( 'm/\b*/' => '\b* matches null string many times in regex; marked by {#} in m/\b*{#}/', 'm/[:blank:]/' => 'POSIX syntax [: :] belongs inside character classes in regex; marked by {#} in m/[:blank:]{#}/', "m'[\\y]'" => 'Unrecognized escape \y in character class passed through in regex; marked by {#} in m/[\y{#}]/', 'm/[a-\d]/' => 'False [] range "a-\d" in regex; marked by {#} in m/[a-\d{#}]/', 'm/[\w-x]/' => 'False [] range "\w-" in regex; marked by {#} in m/[\w-{#}x]/', 'm/[a-\pM]/' => 'False [] range "a-\pM" in regex; marked by {#} in m/[a-\pM{#}]/', 'm/[\pM-x]/' => 'False [] range "\pM-" in regex; marked by {#} in m/[\pM-{#}x]/', "m'\\y'" => 'Unrecognized escape \y passed through in regex; marked by {#} in m/\y{#}/', ); my $total = (@death + @warning)/2; # utf8 is a noop on EBCDIC platforms, it is not fatal my $Is_EBCDIC = (ord('A') == 193); if ($Is_EBCDIC) { my @utf8_death = grep(/utf8/, @death); $total = $total - @utf8_death; } print "1..$total\n"; my $count = 0; while (@death) { my $regex = shift @death; my $result = shift @death; # skip the utf8 test on EBCDIC since they do not die next if ($Is_EBCDIC && $regex =~ /utf8/); $count++; $_ = "x"; eval $regex; if (not $@) { print "# oops, $regex didn't die\nnot ok $count\n"; next; } chomp $@; $result =~ s/{\#}/$marker1/; $result =~ s/{\#}/$marker2/; $result .= " at "; if ($@ !~ /^\Q$result/) { print "# For $regex, expected:\n# $result\n# Got:\n# $@\n#\nnot "; } print "ok $count - $regex\n"; } our $warning; $SIG{__WARN__} = sub { $warning = shift }; while (@warning) { $count++; my $regex = shift @warning; my $result = shift @warning; undef $warning; $_ = "x"; eval $regex; if ($@) { print "# oops, $regex died with:\n#\t$@#\nnot ok $count\n"; next; } if (not $warning) { print "# oops, $regex didn't generate a warning\nnot ok $count\n"; next; } $result =~ s/{\#}/$marker1/; $result =~ s/{\#}/$marker2/; $result .= " at "; if ($warning !~ /^\Q$result/) { print <<"EOM"; # For $regex, expected: # $result # Got: # $warning # not ok $count EOM next; } print "ok $count - $regex\n"; } perl-5.12.0-RC0/t/re/pat_psycho.t0000555000175000017500000001221011325127002015324 0ustar jessejesse#!./perl # # This is a home for regular expression tests that don't fit into # the format supported by re/regexp.t. If you want to add a test # that does fit that format, add it to re/re_tests, not here. use strict; use warnings; use 5.010; sub run_tests; $| = 1; BEGIN { chdir 't' if -d 't'; @INC = ('../lib','.'); do "re/ReTest.pl" or die $@; } plan tests => 11; # Update this when adding/deleting tests. run_tests() unless caller; # # Tests start here. # sub run_tests { SKIP: { print "# Set PERL_SKIP_PSYCHO_TEST to skip this test\n"; my @normal = qw [the are some normal words]; skip "Skipped Psycho", 2 * @normal if $ENV {PERL_SKIP_PSYCHO_TEST}; local $" = "|"; my @psycho = (@normal, map chr $_, 255 .. 20000); my $psycho1 = "@psycho"; for (my $i = @psycho; -- $i;) { my $j = int rand (1 + $i); @psycho [$i, $j] = @psycho [$j, $i]; } my $psycho2 = "@psycho"; foreach my $word (@normal) { ok $word =~ /($psycho1)/ && $1 eq $word, 'Psycho'; ok $word =~ /($psycho2)/ && $1 eq $word, 'Psycho'; } } SKIP: { # stress test CURLYX/WHILEM. # # This test includes varying levels of nesting, and according to # profiling done against build 28905, exercises every code line in the # CURLYX and WHILEM blocks, except those related to LONGJMP, the # super-linear cache and warnings. It executes about 0.5M regexes skip "No psycho tests" if $ENV {PERL_SKIP_PSYCHO_TEST}; print "# Set PERL_SKIP_PSYCHO_TEST to skip this test\n"; my $r = qr/^ (?: ( (?:a|z+)+ ) (?: ( (?:b|z+){3,}? ) ( (?: (?: (?:c|z+){1,1}?z )? (?:c|z+){1,1} )* ) (?:z*){2,} ( (?:z+|d)+ ) (?: ( (?:e|z+)+ ) )* ( (?:f|z+)+ ) )* ( (?:z+|g)+ ) (?: ( (?:h|z+)+ ) )* ( (?:i|z+)+ ) )+ ( (?:j|z+)+ ) (?: ( (?:k|z+)+ ) )* ( (?:l|z+)+ ) $/x; my $ok = 1; my $msg = "CURLYX stress test"; OUTER: for my $a ("x","a","aa") { for my $b ("x","bbb","bbbb") { my $bs = $a.$b; for my $c ("x","c","cc") { my $cs = $bs.$c; for my $d ("x","d","dd") { my $ds = $cs.$d; for my $e ("x","e","ee") { my $es = $ds.$e; for my $f ("x","f","ff") { my $fs = $es.$f; for my $g ("x","g","gg") { my $gs = $fs.$g; for my $h ("x","h","hh") { my $hs = $gs.$h; for my $i ("x","i","ii") { my $is = $hs.$i; for my $j ("x","j","jj") { my $js = $is.$j; for my $k ("x","k","kk") { my $ks = $js.$k; for my $l ("x","l","ll") { my $ls = $ks.$l; if ($ls =~ $r) { if ($ls =~ /x/) { $msg .= ": unexpected match for [$ls]"; $ok = 0; last OUTER; } my $cap = "$1$2$3$4$5$6$7$8$9$10$11$12"; unless ($ls eq $cap) { $msg .= ": capture: [$ls], got [$cap]"; $ok = 0; last OUTER; } } else { unless ($ls =~ /x/) { $msg = ": failed for [$ls]"; $ok = 0; last OUTER; } } } } } } } } } } } } } } ok($ok, $msg); } } # End of sub run_tests 1; perl-5.12.0-RC0/t/re/reg_posixcc.t0000555000175000017500000001104411325127002015464 0ustar jessejesse#!perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } use strict; use warnings; plan "no_plan"; my @pats=( "\\w", "\\W", "\\s", "\\S", "\\d", "\\D", "[:alnum:]", "[:^alnum:]", "[:alpha:]", "[:^alpha:]", "[:ascii:]", "[:^ascii:]", "[:cntrl:]", "[:^cntrl:]", "[:graph:]", "[:^graph:]", "[:lower:]", "[:^lower:]", "[:print:]", "[:^print:]", "[:punct:]", "[:^punct:]", "[:upper:]", "[:^upper:]", "[:xdigit:]", "[:^xdigit:]", "[:space:]", "[:^space:]", "[:blank:]", "[:^blank:]" ); if (1 or $ENV{PERL_TEST_LEGACY_POSIX_CC}) { $::TODO = "Only works under PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS = 0"; } sub rangify { my $ary= shift; my $fmt= shift || '%d'; my $sep= shift || ' '; my $rng= shift || '..'; my $first= $ary->[0]; my $last= $ary->[0]; my $ret= sprintf $fmt, $first; for my $idx (1..$#$ary) { if ( $ary->[$idx] != $last + 1) { if ($last!=$first) { $ret.=sprintf "%s$fmt",$rng, $last; } $first= $last= $ary->[$idx]; $ret.=sprintf "%s$fmt",$sep,$first; } else { $last= $ary->[$idx]; } } if ( $last != $first) { $ret.=sprintf "%s$fmt",$rng, $last; } return $ret; } my $description = ""; while (@pats) { my ($yes,$no)= splice @pats,0,2; my %err_by_type; my %singles; my %complements; foreach my $b (0..255) { my %got; for my $type ('unicode','not-unicode') { my $str=chr($b).chr($b); if ($type eq 'unicode') { $str.=chr(256); chop $str; } if ($str=~/[$yes][$no]/){ TODO: { unlike($str,qr/[$yes][$no]/, "chr($b)=~/[$yes][$no]/ should not match under $type"); } push @{$err_by_type{$type}},$b; } $got{"[$yes]"}{$type} = $str=~/[$yes]/ ? 1 : 0; $got{"[$no]"}{$type} = $str=~/[$no]/ ? 1 : 0; $got{"[^$yes]"}{$type} = $str=~/[^$yes]/ ? 1 : 0; $got{"[^$no]"}{$type} = $str=~/[^$no]/ ? 1 : 0; } foreach my $which ("[$yes]","[$no]","[^$yes]","[^$no]") { if ($got{$which}{'unicode'} != $got{$which}{'not-unicode'}){ TODO: { is($got{$which}{'unicode'},$got{$which}{'not-unicode'}, "chr($b)=~/$which/ should have the same results regardless of internal string encoding"); } push @{$singles{$which}},$b; } } foreach my $which ($yes,$no) { foreach my $strtype ('unicode','not-unicode') { if ($got{"[$which]"}{$strtype} == $got{"[^$which]"}{$strtype}) { TODO: { isnt($got{"[$which]"}{$strtype},$got{"[^$which]"}{$strtype}, "chr($b)=~/[$which]/ should not have the same result as chr($b)=~/[^$which]/"); } push @{$complements{$which}{$strtype}},$b; } } } } if (%err_by_type || %singles || %complements) { $description||=" Error:\n"; $description .= "/[$yes][$no]/\n"; if (%err_by_type) { foreach my $type (sort keys %err_by_type) { $description .= "\tmatches $type codepoints:\t"; $description .= rangify($err_by_type{$type}); $description .= "\n"; } $description .= "\n"; } if (%singles) { $description .= "Unicode/Nonunicode mismatches:\n"; foreach my $type (sort keys %singles) { $description .= "\t$type:\t"; $description .= rangify($singles{$type}); $description .= "\n"; } $description .= "\n"; } if (%complements) { foreach my $class (sort keys %complements) { foreach my $strtype (sort keys %{$complements{$class}}) { $description .= "\t$class has complement failures under $strtype for:\t"; $description .= rangify($complements{$class}{$strtype}); $description .= "\n"; } } } } } TODO: { is( $description, "", "POSIX and perl charclasses should not depend on string type"); } __DATA__ perl-5.12.0-RC0/t/re/reg_60508.t0000555000175000017500000000125711325127002014503 0ustar jessejesse#!./perl # This is a test for [perl #60508] which I can't figure out where else # to put it or what the underlying problem is, but it has to go somewhere. # --Schwern BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } use utf8; plan tests => 1; { my $expect = <<"EXPECT"; k1 = .... k2.1 = >\x{2022} k2.2 = \x{2022} EXPECT utf8::encode($expect); #local $TODO = "[perl #60508]"; fresh_perl_is(<<'CODE', $expect, {}); binmode STDOUT, ":utf8"; sub f { $_[0] =~ s/([>X])//g; } $k1 = "." x 4 . ">>"; f($k1); print "k1 = $k1\n"; $k2 = "\x{f1}\x{2022}"; $k2 =~ s/([\360-\362])/>/g; print "k2.1 = $k2\n"; f($k2); print "k2.2 = $k2\n"; CODE } perl-5.12.0-RC0/t/re/regexp_notrie.t0000555000175000017500000000042311325127002016030 0ustar jessejesse#!./perl #use re 'debug'; BEGIN { ${^RE_TRIE_MAXBUF}=-1; #${^RE_DEBUG_FLAGS}=0; } $qr = 1; for $file ('./re/regexp.t', './t/re/regexp.t', ':re:regexp.t') { if (-r $file) { do $file or die $@; exit; } } die "Cannot find ./re/regexp.t or ./t/re/regexp.t\n"; perl-5.12.0-RC0/t/re/subst_wamp.t0000555000175000017500000000032311325127002015341 0ustar jessejesse#!./perl $dummy = defined $&; # Now we have it... for $file ('re/subst.t', 't/re/subst.t', ':re:subst.t') { if (-r $file) { do "./$file"; exit; } } die "Cannot find re/subst.t or t/re/subst.t\n"; perl-5.12.0-RC0/t/re/re_tests0000444000175000017500000013436011340037012014547 0ustar jessejesse# This stops me getting screenfulls of syntax errors every time I accidentally # run this file via a shell glob __END__ abc abc y $& abc abc abc y $-[0] 0 abc abc y $+[0] 3 abc xbc n - - abc axc n - - abc abx n - - abc xabcy y $& abc abc xabcy y $-[0] 1 abc xabcy y $+[0] 4 abc ababc y $& abc abc ababc y $-[0] 2 abc ababc y $+[0] 5 ab*c abc y $& abc ab*c abc y $-[0] 0 ab*c abc y $+[0] 3 ab*bc abc y $& abc ab*bc abc y $-[0] 0 ab*bc abc y $+[0] 3 ab*bc abbc y $& abbc ab*bc abbc y $-[0] 0 ab*bc abbc y $+[0] 4 ab*bc abbbbc y $& abbbbc ab*bc abbbbc y $-[0] 0 ab*bc abbbbc y $+[0] 6 .{1} abbbbc y $& a .{1} abbbbc y $-[0] 0 .{1} abbbbc y $+[0] 1 .{3,4} abbbbc y $& abbb .{3,4} abbbbc y $-[0] 0 .{3,4} abbbbc y $+[0] 4 \N{1} abbbbc y $& a \N{1} abbbbc y $-[0] 0 \N{1} abbbbc y $+[0] 1 /\N {1}/x abbbbc y $& a /\N {1}/x abbbbc y $-[0] 0 /\N {1}/x abbbbc y $+[0] 1 \N{3,4} abbbbc y $& abbb \N{3,4} abbbbc y $-[0] 0 \N{3,4} abbbbc y $+[0] 4 /\N {3,4}/x abbbbc y $& abbb /\N {3,4}/x abbbbc y $-[0] 0 /\N {3,4}/x abbbbc y $+[0] 4 ab{0,}bc abbbbc y $& abbbbc ab{0,}bc abbbbc y $-[0] 0 ab{0,}bc abbbbc y $+[0] 6 ab+bc abbc y $& abbc ab+bc abbc y $-[0] 0 ab+bc abbc y $+[0] 4 ab+bc abc n - - ab+bc abq n - - ab{1,}bc abq n - - ab+bc abbbbc y $& abbbbc ab+bc abbbbc y $-[0] 0 ab+bc abbbbc y $+[0] 6 ab{1,}bc abbbbc y $& abbbbc ab{1,}bc abbbbc y $-[0] 0 ab{1,}bc abbbbc y $+[0] 6 ab{1,3}bc abbbbc y $& abbbbc ab{1,3}bc abbbbc y $-[0] 0 ab{1,3}bc abbbbc y $+[0] 6 ab{3,4}bc abbbbc y $& abbbbc ab{3,4}bc abbbbc y $-[0] 0 ab{3,4}bc abbbbc y $+[0] 6 ab{4,5}bc abbbbc n - - ab?bc abbc y $& abbc ab?bc abc y $& abc ab{0,1}bc abc y $& abc ab?bc abbbbc n - - ab?c abc y $& abc ab{0,1}c abc y $& abc ^abc$ abc y $& abc ^abc$ abcc n - - ^abc abcc y $& abc ^abc$ aabc n - - abc$ aabc y $& abc abc$ aabcd n - - ^ abc y $& $ abc y $& a.c abc y $& abc a.c axc y $& axc a\Nc abc y $& abc /a\N c/x abc y $& abc a.*c axyzc y $& axyzc a\N*c axyzc y $& axyzc /a\N *c/x axyzc y $& axyzc a.*c axyzd n - - a\N*c axyzd n - - /a\N *c/x axyzd n - - a[bc]d abc n - - a[bc]d abd y $& abd a[b]d abd y $& abd [a][b][d] abd y $& abd .[b]. abd y $& abd .[b]. aBd n - - (?i:.[b].) abd y $& abd (?i:\N[b]\N) abd y $& abd a[b-d]e abd n - - a[b-d]e ace y $& ace a[b-d] aac y $& ac a[-b] a- y $& a- a[b-] a- y $& a- a[b-a] - c - Invalid [] range \"b-a\" a[]b - c - Unmatched [ a[ - c - Unmatched [ a] a] y $& a] a[]]b a]b y $& a]b a[^bc]d aed y $& aed a[^bc]d abd n - - a[^-b]c adc y $& adc a[^-b]c a-c n - - a[^]b]c a]c n - - a[^]b]c adc y $& adc \ba\b a- y - - \ba\b -a y - - \ba\b -a- y - - \by\b xy n - - \by\b yz n - - \by\b xyz n - - \Ba\B a- n - - \Ba\B -a n - - \Ba\B -a- n - - \By\b xy y - - \By\b xy y $-[0] 1 \By\b xy y $+[0] 2 \By\b xy y - - \by\B yz y - - \By\B xyz y - - \w a y - - \w - n - - \W a n - - \W - y - - a\sb a b y - - a\sb a-b n - - a\Sb a b n - - a\Sb a-b y - - \d 1 y - - \d - n - - \D 1 n - - \D - y - - [\w] a y - - [\w] - n - - [\W] a n - - [\W] - y - - a[\s]b a b y - - a[\s]b a-b n - - a[\S]b a b n - - a[\S]b a-b y - - [\d] 1 y - - [\d] - n - - [\D] 1 n - - [\D] - y - - ab|cd abc y $& ab ab|cd abcd y $& ab ()ef def y $&-$1 ef- ()ef def y $-[0] 1 ()ef def y $+[0] 3 ()ef def y $-[1] 1 ()ef def y $+[1] 1 *a - c - Quantifier follows nothing (|*)b - c - Quantifier follows nothing (*)b - c - Unknown verb $b b n - - a\ - c - Search pattern not terminated a\(b a(b y $&-$1 a(b- a\(*b ab y $& ab a\(*b a((b y $& a((b a\\b a\\b y $& a\\b abc) - c - Unmatched ) (abc - c - Unmatched ( ((a)) abc y $&-$1-$2 a-a-a ((a)) abc y $-[0]-$-[1]-$-[2] 0-0-0 ((a)) abc y $+[0]-$+[1]-$+[2] 1-1-1 ((a)) abc b @- 0 0 0 ((a)) abc b @+ 1 1 1 (a)b(c) abc y $&-$1-$2 abc-a-c (a)b(c) abc y $-[0]-$-[1]-$-[2] 0-0-2 (a)b(c) abc y $+[0]-$+[1]-$+[2] 3-1-3 a+b+c aabbabc y $& abc a{1,}b{1,}c aabbabc y $& abc a** - c - Nested quantifiers a.+?c abcabc y $& abc (a+|b)* ab y $&-$1 ab-b (a+|b)* ab y $-[0] 0 (a+|b)* ab y $+[0] 2 (a+|b)* ab y $-[1] 1 (a+|b)* ab y $+[1] 2 (a+|b){0,} ab y $&-$1 ab-b (a+|b)+ ab y $&-$1 ab-b (a+|b){1,} ab y $&-$1 ab-b (a+|b)? ab y $&-$1 a-a (a+|b){0,1} ab y $&-$1 a-a )( - c - Unmatched ) [^ab]* cde y $& cde abc n - - a* y $& ([abc])*d abbbcd y $&-$1 abbbcd-c ([abc])*bcd abcd y $&-$1 abcd-a a|b|c|d|e e y $& e (a|b|c|d|e)f ef y $&-$1 ef-e (a|b|c|d|e)f ef y $-[0] 0 (a|b|c|d|e)f ef y $+[0] 2 (a|b|c|d|e)f ef y $-[1] 0 (a|b|c|d|e)f ef y $+[1] 1 abcd*efg abcdefg y $& abcdefg ab* xabyabbbz y $& ab ab* xayabbbz y $& a (ab|cd)e abcde y $&-$1 cde-cd [abhgefdc]ij hij y $& hij ^(ab|cd)e abcde n x$1y xy (abc|)ef abcdef y $&-$1 ef- (a|b)c*d abcd y $&-$1 bcd-b (ab|ab*)bc abc y $&-$1 abc-a a([bc]*)c* abc y $&-$1 abc-bc a([bc]*)(c*d) abcd y $&-$1-$2 abcd-bc-d a([bc]*)(c*d) abcd y $-[0] 0 a([bc]*)(c*d) abcd y $+[0] 4 a([bc]*)(c*d) abcd y $-[1] 1 a([bc]*)(c*d) abcd y $+[1] 3 a([bc]*)(c*d) abcd y $-[2] 3 a([bc]*)(c*d) abcd y $+[2] 4 a([bc]+)(c*d) abcd y $&-$1-$2 abcd-bc-d a([bc]*)(c+d) abcd y $&-$1-$2 abcd-b-cd a([bc]*)(c+d) abcd y $-[0] 0 a([bc]*)(c+d) abcd y $+[0] 4 a([bc]*)(c+d) abcd y $-[1] 1 a([bc]*)(c+d) abcd y $+[1] 2 a([bc]*)(c+d) abcd y $-[2] 2 a([bc]*)(c+d) abcd y $+[2] 4 a[bcd]*dcdcde adcdcde y $& adcdcde a[bcd]+dcdcde adcdcde n - - (ab|a)b*c abc y $&-$1 abc-ab (ab|a)b*c abc y $-[0] 0 (ab|a)b*c abc y $+[0] 3 (ab|a)b*c abc y $-[1] 0 (ab|a)b*c abc y $+[1] 2 ((a)(b)c)(d) abcd y $1-$2-$3-$4 abc-a-b-d ((a)(b)c)(d) abcd y $-[0] 0 ((a)(b)c)(d) abcd y $+[0] 4 ((a)(b)c)(d) abcd y $-[1] 0 ((a)(b)c)(d) abcd y $+[1] 3 ((a)(b)c)(d) abcd y $-[2] 0 ((a)(b)c)(d) abcd y $+[2] 1 ((a)(b)c)(d) abcd y $-[3] 1 ((a)(b)c)(d) abcd y $+[3] 2 ((a)(b)c)(d) abcd y $-[4] 3 ((a)(b)c)(d) abcd y $+[4] 4 [a-zA-Z_][a-zA-Z0-9_]* alpha y $& alpha ^a(bc+|b[eh])g|.h$ abh y $&-$1 bh- (bc+d$|ef*g.|h?i(j|k)) effgz y $&-$1-$2 effgz-effgz- (bc+d$|ef*g.|h?i(j|k)) ij y $&-$1-$2 ij-ij-j (bc+d$|ef*g.|h?i(j|k)) effg n - - (bc+d$|ef*g.|h?i(j|k)) bcdd n - - (bc+d$|ef*g.|h?i(j|k)) reffgz y $&-$1-$2 effgz-effgz- ((((((((((a)))))))))) a y $10 a ((((((((((a)))))))))) a y $-[0] 0 ((((((((((a)))))))))) a y $+[0] 1 ((((((((((a)))))))))) a y $-[10] 0 ((((((((((a)))))))))) a y $+[10] 1 ((((((((((a))))))))))\10 aa y $& aa ((((((((((a))))))))))${bang} aa n - - ((((((((((a))))))))))${bang} a! y $& a! (((((((((a))))))))) a y $& a multiple words of text uh-uh n - - multiple words multiple words, yeah y $& multiple words (.*)c(.*) abcde y $&-$1-$2 abcde-ab-de \((.*), (.*)\) (a, b) y ($2, $1) (b, a) [k] ab n - - abcd abcd y $&-\$&-\\$& abcd-\$&-\\abcd a(bc)d abcd y $1-\$1-\\$1 bc-\$1-\\bc a[-]?c ac y $& ac (abc)\1 abcabc y $1 abc ([a-c]*)\1 abcabc y $1 abc \1 - c - Reference to nonexistent group \2 - c - Reference to nonexistent group \g1 - c - Reference to nonexistent group \g-1 - c - Reference to nonexistent or unclosed group \g{1} - c - Reference to nonexistent group \g{-1} - c - Reference to nonexistent or unclosed group \g0 - c - Reference to invalid group 0 \g-0 - c - Reference to invalid group 0 \g{0} - c - Reference to invalid group 0 \g{-0} - c - Reference to invalid group 0 (a)|\1 a y - - (a)|\1 x n - Reference to group in different branch (?:(b)?a)\1 a n - Reference to group that did not match (a)|\2 - c - Reference to nonexistent group (([a-c])b*?\2)* ababbbcbc y $&-$1-$2 ababb-bb-b (([a-c])b*?\2){3} ababbbcbc y $&-$1-$2 ababbbcbc-cbc-c ((\3|b)\2(a)x)+ aaxabxbaxbbx n - - ((\3|b)\2(a)x)+ aaaxabaxbaaxbbax y $&-$1-$2-$3 bbax-bbax-b-a ((\3|b)\2(a)){2,} bbaababbabaaaaabbaaaabba y $&-$1-$2-$3 bbaaaabba-bba-b-a #Bug #3589 - up to perl-5.6.0 matches incorrectly, from 5.6.1 not anymore ^((.)?a\2)+$ babadad n - - (a)|(b) b y $-[0] 0 (a)|(b) b y $+[0] 1 (a)|(b) b y x$-[1] x (a)|(b) b y x$+[1] x (a)|(b) b y $-[2] 0 (a)|(b) b y $+[2] 1 'abc'i ABC y $& ABC 'abc'i XBC n - - 'abc'i AXC n - - 'abc'i ABX n - - 'abc'i XABCY y $& ABC 'abc'i ABABC y $& ABC 'ab*c'i ABC y $& ABC 'ab*bc'i ABC y $& ABC 'ab*bc'i ABBC y $& ABBC 'ab*?bc'i ABBBBC y $& ABBBBC 'ab{0,}?bc'i ABBBBC y $& ABBBBC 'ab+?bc'i ABBC y $& ABBC 'ab+bc'i ABC n - - 'ab+bc'i ABQ n - - 'ab{1,}bc'i ABQ n - - 'ab+bc'i ABBBBC y $& ABBBBC 'ab{1,}?bc'i ABBBBC y $& ABBBBC 'ab{1,3}?bc'i ABBBBC y $& ABBBBC 'ab{3,4}?bc'i ABBBBC y $& ABBBBC 'ab{4,5}?bc'i ABBBBC n - - 'ab??bc'i ABBC y $& ABBC 'ab??bc'i ABC y $& ABC 'ab{0,1}?bc'i ABC y $& ABC 'ab??bc'i ABBBBC n - - 'ab??c'i ABC y $& ABC 'ab{0,1}?c'i ABC y $& ABC '^abc$'i ABC y $& ABC '^abc$'i ABCC n - - '^abc'i ABCC y $& ABC '^abc$'i AABC n - - 'abc$'i AABC y $& ABC '^'i ABC y $& '$'i ABC y $& 'a.c'i ABC y $& ABC 'a.c'i AXC y $& AXC 'a\Nc'i ABC y $& ABC 'a.*?c'i AXYZC y $& AXYZC 'a.*c'i AXYZD n - - 'a[bc]d'i ABC n - - 'a[bc]d'i ABD y $& ABD 'a[b-d]e'i ABD n - - 'a[b-d]e'i ACE y $& ACE 'a[b-d]'i AAC y $& AC 'a[-b]'i A- y $& A- 'a[b-]'i A- y $& A- 'a[b-a]'i - c - Invalid [] range \"b-a\" 'a[]b'i - c - Unmatched [ 'a['i - c - Unmatched [ 'a]'i A] y $& A] 'a[]]b'i A]B y $& A]B 'a[^bc]d'i AED y $& AED 'a[^bc]d'i ABD n - - 'a[^-b]c'i ADC y $& ADC 'a[^-b]c'i A-C n - - 'a[^]b]c'i A]C n - - 'a[^]b]c'i ADC y $& ADC 'ab|cd'i ABC y $& AB 'ab|cd'i ABCD y $& AB '()ef'i DEF y $&-$1 EF- '*a'i - c - Quantifier follows nothing '(|*)b'i - c - Quantifier follows nothing '(*)b'i - c - Unknown verb '$b'i B n - - 'a\'i - c - Search pattern not terminated 'a\(b'i A(B y $&-$1 A(B- 'a\(*b'i AB y $& AB 'a\(*b'i A((B y $& A((B 'a\\b'i A\\B y $& A\\B 'abc)'i - c - Unmatched ) '(abc'i - c - Unmatched ( '((a))'i ABC y $&-$1-$2 A-A-A '(a)b(c)'i ABC y $&-$1-$2 ABC-A-C 'a+b+c'i AABBABC y $& ABC 'a{1,}b{1,}c'i AABBABC y $& ABC 'a**'i - c - Nested quantifiers 'a.+?c'i ABCABC y $& ABC 'a.*?c'i ABCABC y $& ABC 'a.{0,5}?c'i ABCABC y $& ABC '(a+|b)*'i AB y $&-$1 AB-B '(a+|b){0,}'i AB y $&-$1 AB-B '(a+|b)+'i AB y $&-$1 AB-B '(a+|b){1,}'i AB y $&-$1 AB-B '(a+|b)?'i AB y $&-$1 A-A '(a+|b){0,1}'i AB y $&-$1 A-A '(a+|b){0,1}?'i AB y $&-$1 - ')('i - c - Unmatched ) '[^ab]*'i CDE y $& CDE 'abc'i n - - 'a*'i y $& '([abc])*d'i ABBBCD y $&-$1 ABBBCD-C '([abc])*bcd'i ABCD y $&-$1 ABCD-A 'a|b|c|d|e'i E y $& E '(a|b|c|d|e)f'i EF y $&-$1 EF-E 'abcd*efg'i ABCDEFG y $& ABCDEFG 'ab*'i XABYABBBZ y $& AB 'ab*'i XAYABBBZ y $& A '(ab|cd)e'i ABCDE y $&-$1 CDE-CD '[abhgefdc]ij'i HIJ y $& HIJ '^(ab|cd)e'i ABCDE n x$1y XY '(abc|)ef'i ABCDEF y $&-$1 EF- '(a|b)c*d'i ABCD y $&-$1 BCD-B '(ab|ab*)bc'i ABC y $&-$1 ABC-A 'a([bc]*)c*'i ABC y $&-$1 ABC-BC 'a([bc]*)(c*d)'i ABCD y $&-$1-$2 ABCD-BC-D 'a([bc]+)(c*d)'i ABCD y $&-$1-$2 ABCD-BC-D 'a([bc]*)(c+d)'i ABCD y $&-$1-$2 ABCD-B-CD 'a[bcd]*dcdcde'i ADCDCDE y $& ADCDCDE 'a[bcd]+dcdcde'i ADCDCDE n - - '(ab|a)b*c'i ABC y $&-$1 ABC-AB '((a)(b)c)(d)'i ABCD y $1-$2-$3-$4 ABC-A-B-D '[a-zA-Z_][a-zA-Z0-9_]*'i ALPHA y $& ALPHA '^a(bc+|b[eh])g|.h$'i ABH y $&-$1 BH- '(bc+d$|ef*g.|h?i(j|k))'i EFFGZ y $&-$1-$2 EFFGZ-EFFGZ- '(bc+d$|ef*g.|h?i(j|k))'i IJ y $&-$1-$2 IJ-IJ-J '(bc+d$|ef*g.|h?i(j|k))'i EFFG n - - '(bc+d$|ef*g.|h?i(j|k))'i BCDD n - - '(bc+d$|ef*g.|h?i(j|k))'i REFFGZ y $&-$1-$2 EFFGZ-EFFGZ- '((((((((((a))))))))))'i A y $10 A '((((((((((a))))))))))\10'i AA y $& AA '((((((((((a))))))))))${bang}'i AA n - - '((((((((((a))))))))))${bang}'i A! y $& A! '(((((((((a)))))))))'i A y $& A '(?:(?:(?:(?:(?:(?:(?:(?:(?:(a))))))))))'i A y $1 A '(?:(?:(?:(?:(?:(?:(?:(?:(?:(a|b|c))))))))))'i C y $1 C 'multiple words of text'i UH-UH n - - 'multiple words'i MULTIPLE WORDS, YEAH y $& MULTIPLE WORDS '(.*)c(.*)'i ABCDE y $&-$1-$2 ABCDE-AB-DE '\((.*), (.*)\)'i (A, B) y ($2, $1) (B, A) '[k]'i AB n - - 'abcd'i ABCD y $&-\$&-\\$& ABCD-\$&-\\ABCD 'a(bc)d'i ABCD y $1-\$1-\\$1 BC-\$1-\\BC 'a[-]?c'i AC y $& AC '(abc)\1'i ABCABC y $1 ABC '([a-c]*)\1'i ABCABC y $1 ABC a(?!b). abad y $& ad (?=)a a y $& a a(?=d). abad y $& ad a(?=c|d). abad y $& ad a(?:b|c|d)(.) ace y $1 e a(?:b|c|d)*(.) ace y $1 e a(?:b|c|d)+?(.) ace y $1 e a(?:b|c|d)+?(.) acdbcdbe y $1 d a(?:b|c|d)+(.) acdbcdbe y $1 e a(?:b|c|d){2}(.) acdbcdbe y $1 b a(?:b|c|d){4,5}(.) acdbcdbe y $1 b a(?:b|c|d){4,5}?(.) acdbcdbe y $1 d ((foo)|(bar))* foobar y $1-$2-$3 bar-foo-bar :(?: - c - Sequence (? incomplete a(?:b|c|d){6,7}(.) acdbcdbe y $1 e a(?:b|c|d){6,7}?(.) acdbcdbe y $1 e a(?:b|c|d){5,6}(.) acdbcdbe y $1 e a(?:b|c|d){5,6}?(.) acdbcdbe y $1 b a(?:b|c|d){5,7}(.) acdbcdbe y $1 e a(?:b|c|d){5,7}?(.) acdbcdbe y $1 b a(?:b|(c|e){1,2}?|d)+?(.) ace y $1$2 ce ^(.+)?B AB y $1 A ^([^a-z])|(\^)$ . y $1 . ^[<>]& <&OUT y $& <& ^(a\1?){4}$ aaaaaaaaaa y $1 aaaa ^(a\1?){4}$ aaaaaaaaa n - - ^(a\1?){4}$ aaaaaaaaaaa n - - ^(a(?(1)\1)){4}$ aaaaaaaaaa y $1 aaaa ^(a(?(1)\1)){4}$ aaaaaaaaa n - - ^(a(?(1)\1)){4}$ aaaaaaaaaaa n - - ((a{4})+) aaaaaaaaa y $1 aaaaaaaa (((aa){2})+) aaaaaaaaaa y $1 aaaaaaaa (((a{2}){2})+) aaaaaaaaaa y $1 aaaaaaaa (?:(f)(o)(o)|(b)(a)(r))* foobar y $1:$2:$3:$4:$5:$6 f:o:o:b:a:r (?<=a)b ab y $& b (?<=a)b cb n - - (?<=a)b b n - - (?a+)ab aaab n - - (?>a+)b aaab y - - ([[:]+) a:[b]: y $1 :[ ([[=]+) a=[b]= y $1 =[ ([[.]+) a.[b]. y $1 .[ [a[:xyz: - c - Unmatched [ [a[:xyz:] - c - POSIX class [:xyz:] unknown [a[:]b[:c] abc y $& abc ([a[:xyz:]b]+) pbaq c - POSIX class [:xyz:] unknown [a[:]b[:c] abc y $& abc ([[:alpha:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd ([[:alnum:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy ([[:ascii:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__-- ${nulnul} ([[:cntrl:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ${nulnul} ([[:digit:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 01 ([[:graph:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__-- ([[:lower:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 cd ([[:print:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__-- ([[:punct:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 __-- ([[:space:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ([[:word:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__ ([[:upper:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 AB ([[:xdigit:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01 ([[:^alpha:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 01 ([[:^alnum:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 __-- ${nulnul}${ffff} ([[:^ascii:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ${ffff} ([[:^cntrl:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__-- ([[:^digit:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd ([[:^lower:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 AB ([[:^print:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ${nulnul}${ffff} ([[:^punct:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy ([[:^space:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__-- ([[:^word:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 -- ${nulnul}${ffff} ([[:^upper:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 cd01 ([[:^xdigit:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 Xy__-- ${nulnul}${ffff} [[:foo:]] - c - POSIX class [:foo:] unknown [[:^foo:]] - c - POSIX class [:^foo:] unknown ((?>a+)b) aaab y $1 aaab (?>(a+))b aaab y $1 aaa ((?>[^()]+)|\([^()]*\))+ ((abc(ade)ufh()()x y $& abc(ade)ufh()()x (?<=x+)y - c - Variable length lookbehind not implemented a{37,17} - c - Can't do {n,m} with n > m a{37,0} - c - Can't do {n,m} with n > m \Z a\nb\n y $-[0] 3 \z a\nb\n y $-[0] 4 $ a\nb\n y $-[0] 3 \Z b\na\n y $-[0] 3 \z b\na\n y $-[0] 4 $ b\na\n y $-[0] 3 \Z b\na y $-[0] 3 \z b\na y $-[0] 3 $ b\na y $-[0] 3 '\Z'm a\nb\n y $-[0] 3 '\z'm a\nb\n y $-[0] 4 '$'m a\nb\n y $-[0] 1 '\Z'm b\na\n y $-[0] 3 '\z'm b\na\n y $-[0] 4 '$'m b\na\n y $-[0] 1 '\Z'm b\na y $-[0] 3 '\z'm b\na y $-[0] 3 '$'m b\na y $-[0] 1 a\Z a\nb\n n - - a\z a\nb\n n - - a$ a\nb\n n - - a\Z b\na\n y $-[0] 2 a\z b\na\n n - - a$ b\na\n y $-[0] 2 a\Z b\na y $-[0] 2 a\z b\na y $-[0] 2 a$ b\na y $-[0] 2 'a\Z'm a\nb\n n - - 'a\z'm a\nb\n n - - 'a$'m a\nb\n y $-[0] 0 'a\Z'm b\na\n y $-[0] 2 'a\z'm b\na\n n - - 'a$'m b\na\n y $-[0] 2 'a\Z'm b\na y $-[0] 2 'a\z'm b\na y $-[0] 2 'a$'m b\na y $-[0] 2 aa\Z aa\nb\n n - - aa\z aa\nb\n n - - aa$ aa\nb\n n - - aa\Z b\naa\n y $-[0] 2 aa\z b\naa\n n - - aa$ b\naa\n y $-[0] 2 aa\Z b\naa y $-[0] 2 aa\z b\naa y $-[0] 2 aa$ b\naa y $-[0] 2 'aa\Z'm aa\nb\n n - - 'aa\z'm aa\nb\n n - - 'aa$'m aa\nb\n y $-[0] 0 'aa\Z'm b\naa\n y $-[0] 2 'aa\z'm b\naa\n n - - 'aa$'m b\naa\n y $-[0] 2 'aa\Z'm b\naa y $-[0] 2 'aa\z'm b\naa y $-[0] 2 'aa$'m b\naa y $-[0] 2 aa\Z ac\nb\n n - - aa\z ac\nb\n n - - aa$ ac\nb\n n - - aa\Z b\nac\n n - - aa\z b\nac\n n - - aa$ b\nac\n n - - aa\Z b\nac n - - aa\z b\nac n - - aa$ b\nac n - - 'aa\Z'm ac\nb\n n - - 'aa\z'm ac\nb\n n - - 'aa$'m ac\nb\n n - - 'aa\Z'm b\nac\n n - - 'aa\z'm b\nac\n n - - 'aa$'m b\nac\n n - - 'aa\Z'm b\nac n - - 'aa\z'm b\nac n - - 'aa$'m b\nac n - - aa\Z ca\nb\n n - - aa\z ca\nb\n n - - aa$ ca\nb\n n - - aa\Z b\nca\n n - - aa\z b\nca\n n - - aa$ b\nca\n n - - aa\Z b\nca n - - aa\z b\nca n - - aa$ b\nca n - - 'aa\Z'm ca\nb\n n - - 'aa\z'm ca\nb\n n - - 'aa$'m ca\nb\n n - - 'aa\Z'm b\nca\n n - - 'aa\z'm b\nca\n n - - 'aa$'m b\nca\n n - - 'aa\Z'm b\nca n - - 'aa\z'm b\nca n - - 'aa$'m b\nca n - - ab\Z ab\nb\n n - - ab\z ab\nb\n n - - ab$ ab\nb\n n - - ab\Z b\nab\n y $-[0] 2 ab\z b\nab\n n - - ab$ b\nab\n y $-[0] 2 ab\Z b\nab y $-[0] 2 ab\z b\nab y $-[0] 2 ab$ b\nab y $-[0] 2 'ab\Z'm ab\nb\n n - - 'ab\z'm ab\nb\n n - - 'ab$'m ab\nb\n y $-[0] 0 'ab\Z'm b\nab\n y $-[0] 2 'ab\z'm b\nab\n n - - 'ab$'m b\nab\n y $-[0] 2 'ab\Z'm b\nab y $-[0] 2 'ab\z'm b\nab y $-[0] 2 'ab$'m b\nab y $-[0] 2 ab\Z ac\nb\n n - - ab\z ac\nb\n n - - ab$ ac\nb\n n - - ab\Z b\nac\n n - - ab\z b\nac\n n - - ab$ b\nac\n n - - ab\Z b\nac n - - ab\z b\nac n - - ab$ b\nac n - - 'ab\Z'm ac\nb\n n - - 'ab\z'm ac\nb\n n - - 'ab$'m ac\nb\n n - - 'ab\Z'm b\nac\n n - - 'ab\z'm b\nac\n n - - 'ab$'m b\nac\n n - - 'ab\Z'm b\nac n - - 'ab\z'm b\nac n - - 'ab$'m b\nac n - - ab\Z ca\nb\n n - - ab\z ca\nb\n n - - ab$ ca\nb\n n - - ab\Z b\nca\n n - - ab\z b\nca\n n - - ab$ b\nca\n n - - ab\Z b\nca n - - ab\z b\nca n - - ab$ b\nca n - - 'ab\Z'm ca\nb\n n - - 'ab\z'm ca\nb\n n - - 'ab$'m ca\nb\n n - - 'ab\Z'm b\nca\n n - - 'ab\z'm b\nca\n n - - 'ab$'m b\nca\n n - - 'ab\Z'm b\nca n - - 'ab\z'm b\nca n - - 'ab$'m b\nca n - - abb\Z abb\nb\n n - - abb\z abb\nb\n n - - abb$ abb\nb\n n - - abb\Z b\nabb\n y $-[0] 2 abb\z b\nabb\n n - - abb$ b\nabb\n y $-[0] 2 abb\Z b\nabb y $-[0] 2 abb\z b\nabb y $-[0] 2 abb$ b\nabb y $-[0] 2 'abb\Z'm abb\nb\n n - - 'abb\z'm abb\nb\n n - - 'abb$'m abb\nb\n y $-[0] 0 'abb\Z'm b\nabb\n y $-[0] 2 'abb\z'm b\nabb\n n - - 'abb$'m b\nabb\n y $-[0] 2 'abb\Z'm b\nabb y $-[0] 2 'abb\z'm b\nabb y $-[0] 2 'abb$'m b\nabb y $-[0] 2 abb\Z ac\nb\n n - - abb\z ac\nb\n n - - abb$ ac\nb\n n - - abb\Z b\nac\n n - - abb\z b\nac\n n - - abb$ b\nac\n n - - abb\Z b\nac n - - abb\z b\nac n - - abb$ b\nac n - - 'abb\Z'm ac\nb\n n - - 'abb\z'm ac\nb\n n - - 'abb$'m ac\nb\n n - - 'abb\Z'm b\nac\n n - - 'abb\z'm b\nac\n n - - 'abb$'m b\nac\n n - - 'abb\Z'm b\nac n - - 'abb\z'm b\nac n - - 'abb$'m b\nac n - - abb\Z ca\nb\n n - - abb\z ca\nb\n n - - abb$ ca\nb\n n - - abb\Z b\nca\n n - - abb\z b\nca\n n - - abb$ b\nca\n n - - abb\Z b\nca n - - abb\z b\nca n - - abb$ b\nca n - - 'abb\Z'm ca\nb\n n - - 'abb\z'm ca\nb\n n - - 'abb$'m ca\nb\n n - - 'abb\Z'm b\nca\n n - - 'abb\z'm b\nca\n n - - 'abb$'m b\nca\n n - - 'abb\Z'm b\nca n - - 'abb\z'm b\nca n - - 'abb$'m b\nca n - - (^|x)(c) ca y $2 c a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz x n - - a(?{$a=2;$b=3;($b)=$a})b yabz y $b 2 round\(((?>[^()]+))\) _I(round(xs * sz),1) y $1 xs * sz '((?x:.) )' x y $1- x - '((?-x:.) )'x x y $1- x- foo.bart foo.bart y - - '^d[x][x][x]'m abcd\ndxxx y - - .X(.+)+X bbbbXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - .X(.+)+XX bbbbXcXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - .XX(.+)+X bbbbXXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - .X(.+)+X bbbbXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - .X(.+)+XX bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - .XX(.+)+X bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - .X(.+)+[X] bbbbXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - .X(.+)+[X][X] bbbbXcXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - .XX(.+)+[X] bbbbXXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - .X(.+)+[X] bbbbXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - .X(.+)+[X][X] bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - .XX(.+)+[X] bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - .[X](.+)+[X] bbbbXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - .[X](.+)+[X][X] bbbbXcXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - .[X][X](.+)+[X] bbbbXXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - .[X](.+)+[X] bbbbXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - .[X](.+)+[X][X] bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - .[X][X](.+)+[X] bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - tt+$ xxxtt y - - ([a-\d]+) za-9z y $1 a-9 ([\d-z]+) a0-za y $1 0-z ([\d-\s]+) a0- z y $1 0- ([a-[:digit:]]+) za-9z y $1 a-9 ([[:digit:]-z]+) =0-z= y $1 0-z ([[:digit:]-[:alpha:]]+) =0-z= y $1 0-z \GX.*X aaaXbX n - - (\d+\.\d+) 3.1415926 y $1 3.1415926 (\ba.{0,10}br) have a web browser y $1 a web br '\.c(pp|xx|c)?$'i Changes n - - '\.c(pp|xx|c)?$'i IO.c y - - '(\.c(pp|xx|c)?$)'i IO.c y $1 .c ^([a-z]:) C:/ n - - '^\S\s+aa$'m \nx aa y - - (^|a)b ab y - - ^([ab]*?)(b)?(c)$ abac y -$2- -- (\w)?(abc)\1b abcab n - - ^(?:.,){2}c a,b,c y - - ^(.,){2}c a,b,c y $1 b, ^(?:[^,]*,){2}c a,b,c y - - ^([^,]*,){2}c a,b,c y $1 b, ^([^,]*,){3}d aaa,b,c,d y $1 c, ^([^,]*,){3,}d aaa,b,c,d y $1 c, ^([^,]*,){0,3}d aaa,b,c,d y $1 c, ^([^,]{1,3},){3}d aaa,b,c,d y $1 c, ^([^,]{1,3},){3,}d aaa,b,c,d y $1 c, ^([^,]{1,3},){0,3}d aaa,b,c,d y $1 c, ^([^,]{1,},){3}d aaa,b,c,d y $1 c, ^([^,]{1,},){3,}d aaa,b,c,d y $1 c, ^([^,]{1,},){0,3}d aaa,b,c,d y $1 c, ^([^,]{0,3},){3}d aaa,b,c,d y $1 c, ^([^,]{0,3},){3,}d aaa,b,c,d y $1 c, ^([^,]{0,3},){0,3}d aaa,b,c,d y $1 c, (?i) y - - '(?!\A)x'm a\nxb\n y - - ^(a(b)?)+$ aba y -$1-$2- -a-- ^(aa(bb)?)+$ aabbaa y -$1-$2- -aa-- '^.{9}abc.*\n'm 123\nabcabcabcabc\n y - - ^(a)?a$ a y -$1- -- ^(a)?(?(1)a|b)+$ a n - - ^(a\1?)(a\1?)(a\2?)(a\3?)$ aaaaaa y $1,$2,$3,$4 a,aa,a,aa ^(a\1?){4}$ aaaaaa y $1 aa ^(0+)?(?:x(1))? x1 y - - ^([0-9a-fA-F]+)(?:x([0-9a-fA-F]+)?)(?:x([0-9a-fA-F]+))? 012cxx0190 y - - ^(b+?|a){1,2}c bbbac y $1 a ^(b+?|a){1,2}c bbbbac y $1 a \((\w\. \w+)\) cd. (A. Tw) y -$1- -A. Tw- ((?:aaaa|bbbb)cccc)? aaaacccc y - - ((?:aaaa|bbbb)cccc)? bbbbcccc y - - (a)?(a)+ a y $1:$2 :a - (ab)?(ab)+ ab y $1:$2 :ab - (abc)?(abc)+ abc y $1:$2 :abc - 'b\s^'m a\nb\n n - - \ba a y - - ^(a(??{"(?!)"})|(a)(?{1}))b ab y $2 a # [ID 20010811.006] ab(?i)cd AbCd n - - # [ID 20010809.023] ab(?i)cd abCd y - - (A|B)*(?(1)(CD)|(CD)) CD y $2-$3 -CD (A|B)*(?(1)(CD)|(CD)) ABCD y $2-$3 CD- (A|B)*?(?(1)(CD)|(CD)) CD y $2-$3 -CD # [ID 20010803.016] (A|B)*?(?(1)(CD)|(CD)) ABCD y $2-$3 CD- '^(o)(?!.*\1)'i Oo n - - (.*)\d+\1 abc12bc y $1 bc (?m:(foo\s*$)) foo\n bar y $1 foo (.*)c abcd y $1 ab (.*)(?=c) abcd y $1 ab (.*)(?=c)c abcd yB $1 ab (.*)(?=b|c) abcd y $1 ab (.*)(?=b|c)c abcd y $1 ab (.*)(?=c|b) abcd y $1 ab (.*)(?=c|b)c abcd y $1 ab (.*)(?=[bc]) abcd y $1 ab (.*)(?=[bc])c abcd yB $1 ab (.*)(?<=b) abcd y $1 ab (.*)(?<=b)c abcd y $1 ab (.*)(?<=b|c) abcd y $1 abc (.*)(?<=b|c)c abcd y $1 ab (.*)(?<=c|b) abcd y $1 abc (.*)(?<=c|b)c abcd y $1 ab (.*)(?<=[bc]) abcd y $1 abc (.*)(?<=[bc])c abcd y $1 ab (.*?)c abcd y $1 ab (.*?)(?=c) abcd y $1 ab (.*?)(?=c)c abcd yB $1 ab (.*?)(?=b|c) abcd y $1 a (.*?)(?=b|c)c abcd y $1 ab (.*?)(?=c|b) abcd y $1 a (.*?)(?=c|b)c abcd y $1 ab (.*?)(?=[bc]) abcd y $1 a (.*?)(?=[bc])c abcd yB $1 ab (.*?)(?<=b) abcd y $1 ab (.*?)(?<=b)c abcd y $1 ab (.*?)(?<=b|c) abcd y $1 ab (.*?)(?<=b|c)c abcd y $1 ab (.*?)(?<=c|b) abcd y $1 ab (.*?)(?<=c|b)c abcd y $1 ab (.*?)(?<=[bc]) abcd y $1 ab (.*?)(?<=[bc])c abcd y $1 ab 2(]*)?$\1 2 y $& 2 (??{}) x y - - a(b)?? abc y <$1> <> # undef [perl #16773] (\d{1,3}\.){3,} 128.134.142.8 y <$1> <142.> # [perl #18019] ^.{3,4}(.+)\1\z foobarbar y $1 bar # 16 tests for [perl #23171] ^(?:f|o|b){3,4}(.+)\1\z foobarbar y $1 bar ^.{3,4}((?:b|a|r)+)\1\z foobarbar y $1 bar ^(?:f|o|b){3,4}((?:b|a|r)+)\1\z foobarbar y $1 bar ^.{3,4}(.+?)\1\z foobarbar y $1 bar ^(?:f|o|b){3,4}(.+?)\1\z foobarbar y $1 bar ^.{3,4}((?:b|a|r)+?)\1\z foobarbar y $1 bar ^(?:f|o|b){3,4}((?:b|a|r)+?)\1\z foobarbar y $1 bar ^.{2,3}?(.+)\1\z foobarbar y $1 bar ^(?:f|o|b){2,3}?(.+)\1\z foobarbar y $1 bar ^.{2,3}?((?:b|a|r)+)\1\z foobarbar y $1 bar ^(?:f|o|b){2,3}?((?:b|a|r)+)\1\z foobarbar y $1 bar ^.{2,3}?(.+?)\1\z foobarbar y $1 bar ^(?:f|o|b){2,3}?(.+?)\1\z foobarbar y $1 bar ^.{2,3}?((?:b|a|r)+?)\1\z foobarbar y $1 bar ^(?:f|o|b){2,3}?((?:b|a|r)+?)\1\z foobarbar y $1 bar .*a(?!(b|cd)*e).*f ......abef n - - # [perl #23030] x(?# x c - Sequence (?#... not terminated :x(?#: x c - Sequence (?#... not terminated (WORDS|WORD)S WORDS y $1 WORD (X.|WORDS|X.|WORD)S WORDS y $1 WORD (WORDS|WORLD|WORD)S WORDS y $1 WORD (X.|WORDS|WORD|Y.)S WORDS y $1 WORD (foo|fool|x.|money|parted)$ fool y $1 fool (x.|foo|fool|x.|money|parted|y.)$ fool y $1 fool (foo|fool|money|parted)$ fool y $1 fool (foo|fool|x.|money|parted)$ fools n - - (x.|foo|fool|x.|money|parted|y.)$ fools n - - (foo|fool|money|parted)$ fools n - - (a|aa|aaa||aaaa|aaaaa|aaaaaa)(b|c) aaaaaaaaaaaaaaab y $1$2 aaaaaab (a|aa|aaa||aaaa|aaaaa|aaaaaa)(??{$1&&""})(b|c) aaaaaaaaaaaaaaab y $1$2 aaaaaab (a|aa|aaa|aaaa|aaaaa|aaaaaa)(??{$1&&"foo"})(b|c) aaaaaaaaaaaaaaab n - - ^(a*?)(?!(aa|aaaa)*$) aaaaaaaaaaaaaaaaaaaa y $1 a # [perl #34195] ^(a*?)(?!(aa|aaaa)*$)(?=a\z) aaaaaaaa y $1 aaaaaaa ^(.)\s+.$(?(1)) A B y $1 A # [perl #37688] (?:r?)*?r|(.{2,4}) abcde y $1 abcd (?!)+?|(.{2,4}) abcde y $1 abcd ^(a*?)(?!(a{6}|a{5})*$) aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y $+[1] 12 # super-linear cache bug may return 18 ^((?>(?:aa)?b)?) aab y $1 aab ^((?:aa)*)(?:X+((?:\d+|-)(?:X+(.+))?))?$ aaaaX5 y $1 aaaa X(A|B||C|D)Y XXXYYY y $& XY # Trie w/ NOTHING (?i:X([A]|[B]|y[Y]y|[D]|)Y) XXXYYYB y $& XY # Trie w/ NOTHING ^([a]{1})*$ aa y $1 a a(?!b(?!c))(..) abababc y $1 bc # test nested negatives a(?!b(?=a))(..) abababc y $1 bc # test nested lookaheads a(?!b(?!c(?!d(?!e))))...(.) abxabcdxabcde y $1 e X(?!b+(?!(c+)*(?!(c+)*d))).*X aXbbbbbbbcccccccccccccaaaX y - - ^(XXXXXXXXXX|YYYYYYYYYY|Z.Q*X|Z[TE]Q*P): ZEQQQQQQQQQQQQQQQQQQP: y $1 ZEQQQQQQQQQQQQQQQQQQP ^(XXXXXXXXXX|YYYYYYYYYY|Z.Q*X|Z[TE]Q*P): ZEQQQX: y $1 ZEQQQX ^([TUV]+|XXXXXXXXXX|YYYYYYYYYY|Z.Q*X|Z[TE]Q*P): ZEQQQQQQQQQQQQQQQQQQP: y $1 ZEQQQQQQQQQQQQQQQQQQP ^([TUV]+|XXXXXXXXXX|YYYYYYYYYY|Z.Q*X|Z[TE]Q*P): ZEQQQX: y $1 ZEQQQX ^([TUV]+|XXXXXXXXXX|YYYYYYYYYY|Z.Q*X|Z[TE]Q*P|[MKJ]): ZEQQQQQQQQQQQQQQQQQQP: y $1 ZEQQQQQQQQQQQQQQQQQQP ^([TUV]+|XXXXXXXXXX|YYYYYYYYYY|Z.Q*X|Z[TE]Q*P|[MKJ]): ZEQQQX: y $1 ZEQQQX ^(XXX|YYY|Z.Q*X|Z[TE]Q*P): ZEQQQQQQQQQQQQQQQQQQP: y $1 ZEQQQQQQQQQQQQQQQQQQP ^(XXX|YYY|Z.Q*X|Z[TE]Q*P): ZEQQQX: y $1 ZEQQQX ^([TUV]+|XXX|YYY|Z.Q*X|Z[TE]Q*P): ZEQQQQQQQQQQQQQQQQQQP: y $1 ZEQQQQQQQQQQQQQQQQQQP ^([TUV]+|XXX|YYY|Z.Q*X|Z[TE]Q*P): ZEQQQX: y $1 ZEQQQX ^([TUV]+|XXX|YYY|Z.Q*X|Z[TE]Q*P|[MKJ]): ZEQQQQQQQQQQQQQQQQQQP: y $1 ZEQQQQQQQQQQQQQQQQQQP ^([TUV]+|XXX|YYY|Z.Q*X|Z[TE]Q*P|[MKJ]): ZEQQQX: y $1 ZEQQQX X(?:ABCF[cC]x*|ABCD|ABCF):(?:DIT|DID|DIM) XABCFCxxxxxxxxxx:DIM y $& XABCFCxxxxxxxxxx:DIM (((ABCD|ABCE|ABCF)))(A|B|C[xy]*): ABCFCxxxxxxxxxx:DIM y $& ABCFCxxxxxxxxxx: (?=foo) foo y pos 0 (?=foo) XfooY y pos 1 .*(?=foo) XfooY y pos 1 (?<=foo) foo y pos 3 (?<=foo) XfooY y pos 4 .*(?<=foo) foo y pos 3 .*(?<=foo) XfooY y pos 4 (?<=foo)Y XfooY y pos 5 o(?<=foo)Y ..XfooY.. y pos 7 X(?=foo)f ..XfooY.. y pos 4 X(?=foo) ..XfooY.. y pos 3 X(?<=foo.)[YZ] ..XfooXY.. y pos 8 (?=XY*foo) Xfoo y pos 0 ^(?=XY*foo) Xfoo y pos 0 ^(??{"a+"})a aa y $& aa ^(?:(??{"a+"})|b)a aa y $& aa ^(??{chr 0x100}).$ \x{100}\x{100} y $& \x{100}\x{100} ^(??{q(\x{100})}). \x{100}\x{100} y $& \x{100}\x{100} ^(??{q(.+)})\x{100} \x{100}\x{100} y $& \x{100}\x{100} ^(??{q(.)})\x{100} \x{100}\x{100} y $& \x{100}\x{100} ^(??{chr 0x100})\xbb \x{100}\x{bb} y $& \x{100}\x{bb} ^(.)(??{"(.)(.)"})(.)$ abcd y $1-$2 a-d ^(.)(??{"(bz+|.)(.)"})(.)$ abcd y $1-$2 a-d ^(.)((??{"(.)(cz+)"})|.) abcd y $1-$2 a-b ^a(?>(??{q(b)}))(??{q(c)})d abcd y - - ^x(??{""})+$ x y $& x ^(<(?:[^<>]+|(?3)|(?1))*>)()(!>!>!>)$ <!>!>><>>!>!>!> y $1 <!>!>><>> ^(<(?:[^<>]+|(?1))*>)$ <<><<<><>>>> y $1 <<><<<><>>>> ((?2)*)([fF]o+) fooFoFoo y $1-$2 fooFo-Foo (<(?:[^<>]+|(?R))*>) <<><<<><>>>> y $1 <<><<<><>>>> (?foo|bar|baz) snofooewa y $1 foo (?foo|bar|baz) snofooewa y $+{n} foo (?foo|bar|baz)(?[ew]+) snofooewa y $+{n} foo (?foo|bar|baz)(?[ew]+) snofooewa y $+{m} ew (?foo)|(?bar)|(?baz) snofooewa y $+{n} foo (?foo)(??{ $+{n} }) snofooefoofoowaa y $+{n} foo (?Pfoo|bar|baz) snofooewa y $1 foo (?Pfoo|bar|baz) snofooewa y $+{n} foo (?Pfoo|bar|baz)(?P[ew]+) snofooewa y $+{n} foo (?Pfoo|bar|baz)(?P[ew]+) snofooewa y $+{m} ew (?Pfoo)|(?Pbar)|(?Pbaz) snofooewa y $+{n} foo (?Pfoo)(??{ $+{n} }) snofooefoofoowaa y $+{n} foo (?P<=n>foo|bar|baz) snofooewa c - Sequence (?P<=...) not recognized (?Pfoo|bar|baz) snofooewa c - Sequence (?Pfoo|bar|baz) snofooewa c - Sequence (?PX<...) not recognized /(?'n'foo|bar|baz)/ snofooewa y $1 foo /(?'n'foo|bar|baz)/ snofooewa y $+{n} foo /(?'n'foo|bar|baz)(?'m'[ew]+)/ snofooewa y $+{n} foo /(?'n'foo|bar|baz)(?'m'[ew]+)/ snofooewa y $+{m} ew /(?'n'foo)|(?'n'bar)|(?baz)/ snobazewa y $+{n} baz /(?'n'foo)(??{ $+{n} })/ snofooefoofoowaa y $+{n} foo /(?'n'foo)\k/ ..foofoo.. y $1 foo /(?'n'foo)\k/ ..foofoo.. y $+{n} foo /(?foo)\k'n'/ ..foofoo.. y $1 foo /(?foo)\k'n'/ ..foofoo.. y $+{n} foo /(?:(?foo)|(?bar))\k/ ..barbar.. y $+{n} bar /^(?'main'<(?:[^<>]+|(?&crap)|(?&main))*>)(?'empty')(?'crap'!>!>!>)$/ <!>!>><>>!>!>!> y $+{main} <!>!>><>> /^(?'main'<(?:[^<>]+|(?&main))*>)$/ <<><<<><>>>> y $1 <<><<<><>>>> /(?'first'(?&second)*)(?'second'[fF]o+)/ fooFoFoo y $+{first}-$+{second} fooFo-Foo (?foo)?(?()bar|nada) foobar y $+{A} foo (?foo)?(?()bar|nada) foo-barnada y $& nada (?foo)?(?(1)bar|nada) foo-barnada y $& nada (?foo(?(R)bar))?(?1) foofoobar y $1 foo (?foo(?(R)bar))?(?1) foofoobar y $& foofoobar (x)(?foo(?(R&A)bar))?(?&A) xfoofoobar y $2 foo (x)(?foo(?(R&A)bar))?(?&A) xfoofoobar y $& xfoofoobar (x)(?foo(?(R2)bar))?(?&A) xfoofoobar y $2 foo (x)(?foo(?(R2)bar))?(?&A) xfoofoobar y $& xfoofoobar (?1)(?(DEFINE)(blah)) blah y $& blah /^(?(?.)((?&PAL)|.?)\k)$/ madamimadam y $& madamimadam /^(?(?.)((?&PAL)|.?)\k)$/ madamiamadam n - - /(a)?((?1))(fox)/ aafox y $1-$2-$3 a-a-fox /(a)*((?1))(fox)/ aafox y $1-$2-$3 a-a-fox /(a)+((?1))(fox)/ aafox y $1-$2-$3 a-a-fox /(a){1,100}((?1))(fox)/ aafox y $1-$2-$3 a-a-fox /(a){0,100}((?1))(fox)/ aafox y $1-$2-$3 a-a-fox /(ab)?((?1))(fox)/ ababfox y $1-$2-$3 ab-ab-fox /(ab)*((?1))(fox)/ ababfox y $1-$2-$3 ab-ab-fox /(ab)+((?1))(fox)/ ababfox y $1-$2-$3 ab-ab-fox /(ab){1,100}((?1))(fox)/ ababfox y $1-$2-$3 ab-ab-fox /(ab){0,100}((?1))(fox)/ ababfox y $1-$2-$3 ab-ab-fox # possessive captures a++a aaaaa n - - a*+a aaaaa n - - a{1,5}+a aaaaa n - - a?+a ab n - - a++b aaaaab y $& aaaaab a*+b aaaaab y $& aaaaab a{1,5}+b aaaaab y $& aaaaab a?+b ab y $& ab fooa++a fooaaaaa n - - fooa*+a fooaaaaa n - - fooa{1,5}+a fooaaaaa n - - fooa?+a fooab n - - fooa++b fooaaaaab y $& fooaaaaab fooa*+b fooaaaaab y $& fooaaaaab fooa{1,5}+b fooaaaaab y $& fooaaaaab fooa?+b fooab y $& fooab (?:aA)++(?:aA) aAaAaAaAaA n - aAaAaAaAaA (aA)++(aA) aAaAaAaAaA n - aAaAaAaAaA (aA|bB)++(aA|bB) aAaAbBaAbB n - aAaAbBaAbB (?:aA|bB)++(?:aA|bB) aAbBbBbBaA n - aAbBbBbBaA (?:aA)*+(?:aA) aAaAaAaAaA n - aAaAaAaAaA (aA)*+(aA) aAaAaAaAaA n - aAaAaAaAaA (aA|bB)*+(aA|bB) aAaAbBaAaA n - aAaAbBaAaA (?:aA|bB)*+(?:aA|bB) aAaAaAbBaA n - aAaAaAbBaA (?:aA){1,5}+(?:aA) aAaAaAaAaA n - aAaAaAaAaA (aA){1,5}+(aA) aAaAaAaAaA n - aAaAaAaAaA (aA|bB){1,5}+(aA|bB) aAaAbBaAaA n - aAaAbBaAaA (?:aA|bB){1,5}+(?:aA|bB) bBbBbBbBbB n - bBbBbBbBbB (?:aA)?+(?:aA) aAb n - aAb (aA)?+(aA) aAb n - aAb (aA|bB)?+(aA|bB) bBb n - bBb (?:aA|bB)?+(?:aA|bB) aAb n - aAb (?:aA)++b aAaAaAaAaAb y $& aAaAaAaAaAb (aA)++b aAaAaAaAaAb y $& aAaAaAaAaAb (aA|bB)++b aAbBaAaAbBb y $& aAbBaAaAbBb (?:aA|bB)++b aAbBbBaAaAb y $& aAbBbBaAaAb (?:aA)*+b aAaAaAaAaAb y $& aAaAaAaAaAb (aA)*+b aAaAaAaAaAb y $& aAaAaAaAaAb (aA|bB)*+b bBbBbBbBbBb y $& bBbBbBbBbBb (?:aA|bB)*+b bBaAbBbBaAb y $& bBaAbBbBaAb (?:aA){1,5}+b aAaAaAaAaAb y $& aAaAaAaAaAb (aA){1,5}+b aAaAaAaAaAb y $& aAaAaAaAaAb (aA|bB){1,5}+b bBaAbBaAbBb y $& bBaAbBaAbBb (?:aA|bB){1,5}+b aAbBaAbBbBb y $& aAbBaAbBbBb (?:aA)?+b aAb y $& aAb (aA)?+b aAb y $& aAb (aA|bB)?+b bBb y $& bBb (?:aA|bB)?+b bBb y $& bBb foo(?:aA)++(?:aA) fooaAaAaAaAaA n - fooaAaAaAaAaA foo(aA)++(aA) fooaAaAaAaAaA n - fooaAaAaAaAaA foo(aA|bB)++(aA|bB) foobBbBbBaAaA n - foobBbBbBaAaA foo(?:aA|bB)++(?:aA|bB) fooaAaAaAaAaA n - fooaAaAaAaAaA foo(?:aA)*+(?:aA) fooaAaAaAaAaA n - fooaAaAaAaAaA foo(aA)*+(aA) fooaAaAaAaAaA n - fooaAaAaAaAaA foo(aA|bB)*+(aA|bB) foobBaAbBaAaA n - foobBaAbBaAaA foo(?:aA|bB)*+(?:aA|bB) fooaAaAbBbBaA n - fooaAaAbBbBaA foo(?:aA){1,5}+(?:aA) fooaAaAaAaAaA n - fooaAaAaAaAaA foo(aA){1,5}+(aA) fooaAaAaAaAaA n - fooaAaAaAaAaA foo(aA|bB){1,5}+(aA|bB) fooaAbBbBaAaA n - fooaAbBbBaAaA foo(?:aA|bB){1,5}+(?:aA|bB) fooaAbBbBaAbB n - fooaAbBbBaAbB foo(?:aA)?+(?:aA) fooaAb n - fooaAb foo(aA)?+(aA) fooaAb n - fooaAb foo(aA|bB)?+(aA|bB) foobBb n - foobBb foo(?:aA|bB)?+(?:aA|bB) fooaAb n - fooaAb foo(?:aA)++b fooaAaAaAaAaAb y $& fooaAaAaAaAaAb foo(aA)++b fooaAaAaAaAaAb y $& fooaAaAaAaAaAb foo(aA|bB)++b foobBaAbBaAbBb y $& foobBaAbBaAbBb foo(?:aA|bB)++b fooaAaAbBaAaAb y $& fooaAaAbBaAaAb foo(?:aA)*+b fooaAaAaAaAaAb y $& fooaAaAaAaAaAb foo(aA)*+b fooaAaAaAaAaAb y $& fooaAaAaAaAaAb foo(aA|bB)*+b foobBbBaAaAaAb y $& foobBbBaAaAaAb foo(?:aA|bB)*+b foobBaAaAbBaAb y $& foobBaAaAbBaAb foo(?:aA){1,5}+b fooaAaAaAaAaAb y $& fooaAaAaAaAaAb foo(aA){1,5}+b fooaAaAaAaAaAb y $& fooaAaAaAaAaAb foo(aA|bB){1,5}+b foobBaAaAaAaAb y $& foobBaAaAaAaAb foo(?:aA|bB){1,5}+b fooaAbBaAbBbBb y $& fooaAbBaAbBbBb foo(?:aA)?+b fooaAb y $& fooaAb foo(aA)?+b fooaAb y $& fooaAb foo(aA|bB)?+b foobBb y $& foobBb foo(?:aA|bB)?+b foobBb y $& foobBb ([^()]++|\([^()]*\))+ ((abc(ade)ufh()()x y $& abc(ade)ufh()()x round\(([^()]++)\) _I(round(xs * sz),1) y $1 xs * sz (foo[1x]|bar[2x]|baz[3x])+y foo1bar2baz3y y $1 baz3 (foo[1x]|bar[2x]|baz[3x])+y foo1bar2baz3y y $& foo1bar2baz3y (foo[1x]|bar[2x]|baz[3x])*y foo1bar2baz3y y $1 baz3 (foo[1x]|bar[2x]|baz[3x])*y foo1bar2baz3y y $& foo1bar2baz3y ([yX].|WORDS|[yX].|WORD)S WORDS y $1 WORD (WORDS|WORLD|WORD)S WORDS y $1 WORD ([yX].|WORDS|WORD|[xY].)S WORDS y $1 WORD (foo|fool|[zx].|money|parted)$ fool y $1 fool ([zx].|foo|fool|[zq].|money|parted|[yx].)$ fool y $1 fool (foo|fool|[zx].|money|parted)$ fools n - - ([zx].|foo|fool|[qx].|money|parted|[py].)$ fools n - - ([yX].|WORDS|[yX].|WORD)+S WORDS y $1 WORD (WORDS|WORLD|WORD)+S WORDS y $1 WORD ([yX].|WORDS|WORD|[xY].)+S WORDS y $1 WORD (foo|fool|[zx].|money|parted)+$ fool y $1 fool ([zx].|foo|fool|[zq].|money|parted|[yx].)+$ fool y $1 fool (foo|fool|[zx].|money|parted)+$ fools n - - ([zx].|foo|fool|[qx].|money|parted|[py].)+$ fools n - - (x|y|z[QW])+(longish|loquatious|excessive|overblown[QW])+ xyzQzWlongishoverblownW y $1-$2 zW-overblownW (x|y|z[QW])*(longish|loquatious|excessive|overblown[QW])* xyzQzWlongishoverblownW y $1-$2 zW-overblownW (x|y|z[QW]){1,5}(longish|loquatious|excessive|overblown[QW]){1,5} xyzQzWlongishoverblownW y $1-$2 zW-overblownW (x|y|z[QW])++(longish|loquatious|excessive|overblown[QW])++ xyzQzWlongishoverblownW y $1-$2 zW-overblownW (x|y|z[QW])*+(longish|loquatious|excessive|overblown[QW])*+ xyzQzWlongishoverblownW y $1-$2 zW-overblownW (x|y|z[QW]){1,5}+(longish|loquatious|excessive|overblown[QW]){1,5}+ xyzQzWlongishoverblownW y $1-$2 zW-overblownW a*(?!) aaaab n - - a*(*FAIL) aaaab n - - a*(*F) aaaab n - - (A(A|B(*ACCEPT)|C)D)(E) AB y $1 AB (A(A|B(*ACCEPT)|C)D)(E) ACDE y $1$2$3 ACDCE (a)(?:(?-1)|(?+1))(b) aab y $&-$1-$2 aab-a-b (a)(?:(?-1)|(?+1))(b) abb y $1-$2 a-b (a)(?:(?-1)|(?+1))(b) acb n - - (foo)(\g-2) foofoo y $1-$2 foo-foo (foo)(\g-2)(foo)(\g-2) foofoofoofoo y $1-$2-$3-$4 foo-foo-foo-foo (([abc]+) \g-1)(([abc]+) \g{-1}) abc abccba cba y $2-$4 abc-cba (a)(b)(c)\g1\g2\g3 abcabc y $1$2$3 abc # \k preceded by a literal /(?'n'foo) \k/ ..foo foo.. y $1 foo /(?'n'foo) \k/ ..foo foo.. y $+{n} foo /(?foo) \k'n'/ ..foo foo.. y $1 foo /(?foo) \k'n'/ ..foo foo.. y $+{n} foo /(?'a1'foo) \k'a1'/ ..foo foo.. y $+{a1} foo /(?foo) \k/ ..foo foo.. y $+{a1} foo /(?'_'foo) \k'_'/ ..foo foo.. y $+{_} foo /(?<_>foo) \k<_>/ ..foo foo.. y $+{_} foo /(?'_0_'foo) \k'_0_'/ ..foo foo.. y $+{_0_} foo /(?<_0_>foo) \k<_0_>/ ..foo foo.. y $+{_0_} foo /(?'0'foo) bar/ ..foo bar.. c - Sequence (?' /(?<0>foo) bar/ ..foo bar.. c - Sequence (?< /(?'12'foo) bar/ ..foo bar.. c - Sequence (?' /(?<12>foo) bar/ ..foo bar.. c - Sequence (?< /(?'1a'foo) bar/ ..foo bar.. c - Sequence (?' /(?<1a>foo) bar/ ..foo bar.. c - Sequence (?< /(?''foo) bar/ ..foo bar.. c - Sequence (?'' /(?<>foo) bar/ ..foo bar.. c - Sequence (?<> /foo \k'n'/ foo foo c - Reference to nonexistent named group /foo \k/ foo foo c - Reference to nonexistent named group /foo \k'a1'/ foo foo c - Reference to nonexistent named group /foo \k/ foo foo c - Reference to nonexistent named group /foo \k'_'/ foo foo c - Reference to nonexistent named group /foo \k<_>/ foo foo c - Reference to nonexistent named group /foo \k'_0_'/ foo foo c - Reference to nonexistent named group /foo \k<_0_>/ foo foo c - Reference to nonexistent named group /foo \k'0'/ foo foo c - Sequence \\k' /foo \k<0>/ foo foo c - Sequence \\k< /foo \k'12'/ foo foo c - Sequence \\k' /foo \k<12>/ foo foo c - Sequence \\k< /foo \k'1a'/ foo foo c - Sequence \\k' /foo \k<1a>/ foo foo c - Sequence \\k< /foo \k''/ foo foo c - Sequence \\k' /foo \k<>/ foo foo c - Sequence \\k< /(?as) (\w+) \k (\w+)/ as easy as pie y $1-$2-$3 as-easy-pie # \g{...} with a name as the argument /(?'n'foo) \g{n}/ ..foo foo.. y $1 foo /(?'n'foo) \g{n}/ ..foo foo.. y $+{n} foo /(?foo) \g{n}/ ..foo foo.. y $1 foo /(?foo) \g{n}/ ..foo foo.. y $+{n} foo /(?as) (\w+) \g{as} (\w+)/ as easy as pie y $1-$2-$3 as-easy-pie # Python style named capture buffer stuff /(?Pfoo)(?P=n)/ ..foofoo.. y $1 foo /(?Pfoo)(?P=n)/ ..foofoo.. y $+{n} foo /(?:(?Pfoo)|(?Pbar))(?P=n)/ ..barbar.. y $+{n} bar /^(?P(?P.)((?P>PAL)|.?)(?P=CHAR))$/ madamimadam y $& madamimadam /^(?P(?P.)((?P>PAL)|.?)(?P=CHAR))$/ madamiamadam n - - /(?Pfoo) (?P=n)/ ..foo foo.. y $1 foo /(?Pfoo) (?P=n)/ ..foo foo.. y $+{n} foo /(?Pas) (\w+) (?P=as) (\w+)/ as easy as pie y $1-$2-$3 as-easy-pie #check that non identifiers as names are treated as the appropriate lookaround (?<=bar>)foo bar>foo y $& foo (?)foo bar>foo n - - (?<=bar>ABC)foo bar>ABCfoo y $& foo (?ABC)foo bar>ABCfoo n - - (?)foo bar>ABCfoo y $& foo (?ABC)foo bar>ABCfoo y $& ABCfoo (?<=abcd(?<=(aaaabcd))) ..aaaabcd.. y $1 aaaabcd (?=xy(?<=(aaxy))) ..aaxy.. y $1 aaxy X(\w+)(?=\s)|X(\w+) Xab y [$1-$2] [-ab] #check that branch reset works ok. (?|(a)) a y $1-$+-$^N a-a-a (?|a(.)b|d(.(o).)d|i(.)(.)j)(.) d!o!da y $1-$2-$3 !o!-o-a (?|a(.)b|d(.(o).)d|i(.)(.)j)(.) aabc y $1-$2-$3 a--c (?|a(.)b|d(.(o).)d|i(.)(.)j)(.) ixyjp y $1-$2-$3 x-y-p (?|(?|(a)|(b))|(?|(c)|(d))) a y $1 a (?|(?|(a)|(b))|(?|(c)|(d))) b y $1 b (?|(?|(a)|(b))|(?|(c)|(d))) c y $1 c (?|(?|(a)|(b))|(?|(c)|(d))) d y $1 d (.)(?|(.)(.)x|(.)d)(.) abcde y $1-$2-$3-$4-$5- b-c--e-- (\N)(?|(\N)(\N)x|(\N)d)(\N) abcde y $1-$2-$3-$4-$5- b-c--e-- (?|(?x)) x y $+{foo} x (?|(?x)|(?y)) x y $+{foo} x (?|(?y)|(?x)) x y $+{foo} x (?)(?|(?x)) x y $+{foo} x #Bug #41492 (?(DEFINE)(?(?&B)+)(?a))(?&A) a y $& a (?(DEFINE)(?(?&B)+)(?a))(?&A) aa y $& aa \x{100}?(??{""})xxx xxx y $& xxx foo(\R)bar foo\r\nbar y $1 \r\n foo(\R)bar foo\nbar y $1 \n foo(\R)bar foo\rbar y $1 \r foo(\R+)bar foo\r\n\x{85}\r\n\nbar y $1 \r\n\x{85}\r\n\n (\V+)(\R) foo\r\n\x{85}\r\n\nbar y $1-$2 foo-\r\n (\R+)(\V) foo\r\n\x{85}\r\n\nbar y $1-$2 \r\n\x{85}\r\n\n-b foo(\R)bar foo\x{85}bar y $1 \x{85} (\V)(\R) foo\x{85}bar y $1-$2 o-\x{85} (\R)(\V) foo\x{85}bar y $1-$2 \x{85}-b foo(\R)bar foo\r\nbar y $1 \r\n (\V)(\R) foo\r\nbar y $1-$2 o-\r\n (\R)(\V) foo\r\nbar y $1-$2 \r\n-b foo(\R)bar foo\r\nbar y $1 \r\n (\V)(\R) foo\r\nbar y $1-$2 o-\r\n (\R)(\V) foo\r\nbar y $1-$2 \r\n-b foo(\R)bar foo\rbar y $1 \r (\V)(\R) foo\rbar y $1-$2 o-\r (\R)(\V) foo\rbar y $1-$2 \r-b foo(\v+)bar foo\r\n\x{85}\r\n\nbar y $1 \r\n\x{85}\r\n\n (\V+)(\v) foo\r\n\x{85}\r\n\nbar y $1-$2 foo-\r (\v+)(\V) foo\r\n\x{85}\r\n\nbar y $1-$2 \r\n\x{85}\r\n\n-b foo(\v)bar foo\x{85}bar y $1 \x{85} (\V)(\v) foo\x{85}bar y $1-$2 o-\x{85} (\v)(\V) foo\x{85}bar y $1-$2 \x{85}-b foo(\v)bar foo\rbar y $1 \r (\V)(\v) foo\rbar y $1-$2 o-\r (\v)(\V) foo\rbar y $1-$2 \r-b foo(\h+)bar foo\t\x{A0}bar y $1 \t\x{A0} (\H+)(\h) foo\t\x{A0}bar y $1-$2 foo-\t (\h+)(\H) foo\t\x{A0}bar y $1-$2 \t\x{A0}-b foo(\h)bar foo\x{A0}bar y $1 \x{A0} (\H)(\h) foo\x{A0}bar y $1-$2 o-\x{A0} (\h)(\H) foo\x{A0}bar y $1-$2 \x{A0}-b foo(\h)bar foo\tbar y $1 \t (\H)(\h) foo\tbar y $1-$2 o-\t (\h)(\H) foo\tbar y $1-$2 \t-b .*\z foo\n y -$&- -- \N*\z foo\n y -$&- -- .*\Z foo\n y -$&- -foo- \N*\Z foo\n y -$&- -foo- ^(?:(\d)x)?\d$ 1 y ${\(defined($1)?1:0)} 0 .*?(?:(\w)|(\w))x abx y $1-$2 b- 0{50} 000000000000000000000000000000000000000000000000000 y - - ^a?(?=b)b ab y $& ab # Bug #56690 ^a*(?=b)b ab y $& ab # Bug #56690 />\d+$ \n/ix >10\n y $& >10 />\d+$ \n/ix >1\n y $& >1 /\d+$ \n/ix >10\n y $& 10 />\d\d$ \n/ix >10\n y $& >10 />\d+$ \n/x >10\n y $& >10 # Two regressions in 5.8.x (only) introduced by change 30638 # Simplification of the test failure in XML::LibXML::Simple: /^\s*i.*?o\s*$/s io\n io y - - # As reported in #59168 by Father Chrysostomos: /(.*?)a(?!(a+)b\2c)/ baaabaac y $&-$1 baa-ba # [perl #60344] Regex lookbehind failure after an (if)then|else in perl 5.10 /\A(?(?=db2)db2|\D+)(? 297; # Update this when adding/deleting tests. run_tests() unless caller; # # Tests start here. # sub run_tests { { my $x = "abc\ndef\n"; ok $x =~ /^abc/, qq ["$x" =~ /^abc/]; ok $x !~ /^def/, qq ["$x" !~ /^def/]; # used to be a test for $* ok $x =~ /^def/m, qq ["$x" =~ /^def/m]; nok $x =~ /^xxx/, qq ["$x" =~ /^xxx/]; nok $x !~ /^abc/, qq ["$x" !~ /^abc/]; ok $x =~ /def/, qq ["$x" =~ /def/]; nok $x !~ /def/, qq ["$x" !~ /def/]; ok $x !~ /.def/, qq ["$x" !~ /.def/]; nok $x =~ /.def/, qq ["$x" =~ /.def/]; ok $x =~ /\ndef/, qq ["$x" =~ /\ndef/]; nok $x !~ /\ndef/, qq ["$x" !~ /\ndef/]; } { $_ = '123'; ok /^([0-9][0-9]*)/, qq [\$_ = '$_'; /^([0-9][0-9]*)/]; } { $_ = 'aaabbbccc'; ok /(a*b*)(c*)/ && $1 eq 'aaabbb' && $2 eq 'ccc', qq [\$_ = '$_'; /(a*b*)(c*)/]; ok /(a+b+c+)/ && $1 eq 'aaabbbccc', qq [\$_ = '$_'; /(a+b+c+)/]; nok /a+b?c+/, qq [\$_ = '$_'; /a+b?c+/]; $_ = 'aaabccc'; ok /a+b?c+/, qq [\$_ = '$_'; /a+b?c+/]; ok /a*b?c*/, qq [\$_ = '$_'; /a*b?c*/]; $_ = 'aaaccc'; ok /a*b?c*/, qq [\$_ = '$_'; /a*b?c*/]; nok /a*b+c*/, qq [\$_ = '$_'; /a*b+c*/]; $_ = 'abcdef'; ok /bcd|xyz/, qq [\$_ = '$_'; /bcd|xyz/]; ok /xyz|bcd/, qq [\$_ = '$_'; /xyz|bcd/]; ok m|bc/*d|, qq [\$_ = '$_'; m|bc/*d|]; ok /^$_$/, qq [\$_ = '$_'; /^\$_\$/]; } { # used to be a test for $* ok "ab\ncd\n" =~ /^cd/m, qq ["ab\ncd\n" =~ /^cd/m]; } { our %XXX = map {($_ => $_)} 123, 234, 345; our @XXX = ('ok 1','not ok 1', 'ok 2','not ok 2','not ok 3'); while ($_ = shift(@XXX)) { my $f = index ($_, 'not') >= 0 ? \&nok : \&ok; my $r = ?(.*)?; &$f ($r, "?(.*)?"); /not/ && reset; if (/not ok 2/) { if ($^O eq 'VMS') { $_ = shift(@XXX); } else { reset 'X'; } } } SKIP: { if ($^O eq 'VMS') { skip "Reset 'X'", 1; } ok !keys %XXX, "%XXX is empty"; } } { local $Message = "Test empty pattern"; my $xyz = 'xyz'; my $cde = 'cde'; $cde =~ /[^ab]*/; $xyz =~ //; iseq $&, $xyz; my $foo = '[^ab]*'; $cde =~ /$foo/; $xyz =~ //; iseq $&, $xyz; $cde =~ /$foo/; my $null; no warnings 'uninitialized'; $xyz =~ /$null/; iseq $&, $xyz; $null = ""; $xyz =~ /$null/; iseq $&, $xyz; } { local $Message = q !Check $`, $&, $'!; $_ = 'abcdefghi'; /def/; # optimized up to cmd iseq "$`:$&:$'", 'abc:def:ghi'; no warnings 'void'; /cde/ + 0; # optimized only to spat iseq "$`:$&:$'", 'ab:cde:fghi'; /[d][e][f]/; # not optimized iseq "$`:$&:$'", 'abc:def:ghi'; } { $_ = 'now is the {time for all} good men to come to.'; / {([^}]*)}/; iseq $1, 'time for all', "Match braces"; } { local $Message = "{N,M} quantifier"; $_ = 'xxx {3,4} yyy zzz'; ok /( {3,4})/; iseq $1, ' '; ok !/( {4,})/; ok /( {2,3}.)/; iseq $1, ' y'; ok /(y{2,3}.)/; iseq $1, 'yyy '; ok !/x {3,4}/; ok !/^xxx {3,4}/; } { local $Message = "Test /g"; local $" = ":"; $_ = "now is the time for all good men to come to."; my @words = /(\w+)/g; my $exp = "now:is:the:time:for:all:good:men:to:come:to"; iseq "@words", $exp; @words = (); while (/\w+/g) { push (@words, $&); } iseq "@words", $exp; @words = (); pos = 0; while (/to/g) { push(@words, $&); } iseq "@words", "to:to"; pos $_ = 0; @words = /to/g; iseq "@words", "to:to"; } { $_ = "abcdefghi"; my $pat1 = 'def'; my $pat2 = '^def'; my $pat3 = '.def.'; my $pat4 = 'abc'; my $pat5 = '^abc'; my $pat6 = 'abc$'; my $pat7 = 'ghi'; my $pat8 = '\w*ghi'; my $pat9 = 'ghi$'; my $t1 = my $t2 = my $t3 = my $t4 = my $t5 = my $t6 = my $t7 = my $t8 = my $t9 = 0; for my $iter (1 .. 5) { $t1++ if /$pat1/o; $t2++ if /$pat2/o; $t3++ if /$pat3/o; $t4++ if /$pat4/o; $t5++ if /$pat5/o; $t6++ if /$pat6/o; $t7++ if /$pat7/o; $t8++ if /$pat8/o; $t9++ if /$pat9/o; } my $x = "$t1$t2$t3$t4$t5$t6$t7$t8$t9"; iseq $x, '505550555', "Test /o"; } SKIP: { my $xyz = 'xyz'; ok "abc" =~ /^abc$|$xyz/, "| after \$"; # perl 4.009 says "unmatched ()" local $Message = '$ inside ()'; my $result; eval '"abc" =~ /a(bc$)|$xyz/; $result = "$&:$1"'; iseq $@, "" or skip "eval failed", 1; iseq $result, "abc:bc"; } { local $Message = "Scalar /g"; $_ = "abcfooabcbar"; ok /abc/g && $` eq ""; ok /abc/g && $` eq "abcfoo"; ok !/abc/g; local $Message = "Scalar /gi"; pos = 0; ok /ABC/gi && $` eq ""; ok /ABC/gi && $` eq "abcfoo"; ok !/ABC/gi; local $Message = "Scalar /g"; pos = 0; ok /abc/g && $' eq "fooabcbar"; ok /abc/g && $' eq "bar"; $_ .= ''; my @x = /abc/g; iseq @x, 2, "/g reset after assignment"; } { local $Message = '/g, \G and pos'; $_ = "abdc"; pos $_ = 2; /\Gc/gc; iseq pos $_, 2; /\Gc/g; ok !defined pos $_; } { local $Message = '(?{ })'; our $out = 1; 'abc' =~ m'a(?{ $out = 2 })b'; iseq $out, 2; $out = 1; 'abc' =~ m'a(?{ $out = 3 })c'; iseq $out, 1; } { $_ = 'foobar1 bar2 foobar3 barfoobar5 foobar6'; my @out = /(? 1, 'ax13876y25677mcb' => 0, # not b. 'ax13876y35677nbc' => 0, # Num too big 'ax13876y25677y21378obc' => 1, 'ax13876y25677y21378zbc' => 0, # Not followed by [k-o] 'ax13876y25677y21378y21378kbc' => 1, 'ax13876y25677y21378y21378kcb' => 0, # Not b. 'ax13876y25677y21378y21378y21378kbc' => 0, # 5 runs ); local $Message = "20000 nodes"; for (keys %ans) { local $Error = "const-len '$_'"; ok !($ans{$_} xor /a(?=([yx]($long_constant_len)){2,4}[k-o]).*b./o); local $Error = "var-len '$_'"; ok !($ans{$_} xor /a(?=([yx]($long_var_len)){2,4}[k-o]).*b./o); } } { local $Message = "Complicated backtracking"; $_ = " a (bla()) and x(y b((l)u((e))) and b(l(e)e)e"; my $expect = "(bla()) ((l)u((e))) (l(e)e)"; use vars '$c'; sub matchit { m/ ( \( (?{ $c = 1 }) # Initialize (?: (?(?{ $c == 0 }) # PREVIOUS iteration was OK, stop the loop (?! ) # Fail: will unwind one iteration back ) (?: [^()]+ # Match a big chunk (?= [()] ) # Do not try to match subchunks | \( (?{ ++$c }) | \) (?{ --$c }) ) )+ # This may not match with different subblocks ) (?(?{ $c != 0 }) (?! ) # Fail ) # Otherwise the chunk 1 may succeed with $c>0 /xg; } my @ans = (); my $res; push @ans, $res while $res = matchit; iseq "@ans", "1 1 1"; @ans = matchit; iseq "@ans", $expect; local $Message = "Recursion with (??{ })"; our $matched; $matched = qr/\((?:(?>[^()]+)|(??{$matched}))*\)/; @ans = my @ans1 = (); push (@ans, $res), push (@ans1, $&) while $res = m/$matched/g; iseq "@ans", "1 1 1"; iseq "@ans1", $expect; @ans = m/$matched/g; iseq "@ans", $expect; } { ok "abc" =~ /^(??{"a"})b/, '"abc" =~ /^(??{"a"})b/'; } { my @ans = ('a/b' =~ m%(.*/)?(.*)%); # Stack may be bad iseq "@ans", 'a/ b', "Stack may be bad"; } { local $Message = "Eval-group not allowed at runtime"; my $code = '{$blah = 45}'; our $blah = 12; eval { /(?$code)/ }; ok $@ && $@ =~ /not allowed at runtime/ && $blah == 12; for $code ('{$blah = 45}','=xx') { $blah = 12; my $res = eval { "xx" =~ /(?$code)/o }; no warnings 'uninitialized'; local $Error = "'$@', '$res', '$blah'"; if ($code eq '=xx') { ok !$@ && $res; } else { ok $@ && $@ =~ /not allowed at runtime/ && $blah == 12; } } $code = '{$blah = 45}'; $blah = 12; eval "/(?$code)/"; iseq $blah, 45; $blah = 12; /(?{$blah = 45})/; iseq $blah, 45; } { local $Message = "Pos checks"; my $x = 'banana'; $x =~ /.a/g; iseq pos ($x), 2; $x =~ /.z/gc; iseq pos ($x), 2; sub f { my $p = $_[0]; return $p; } $x =~ /.a/g; iseq f (pos ($x)), 4; } { local $Message = 'Checking $^R'; our $x = $^R = 67; 'foot' =~ /foo(?{$x = 12; 75})[t]/; iseq $^R, 75; $x = $^R = 67; 'foot' =~ /foo(?{$x = 12; 75})[xy]/; ok $^R eq '67' && $x eq '12'; $x = $^R = 67; 'foot' =~ /foo(?{ $^R + 12 })((?{ $x = 12; $^R + 17 })[xy])?/; ok $^R eq '79' && $x eq '12'; } { iseq qr/\b\v$/i, '(?i-xsm:\b\v$)', 'qr/\b\v$/i'; iseq qr/\b\v$/s, '(?s-xim:\b\v$)', 'qr/\b\v$/s'; iseq qr/\b\v$/m, '(?m-xis:\b\v$)', 'qr/\b\v$/m'; iseq qr/\b\v$/x, '(?x-ism:\b\v$)', 'qr/\b\v$/x'; iseq qr/\b\v$/xism, '(?msix:\b\v$)', 'qr/\b\v$/xism'; iseq qr/\b\v$/, '(?-xism:\b\v$)', 'qr/\b\v$/'; } { local $Message = "Look around"; $_ = 'xabcx'; SKIP: foreach my $ans ('', 'c') { ok /(?<=(?=a)..)((?=c)|.)/g or skip "Match failed", 1; iseq $1, $ans; } } { local $Message = "Empty clause"; $_ = 'a'; foreach my $ans ('', 'a', '') { ok /^|a|$/g or skip "Match failed", 1; iseq $&, $ans; } } { local $Message = "Prefixify"; sub prefixify { SKIP: { my ($v, $a, $b, $res) = @_; ok $v =~ s/\Q$a\E/$b/ or skip "Match failed", 1; iseq $v, $res; } } prefixify ('/a/b/lib/arch', "/a/b/lib", 'X/lib', 'X/lib/arch'); prefixify ('/a/b/man/arch', "/a/b/man", 'X/man', 'X/man/arch'); } { $_ = 'var="foo"'; /(\")/; ok $1 && /$1/, "Capture a quote"; } { no warnings 'closure'; local $Message = '(?{ $var } refers to package vars'; package aa; our $c = 2; $::c = 3; '' =~ /(?{ $c = 4 })/; main::iseq $c, 4; main::iseq $::c, 3; } { must_die 'q(a:[b]:) =~ /[x[:foo:]]/', 'POSIX class \[:[^:]+:\] unknown in regex', 'POSIX class [: :] must have valid name'; for my $d (qw [= .]) { must_die "/[[${d}foo${d}]]/", "\QPOSIX syntax [$d $d] is reserved for future extensions", "POSIX syntax [[$d $d]] is an error"; } } { # test if failure of patterns returns empty list local $Message = "Failed pattern returns empty list"; $_ = 'aaa'; @_ = /bbb/; iseq "@_", ""; @_ = /bbb/g; iseq "@_", ""; @_ = /(bbb)/; iseq "@_", ""; @_ = /(bbb)/g; iseq "@_", ""; } { local $Message = '@- and @+ tests'; /a(?=.$)/; iseq $#+, 0; iseq $#-, 0; iseq $+ [0], 2; iseq $- [0], 1; ok !defined $+ [1] && !defined $- [1] && !defined $+ [2] && !defined $- [2]; /a(a)(a)/; iseq $#+, 2; iseq $#-, 2; iseq $+ [0], 3; iseq $- [0], 0; iseq $+ [1], 2; iseq $- [1], 1; iseq $+ [2], 3; iseq $- [2], 2; ok !defined $+ [3] && !defined $- [3] && !defined $+ [4] && !defined $- [4]; /.(a)(b)?(a)/; iseq $#+, 3; iseq $#-, 3; iseq $+ [1], 2; iseq $- [1], 1; iseq $+ [3], 3; iseq $- [3], 2; ok !defined $+ [2] && !defined $- [2] && !defined $+ [4] && !defined $- [4]; /.(a)/; iseq $#+, 1; iseq $#-, 1; iseq $+ [0], 2; iseq $- [0], 0; iseq $+ [1], 2; iseq $- [1], 1; ok !defined $+ [2] && !defined $- [2] && !defined $+ [3] && !defined $- [3]; /.(a)(ba*)?/; iseq $#+, 2; iseq $#-, 1; } { local $DiePattern = '^Modification of a read-only value attempted'; local $Message = 'Elements of @- and @+ are read-only'; must_die '$+[0] = 13'; must_die '$-[0] = 13'; must_die '@+ = (7, 6, 5)'; must_die '@- = qw (foo bar)'; } { local $Message = '\G testing'; $_ = 'aaa'; pos = 1; my @a = /\Ga/g; iseq "@a", "a a"; my $str = 'abcde'; pos $str = 2; ok $str !~ /^\G/; ok $str !~ /^.\G/; ok $str =~ /^..\G/; ok $str !~ /^...\G/; ok $str =~ /\G../ && $& eq 'cd'; local $TODO = $running_as_thread; ok $str =~ /.\G./ && $& eq 'bc'; } { local $Message = 'pos inside (?{ })'; my $str = 'abcde'; our ($foo, $bar); ok $str =~ /b(?{$foo = $_; $bar = pos})c/; iseq $foo, $str; iseq $bar, 2; ok !defined pos ($str); undef $foo; undef $bar; pos $str = undef; ok $str =~ /b(?{$foo = $_; $bar = pos})c/g; iseq $foo, $str; iseq $bar, 2; iseq pos ($str), 3; $_ = $str; undef $foo; undef $bar; ok /b(?{$foo = $_; $bar = pos})c/; iseq $foo, $str; iseq $bar, 2; undef $foo; undef $bar; ok /b(?{$foo = $_; $bar = pos})c/g; iseq $foo, $str; iseq $bar, 2; iseq pos, 3; undef $foo; undef $bar; pos = undef; 1 while /b(?{$foo = $_; $bar = pos})c/g; iseq $foo, $str; iseq $bar, 2; ok !defined pos; undef $foo; undef $bar; $_ = 'abcde|abcde'; ok s/b(?{$foo = $_; $bar = pos})c/x/g; iseq $foo, 'abcde|abcde'; iseq $bar, 8; iseq $_, 'axde|axde'; # List context: $_ = 'abcde|abcde'; our @res; () = /([ace]).(?{push @res, $1,$2})([ce])(?{push @res, $1,$2})/g; @res = map {defined $_ ? "'$_'" : 'undef'} @res; iseq "@res", "'a' undef 'a' 'c' 'e' undef 'a' undef 'a' 'c'"; @res = (); () = /([ace]).(?{push @res, $`,$&,$'})([ce])(?{push @res, $`,$&,$'})/g; @res = map {defined $_ ? "'$_'" : 'undef'} @res; iseq "@res", "'' 'ab' 'cde|abcde' " . "'' 'abc' 'de|abcde' " . "'abcd' 'e|' 'abcde' " . "'abcde|' 'ab' 'cde' " . "'abcde|' 'abc' 'de'" ; } { local $Message = '\G anchor checks'; my $foo = 'aabbccddeeffgg'; pos ($foo) = 1; { local $TODO = $running_as_thread; no warnings 'uninitialized'; ok $foo =~ /.\G(..)/g; iseq $1, 'ab'; pos ($foo) += 1; ok $foo =~ /.\G(..)/g; iseq $1, 'cc'; pos ($foo) += 1; ok $foo =~ /.\G(..)/g; iseq $1, 'de'; ok $foo =~ /\Gef/g; } undef pos $foo; ok $foo =~ /\G(..)/g; iseq $1, 'aa'; ok $foo =~ /\G(..)/g; iseq $1, 'bb'; pos ($foo) = 5; ok $foo =~ /\G(..)/g; iseq $1, 'cd'; } { $_ = '123x123'; my @res = /(\d*|x)/g; local $" = '|'; iseq "@res", "123||x|123|", "0 match in alternation"; } { local $Message = "Match against temporaries (created via pp_helem())" . " is safe"; ok {foo => "bar\n" . $^X} -> {foo} =~ /^(.*)\n/g; iseq $1, "bar"; } { local $Message = 'package $i inside (?{ }), ' . 'saved substrings and changing $_'; our @a = qw [foo bar]; our @b = (); s/(\w)(?{push @b, $1})/,$1,/g for @a; iseq "@b", "f o o b a r"; iseq "@a", ",f,,o,,o, ,b,,a,,r,"; local $Message = 'lexical $i inside (?{ }), ' . 'saved substrings and changing $_'; no warnings 'closure'; my @c = qw [foo bar]; my @d = (); s/(\w)(?{push @d, $1})/,$1,/g for @c; iseq "@d", "f o o b a r"; iseq "@c", ",f,,o,,o, ,b,,a,,r,"; } { local $Message = 'Brackets'; our $brackets; $brackets = qr { { (?> [^{}]+ | (??{ $brackets }) )* } }x; ok "{{}" =~ $brackets; iseq $&, "{}"; ok "something { long { and } hairy" =~ $brackets; iseq $&, "{ and }"; ok "something { long { and } hairy" =~ m/((??{ $brackets }))/; iseq $&, "{ and }"; } { $_ = "a-a\nxbb"; pos = 1; nok m/^-.*bb/mg, '$_ = "a-a\nxbb"; m/^-.*bb/mg'; } { local $Message = '\G anchor checks'; my $text = "aaXbXcc"; pos ($text) = 0; ok $text !~ /\GXb*X/g; } { $_ = "xA\n" x 500; nok /^\s*A/m, '$_ = "xA\n" x 500; /^\s*A/m"'; my $text = "abc dbf"; my @res = ($text =~ /.*?(b).*?\b/g); iseq "@res", "b b", '\b is not special'; } { local $Message = '\S, [\S], \s, [\s]'; my @a = map chr, 0 .. 255; my @b = grep m/\S/, @a; my @c = grep m/[^\s]/, @a; iseq "@b", "@c"; @b = grep /\S/, @a; @c = grep /[\S]/, @a; iseq "@b", "@c"; @b = grep /\s/, @a; @c = grep /[^\S]/, @a; iseq "@b", "@c"; @b = grep /\s/, @a; @c = grep /[\s]/, @a; iseq "@b", "@c"; } { local $Message = '\D, [\D], \d, [\d]'; my @a = map chr, 0 .. 255; my @b = grep /\D/, @a; my @c = grep /[^\d]/, @a; iseq "@b", "@c"; @b = grep /\D/, @a; @c = grep /[\D]/, @a; iseq "@b", "@c"; @b = grep /\d/, @a; @c = grep /[^\D]/, @a; iseq "@b", "@c"; @b = grep /\d/, @a; @c = grep /[\d]/, @a; iseq "@b", "@c"; } { local $Message = '\W, [\W], \w, [\w]'; my @a = map chr, 0 .. 255; my @b = grep /\W/, @a; my @c = grep /[^\w]/, @a; iseq "@b", "@c"; @b = grep /\W/, @a; @c = grep /[\W]/, @a; iseq "@b", "@c"; @b = grep /\w/, @a; @c = grep /[^\W]/, @a; iseq "@b", "@c"; @b = grep /\w/, @a; @c = grep /[\w]/, @a; iseq "@b", "@c"; } { # see if backtracking optimization works correctly local $Message = 'Backtrack optimization'; ok "\n\n" =~ /\n $ \n/x; ok "\n\n" =~ /\n* $ \n/x; ok "\n\n" =~ /\n+ $ \n/x; ok "\n\n" =~ /\n? $ \n/x; ok "\n\n" =~ /\n*? $ \n/x; ok "\n\n" =~ /\n+? $ \n/x; ok "\n\n" =~ /\n?? $ \n/x; ok "\n\n" !~ /\n*+ $ \n/x; ok "\n\n" !~ /\n++ $ \n/x; ok "\n\n" =~ /\n?+ $ \n/x; } { package S; use overload '""' => sub {'Object S'}; sub new {bless []} local $::Message = "Ref stringification"; ::ok do { \my $v} =~ /^SCALAR/, "Scalar ref stringification"; ::ok do {\\my $v} =~ /^REF/, "Ref ref stringification"; ::ok [] =~ /^ARRAY/, "Array ref stringification"; ::ok {} =~ /^HASH/, "Hash ref stringification"; ::ok 'S' -> new =~ /^Object S/, "Object stringification"; } { local $Message = "Test result of match used as match"; ok 'a1b' =~ ('xyz' =~ /y/); iseq $`, 'a'; ok 'a1b' =~ ('xyz' =~ /t/); iseq $`, 'a'; } { local $Message = '"1" is not \s'; may_not_warn sub {ok ("1\n" x 102) !~ /^\s*\n/m}; } { local $Message = '\s, [[:space:]] and [[:blank:]]'; my %space = (spc => " ", tab => "\t", cr => "\r", lf => "\n", ff => "\f", # There's no \v but the vertical tabulator seems miraculously # be 11 both in ASCII and EBCDIC. vt => chr(11), false => "space"); my @space0 = sort grep {$space {$_} =~ /\s/ } keys %space; my @space1 = sort grep {$space {$_} =~ /[[:space:]]/} keys %space; my @space2 = sort grep {$space {$_} =~ /[[:blank:]]/} keys %space; iseq "@space0", "cr ff lf spc tab"; iseq "@space1", "cr ff lf spc tab vt"; iseq "@space2", "spc tab"; } { use charnames ":full"; local $Message = 'Delayed interpolation of \N'; my $r1 = qr/\N{THAI CHARACTER SARA I}/; my $s1 = "\x{E34}\x{E34}\x{E34}\x{E34}"; # Bug #56444 ok $s1 =~ /$r1+/, 'my $r1 = qr/\N{THAI CHARACTER SARA I}/; my $s1 = "\x{E34}\x{E34}\x{E34}\x{E34}; $s1 =~ /$r1+/'; # Bug #62056 ok "${s1}A" =~ m/$s1\N{LATIN CAPITAL LETTER A}/, '"${s1}A" =~ m/$s1\N{LATIN CAPITAL LETTER A}/'; ok "abbbbc" =~ m/\N{1}/ && $& eq "a", '"abbbbc" =~ m/\N{1}/ && $& eq "a"'; ok "abbbbc" =~ m/\N{3,4}/ && $& eq "abbb", '"abbbbc" =~ m/\N{3,4}/ && $& eq "abbb"'; } } # End of sub run_tests 1; perl-5.12.0-RC0/t/re/reg_namedcapture.t0000555000175000017500000000131211325127002016461 0ustar jessejesse#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; unless ( -r "$INC[0]/Errno.pm") { print "1..0 # Skip: Errno.pm not yet available\n"; exit 0; } } # WARNING: Do not directly use any modules as part of this test code. # We could get action at a distance that would invalidate the tests. print "1..2\n"; # This tests whether glob assignment fails to load the tie. *X = *-; 'X'=~/(?X)/; print eval '*X{HASH}{X} || 1' ? "" :"not ","ok ",++$test,"\n"; # And since it's a similar case we check %! as well. Note that # this can't be done until ../lib/Errno.pm is in place, as the # glob hits $!, which needs that module. *Y = *!; print 0. # Modifiers can be put after the closing C<'>. # # Column 2 contains the string to be matched. # # Column 3 contains the expected result: # y expect a match # n expect no match # c expect an error # T the test is a TODO (can be combined with y/n/c) # B test exposes a known bug in Perl, should be skipped # b test exposes a known bug in Perl, should be skipped if noamp # t test exposes a bug with threading, TODO if qr_embed_thr # # Columns 4 and 5 are used only if column 3 contains C or C. # # Column 4 contains a string, usually C<$&>. # # Column 5 contains the expected result of double-quote # interpolating that string after the match, or start of error message. # # Column 6, if present, contains a reason why the test is skipped. # This is printed with "skipped", for harness to pick up. # # \n in the tests are interpolated, as are variables of the form ${\w+}. # # Blanks lines are treated as PASSING tests to keep the line numbers # linked to the test number. # # If you want to add a regular expression test that can't be expressed # in this format, don't add it here: put it in re/pat.t instead. # # Note that the inputs get passed on as "m're'", so the re bypasses the lexer. # This means this file cannot be used for testing anything that the lexer # handles; in 5.12 this means just \N{NAME} and \N{U+...}. # # Note that columns 2,3 and 5 are all enclosed in double quotes and then # evalled; so something like a\"\x{100}$1 has length 3+length($1). my $file; BEGIN { $iters = shift || 1; # Poor man performance suite, 10000 is OK. # Do this open before any chdir $file = shift; if (defined $file) { open TESTS, $file or die "Can't open $file"; } chdir 't' if -d 't'; @INC = '../lib'; if ($qr_embed_thr) { require Config; if (!$Config::Config{useithreads}) { print "1..0 # Skip: no ithreads\n"; exit 0; } if ($ENV{PERL_CORE_MINITEST}) { print "1..0 # Skip: no dynamic loading on miniperl, no threads\n"; exit 0; } require threads; } } use strict; use warnings FATAL=>"all"; use vars qw($iters $numtests $bang $ffff $nulnul $OP); use vars qw($qr $skip_amp $qr_embed $qr_embed_thr); # set by our callers if (!defined $file) { open(TESTS,'re/re_tests') || open(TESTS,'t/re/re_tests') || open(TESTS,':re:re_tests') || die "Can't open re_tests"; } my @tests = ; close TESTS; $bang = sprintf "\\%03o", ord "!"; # \41 would not be portable. $ffff = chr(0xff) x 2; $nulnul = "\0" x 2; $OP = $qr ? 'qr' : 'm'; $| = 1; printf "1..%d\n# $iters iterations\n", scalar @tests; my $test; TEST: foreach (@tests) { $test++; if (!/\S/ || /^\s*#/ || /^__END__$/) { print "ok $test # (Blank line or comment)\n"; if (/#/) { print $_ }; next; } chomp; s/\\n/\n/g; my ($pat, $subject, $result, $repl, $expect, $reason) = split(/\t/,$_,6); $reason = '' unless defined $reason; my $input = join(':',$pat,$subject,$result,$repl,$expect); # the double '' below keeps simple syntax highlighters from going crazy $pat = "'$pat'" unless $pat =~ /^[:''\/]/; $pat =~ s/(\$\{\w+\})/$1/eeg; $pat =~ s/\\n/\n/g; $subject = eval qq("$subject"); die $@ if $@; $expect = eval qq("$expect"); die $@ if $@; $expect = $repl = '-' if $skip_amp and $input =~ /\$[&\`\']/; my $todo_qr = $qr_embed_thr && ($result =~ s/t//); my $skip = ($skip_amp ? ($result =~ s/B//i) : ($result =~ s/B//)); $reason = 'skipping $&' if $reason eq '' && $skip_amp; $result =~ s/B//i unless $skip; my $todo= $result =~ s/T// ? " # TODO" : ""; for my $study ('', 'study $subject', 'utf8::upgrade($subject)', 'utf8::upgrade($subject); study $subject') { # Need to make a copy, else the utf8::upgrade of an alreay studied # scalar confuses things. my $subject = $subject; my $c = $iters; my ($code, $match, $got); if ($repl eq 'pos') { $code= <new(sub {qr$pat})->join(); $study; \$match = (\$subject =~ /(?:)\$RE(?:)/) while \$c--; \$got = "$repl"; EOFCODE } else { $code= < `$err'\n"; next TEST } last; # no need to study a syntax error } elsif ( $skip ) { print "ok $test # skipped", length($reason) ? " $reason" : '', "\n"; next TEST; } elsif ( $todo_qr ) { print "not ok $test # TODO", length($reason) ? " - $reason" : '', "\n"; next TEST; } elsif ($@) { print "not ok $test$todo $input => error `$err'\n$code\n$@\n"; next TEST; } elsif ($result =~ /^n/) { if ($match) { print "not ok $test$todo ($study) $input => false positive\n"; next TEST } } else { if (!$match || $got ne $expect) { eval { require Data::Dumper }; if ($@) { print "not ok $test$todo ($study) $input => `$got', match=$match\n$code\n"; } else { # better diagnostics my $s = Data::Dumper->new([$subject],['subject'])->Useqq(1)->Dump; my $g = Data::Dumper->new([$got],['got'])->Useqq(1)->Dump; print "not ok $test$todo ($study) $input => `$got', match=$match\n$s\n$g\n$code\n"; } next TEST; } } } print "ok $test$todo\n"; } 1; perl-5.12.0-RC0/t/perl.supp0000444000175000017500000000103111325125742014240 0ustar jessejesse## Catch various leaks during dlopen... { calloc Memcheck:Leak fun:calloc obj:/lib/ld-2.*.so } { malloc Memcheck:Leak fun:malloc obj:/lib/ld-2.*.so } { realloc Memcheck:Leak fun:malloc fun:realloc obj:/lib/ld-2.*.so } { calloc Memcheck:Leak fun:calloc obj:/lib/libdl-2.*.so } { malloc Memcheck:Leak fun:malloc obj:/lib/libdl-2.*.so } { realloc Memcheck:Leak fun:malloc fun:realloc obj:/lib/libdl-2.*.so } { dlopen Memcheck:Addr4 obj:/lib/ld-2.*.so } perl-5.12.0-RC0/t/harness0000444000175000017500000001374211325127001013755 0ustar jessejesse#!./perl # We suppose that perl _mostly_ works at this moment, so may use # sophisticated testing. BEGIN { chdir 't' if -d 't'; @INC = '../lib'; # pick up only this build's lib } my $torture; # torture testing? use TAP::Harness 3.13; use strict; $::do_nothing = $::do_nothing = 1; require './TEST'; my $Verbose = 0; $Verbose++ while @ARGV && $ARGV[0] eq '-v' && shift; if ($ARGV[0] && $ARGV[0] eq '-torture') { shift; $torture = 1; } # Let tests know they're running in the perl core. Useful for modules # which live dual lives on CPAN. $ENV{PERL_CORE} = 1; #fudge DATA for now. my %datahandle = qw( lib/bigint.t 1 lib/bigintpm.t 1 lib/bigfloat.t 1 lib/bigfloatpm.t 1 op/gv.t 1 lib/complex.t 1 lib/ph.t 1 lib/soundex.t 1 op/misc.t 1 op/runlevel.t 1 op/tie.t 1 op/lex_assign.t 1 ); foreach (keys %datahandle) { unlink "$_.t"; } my (@tests, $re); # [.VMS]TEST.COM calls harness with empty arguments, so clean-up @ARGV @ARGV = grep $_ && length( $_ ) => @ARGV; sub _extract_tests; sub _extract_tests { # This can probably be done more tersely with a map, but I doubt that it # would be as clear my @results; foreach (@_) { my $ref = ref $_; if ($ref) { if ($ref eq 'ARRAY') { push @results, _extract_tests @$_; } elsif ($ref eq 'HASH') { push @results, _extract_tests values %$_; } else { die "Unknown reference type $ref"; } } else { push @results, glob $_; } } @results; } if ($ARGV[0] && $ARGV[0]=~/^-re/) { if ($ARGV[0]!~/=/) { shift; $re=join "|",@ARGV; @ARGV=(); } else { (undef,$re)=split/=/,shift; } } my $jobs = $ENV{TEST_JOBS}; my ($rules, $state, $color); if ($ENV{HARNESS_OPTIONS}) { for my $opt ( split /:/, $ENV{HARNESS_OPTIONS} ) { if ( $opt =~ /^j(\d*)$/ ) { $jobs ||= $1 || 9; } elsif ( $opt eq 'c' ) { $color = 1; } else { die "Unknown HARNESS_OPTIONS item: $opt\n"; } } } if (@ARGV) { # If you want these run in speed order, just use prove if ($^O eq 'MSWin32') { @tests = map(glob($_),@ARGV); } else { @tests = @ARGV; } } else { # Ideally we'd get somewhere close to Tux's Oslo rules # my $rules = { # par => [ # { seq => '../ext/DB_File/t/*' }, # { seq => '../ext/IO_Compress_Zlib/t/*' }, # { seq => '../lib/CPANPLUS/*' }, # { seq => '../lib/ExtUtils/t/*' }, # '*' # ] # }; # but for now, run all directories in sequence. In particular, it would be # nice to get the tests in t/op/*.t able to run in parallel. unless (@tests) { my @seq = ; my @next = qw(comp run cmd io re op uni mro lib porting); push @next, 'japh' if $torture; push @next, 'win32' if $^O eq 'MSWin32'; push @next, 'benchmark' if $ENV{PERL_BENCHMARK}; # Hopefully TAP::Parser::Scheduler will support this syntax soon. # my $next = { par => '{' . join (',', @next) . '}/*.t' }; my $next = { par => [ map { "$_/*.t" } @next ] }; @tests = _extract_tests ($next); # This is a bit of a game, because we only want to sort these tests in # speed order. base/*.t wants to run first, and ext,lib etc last and in # MANIFEST order if ($jobs) { require App::Prove::State; $state = App::Prove::State->new({ store => 'test_state' }); $state->apply_switch('slow', 'save'); # For some reason get_tests returns *all* the tests previously run, # (in the right order), not simply the selection in @tests # (in the right order). Not sure if this is a bug or a feature. # Whatever, *we* are only interested in the ones that are in @tests my %seen; @seen{@tests} = (); @tests = grep {exists $seen{$_} } $state->get_tests(0, @tests); } @tests = (@seq, @tests); push @seq, $next; my @last; use Config; push @last, sort { lc $a cmp lc $b } _tests_from_manifest($Config{extensions}, $Config{known_extensions}); push @last, ; my %times; if ($state) { # Where known, collate the elapsed times by test name foreach ($state->results->tests()) { $times{$_->name} = $_->elapsed(); } } my %dir; my %total_time; for (@last) { if ($^O eq 'MSWin32') { s,\\,/,g; # canonicalize path }; m!(.*[/])! or die "'$_'"; push @{$dir{$1}}, $_; $total_time{$1} += $times{$_} || 0; } push @tests, @last; # Generate T::H schedule rules that run the contents of each directory # sequentially. push @seq, { par => [ map { { seq => "$_*" } } sort { # Directories, ordered by total time descending then name ascending $total_time{$b} <=> $total_time{$a} || $a cmp $b } keys %dir ] }; $rules = { seq => \@seq }; } } if ($^O eq 'MSWin32') { s,\\,/,g for @tests; } @tests=grep /$re/, @tests if $re; my %options; my $type = 'perl'; # Load TAP::Parser now as otherwise it could be required in the short time span # in which the harness process chdirs into ext/Dist require TAP::Parser; my $h = TAP::Harness->new({ rules => $rules, color => $color, jobs => $jobs, verbosity => $Verbose, exec => sub { my ($harness, $test) = @_; my $options = $options{$test}; if (!defined $options) { $options = $options{$test} = _scan_test($test, $type); } return [ split ' ', _cmd($options, $type) ]; }, }); if ($state) { $h->callback( after_test => sub { $state->observe_test(@_); } ); $h->callback( after_runtests => sub { $state->commit(@_); } ); } $h->callback( parser_args => sub { my ($args, $job) = @_; my $test = $job->[0]; _before_fork($options{$test}); push @{ $args->{switches} }, "-I../../lib"; } ); $h->callback( made_parser => sub { my ($parser, $job) = @_; my $test = $job->[0]; my $options = delete $options{$test}; _after_fork($options); } ); my $agg = $h->runtests(@tests); exit $agg->has_errors ? 1 : 0; perl-5.12.0-RC0/t/mro/0000755000175000017500000000000011351321566013172 5ustar jessejesseperl-5.12.0-RC0/t/mro/inconsistent_c3.t0000555000175000017500000000147311325125742016471 0ustar jessejesse#!./perl use strict; use warnings; BEGIN { unless (-d 'blib') { chdir 't' if -d 't'; @INC = '../lib'; } } require q(./test.pl); plan(tests => 1); require mro; =pod This example is take from: http://www.python.org/2.3/mro.html "Serious order disagreement" # From Guido class O: pass class X(O): pass class Y(O): pass class A(X,Y): pass class B(Y,X): pass try: class Z(A,B): pass #creates Z(A,B) in Python 2.2 except TypeError: pass # Z(A,B) cannot be created in Python 2.3 =cut { package X; package Y; package XY; our @ISA = ('X', 'Y'); package YX; our @ISA = ('Y', 'X'); package Z; our @ISA = ('XY', 'YX'); } eval { mro::get_linear_isa('Z', 'c3') }; like($@, qr/^Inconsistent /, '... got the right error with an inconsistent hierarchy'); perl-5.12.0-RC0/t/mro/next_goto.t0000555000175000017500000000153011325125742015364 0ustar jessejesse#!/usr/bin/perl use strict; use warnings; require q(./test.pl); plan(tests => 4); use mro; { package Proxy; our @ISA = qw//; sub next_proxy { goto &next::method } sub maybe_proxy { goto &maybe::next::method } sub can_proxy { goto &next::can } package TBase; our @ISA = qw//; sub foo { 42 } sub bar { 24 } # baz doesn't exist intentionally sub quux { 242 } package TTop; our @ISA = qw/TBase/; sub foo { shift->Proxy::next_proxy() } sub bar { shift->Proxy::maybe_proxy() } sub baz { shift->Proxy::maybe_proxy() } sub quux { shift->Proxy::can_proxy()->() } } is(TTop->foo, 42, 'proxy next::method via goto'); is(TTop->bar, 24, 'proxy maybe::next::method via goto'); ok(!TTop->baz, 'proxy maybe::next::method via goto with no method'); is(TTop->quux, 242, 'proxy next::can via goto'); perl-5.12.0-RC0/t/mro/isa_c3.t0000555000175000017500000000220311325127001014503 0ustar jessejesse#!perl -w BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require "./test.pl"; } use strict; plan 'no_plan'; # package klonk doesn't have a stash. package kapow; use mro 'c3'; # No parents package urkkk; use mro 'c3'; # 1 parent @urkkk::ISA = 'klonk'; package kayo; use mro 'c3'; # 2 parents @urkkk::ISA = ('klonk', 'kapow'); package thwacke; use mro 'c3'; # No parents, has @ISA @thwacke::ISA = (); package zzzzzwap; use mro 'c3'; @zzzzzwap::ISA = ('thwacke', 'kapow'); package whamm; use mro 'c3'; @whamm::ISA = ('kapow', 'thwacke'); package main; my %expect = ( klonk => [qw(klonk)], urkkk => [qw(urkkk klonk kapow)], kapow => [qw(kapow)], kayo => [qw(kayo)], thwacke => [qw(thwacke)], zzzzzwap => [qw(zzzzzwap thwacke kapow)], whamm => [qw(whamm kapow thwacke)], ); foreach my $package (qw(klonk urkkk kapow kayo thwacke zzzzzwap whamm)) { my $ref = bless [], $package; my $isa = $expect{$package}; is("@{mro::get_linear_isa($package)}", "@$isa", "\@ISA for $package"); foreach my $class ($package, @$isa, 'UNIVERSAL') { isa_ok($ref, $class, $package); } } perl-5.12.0-RC0/t/mro/vulcan_dfs.t0000555000175000017500000000247611325125742015514 0ustar jessejesse#!./perl use strict; use warnings; require q(./test.pl); plan(tests => 1); =pod example taken from: L Object ^ | LifeForm ^ ^ / \ Sentient BiPedal ^ ^ | | Intelligent Humanoid ^ ^ \ / Vulcan define class () end class; define class () end class; define class () end class; define class () end class; define class (, ) end class; =cut { package Object; use mro 'dfs'; package LifeForm; use mro 'dfs'; use base 'Object'; package Sentient; use mro 'dfs'; use base 'LifeForm'; package BiPedal; use mro 'dfs'; use base 'LifeForm'; package Intelligent; use mro 'dfs'; use base 'Sentient'; package Humanoid; use mro 'dfs'; use base 'BiPedal'; package Vulcan; use mro 'dfs'; use base ('Intelligent', 'Humanoid'); } ok(eq_array( mro::get_linear_isa('Vulcan'), [ qw(Vulcan Intelligent Sentient LifeForm Object Humanoid BiPedal) ] ), '... got the right MRO for the Vulcan Dylan Example'); perl-5.12.0-RC0/t/mro/dbic_c3.t0000555000175000017500000001006611325125742014650 0ustar jessejesse#!./perl use strict; use warnings; require q(./test.pl); plan(tests => 1); =pod This example is taken from the inheritance graph of DBIx::Class::Core in DBIx::Class v0.07002: (No ASCII art this time, this graph is insane) The xx:: prefixes are just to be sure these bogus declarations never stomp on real ones =cut { package xx::DBIx::Class::Core; use mro 'c3'; our @ISA = qw/ xx::DBIx::Class::Serialize::Storable xx::DBIx::Class::InflateColumn xx::DBIx::Class::Relationship xx::DBIx::Class::PK::Auto xx::DBIx::Class::PK xx::DBIx::Class::Row xx::DBIx::Class::ResultSourceProxy::Table xx::DBIx::Class::AccessorGroup /; package xx::DBIx::Class::InflateColumn; use mro 'c3'; our @ISA = qw/ xx::DBIx::Class::Row /; package xx::DBIx::Class::Row; use mro 'c3'; our @ISA = qw/ xx::DBIx::Class /; package xx::DBIx::Class; use mro 'c3'; our @ISA = qw/ xx::DBIx::Class::Componentised xx::Class::Data::Accessor /; package xx::DBIx::Class::Relationship; use mro 'c3'; our @ISA = qw/ xx::DBIx::Class::Relationship::Helpers xx::DBIx::Class::Relationship::Accessor xx::DBIx::Class::Relationship::CascadeActions xx::DBIx::Class::Relationship::ProxyMethods xx::DBIx::Class::Relationship::Base xx::DBIx::Class /; package xx::DBIx::Class::Relationship::Helpers; use mro 'c3'; our @ISA = qw/ xx::DBIx::Class::Relationship::HasMany xx::DBIx::Class::Relationship::HasOne xx::DBIx::Class::Relationship::BelongsTo xx::DBIx::Class::Relationship::ManyToMany /; package xx::DBIx::Class::Relationship::ProxyMethods; use mro 'c3'; our @ISA = qw/ xx::DBIx::Class /; package xx::DBIx::Class::Relationship::Base; use mro 'c3'; our @ISA = qw/ xx::DBIx::Class /; package xx::DBIx::Class::PK::Auto; use mro 'c3'; our @ISA = qw/ xx::DBIx::Class /; package xx::DBIx::Class::PK; use mro 'c3'; our @ISA = qw/ xx::DBIx::Class::Row /; package xx::DBIx::Class::ResultSourceProxy::Table; use mro 'c3'; our @ISA = qw/ xx::DBIx::Class::AccessorGroup xx::DBIx::Class::ResultSourceProxy /; package xx::DBIx::Class::ResultSourceProxy; use mro 'c3'; our @ISA = qw/ xx::DBIx::Class /; package xx::Class::Data::Accessor; our @ISA = (); use mro 'c3'; package xx::DBIx::Class::Relationship::HasMany; our @ISA = (); use mro 'c3'; package xx::DBIx::Class::Relationship::HasOne; our @ISA = (); use mro 'c3'; package xx::DBIx::Class::Relationship::BelongsTo; our @ISA = (); use mro 'c3'; package xx::DBIx::Class::Relationship::ManyToMany; our @ISA = (); use mro 'c3'; package xx::DBIx::Class::Componentised; our @ISA = (); use mro 'c3'; package xx::DBIx::Class::AccessorGroup; our @ISA = (); use mro 'c3'; package xx::DBIx::Class::Serialize::Storable; our @ISA = (); use mro 'c3'; package xx::DBIx::Class::Relationship::Accessor; our @ISA = (); use mro 'c3'; package xx::DBIx::Class::Relationship::CascadeActions; our @ISA = (); use mro 'c3'; } ok(eq_array( mro::get_linear_isa('xx::DBIx::Class::Core'), [qw/ xx::DBIx::Class::Core xx::DBIx::Class::Serialize::Storable xx::DBIx::Class::InflateColumn xx::DBIx::Class::Relationship xx::DBIx::Class::Relationship::Helpers xx::DBIx::Class::Relationship::HasMany xx::DBIx::Class::Relationship::HasOne xx::DBIx::Class::Relationship::BelongsTo xx::DBIx::Class::Relationship::ManyToMany xx::DBIx::Class::Relationship::Accessor xx::DBIx::Class::Relationship::CascadeActions xx::DBIx::Class::Relationship::ProxyMethods xx::DBIx::Class::Relationship::Base xx::DBIx::Class::PK::Auto xx::DBIx::Class::PK xx::DBIx::Class::Row xx::DBIx::Class::ResultSourceProxy::Table xx::DBIx::Class::AccessorGroup xx::DBIx::Class::ResultSourceProxy xx::DBIx::Class xx::DBIx::Class::Componentised xx::Class::Data::Accessor /] ), '... got the right C3 merge order for xx::DBIx::Class::Core'); perl-5.12.0-RC0/t/mro/method_caching.t0000555000175000017500000000641411325125742016320 0ustar jessejesse#!./perl use strict; use warnings; no warnings 'redefine'; # we do a lot of this no warnings 'prototype'; # we do a lot of this BEGIN { unless (-d 'blib') { chdir 't' if -d 't'; @INC = '../lib'; } } require './test.pl'; { package MCTest::Base; sub foo { return $_[1]+1 }; package MCTest::Derived; our @ISA = qw/MCTest::Base/; package Foo; our @FOO = qw//; } # These are various ways of re-defining MCTest::Base::foo and checking whether the method is cached when it shouldn't be my @testsubs = ( sub { is(MCTest::Derived->foo(0), 1); }, sub { eval 'sub MCTest::Base::foo { return $_[1]+2 }'; is(MCTest::Derived->foo(0), 2); }, sub { eval 'sub MCTest::Base::foo($) { return $_[1]+3 }'; is(MCTest::Derived->foo(0), 3); }, sub { eval 'sub MCTest::Base::foo($) { 4 }'; is(MCTest::Derived->foo(0), 4); }, sub { *MCTest::Base::foo = sub { $_[1]+5 }; is(MCTest::Derived->foo(0), 5); }, sub { local *MCTest::Base::foo = sub { $_[1]+6 }; is(MCTest::Derived->foo(0), 6); }, sub { is(MCTest::Derived->foo(0), 5); }, sub { sub FFF { $_[1]+7 }; local *MCTest::Base::foo = *FFF; is(MCTest::Derived->foo(0), 7); }, sub { is(MCTest::Derived->foo(0), 5); }, sub { sub DDD { $_[1]+8 }; *MCTest::Base::foo = *DDD; is(MCTest::Derived->foo(0), 8); }, sub { *ASDF::asdf = sub { $_[1]+9 }; *MCTest::Base::foo = \&ASDF::asdf; is(MCTest::Derived->foo(0), 9); }, sub { undef *MCTest::Base::foo; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); }, sub { eval "sub MCTest::Base::foo($);"; *MCTest::Base::foo = \&ASDF::asdf; is(MCTest::Derived->foo(0), 9); }, sub { *XYZ = sub { $_[1]+10 }; ${MCTest::Base::}{foo} = \&XYZ; is(MCTest::Derived->foo(0), 10); }, sub { ${MCTest::Base::}{foo} = sub { $_[1]+11 }; is(MCTest::Derived->foo(0), 11); }, sub { undef *MCTest::Base::foo; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); }, sub { eval 'package MCTest::Base; sub foo { $_[1]+12 }'; is(MCTest::Derived->foo(0), 12); }, sub { eval 'package ZZZ; sub foo { $_[1]+13 }'; *MCTest::Base::foo = \&ZZZ::foo; is(MCTest::Derived->foo(0), 13); }, sub { ${MCTest::Base::}{foo} = sub { $_[1]+14 }; is(MCTest::Derived->foo(0), 14); }, # 5.8.8 fails this one sub { undef *{MCTest::Base::}; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); }, sub { eval 'package MCTest::Base; sub foo { $_[1]+15 }'; is(MCTest::Derived->foo(0), 15); }, sub { undef %{MCTest::Base::}; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); }, sub { eval 'package MCTest::Base; sub foo { $_[1]+16 }'; is(MCTest::Derived->foo(0), 16); }, sub { %{MCTest::Base::} = (); eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); }, sub { eval 'package MCTest::Base; sub foo { $_[1]+17 }'; is(MCTest::Derived->foo(0), 17); }, # 5.8.8 fails this one too sub { *{MCTest::Base::} = *{Foo::}; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); }, sub { *MCTest::Derived::foo = \&MCTest::Base::foo; eval { MCTest::Derived::foo(0,0) }; ok(!$@); undef *MCTest::Derived::foo }, sub { eval 'package MCTest::Base; sub foo { $_[1]+18 }'; is(MCTest::Derived->foo(0), 18); }, ); plan(tests => scalar(@testsubs)); $_->() for (@testsubs); perl-5.12.0-RC0/t/mro/c3_with_overload.t0000555000175000017500000000220411325125742016610 0ustar jessejesse#!/usr/bin/perl use strict; use warnings; require q(./test.pl); plan(tests => 7); { package BaseTest; use strict; use warnings; use mro 'c3'; package OverloadingTest; use strict; use warnings; use mro 'c3'; use base 'BaseTest'; use overload '""' => sub { ref(shift) . " stringified" }, fallback => 1; sub new { bless {} => shift } package InheritingFromOverloadedTest; use strict; use warnings; use base 'OverloadingTest'; use mro 'c3'; } my $x = InheritingFromOverloadedTest->new(); isa_ok($x, 'InheritingFromOverloadedTest'); my $y = OverloadingTest->new(); isa_ok($y, 'OverloadingTest'); is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing'); is("$y", 'OverloadingTest stringified', '... got the right value when stringifing'); ok(($y eq 'OverloadingTest stringified'), '... eq was handled correctly'); my $result; eval { $result = $x eq 'InheritingFromOverloadedTest stringified' }; ok(!$@, '... this should not throw an exception'); ok($result, '... and we should get the true value'); perl-5.12.0-RC0/t/mro/complex_dfs.t0000555000175000017500000000761711325125742015675 0ustar jessejesse#!./perl use strict; use warnings; require q(./test.pl); plan(tests => 11); =pod This example is taken from: http://rt.cpan.org/Public/Bug/Display.html?id=20879 --- --- --- Level 5 8 | A | 9 | B | A | C | (More General) --- --- --- V \ | / | \ | / | \ | / | \ | / | --- | Level 4 7 | D | | --- | / \ | / \ | --- --- | Level 3 4 | G | 6 | E | | --- --- | | | | | | | --- --- | Level 2 3 | H | 5 | F | | --- --- | \ / | | \ / | | \ | | / \ | | / \ | | --- --- | Level 1 1 | J | 2 | I | | --- --- | \ / | \ / | --- v Level 0 0 | K | (More Specialized) --- 0123456789A KJIHGFEDABC =cut { package Test::A; use mro 'dfs'; package Test::B; use mro 'dfs'; package Test::C; use mro 'dfs'; package Test::D; use mro 'dfs'; use base qw/Test::A Test::B Test::C/; package Test::E; use mro 'dfs'; use base qw/Test::D/; package Test::F; use mro 'dfs'; use base qw/Test::E/; package Test::G; use mro 'dfs'; use base qw/Test::D/; package Test::H; use mro 'dfs'; use base qw/Test::G/; package Test::I; use mro 'dfs'; use base qw/Test::H Test::F/; package Test::J; use mro 'dfs'; use base qw/Test::F/; package Test::K; use mro 'dfs'; use base qw/Test::J Test::I/; } ok(eq_array( mro::get_linear_isa('Test::A'), [ qw(Test::A) ] ), '... got the right DFS merge order for Test::A'); ok(eq_array( mro::get_linear_isa('Test::B'), [ qw(Test::B) ] ), '... got the right DFS merge order for Test::B'); ok(eq_array( mro::get_linear_isa('Test::C'), [ qw(Test::C) ] ), '... got the right DFS merge order for Test::C'); ok(eq_array( mro::get_linear_isa('Test::D'), [ qw(Test::D Test::A Test::B Test::C) ] ), '... got the right DFS merge order for Test::D'); ok(eq_array( mro::get_linear_isa('Test::E'), [ qw(Test::E Test::D Test::A Test::B Test::C) ] ), '... got the right DFS merge order for Test::E'); ok(eq_array( mro::get_linear_isa('Test::F'), [ qw(Test::F Test::E Test::D Test::A Test::B Test::C) ] ), '... got the right DFS merge order for Test::F'); ok(eq_array( mro::get_linear_isa('Test::G'), [ qw(Test::G Test::D Test::A Test::B Test::C) ] ), '... got the right DFS merge order for Test::G'); ok(eq_array( mro::get_linear_isa('Test::H'), [ qw(Test::H Test::G Test::D Test::A Test::B Test::C) ] ), '... got the right DFS merge order for Test::H'); ok(eq_array( mro::get_linear_isa('Test::I'), [ qw(Test::I Test::H Test::G Test::D Test::A Test::B Test::C Test::F Test::E) ] ), '... got the right DFS merge order for Test::I'); ok(eq_array( mro::get_linear_isa('Test::J'), [ qw(Test::J Test::F Test::E Test::D Test::A Test::B Test::C) ] ), '... got the right DFS merge order for Test::J'); ok(eq_array( mro::get_linear_isa('Test::K'), [ qw(Test::K Test::J Test::F Test::E Test::D Test::A Test::B Test::C Test::I Test::H Test::G) ] ), '... got the right DFS merge order for Test::K'); perl-5.12.0-RC0/t/mro/basic_02_c3.t0000555000175000017500000000613711325125742015335 0ustar jessejesse#!./perl use strict; use warnings; require q(./test.pl); plan(tests => 10); =pod This example is take from: http://www.python.org/2.3/mro.html "My first example" class O: pass class F(O): pass class E(O): pass class D(O): pass class C(D,F): pass class B(D,E): pass class A(B,C): pass 6 --- Level 3 | O | (more general) / --- \ / | \ | / | \ | / | \ | --- --- --- | Level 2 3 | D | 4| E | | F | 5 | --- --- --- | \ \ _ / | | \ / \ _ | | \ / \ | | --- --- | Level 1 1 | B | | C | 2 | --- --- | \ / | \ / \ / --- Level 0 0 | A | (more specialized) --- =cut { package Test::O; use mro 'c3'; package Test::F; use mro 'c3'; use base 'Test::O'; package Test::E; use base 'Test::O'; use mro 'c3'; sub C_or_E { 'Test::E' } package Test::D; use mro 'c3'; use base 'Test::O'; sub C_or_D { 'Test::D' } package Test::C; use base ('Test::D', 'Test::F'); use mro 'c3'; sub C_or_D { 'Test::C' } sub C_or_E { 'Test::C' } package Test::B; use mro 'c3'; use base ('Test::D', 'Test::E'); package Test::A; use base ('Test::B', 'Test::C'); use mro 'c3'; } ok(eq_array( mro::get_linear_isa('Test::F'), [ qw(Test::F Test::O) ] ), '... got the right MRO for Test::F'); ok(eq_array( mro::get_linear_isa('Test::E'), [ qw(Test::E Test::O) ] ), '... got the right MRO for Test::E'); ok(eq_array( mro::get_linear_isa('Test::D'), [ qw(Test::D Test::O) ] ), '... got the right MRO for Test::D'); ok(eq_array( mro::get_linear_isa('Test::C'), [ qw(Test::C Test::D Test::F Test::O) ] ), '... got the right MRO for Test::C'); ok(eq_array( mro::get_linear_isa('Test::B'), [ qw(Test::B Test::D Test::E Test::O) ] ), '... got the right MRO for Test::B'); ok(eq_array( mro::get_linear_isa('Test::A'), [ qw(Test::A Test::B Test::C Test::D Test::E Test::F Test::O) ] ), '... got the right MRO for Test::A'); is(Test::A->C_or_D, 'Test::C', '... got the expected method output'); is(Test::A->can('C_or_D')->(), 'Test::C', '... can got the expected method output'); is(Test::A->C_or_E, 'Test::C', '... got the expected method output'); is(Test::A->can('C_or_E')->(), 'Test::C', '... can got the expected method output'); perl-5.12.0-RC0/t/mro/basic_05_dfs.t0000555000175000017500000000166111325125742015604 0ustar jessejesse#!./perl use strict; use warnings; require q(./test.pl); plan(tests => 2); =pod This tests a strange bug found by Matt S. Trout while building DBIx::Class. Thanks Matt!!!! / \ \ / =cut { package Diamond_A; use mro 'dfs'; sub foo { 'Diamond_A::foo' } } { package Diamond_B; use base 'Diamond_A'; use mro 'dfs'; sub foo { 'Diamond_B::foo => ' . (shift)->SUPER::foo } } { package Diamond_C; use mro 'dfs'; use base 'Diamond_A'; } { package Diamond_D; use base ('Diamond_C', 'Diamond_B'); use mro 'dfs'; sub foo { 'Diamond_D::foo => ' . (shift)->SUPER::foo } } ok(eq_array( mro::get_linear_isa('Diamond_D'), [ qw(Diamond_D Diamond_C Diamond_A Diamond_B) ] ), '... got the right MRO for Diamond_D'); is(Diamond_D->foo, 'Diamond_D::foo => Diamond_A::foo', '... got the right next::method dispatch path'); perl-5.12.0-RC0/t/mro/basic_01_dfs.t0000555000175000017500000000164511325125742015602 0ustar jessejesse#!./perl use strict; use warnings; require q(./test.pl); plan(tests => 4); =pod This tests the classic diamond inheritence pattern. / \ \ / =cut { package Diamond_A; sub hello { 'Diamond_A::hello' } } { package Diamond_B; use base 'Diamond_A'; } { package Diamond_C; use base 'Diamond_A'; sub hello { 'Diamond_C::hello' } } { package Diamond_D; use base ('Diamond_B', 'Diamond_C'); use mro 'dfs'; } ok(eq_array( mro::get_linear_isa('Diamond_D'), [ qw(Diamond_D Diamond_B Diamond_A Diamond_C) ] ), '... got the right MRO for Diamond_D'); is(Diamond_D->hello, 'Diamond_A::hello', '... method resolved itself as expected'); is(Diamond_D->can('hello')->(), 'Diamond_A::hello', '... can(method) resolved itself as expected'); is(UNIVERSAL::can("Diamond_D", 'hello')->(), 'Diamond_A::hello', '... can(method) resolved itself as expected'); perl-5.12.0-RC0/t/mro/next_method.t0000555000175000017500000000277111325125742015704 0ustar jessejesse#!/usr/bin/perl use strict; use warnings; require q(./test.pl); plan(tests => 5); =pod This tests the classic diamond inheritence pattern. / \ \ / =cut { package Diamond_A; use mro 'c3'; sub hello { 'Diamond_A::hello' } sub foo { 'Diamond_A::foo' } } { package Diamond_B; use base 'Diamond_A'; use mro 'c3'; sub foo { 'Diamond_B::foo => ' . (shift)->next::method() } } { package Diamond_C; use mro 'c3'; use base 'Diamond_A'; sub hello { 'Diamond_C::hello => ' . (shift)->next::method() } sub foo { 'Diamond_C::foo => ' . (shift)->next::method() } } { package Diamond_D; use base ('Diamond_B', 'Diamond_C'); use mro 'c3'; sub foo { 'Diamond_D::foo => ' . (shift)->next::method() } } ok(eq_array( mro::get_linear_isa('Diamond_D'), [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ] ), '... got the right MRO for Diamond_D'); is(Diamond_D->hello, 'Diamond_C::hello => Diamond_A::hello', '... method resolved itself as expected'); is(Diamond_D->can('hello')->('Diamond_D'), 'Diamond_C::hello => Diamond_A::hello', '... can(method) resolved itself as expected'); is(UNIVERSAL::can("Diamond_D", 'hello')->('Diamond_D'), 'Diamond_C::hello => Diamond_A::hello', '... can(method) resolved itself as expected'); is(Diamond_D->foo, 'Diamond_D::foo => Diamond_B::foo => Diamond_C::foo => Diamond_A::foo', '... method foo resolved itself as expected'); perl-5.12.0-RC0/t/mro/vulcan_c3.t0000555000175000017500000000246711325125742015245 0ustar jessejesse#!./perl use strict; use warnings; require q(./test.pl); plan(tests => 1); =pod example taken from: L Object ^ | LifeForm ^ ^ / \ Sentient BiPedal ^ ^ | | Intelligent Humanoid ^ ^ \ / Vulcan define class () end class; define class () end class; define class () end class; define class () end class; define class (, ) end class; =cut { package Object; use mro 'c3'; package LifeForm; use mro 'c3'; use base 'Object'; package Sentient; use mro 'c3'; use base 'LifeForm'; package BiPedal; use mro 'c3'; use base 'LifeForm'; package Intelligent; use mro 'c3'; use base 'Sentient'; package Humanoid; use mro 'c3'; use base 'BiPedal'; package Vulcan; use mro 'c3'; use base ('Intelligent', 'Humanoid'); } ok(eq_array( mro::get_linear_isa('Vulcan'), [ qw(Vulcan Intelligent Sentient Humanoid BiPedal LifeForm Object) ] ), '... got the right MRO for the Vulcan Dylan Example'); perl-5.12.0-RC0/t/mro/basic_05_c3.t0000555000175000017500000000167711325125742015344 0ustar jessejesse#!./perl use strict; use warnings; require q(./test.pl); plan(tests => 2); =pod This tests a strange bug found by Matt S. Trout while building DBIx::Class. Thanks Matt!!!! / \ \ / =cut { package Diamond_A; use mro 'c3'; sub foo { 'Diamond_A::foo' } } { package Diamond_B; use base 'Diamond_A'; use mro 'c3'; sub foo { 'Diamond_B::foo => ' . (shift)->SUPER::foo } } { package Diamond_C; use mro 'c3'; use base 'Diamond_A'; } { package Diamond_D; use base ('Diamond_C', 'Diamond_B'); use mro 'c3'; sub foo { 'Diamond_D::foo => ' . (shift)->SUPER::foo } } ok(eq_array( mro::get_linear_isa('Diamond_D'), [ qw(Diamond_D Diamond_C Diamond_B Diamond_A) ] ), '... got the right MRO for Diamond_D'); is(Diamond_D->foo, 'Diamond_D::foo => Diamond_B::foo => Diamond_A::foo', '... got the right next::method dispatch path'); perl-5.12.0-RC0/t/mro/basic_03_c3.t0000555000175000017500000000456711325125742015343 0ustar jessejesse#!./perl use strict; use warnings; require q(./test.pl); plan(tests => 4); =pod This example is take from: http://www.python.org/2.3/mro.html "My second example" class O: pass class F(O): pass class E(O): pass class D(O): pass class C(D,F): pass class B(E,D): pass class A(B,C): pass 6 --- Level 3 | O | / --- \ / | \ / | \ / | \ --- --- --- Level 2 2 | E | 4 | D | | F | 5 --- --- --- \ / \ / \ / \ / \ / \ / --- --- Level 1 1 | B | | C | 3 --- --- \ / \ / --- Level 0 0 | A | --- >>> A.mro() (, , , , , , ) =cut { package Test::O; use mro 'c3'; sub O_or_D { 'Test::O' } sub O_or_F { 'Test::O' } package Test::F; use base 'Test::O'; use mro 'c3'; sub O_or_F { 'Test::F' } package Test::E; use base 'Test::O'; use mro 'c3'; package Test::D; use base 'Test::O'; use mro 'c3'; sub O_or_D { 'Test::D' } sub C_or_D { 'Test::D' } package Test::C; use base ('Test::D', 'Test::F'); use mro 'c3'; sub C_or_D { 'Test::C' } package Test::B; use base ('Test::E', 'Test::D'); use mro 'c3'; package Test::A; use base ('Test::B', 'Test::C'); use mro 'c3'; } ok(eq_array( mro::get_linear_isa('Test::A'), [ qw(Test::A Test::B Test::E Test::C Test::D Test::F Test::O) ] ), '... got the right MRO for Test::A'); is(Test::A->O_or_D, 'Test::D', '... got the right method dispatch'); is(Test::A->O_or_F, 'Test::F', '... got the right method dispatch'); # NOTE: # this test is particularly interesting because the p5 dispatch # would actually call Test::D before Test::C and Test::D is a # subclass of Test::C is(Test::A->C_or_D, 'Test::C', '... got the right method dispatch'); perl-5.12.0-RC0/t/mro/pkg_gen.t0000555000175000017500000000161411325125742014773 0ustar jessejesse#!./perl use strict; use warnings; chdir 't' if -d 't'; require q(./test.pl); plan(tests => 7); require mro; { package Foo; our @ISA = qw//; } ok(!mro::get_pkg_gen('ReallyDoesNotExist'), "pkg_gen 0 for non-existant pkg"); my $f_gen = mro::get_pkg_gen('Foo'); ok($f_gen > 0, 'Foo pkg_gen > 0'); { no warnings 'once'; *Foo::foo_func = sub { 123 }; } my $new_f_gen = mro::get_pkg_gen('Foo'); ok($new_f_gen > $f_gen, 'Foo pkg_gen incs for methods'); $f_gen = $new_f_gen; @Foo::ISA = qw/Bar/; $new_f_gen = mro::get_pkg_gen('Foo'); ok($new_f_gen > $f_gen, 'Foo pkg_gen incs for @ISA'); undef %Foo::; is(mro::get_pkg_gen('Foo'), 1, "pkg_gen 1 for undef %Pkg::"); delete $::{"Foo::"}; is(mro::get_pkg_gen('Foo'), 0, 'pkg_gen 0 for delete $::{Pkg::}'); delete $::{"Quux::"}; push @Quux::ISA, "Woot"; # should not segfault ok(1, "No segfault on modification of ISA in a deleted stash"); perl-5.12.0-RC0/t/mro/isa_dfs.t0000555000175000017500000000207511325127001014761 0ustar jessejesse#!perl -w BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require "./test.pl"; } use strict; plan 'no_plan'; # package klonk doesn't have a stash. package kapow; # No parents package urkkk; # 1 parent @urkkk::ISA = 'klonk'; package kayo; # 2 parents @urkkk::ISA = ('klonk', 'kapow'); package thwacke; # No parents, has @ISA @thwacke::ISA = (); package zzzzzwap; @zzzzzwap::ISA = ('thwacke', 'kapow'); package whamm; @whamm::ISA = ('kapow', 'thwacke'); package main; require mro; my %expect = ( klonk => [qw(klonk)], urkkk => [qw(urkkk klonk kapow)], kapow => [qw(kapow)], kayo => [qw(kayo)], thwacke => [qw(thwacke)], zzzzzwap => [qw(zzzzzwap thwacke kapow)], whamm => [qw(whamm kapow thwacke)], ); foreach my $package (qw(klonk urkkk kapow kayo thwacke zzzzzwap whamm)) { my $ref = bless [], $package; my $isa = $expect{$package}; is("@{mro::get_linear_isa($package)}", "@$isa", "\@ISA for $package"); foreach my $class ($package, @$isa, 'UNIVERSAL') { isa_ok($ref, $class, $package); } } perl-5.12.0-RC0/t/mro/basic_04_dfs.t0000555000175000017500000000130711325125742015600 0ustar jessejesse#!./perl use strict; use warnings; require q(./test.pl); plan(tests => 1); =pod From the parrot test t/pmc/object-meths.t A B A E \ / \ / C D \ / \ / F =cut { package t::lib::A; use mro 'dfs'; package t::lib::B; use mro 'dfs'; package t::lib::E; use mro 'dfs'; package t::lib::C; use mro 'dfs'; use base ('t::lib::A', 't::lib::B'); package t::lib::D; use mro 'dfs'; use base ('t::lib::A', 't::lib::E'); package t::lib::F; use mro 'dfs'; use base ('t::lib::C', 't::lib::D'); } ok(eq_array( mro::get_linear_isa('t::lib::F'), [ qw(t::lib::F t::lib::C t::lib::A t::lib::B t::lib::D t::lib::E) ] ), '... got the right MRO for t::lib::F'); perl-5.12.0-RC0/t/mro/complex_c3.t0000555000175000017500000001003211325125742015407 0ustar jessejesse#!./perl use strict; use warnings; require q(./test.pl); plan(tests => 12); =pod This example is taken from: http://rt.cpan.org/Public/Bug/Display.html?id=20879 --- --- --- Level 5 8 | A | 9 | B | A | C | (More General) --- --- --- V \ | / | \ | / | \ | / | \ | / | --- | Level 4 7 | D | | --- | / \ | / \ | --- --- | Level 3 4 | G | 6 | E | | --- --- | | | | | | | --- --- | Level 2 3 | H | 5 | F | | --- --- | \ / | | \ / | | \ | | / \ | | / \ | | --- --- | Level 1 1 | J | 2 | I | | --- --- | \ / | \ / | --- v Level 0 0 | K | (More Specialized) --- 0123456789A KJIHGFEDABC =cut { package Test::A; use mro 'c3'; package Test::B; use mro 'c3'; package Test::C; use mro 'c3'; package Test::D; use mro 'c3'; use base qw/Test::A Test::B Test::C/; package Test::E; use mro 'c3'; use base qw/Test::D/; package Test::F; use mro 'c3'; use base qw/Test::E/; sub testmeth { "wrong" } package Test::G; use mro 'c3'; use base qw/Test::D/; package Test::H; use mro 'c3'; use base qw/Test::G/; package Test::I; use mro 'c3'; use base qw/Test::H Test::F/; sub testmeth { "right" } package Test::J; use mro 'c3'; use base qw/Test::F/; package Test::K; use mro 'c3'; use base qw/Test::J Test::I/; sub testmeth { shift->next::method } } ok(eq_array( mro::get_linear_isa('Test::A'), [ qw(Test::A) ] ), '... got the right C3 merge order for Test::A'); ok(eq_array( mro::get_linear_isa('Test::B'), [ qw(Test::B) ] ), '... got the right C3 merge order for Test::B'); ok(eq_array( mro::get_linear_isa('Test::C'), [ qw(Test::C) ] ), '... got the right C3 merge order for Test::C'); ok(eq_array( mro::get_linear_isa('Test::D'), [ qw(Test::D Test::A Test::B Test::C) ] ), '... got the right C3 merge order for Test::D'); ok(eq_array( mro::get_linear_isa('Test::E'), [ qw(Test::E Test::D Test::A Test::B Test::C) ] ), '... got the right C3 merge order for Test::E'); ok(eq_array( mro::get_linear_isa('Test::F'), [ qw(Test::F Test::E Test::D Test::A Test::B Test::C) ] ), '... got the right C3 merge order for Test::F'); ok(eq_array( mro::get_linear_isa('Test::G'), [ qw(Test::G Test::D Test::A Test::B Test::C) ] ), '... got the right C3 merge order for Test::G'); ok(eq_array( mro::get_linear_isa('Test::H'), [ qw(Test::H Test::G Test::D Test::A Test::B Test::C) ] ), '... got the right C3 merge order for Test::H'); ok(eq_array( mro::get_linear_isa('Test::I'), [ qw(Test::I Test::H Test::G Test::F Test::E Test::D Test::A Test::B Test::C) ] ), '... got the right C3 merge order for Test::I'); ok(eq_array( mro::get_linear_isa('Test::J'), [ qw(Test::J Test::F Test::E Test::D Test::A Test::B Test::C) ] ), '... got the right C3 merge order for Test::J'); ok(eq_array( mro::get_linear_isa('Test::K'), [ qw(Test::K Test::J Test::I Test::H Test::G Test::F Test::E Test::D Test::A Test::B Test::C) ] ), '... got the right C3 merge order for Test::K'); is(Test::K->testmeth(), "right", 'next::method working ok'); perl-5.12.0-RC0/t/mro/basic.t0000555000175000017500000001565111337270102014442 0ustar jessejesse#!./perl use strict; use warnings; require q(./test.pl); plan(tests => 48); require mro; { package MRO_A; our @ISA = qw//; package MRO_B; our @ISA = qw//; package MRO_C; our @ISA = qw//; package MRO_D; our @ISA = qw/MRO_A MRO_B MRO_C/; package MRO_E; our @ISA = qw/MRO_A MRO_B MRO_C/; package MRO_F; our @ISA = qw/MRO_D MRO_E/; } my @MFO_F_DFS = qw/MRO_F MRO_D MRO_A MRO_B MRO_C MRO_E/; my @MFO_F_C3 = qw/MRO_F MRO_D MRO_E MRO_A MRO_B MRO_C/; is(mro::get_mro('MRO_F'), 'dfs'); ok(eq_array( mro::get_linear_isa('MRO_F'), \@MFO_F_DFS )); ok(eq_array(mro::get_linear_isa('MRO_F', 'dfs'), \@MFO_F_DFS)); ok(eq_array(mro::get_linear_isa('MRO_F', 'c3'), \@MFO_F_C3)); eval{mro::get_linear_isa('MRO_F', 'C3')}; like($@, qr/^Invalid mro name: 'C3'/); mro::set_mro('MRO_F', 'c3'); is(mro::get_mro('MRO_F'), 'c3'); ok(eq_array( mro::get_linear_isa('MRO_F'), \@MFO_F_C3 )); ok(eq_array(mro::get_linear_isa('MRO_F', 'dfs'), \@MFO_F_DFS)); ok(eq_array(mro::get_linear_isa('MRO_F', 'c3'), \@MFO_F_C3)); eval{mro::get_linear_isa('MRO_F', 'C3')}; like($@, qr/^Invalid mro name: 'C3'/); my @isarev = sort { $a cmp $b } @{mro::get_isarev('MRO_B')}; ok(eq_array( \@isarev, [qw/MRO_D MRO_E MRO_F/] )); ok(!mro::is_universal('MRO_B')); @UNIVERSAL::ISA = qw/MRO_F/; ok(mro::is_universal('MRO_B')); @UNIVERSAL::ISA = (); ok(mro::is_universal('MRO_B')); # is_universal, get_mro, and get_linear_isa should # handle non-existant packages sanely ok(!mro::is_universal('Does_Not_Exist')); is(mro::get_mro('Also_Does_Not_Exist'), 'dfs'); ok(eq_array( mro::get_linear_isa('Does_Not_Exist_Three'), [qw/Does_Not_Exist_Three/] )); # Assigning @ISA via globref { package MRO_TestBase; sub testfunc { return 123 } package MRO_TestOtherBase; sub testfunctwo { return 321 } package MRO_M; our @ISA = qw/MRO_TestBase/; } *MRO_N::ISA = *MRO_M::ISA; is(eval { MRO_N->testfunc() }, 123); # XXX TODO (when there's a way to backtrack through a glob's aliases) # push(@MRO_M::ISA, 'MRO_TestOtherBase'); # is(eval { MRO_N->testfunctwo() }, 321); # Simple DESTROY Baseline { my $x = 0; my $obj; { package DESTROY_MRO_Baseline; sub new { bless {} => shift } sub DESTROY { $x++ } package DESTROY_MRO_Baseline_Child; our @ISA = qw/DESTROY_MRO_Baseline/; } $obj = DESTROY_MRO_Baseline->new(); undef $obj; is($x, 1); $obj = DESTROY_MRO_Baseline_Child->new(); undef $obj; is($x, 2); } # Dynamic DESTROY { my $x = 0; my $obj; { package DESTROY_MRO_Dynamic; sub new { bless {} => shift } package DESTROY_MRO_Dynamic_Child; our @ISA = qw/DESTROY_MRO_Dynamic/; } $obj = DESTROY_MRO_Dynamic->new(); undef $obj; is($x, 0); $obj = DESTROY_MRO_Dynamic_Child->new(); undef $obj; is($x, 0); no warnings 'once'; *DESTROY_MRO_Dynamic::DESTROY = sub { $x++ }; $obj = DESTROY_MRO_Dynamic->new(); undef $obj; is($x, 1); $obj = DESTROY_MRO_Dynamic_Child->new(); undef $obj; is($x, 2); } # clearing @ISA in different ways # some are destructive to the package, hence the new # package name each time { no warnings 'uninitialized'; { package ISACLEAR; our @ISA = qw/XX YY ZZ/; } # baseline ok(eq_array(mro::get_linear_isa('ISACLEAR'),[qw/ISACLEAR XX YY ZZ/])); # this looks dumb, but it preserves existing behavior for compatibility # (undefined @ISA elements treated as "main") $ISACLEAR::ISA[1] = undef; ok(eq_array(mro::get_linear_isa('ISACLEAR'),[qw/ISACLEAR XX main ZZ/])); # undef the array itself undef @ISACLEAR::ISA; ok(eq_array(mro::get_linear_isa('ISACLEAR'),[qw/ISACLEAR/])); # Now, clear more than one package's @ISA at once { package ISACLEAR1; our @ISA = qw/WW XX/; package ISACLEAR2; our @ISA = qw/YY ZZ/; } # baseline ok(eq_array(mro::get_linear_isa('ISACLEAR1'),[qw/ISACLEAR1 WW XX/])); ok(eq_array(mro::get_linear_isa('ISACLEAR2'),[qw/ISACLEAR2 YY ZZ/])); (@ISACLEAR1::ISA, @ISACLEAR2::ISA) = (); ok(eq_array(mro::get_linear_isa('ISACLEAR1'),[qw/ISACLEAR1/])); ok(eq_array(mro::get_linear_isa('ISACLEAR2'),[qw/ISACLEAR2/])); # [perl #49564] This is a pretty obscure way of clearing @ISA but # it tests a regression that affects XS code calling av_clear too. { package ISACLEAR3; our @ISA = qw/WW XX/; } ok(eq_array(mro::get_linear_isa('ISACLEAR3'),[qw/ISACLEAR3 WW XX/])); { package ISACLEAR3; reset 'I'; } ok(eq_array(mro::get_linear_isa('ISACLEAR3'),[qw/ISACLEAR3/])); } # Check that recursion bails out "cleanly" in a variety of cases # (as opposed to say, bombing the interpreter or something) { my @recurse_codes = ( '@MRO_R1::ISA = "MRO_R2"; @MRO_R2::ISA = "MRO_R1";', '@MRO_R3::ISA = "MRO_R4"; push(@MRO_R4::ISA, "MRO_R3");', '@MRO_R5::ISA = "MRO_R6"; @MRO_R6::ISA = qw/XX MRO_R5 YY/;', '@MRO_R7::ISA = "MRO_R8"; push(@MRO_R8::ISA, qw/XX MRO_R7 YY/)', ); foreach my $code (@recurse_codes) { eval $code; ok($@ =~ /Recursive inheritance detected/); } } # Check that SUPER caches get invalidated correctly { { package SUPERTEST; sub new { bless {} => shift } sub foo { $_[1]+1 } package SUPERTEST::MID; our @ISA = 'SUPERTEST'; package SUPERTEST::KID; our @ISA = 'SUPERTEST::MID'; sub foo { my $s = shift; $s->SUPER::foo(@_) } package SUPERTEST::REBASE; sub foo { $_[1]+3 } } my $stk_obj = SUPERTEST::KID->new(); is($stk_obj->foo(1), 2); { no warnings 'redefine'; *SUPERTEST::foo = sub { $_[1]+2 }; } is($stk_obj->foo(2), 4); @SUPERTEST::MID::ISA = 'SUPERTEST::REBASE'; is($stk_obj->foo(3), 6); } { { # assigning @ISA via arrayref to globref RT 60220 package P1; sub new { bless {}, shift } package P2; } *{P2::ISA} = [ 'P1' ]; my $foo = P2->new; ok(!eval { $foo->bark }, "no bark method"); no warnings 'once'; # otherwise it'll bark about P1::bark used only once *{P1::bark} = sub { "[bark]" }; is(scalar eval { $foo->bark }, "[bark]", "can bark now"); } { # assigning @ISA via arrayref then modifying it RT 72866 { package Q1; sub foo { } package Q2; sub bar { } package Q3; } push @Q3::ISA, "Q1"; can_ok("Q3", "foo"); *Q3::ISA = []; push @Q3::ISA, "Q1"; can_ok("Q3", "foo"); *Q3::ISA = []; push @Q3::ISA, "Q2"; can_ok("Q3", "bar"); ok(!Q3->can("foo"), "can't call foo method any longer"); } { # test mro::method_changed_in my $count = mro::get_pkg_gen("MRO_A"); mro::method_changed_in("MRO_A"); my $count_new = mro::get_pkg_gen("MRO_A"); is($count_new, $count + 1); } { # test if we can call mro::invalidate_all_method_caches; eval { mro::invalidate_all_method_caches(); }; is($@, ""); } perl-5.12.0-RC0/t/mro/overload_dfs.t0000555000175000017500000000234011325125742016025 0ustar jessejesse#!./perl use strict; use warnings; BEGIN { unless (-d 'blib') { chdir 't' if -d 't'; @INC = '../lib'; } } require q(./test.pl); plan(tests => 7); { package BaseTest; use strict; use warnings; use mro 'dfs'; package OverloadingTest; use strict; use warnings; use mro 'dfs'; use base 'BaseTest'; use overload '""' => sub { ref(shift) . " stringified" }, fallback => 1; sub new { bless {} => shift } package InheritingFromOverloadedTest; use strict; use warnings; use base 'OverloadingTest'; use mro 'dfs'; } my $x = InheritingFromOverloadedTest->new(); isa_ok($x, 'InheritingFromOverloadedTest'); my $y = OverloadingTest->new(); isa_ok($y, 'OverloadingTest'); is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing'); is("$y", 'OverloadingTest stringified', '... got the right value when stringifing'); ok(($y eq 'OverloadingTest stringified'), '... eq was handled correctly'); my $result; eval { $result = $x eq 'InheritingFromOverloadedTest stringified' }; ok(!$@, '... this should not throw an exception'); ok($result, '... and we should get the true value'); perl-5.12.0-RC0/t/mro/recursion_dfs.t0000555000175000017500000000363411325125742016232 0ustar jessejesse#!./perl use strict; use warnings; BEGIN { unless (-d 'blib') { chdir 't' if -d 't'; @INC = '../lib'; } } require './test.pl'; plan(skip_all => "Your system has no SIGALRM") if !exists $SIG{ALRM}; plan(tests => 8); =pod These are like the 010_complex_merge_classless test, but an infinite loop has been made in the heirarchy, to test that we can fail cleanly instead of going into an infinite loop =cut # initial setup, everything sane { package K; our @ISA = qw/J I/; package J; our @ISA = qw/F/; package I; our @ISA = qw/H F/; package H; our @ISA = qw/G/; package G; our @ISA = qw/D/; package F; our @ISA = qw/E/; package E; our @ISA = qw/D/; package D; our @ISA = qw/A B C/; package C; our @ISA = qw//; package B; our @ISA = qw//; package A; our @ISA = qw//; } # A series of 8 abberations that would cause infinite loops, # each one undoing the work of the previous my @loopies = ( sub { @E::ISA = qw/F/ }, sub { @E::ISA = qw/D/; @C::ISA = qw/F/ }, sub { @C::ISA = qw//; @A::ISA = qw/K/ }, sub { @A::ISA = qw//; @J::ISA = qw/F K/ }, sub { @J::ISA = qw/F/; @H::ISA = qw/K G/ }, sub { @H::ISA = qw/G/; @B::ISA = qw/B/ }, sub { @B::ISA = qw//; @K::ISA = qw/K J I/ }, sub { @K::ISA = qw/J I/; @D::ISA = qw/A H B C/ }, ); foreach my $loopy (@loopies) { eval { local $SIG{ALRM} = sub { die "ALRMTimeout" }; alarm(3); $loopy->(); mro::get_linear_isa('K', 'dfs'); }; if(my $err = $@) { if($err =~ /ALRMTimeout/) { ok(0, "Loop terminated by SIGALRM"); } elsif($err =~ /Recursive inheritance detected/) { ok(1, "Graceful exception thrown"); } else { ok(0, "Unrecognized exception: $err"); } } else { ok(0, "Infinite loop apparently succeeded???"); } } perl-5.12.0-RC0/t/mro/recursion_c3.t0000555000175000017500000000415711325125742015764 0ustar jessejesse#!./perl use strict; use warnings; BEGIN { unless (-d 'blib') { chdir 't' if -d 't'; @INC = '../lib'; } } require './test.pl'; plan(skip_all => "Your system has no SIGALRM") if !exists $SIG{ALRM}; plan(tests => 8); require mro; =pod These are like the 010_complex_merge_classless test, but an infinite loop has been made in the heirarchy, to test that we can fail cleanly instead of going into an infinite loop =cut # initial setup, everything sane { package K; use mro 'c3'; our @ISA = qw/J I/; package J; use mro 'c3'; our @ISA = qw/F/; package I; use mro 'c3'; our @ISA = qw/H F/; package H; use mro 'c3'; our @ISA = qw/G/; package G; use mro 'c3'; our @ISA = qw/D/; package F; use mro 'c3'; our @ISA = qw/E/; package E; use mro 'c3'; our @ISA = qw/D/; package D; use mro 'c3'; our @ISA = qw/A B C/; package C; use mro 'c3'; our @ISA = qw//; package B; use mro 'c3'; our @ISA = qw//; package A; use mro 'c3'; our @ISA = qw//; } # A series of 8 abberations that would cause infinite loops, # each one undoing the work of the previous my @loopies = ( sub { @E::ISA = qw/F/ }, sub { @E::ISA = qw/D/; @C::ISA = qw/F/ }, sub { @C::ISA = qw//; @A::ISA = qw/K/ }, sub { @A::ISA = qw//; @J::ISA = qw/F K/ }, sub { @J::ISA = qw/F/; @H::ISA = qw/K G/ }, sub { @H::ISA = qw/G/; @B::ISA = qw/B/ }, sub { @B::ISA = qw//; @K::ISA = qw/K J I/ }, sub { @K::ISA = qw/J I/; @D::ISA = qw/A H B C/ }, ); foreach my $loopy (@loopies) { eval { local $SIG{ALRM} = sub { die "ALRMTimeout" }; alarm(3); $loopy->(); mro::get_linear_isa('K', 'c3'); }; if(my $err = $@) { if($err =~ /ALRMTimeout/) { ok(0, "Loop terminated by SIGALRM"); } elsif($err =~ /Recursive inheritance detected/) { ok(1, "Graceful exception thrown"); } else { ok(0, "Unrecognized exception: $err"); } } else { ok(0, "Infinite loop apparently succeeded???"); } } perl-5.12.0-RC0/t/mro/dbic_dfs.t0000555000175000017500000001011511325125742015112 0ustar jessejesse#!./perl use strict; use warnings; require q(./test.pl); plan(tests => 1); =pod This example is taken from the inheritance graph of DBIx::Class::Core in DBIx::Class v0.07002: (No ASCII art this time, this graph is insane) The xx:: prefixes are just to be sure these bogus declarations never stomp on real ones =cut { package xx::DBIx::Class::Core; use mro 'dfs'; our @ISA = qw/ xx::DBIx::Class::Serialize::Storable xx::DBIx::Class::InflateColumn xx::DBIx::Class::Relationship xx::DBIx::Class::PK::Auto xx::DBIx::Class::PK xx::DBIx::Class::Row xx::DBIx::Class::ResultSourceProxy::Table xx::DBIx::Class::AccessorGroup /; package xx::DBIx::Class::InflateColumn; use mro 'dfs'; our @ISA = qw/ xx::DBIx::Class::Row /; package xx::DBIx::Class::Row; use mro 'dfs'; our @ISA = qw/ xx::DBIx::Class /; package xx::DBIx::Class; use mro 'dfs'; our @ISA = qw/ xx::DBIx::Class::Componentised xx::Class::Data::Accessor /; package xx::DBIx::Class::Relationship; use mro 'dfs'; our @ISA = qw/ xx::DBIx::Class::Relationship::Helpers xx::DBIx::Class::Relationship::Accessor xx::DBIx::Class::Relationship::CascadeActions xx::DBIx::Class::Relationship::ProxyMethods xx::DBIx::Class::Relationship::Base xx::DBIx::Class /; package xx::DBIx::Class::Relationship::Helpers; use mro 'dfs'; our @ISA = qw/ xx::DBIx::Class::Relationship::HasMany xx::DBIx::Class::Relationship::HasOne xx::DBIx::Class::Relationship::BelongsTo xx::DBIx::Class::Relationship::ManyToMany /; package xx::DBIx::Class::Relationship::ProxyMethods; use mro 'dfs'; our @ISA = qw/ xx::DBIx::Class /; package xx::DBIx::Class::Relationship::Base; use mro 'dfs'; our @ISA = qw/ xx::DBIx::Class /; package xx::DBIx::Class::PK::Auto; use mro 'dfs'; our @ISA = qw/ xx::DBIx::Class /; package xx::DBIx::Class::PK; use mro 'dfs'; our @ISA = qw/ xx::DBIx::Class::Row /; package xx::DBIx::Class::ResultSourceProxy::Table; use mro 'dfs'; our @ISA = qw/ xx::DBIx::Class::AccessorGroup xx::DBIx::Class::ResultSourceProxy /; package xx::DBIx::Class::ResultSourceProxy; use mro 'dfs'; our @ISA = qw/ xx::DBIx::Class /; package xx::Class::Data::Accessor; our @ISA = (); use mro 'dfs'; package xx::DBIx::Class::Relationship::HasMany; our @ISA = (); use mro 'dfs'; package xx::DBIx::Class::Relationship::HasOne; our @ISA = (); use mro 'dfs'; package xx::DBIx::Class::Relationship::BelongsTo; our @ISA = (); use mro 'dfs'; package xx::DBIx::Class::Relationship::ManyToMany; our @ISA = (); use mro 'dfs'; package xx::DBIx::Class::Componentised; our @ISA = (); use mro 'dfs'; package xx::DBIx::Class::AccessorGroup; our @ISA = (); use mro 'dfs'; package xx::DBIx::Class::Serialize::Storable; our @ISA = (); use mro 'dfs'; package xx::DBIx::Class::Relationship::Accessor; our @ISA = (); use mro 'dfs'; package xx::DBIx::Class::Relationship::CascadeActions; our @ISA = (); use mro 'dfs'; } ok(eq_array( mro::get_linear_isa('xx::DBIx::Class::Core'), [qw/ xx::DBIx::Class::Core xx::DBIx::Class::Serialize::Storable xx::DBIx::Class::InflateColumn xx::DBIx::Class::Row xx::DBIx::Class xx::DBIx::Class::Componentised xx::Class::Data::Accessor xx::DBIx::Class::Relationship xx::DBIx::Class::Relationship::Helpers xx::DBIx::Class::Relationship::HasMany xx::DBIx::Class::Relationship::HasOne xx::DBIx::Class::Relationship::BelongsTo xx::DBIx::Class::Relationship::ManyToMany xx::DBIx::Class::Relationship::Accessor xx::DBIx::Class::Relationship::CascadeActions xx::DBIx::Class::Relationship::ProxyMethods xx::DBIx::Class::Relationship::Base xx::DBIx::Class::PK::Auto xx::DBIx::Class::PK xx::DBIx::Class::ResultSourceProxy::Table xx::DBIx::Class::AccessorGroup xx::DBIx::Class::ResultSourceProxy /] ), '... got the right DFS merge order for xx::DBIx::Class::Core'); perl-5.12.0-RC0/t/mro/next_ineval.t0000555000175000017500000000106111325125742015671 0ustar jessejesse#!/usr/bin/perl use strict; use warnings; require q(./test.pl); plan(tests => 1); =pod This tests the use of an eval{} block to wrap a next::method call. =cut { package A; use mro 'c3'; sub foo { die 'A::foo died'; return 'A::foo succeeded'; } } { package B; use base 'A'; use mro 'c3'; sub foo { eval { return 'B::foo => ' . (shift)->next::method(); }; if ($@) { return $@; } } } like(B->foo, qr/^A::foo died/, 'method resolved inside eval{}'); perl-5.12.0-RC0/t/mro/next_edgecases.t0000555000175000017500000000371711325125742016350 0ustar jessejesse#!/usr/bin/perl use strict; use warnings; require q(./test.pl); plan(tests => 12); { { package Foo; use strict; use warnings; use mro 'c3'; sub new { bless {}, $_[0] } sub bar { 'Foo::bar' } } # call the submethod in the direct instance my $foo = Foo->new(); isa_ok($foo, 'Foo'); can_ok($foo, 'bar'); is($foo->bar(), 'Foo::bar', '... got the right return value'); # fail calling it from a subclass { package Bar; use strict; use warnings; use mro 'c3'; our @ISA = ('Foo'); } my $bar = Bar->new(); isa_ok($bar, 'Bar'); isa_ok($bar, 'Foo'); # test it working with with Sub::Name SKIP: { eval 'use Sub::Name'; skip("Sub::Name is required for this test", 3) if $@; my $m = sub { (shift)->next::method() }; Sub::Name::subname('Bar::bar', $m); { no strict 'refs'; *{'Bar::bar'} = $m; } can_ok($bar, 'bar'); my $value = eval { $bar->bar() }; ok(!$@, '... calling bar() succedded') || diag $@; is($value, 'Foo::bar', '... got the right return value too'); } # test it failing without Sub::Name { package Baz; use strict; use warnings; use mro 'c3'; our @ISA = ('Foo'); } my $baz = Baz->new(); isa_ok($baz, 'Baz'); isa_ok($baz, 'Foo'); { my $m = sub { (shift)->next::method() }; { no strict 'refs'; *{'Baz::bar'} = $m; } eval { $baz->bar() }; ok($@, '... calling bar() with next::method failed') || diag $@; } # Test with non-existing class (used to segfault) { package Qux; use mro; sub foo { No::Such::Class->next::can } } eval { Qux->foo() }; is($@, '', "->next::can on non-existing package name"); } perl-5.12.0-RC0/t/mro/basic_04_c3.t0000555000175000017500000000130111325125742015323 0ustar jessejesse#!./perl use strict; use warnings; require q(./test.pl); plan(tests => 1); =pod From the parrot test t/pmc/object-meths.t A B A E \ / \ / C D \ / \ / F =cut { package t::lib::A; use mro 'c3'; package t::lib::B; use mro 'c3'; package t::lib::E; use mro 'c3'; package t::lib::C; use mro 'c3'; use base ('t::lib::A', 't::lib::B'); package t::lib::D; use mro 'c3'; use base ('t::lib::A', 't::lib::E'); package t::lib::F; use mro 'c3'; use base ('t::lib::C', 't::lib::D'); } ok(eq_array( mro::get_linear_isa('t::lib::F'), [ qw(t::lib::F t::lib::C t::lib::D t::lib::A t::lib::B t::lib::E) ] ), '... got the right MRO for t::lib::F'); perl-5.12.0-RC0/t/mro/next_skip.t0000555000175000017500000000466511325125742015376 0ustar jessejesse#!/usr/bin/perl use strict; use warnings; require q(./test.pl); plan(tests => 10); =pod This tests the classic diamond inheritence pattern. / \ \ / =cut { package Diamond_A; use mro 'c3'; sub bar { 'Diamond_A::bar' } sub baz { 'Diamond_A::baz' } } { package Diamond_B; use base 'Diamond_A'; use mro 'c3'; sub baz { 'Diamond_B::baz => ' . (shift)->next::method() } } { package Diamond_C; use mro 'c3'; use base 'Diamond_A'; sub foo { 'Diamond_C::foo' } sub buz { 'Diamond_C::buz' } sub woz { 'Diamond_C::woz' } sub maybe { 'Diamond_C::maybe' } } { package Diamond_D; use base ('Diamond_B', 'Diamond_C'); use mro 'c3'; sub foo { 'Diamond_D::foo => ' . (shift)->next::method() } sub bar { 'Diamond_D::bar => ' . (shift)->next::method() } sub buz { 'Diamond_D::buz => ' . (shift)->baz() } sub fuz { 'Diamond_D::fuz => ' . (shift)->next::method() } sub woz { 'Diamond_D::woz can => ' . ((shift)->next::can() ? 1 : 0) } sub noz { 'Diamond_D::noz can => ' . ((shift)->next::can() ? 1 : 0) } sub maybe { 'Diamond_D::maybe => ' . ((shift)->maybe::next::method() || 0) } sub moybe { 'Diamond_D::moybe => ' . ((shift)->maybe::next::method() || 0) } } ok(eq_array( mro::get_linear_isa('Diamond_D'), [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ] ), '... got the right MRO for Diamond_D'); is(Diamond_D->foo, 'Diamond_D::foo => Diamond_C::foo', '... skipped B and went to C correctly'); is(Diamond_D->bar, 'Diamond_D::bar => Diamond_A::bar', '... skipped B & C and went to A correctly'); is(Diamond_D->baz, 'Diamond_B::baz => Diamond_A::baz', '... called B method, skipped C and went to A correctly'); is(Diamond_D->buz, 'Diamond_D::buz => Diamond_B::baz => Diamond_A::baz', '... called D method dispatched to , different method correctly'); eval { Diamond_D->fuz }; like($@, qr/^No next::method 'fuz' found for Diamond_D/, '... cannot re-dispatch to a method which is not there'); is(Diamond_D->woz, 'Diamond_D::woz can => 1', '... can re-dispatch figured out correctly'); is(Diamond_D->noz, 'Diamond_D::noz can => 0', '... cannot re-dispatch figured out correctly'); is(Diamond_D->maybe, 'Diamond_D::maybe => Diamond_C::maybe', '... redispatched D to C when it exists'); is(Diamond_D->moybe, 'Diamond_D::moybe => 0', '... quietly failed redispatch from D'); perl-5.12.0-RC0/t/mro/basic_03_dfs.t0000555000175000017500000000457611325125742015612 0ustar jessejesse#!./perl use strict; use warnings; require q(./test.pl); plan(tests => 4); =pod This example is take from: http://www.python.org/2.3/mro.html "My second example" class O: pass class F(O): pass class E(O): pass class D(O): pass class C(D,F): pass class B(E,D): pass class A(B,C): pass 6 --- Level 3 | O | / --- \ / | \ / | \ / | \ --- --- --- Level 2 2 | E | 4 | D | | F | 5 --- --- --- \ / \ / \ / \ / \ / \ / --- --- Level 1 1 | B | | C | 3 --- --- \ / \ / --- Level 0 0 | A | --- >>> A.mro() (, , , , , , ) =cut { package Test::O; use mro 'dfs'; sub O_or_D { 'Test::O' } sub O_or_F { 'Test::O' } package Test::F; use base 'Test::O'; use mro 'dfs'; sub O_or_F { 'Test::F' } package Test::E; use base 'Test::O'; use mro 'dfs'; package Test::D; use base 'Test::O'; use mro 'dfs'; sub O_or_D { 'Test::D' } sub C_or_D { 'Test::D' } package Test::C; use base ('Test::D', 'Test::F'); use mro 'dfs'; sub C_or_D { 'Test::C' } package Test::B; use base ('Test::E', 'Test::D'); use mro 'dfs'; package Test::A; use base ('Test::B', 'Test::C'); use mro 'dfs'; } ok(eq_array( mro::get_linear_isa('Test::A'), [ qw(Test::A Test::B Test::E Test::O Test::D Test::C Test::F) ] ), '... got the right MRO for Test::A'); is(Test::A->O_or_D, 'Test::O', '... got the right method dispatch'); is(Test::A->O_or_F, 'Test::O', '... got the right method dispatch'); # NOTE: # this test is particularly interesting because the p5 dispatch # would actually call Test::D before Test::C and Test::D is a # subclass of Test::C is(Test::A->C_or_D, 'Test::D', '... got the right method dispatch'); perl-5.12.0-RC0/t/mro/package_aliases.t0000555000175000017500000000104011325125742016446 0ustar jessejesse#!./perl BEGIN { unless (-d 'blib') { chdir 't' if -d 't'; @INC = '../lib'; } } use strict; use warnings; require q(./test.pl); plan(tests => 4); { package New; use strict; use warnings; package Old; use strict; use warnings; { no strict 'refs'; *{'Old::'} = *{'New::'}; } } ok (Old->isa (New::), 'Old inherits from New'); ok (New->isa (Old::), 'New inherits from Old'); isa_ok (bless ({}, Old::), New::, 'Old object'); isa_ok (bless ({}, New::), Old::, 'New object'); perl-5.12.0-RC0/t/mro/basic_02_dfs.t0000555000175000017500000000614611325125742015604 0ustar jessejesse#!./perl use strict; use warnings; require q(./test.pl); plan(tests => 10); =pod This example is take from: http://www.python.org/2.3/mro.html "My first example" class O: pass class F(O): pass class E(O): pass class D(O): pass class C(D,F): pass class B(D,E): pass class A(B,C): pass 6 --- Level 3 | O | (more general) / --- \ / | \ | / | \ | / | \ | --- --- --- | Level 2 3 | D | 4| E | | F | 5 | --- --- --- | \ \ _ / | | \ / \ _ | | \ / \ | | --- --- | Level 1 1 | B | | C | 2 | --- --- | \ / | \ / \ / --- Level 0 0 | A | (more specialized) --- =cut { package Test::O; use mro 'dfs'; package Test::F; use mro 'dfs'; use base 'Test::O'; package Test::E; use base 'Test::O'; use mro 'dfs'; sub C_or_E { 'Test::E' } package Test::D; use mro 'dfs'; use base 'Test::O'; sub C_or_D { 'Test::D' } package Test::C; use base ('Test::D', 'Test::F'); use mro 'dfs'; sub C_or_D { 'Test::C' } sub C_or_E { 'Test::C' } package Test::B; use mro 'dfs'; use base ('Test::D', 'Test::E'); package Test::A; use base ('Test::B', 'Test::C'); use mro 'dfs'; } ok(eq_array( mro::get_linear_isa('Test::F'), [ qw(Test::F Test::O) ] ), '... got the right MRO for Test::F'); ok(eq_array( mro::get_linear_isa('Test::E'), [ qw(Test::E Test::O) ] ), '... got the right MRO for Test::E'); ok(eq_array( mro::get_linear_isa('Test::D'), [ qw(Test::D Test::O) ] ), '... got the right MRO for Test::D'); ok(eq_array( mro::get_linear_isa('Test::C'), [ qw(Test::C Test::D Test::O Test::F) ] ), '... got the right MRO for Test::C'); ok(eq_array( mro::get_linear_isa('Test::B'), [ qw(Test::B Test::D Test::O Test::E) ] ), '... got the right MRO for Test::B'); ok(eq_array( mro::get_linear_isa('Test::A'), [ qw(Test::A Test::B Test::D Test::O Test::E Test::C Test::F) ] ), '... got the right MRO for Test::A'); is(Test::A->C_or_D, 'Test::D', '... got the expected method output'); is(Test::A->can('C_or_D')->(), 'Test::D', '... can got the expected method output'); is(Test::A->C_or_E, 'Test::E', '... got the expected method output'); is(Test::A->can('C_or_E')->(), 'Test::E', '... can got the expected method output'); perl-5.12.0-RC0/t/mro/next_NEXT.t0000555000175000017500000000176411325125742015203 0ustar jessejesse#!/usr/bin/perl use strict; use warnings; use NEXT; require './test.pl'; plan(tests => 4); { package Foo; use strict; use warnings; use mro 'c3'; sub foo { 'Foo::foo' } package Fuz; use strict; use warnings; use mro 'c3'; use base 'Foo'; sub foo { 'Fuz::foo => ' . (shift)->next::method } package Bar; use strict; use warnings; use mro 'c3'; use base 'Foo'; sub foo { 'Bar::foo => ' . (shift)->next::method } package Baz; use strict; use warnings; use base 'Bar', 'Fuz'; sub foo { 'Baz::foo => ' . (shift)->NEXT::foo } } is(Foo->foo, 'Foo::foo', '... got the right value from Foo->foo'); is(Fuz->foo, 'Fuz::foo => Foo::foo', '... got the right value from Fuz->foo'); is(Bar->foo, 'Bar::foo => Foo::foo', '... got the right value from Bar->foo'); is(Baz->foo, 'Baz::foo => Bar::foo => Fuz::foo => Foo::foo', '... got the right value using NEXT in a subclass of a C3 class'); perl-5.12.0-RC0/t/mro/overload_c3.t0000555000175000017500000000233511325125742015562 0ustar jessejesse#!./perl use strict; use warnings; BEGIN { unless (-d 'blib') { chdir 't' if -d 't'; @INC = '../lib'; } } require q(./test.pl); plan(tests => 7); { package BaseTest; use strict; use warnings; use mro 'c3'; package OverloadingTest; use strict; use warnings; use mro 'c3'; use base 'BaseTest'; use overload '""' => sub { ref(shift) . " stringified" }, fallback => 1; sub new { bless {} => shift } package InheritingFromOverloadedTest; use strict; use warnings; use base 'OverloadingTest'; use mro 'c3'; } my $x = InheritingFromOverloadedTest->new(); isa_ok($x, 'InheritingFromOverloadedTest'); my $y = OverloadingTest->new(); isa_ok($y, 'OverloadingTest'); is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing'); is("$y", 'OverloadingTest stringified', '... got the right value when stringifing'); ok(($y eq 'OverloadingTest stringified'), '... eq was handled correctly'); my $result; eval { $result = $x eq 'InheritingFromOverloadedTest stringified' }; ok(!$@, '... this should not throw an exception'); ok($result, '... and we should get the true value'); perl-5.12.0-RC0/t/mro/basic_01_c3.t0000555000175000017500000000164411325125742015332 0ustar jessejesse#!./perl use strict; use warnings; require q(./test.pl); plan(tests => 4); =pod This tests the classic diamond inheritence pattern. / \ \ / =cut { package Diamond_A; sub hello { 'Diamond_A::hello' } } { package Diamond_B; use base 'Diamond_A'; } { package Diamond_C; use base 'Diamond_A'; sub hello { 'Diamond_C::hello' } } { package Diamond_D; use base ('Diamond_B', 'Diamond_C'); use mro 'c3'; } ok(eq_array( mro::get_linear_isa('Diamond_D'), [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ] ), '... got the right MRO for Diamond_D'); is(Diamond_D->hello, 'Diamond_C::hello', '... method resolved itself as expected'); is(Diamond_D->can('hello')->(), 'Diamond_C::hello', '... can(method) resolved itself as expected'); is(UNIVERSAL::can("Diamond_D", 'hello')->(), 'Diamond_C::hello', '... can(method) resolved itself as expected'); perl-5.12.0-RC0/t/mro/next_inanon.t0000555000175000017500000000157111325125742015703 0ustar jessejesse#!/usr/bin/perl use strict; use warnings; require q(./test.pl); plan(tests => 2); =pod This tests the successful handling of a next::method call from within an anonymous subroutine. =cut { package A; use mro 'c3'; sub foo { return 'A::foo'; } sub bar { return 'A::bar'; } } { package B; use base 'A'; use mro 'c3'; sub foo { my $code = sub { return 'B::foo => ' . (shift)->next::method(); }; return (shift)->$code; } sub bar { my $code1 = sub { my $code2 = sub { return 'B::bar => ' . (shift)->next::method(); }; return (shift)->$code2; }; return (shift)->$code1; } } is(B->foo, "B::foo => A::foo", 'method resolved inside anonymous sub'); is(B->bar, "B::bar => A::bar", 'method resolved inside nested anonymous subs'); perl-5.12.0-RC0/t/japh/0000755000175000017500000000000011351321566013317 5ustar jessejesseperl-5.12.0-RC0/t/japh/abigail.t0000555000175000017500000005127611325127001015075 0ustar jessejesse#!./perl -w # # Tests derived from Japhs. # # These test use obscure features of Perl, or surprising combinations # of features. The tests were added because in the past, they have # exposed several bugs in Perl. # # Some of these tests may actually (mis)use bugs or use undefined behaviour. # These tests are still useful - behavioural changes or bugfixes will be # noted, and a remark can be put in the documentation. (Don't forget to # disable the test!) # # Getting everything to run well on the myriad of platforms Perl runs on # is unfortunately not a trivial task. # # WARNING: these tests are obfuscated. Do not get frustrated. # Ask Abigail , or use the Deparse or Concise # modules (the former parses Perl to Perl, the latter shows the # op syntax tree) like this: # ./perl -Ilib -MO=Deparse foo.pl # ./perl -Ilib -MO=Concise foo.pl # BEGIN { if (ord("A") == 193) { print "1..0 # Skip: EBCDIC\n"; # For now, until someone has time. exit(0); } chdir 't' if -d 't'; @INC = '../lib'; require "./test.pl"; undef &skip; } # # ./test.pl does real evilness by jumping to a label. # This function copies the skip from ./test, omitting the goto. # sub skip { my $why = shift; my $n = @_ ? shift : 1; for (1..$n) { my $test = curr_test; print STDOUT "ok $test # skip: $why\n"; next_test; } } # # ./test.pl doesn't give use 'notok', so we make it here. # sub notok { my ($pass, $name, @mess) = @_; _ok(!$pass, _where(), $name, @mess); } my $JaPH = "Just another Perl Hacker"; my $JaPh = "Just another Perl hacker"; my $JaPH_n = "Just another Perl Hacker\n"; my $JaPh_n = "Just another Perl hacker\n"; my $JaPH_s = "Just another Perl Hacker "; my $JaPh_s = "Just another Perl hacker "; my $JaPH_c = "Just another Perl Hacker,"; my $JaPh_c = "Just another Perl hacker,"; plan tests => 130; { my $out = sprintf "Just another Perl Hacker"; is ($out, $JaPH); } { my @primes = (2, 3, 7, 13, 53, 101, 557, 1429); my @composites = (4, 10, 25, 32, 75, 143, 1333, 1728); my %primeness = ((map {$_ => 1} @primes), (map {$_ => 0} @composites)); while (my ($num, $is_prime) = each %primeness) { my $comment = "$num is " . ($is_prime ? "prime." : "composite."); my $sub = $is_prime ? "ok" : "notok"; &$sub (( 1 x $num) !~ /^1?$|^(11+?)\1+$/, $comment); &$sub (( 0 x $num) !~ m 0^\0?$|^(\0\0+?)\1+$0, $comment); &$sub (("m" x $num) !~ m m^\m?$|^(\m\m+?)\1+$mm, $comment); } } { # Some platforms use different quoting techniques. # I do not have access to those platforms to test # things out. So, we'll skip things.... if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') { skip "Your platform quotes differently.", 3; last; } my $expected = $JaPH; $expected =~ s/ /\n/g; $expected .= "\n"; is (runperl (switches => [qw /'-weprint< 0), $expected, "Multiple -e switches"); is (runperl (switches => [q !'-wle$_=< 0), $JaPH . " \n", "Multiple -e switches"); is (runperl (switches => [qw !-wl!], progs => [qw !print qq-@{[ qw+ Just another Perl Hacker +]}-!], verbose => 0), $JaPH_n, "Multiple -e switches"); } { if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') { skip "Your platform quotes differently.", 1; last; } is (runperl (switches => [qw /-sweprint --/, "-_='Just another Perl Hacker'"], nolib => 1, verbose => 0), $JaPH, 'setting $_ via -s'); } { my $datafile = "datatmp000"; 1 while -f ++ $datafile; END {unlink_all $datafile if $datafile} open MY_DATA, "> $datafile" or die "Failed to open $datafile: $!"; print MY_DATA << " --"; One Two Three Four Five Six -- close MY_DATA or die "Failed to close $datafile: $!\n"; my @progs; my $key; while () { last if /^__END__$/; if (/^#{7}(?:\s+(.*))?/) { push @progs => {COMMENT => $1 || '', CODE => '', SKIP_OS => [], ARGS => [], SWITCHES => [],}; $key = 'CODE'; next; } elsif (/^(COMMENT|CODE|ARGS|SWITCHES|EXPECT|SKIP|SKIP_OS) (?::\s+(.*))?$/sx) { $key = $1; $progs [-1] {$key} = '' unless exists $progs [-1] {$key}; next unless defined $2; $_ = $2; } elsif (/^$/) { next; } if (ref ($progs [-1] {$key})) { push @{$progs [-1] {$key}} => $_; } else { $progs [-1] {$key} .= $_; } } foreach my $program (@progs) { if (exists $program -> {SKIP}) { chomp $program -> {SKIP}; skip $program -> {SKIP}, 1; next; } chomp @{$program -> {SKIP_OS}}; if (@{$program -> {SKIP_OS}}) { if (grep {$^O eq $_} @{$program -> {SKIP_OS}}) { skip "Your OS uses different quoting.", 1; next; } } map {s/\$datafile/$datafile/} @{$program -> {ARGS}}; $program -> {EXPECT} = $JaPH unless exists $program -> {EXPECT}; $program -> {EXPECT} =~ s/\$JaPH_s\b/$JaPH_s/g; $program -> {EXPECT} =~ s/\$JaPh_c\b/$JaPh_c/g; $program -> {EXPECT} =~ s/\$JaPh\b/$JaPh/g; chomp ($program -> {EXPECT}, @{$program -> {SWITCHES}}, @{$program -> {ARGS}}); fresh_perl_is ($program -> {CODE}, $program -> {EXPECT}, {switches => $program -> {SWITCHES}, args => $program -> {ARGS}, verbose => 0}, $program -> {COMMENT}); } } { my $progfile = "progtmp000"; 1 while -f ++ $progfile; END {unlink_all $progfile if $progfile} my @programs = (<< ' --', << ' --'); #!./perl BEGIN{$|=$SIG{__WARN__}=sub{$_=$_[0];y-_- -;print/(.)"$/;seek _,-open(_ ,"+<$0"),2;truncate _,tell _;close _;exec$0}}//rekcaH_lreP_rehtona_tsuJ -- #!./perl BEGIN{$SIG{__WARN__}=sub{$_=pop;y-_- -;print/".*(.)"/; truncate$0,-1+-s$0;exec$0;}}//rekcaH_lreP_rehtona_tsuJ -- chomp @programs; if ($^O eq 'VMS' or $^O eq 'MSWin32') { # VMS needs extensions for files to be executable, # but the Japhs above rely on $0 being exactly the # filename of the program. skip $^O, 2 * @programs; last } use Config; unless (defined $Config {useperlio}) { skip "Uuseperlio", 2 * @programs; last } my $i = 1; foreach my $program (@programs) { open my $fh => "> $progfile" or die "Failed to open $progfile: $!\n"; print $fh $program; close $fh or die "Failed to close $progfile: $!\n"; chmod 0755 => $progfile or die "Failed to chmod $progfile: $!\n"; my $command = "./$progfile 2>&1"; if ( $^O eq 'qnx' ) { skip "#!./perl not supported in QNX4"; skip "#!./perl not supported in QNX4"; } else { my $output = `$command`; is ($output, $JaPH, "Self correcting code $i"); $output = `$command`; is ($output, "", "Self corrected code $i"); } $i ++; } } __END__ ####### Funky loop 1. $_ = q ;4a75737420616e6f74686572205065726c204861636b65720as;; for (s;s;s;s;s;s;s;s;s;s;s;s) {s;(..)s?;qq qprint chr 0x$1 and \161 ssq;excess;} ####### Funky loop 2. $_ = q *4a75737420616e6f74686572205065726c204861636b65720a*; for ($*=******;$**=******;$**=******) {$**=*******s*..*qq} print chr 0x$& and q qq}*excess********} SKIP: $* was removed. ####### Funky loop 3. $_ = q *4a75737420616e6f74686572205065726c204861636b65720a*; for ($*=******;$**=******;$**=******) {$**=*******s*..*qq} print chr 0x$& and q qq}*excess********} SKIP: $* was removed. ####### Funky loop 4. $_ = q ?4a75737420616e6f74686572205065726c204861636b65720as?;??; for (??;(??)x??;??) {??;s;(..)s?;qq ?print chr 0x$1 and \161 ss?;excess;??} SKIP: Abuses a fixed bug. ####### Funky loop 5. for (s??4a75737420616e6f74686572205065726c204861636b65720as?;??;??) {s?(..)s\??qq \?print chr 0x$1 and q ss\??excess} SKIP: Abuses a fixed bug. ####### Funky loop 6. $a = q 94a75737420616e6f74686572205065726c204861636b65720a9 and ${qq$\x5F$} = q 97265646f9 and s g..g; qq e\x63\x68\x72\x20\x30\x78$&eggee; {eval if $a =~ s e..eqq qprint chr 0x$& and \x71\x20\x71\x71qeexcess} ####### Roman Dates. @r=reverse(M=>(0)x99=>CM=>(0)x399=>D=>(0)x99=>CD=>( 0)x299=>C=>(0)x9=>XC=>(0)x39=>L=>(0)x9=>XL=>(0)x29=>X=>IX=>0=>0=>0=>V=>IV=>0=>0 =>I=>$==-2449231+gm_julian_day+time);do{until($=<$#r){$_.=$r[$#r];$=-=$#r}for(; !$r[--$#r];){}}while$=;$,="\x20";print+$_=>September=>MCMXCIII=>=>=>=>=>=>=>=> SWITCHES -MTimes::JulianDay -l SKIP: Times::JulianDay not part of the main distribution. ####### Autoload 1. sub _'_{$_'_=~s/$a/$_/}map{$$_=$Z++}Y,a..z,A..X;*{($_::_=sprintf+q=%X==>"$A$Y". "$b$r$T$u")=~s~0~O~g;map+_::_,U=>T=>L=>$Z;$_::_}=*_;sub _{print+/.*::(.*)/s};;; *{chr($b*$e)}=*_'_;*__=*{chr(1<<$e)}; # Perl 5.6.0 broke this... _::_(r(e(k(c(a(H(__(l(r(e(P(__(r(e(h(t(o(n(a(__(t(us(J()))))))))))))))))))))))) EXPECT: Just__another__Perl__Hacker ####### Autoload 2. $"=$,;*{;qq{@{[(A..Z)[qq[0020191411140003]=~m[..]g]]}}}=*_=sub{print/::(.*)/}; $\=$/;q->(); ####### Autoload 3. $"=$,;*{;qq{@{[(A..Z)[qq[0020191411140003]=~m[..]g]]}}}=*_; sub _ {push @_ => /::(.*)/s and goto &{ shift}} sub shift {print shift; @_ and goto &{+shift}} Hack ("Just", "Perl ", " ano", "er\n", "ther "); # YYYYMMDD ####### Autoload 4. $, = " "; sub AUTOLOAD {($AUTOLOAD =~ /::(.*)/) [0];} print+Just (), another (), Perl (), Hacker (); ####### Look ma! No letters! $@="\145\143\150\157\040\042\112\165\163\164\040\141\156\157\164". "\150\145\162\040\120\145\162\154\040\110\141\143\153\145\162". "\042\040\076\040\057\144\145\166\057\164\164\171";`$@` SKIP: Unix specific ####### sprintf fun 1. sub f{sprintf$_[0],$_[1],$_[2]}print f('%c%s',74,f('%c%s',117,f('%c%s',115,f( '%c%s',116,f('%c%s',32,f('%c%s',97,f('%c%s',0x6e,f('%c%s',111,f('%c%s',116,f( '%c%s',104,f('%c%s',0x65,f('%c%s',114,f('%c%s',32,f('%c%s',80,f('%c%s',101,f( '%c%s',114,f('%c%s',0x6c,f('%c%s',32,f('%c%s',0x48,f('%c%s',97,f('%c%s',99,f( '%c%s',107,f('%c%s',101,f('%c%s',114,f('%c%s',10,))))))))))))))))))))))))) ####### sprintf fun 2. sub f{sprintf'%c%s',$_[0],$_[1]}print f(74,f(117,f(115,f(116,f(32,f(97, f(110,f(111,f(116,f(104,f(0x65,f(114,f(32,f(80,f(101,f(114,f(0x6c,f(32, f(0x48,f(97,f(99,f(107,f(101,f(114,f(10,q ff))))))))))))))))))))))))) ####### Hanoi. %0=map{local$_=$_;reverse+chop,$_}ABC,ACB,BAC,BCA,CAB,CBA;$_=3 .AC;1while+ s/(\d+)((.)(.))/($0=$1-1)?"$0$3$0{$2}1$2$0$0{$2}$4":"$3 => $4\n"/xeg;print EXPECT A => C A => B C => B A => C B => A B => C A => C ####### Funky -p 1 }{$_=$. SWITCHES: -wlp ARGS: $datafile EXPECT: 6 ####### Funky -p 2 }$_=$.;{ SWITCHES: -wlp ARGS: $datafile EXPECT: 6 ####### Funky -p 3 }{$_=$.}{ SWITCHES: -wlp ARGS: $datafile EXPECT: 6 ####### Funky -p 4 }{*_=*.}{ SWITCHES: -wlp ARGS: $datafile EXPECT: 6 ####### Funky -p 5 }for($.){print SWITCHES: -wln ARGS: $datafile EXPECT: 6 ####### Funky -p 6 }{print$. SWITCHES: -wln ARGS: $datafile EXPECT: 6 ####### Funky -p 7 }print$.;{ SWITCHES: -wln ARGS: $datafile EXPECT: 6 ####### Abusing -M 1 SWITCHES -Mstrict='}); print "Just another Perl Hacker"; ({' -l SKIP: No longer works in 5.8.2 and beyond. SKIP_OS: MSWin32 SKIP_OS: NetWare ####### rand srand 123456;$-=rand$_--=>@[[$-,$_]=@[[$_,$-]for(reverse+1..(@[=split //=>"IGrACVGQ\x02GJCWVhP\x02PL\x02jNMP"));print+(map{$_^q^"^}@[),"\n" SKIP: Solaris specific. ####### print and __PACKAGE__ package Just_another_Perl_Hacker; sub print {($_=$_[0])=~ s/_/ /g; print } sub __PACKAGE__ { & print ( __PACKAGE__)} & __PACKAGE__ ( ) ####### Decorations. * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * / / / / / / / / / / / / / / / / / / / / / / / / / / / / / / / / / % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %; BEGIN {% % = ($ _ = " " => print "Just another Perl Hacker\n")} ####### Tie 1 sub J::FETCH{Just }$_.='print+"@{[map';sub J::TIESCALAR{bless\my$J,J} sub A::FETCH{another}$_.='{tie my($x),$';sub A::TIESCALAR{bless\my$A,A} sub P::FETCH{Perl }$_.='_;$x}qw/J A P';sub P::TIESCALAR{bless\my$P,P} sub H::FETCH{Hacker }$_.=' H/]}\n"';eval;sub H::TIESCALAR{bless\my$H,H} ####### Tie 2 package Z;use overload'""'=>sub{$b++?Hacker:another}; sub TIESCALAR{bless\my$y=>Z}sub FETCH{$a++?Perl:Just} $,=$";my$x=tie+my$y=>Z;print$y,$x,$y,$x,"\n";#Abigail EXPECT: $JaPH_s ####### Tie 3 sub A::TIESCALAR{bless\my$x=>A};package B;@q[0..3]=qw/Hacker Perl another Just/;use overload'""'=>sub{pop @q};sub A::FETCH{bless\my $y=>B}; tie my $shoe => qq 'A';print "$shoe $shoe $shoe $shoe\n"; ####### Tie 4 sub A::TIESCALAR{bless\my$x=>'A'};package B;@q=qw/Hacker Perl another Just/;use overload'""',sub{pop @q};sub A::FETCH{bless \my $y=>B};tie my$shoe=>'A';print"$shoe $shoe $shoe $shoe\n"; ####### Tie 5 tie $" => A; $, = " "; $\ = "\n"; @a = ("") x 2; print map {"@a"} 1 .. 4; sub A::TIESCALAR {bless \my $A => A} # Yet Another silly JAPH by Abigail sub A::FETCH {@q = qw /Just Another Perl Hacker/ unless @q; shift @q} SKIP: Pending a bug fix. ####### Prototype fun 1 sub camel (^#87=i@J&&&#]u'^^s]#'#={123{#}7890t[0.9]9@+*`"'***}A&&&}n2o}00}t324i; h[{e **###{r{+P={**{e^^^#'#i@{r'^=^{l+{#}H***i[0.9]&@a5`"':&^;&^,*&^$43##@@####; c}^^^&&&k}&&&}#=e*****[]}'r####'`=437*{#};::'1[0.9]2@43`"'*#==[[.{{],,,1278@#@); print+((($llama=prototype'camel')=~y|+{#}$=^*&[0-9]i@:;`"',.| |d)&&$llama."\n"); SKIP: Abuses a fixed bug. ####### Prototype fun 2 print prototype sub "Just another Perl Hacker" {}; SKIP: Abuses a fixed bug. ####### Prototype fun 3 sub _ "Just another Perl Hacker"; print prototype \&_ SKIP: Abuses a fixed bug. ####### Split 1 split // => '"'; ${"@_"} = "/"; split // => eval join "+" => 1 .. 7; *{"@_"} = sub {foreach (sort keys %_) {print "$_ $_{$_} "}}; %{"@_"} = %_ = (Just => another => Perl => Hacker); &{%{%_}}; SKIP: Hashes are now randomized. EXPECT: $JaPH_s ####### Split 2 $" = "/"; split // => eval join "+" => 1 .. 7; *{"@_"} = sub {foreach (sort keys %_) {print "$_ $_{$_} "}}; %_ = (Just => another => Perl => Hacker); &{%_}; SKIP: Hashes are now randomized. EXPECT: $JaPH_s ####### Split 3 $" = "/"; split $, => eval join "+" => 1 .. 7; *{"@_"} = sub {foreach (sort keys %_) {print "$_ $_{$_} "}}; %{"@_"} = %_ = (Just => another => Perl => Hacker); &{%{%_}}; SKIP: Hashes are now randomized. EXPECT: $JaPH_s ####### Here documents 1 $_ = "\x3C\x3C\x45\x4F\x54"; s/< ("a" .. "z") [8, 13, 19, 4, 6, 4, 17]} = sub {["", "Just ", "another ", "Perl ", "Hacker\n"] -> [shift]}; $^H = hex join "" => reverse map {int ($_ / 2)} 0 .. 4} print 1, 2, 3, 4; ####### Overloaded constants 4 BEGIN {$^H {join "" => ("a" .. "z") [8, 13, 19, 4, 6, 4, 17]} = sub {["", "Just ", "another ", "Perl ", "Hacker"] -> [shift]}; $^H = hex join "" => reverse map {int ($_ / 2)} 0 .. 4} print 1, 2, 3, 4, "\n"; ####### Overloaded constants 5 BEGIN {my $x = "Knuth heals rare project\n"; $^H {integer} = sub {my $y = shift; $_ = substr $x => $y & 0x1F, 1; $y > 32 ? uc : lc}; $^H = hex join "" => 2, 1, 1, 0, 0} print 52,2,10,23,16,8,1,19,3,6,15,12,5,49,21,14,9,11,36,13,22,32,7,18,24; ####### v-strings 1 print v74.117.115.116.32; print v97.110.111.116.104.101.114.32; print v80.101.114.108.32; print v72.97.99.107.101.114.10; ####### v-strings 2 print 74.117.115.116.32; print 97.110.111.116.104.101.114.32; print 80.101.114.108.32; print 72.97.99.107.101.114.10; ####### v-strings 3 print v74.117.115.116.32, v97.110.111.116.104.101.114.32, v80.101.114.108.32, v72.97.99.107.101.114.10; ####### v-strings 4 print 74.117.115.116.32, 97.110.111.116.104.101.114.32, 80.101.114.108.32, 72.97.99.107.101.114.10; ####### v-strings 5 print v74.117.115.116.32.97.110.111.116.104.101.114. v32.80.101.114.108.32.72.97.99.107.101.114.10; ####### v-strings 6 print 74.117.115.116.32.97.110.111.116.104.101.114. 32.80.101.114.108.32.72.97.99.107.101.114.10; ####### Symbolic references. map{${+chr}=chr}map{$_=>$_^ord$"}$=+$]..3*$=/2; print "$J$u$s$t $a$n$o$t$h$e$r $P$e$r$l $H$a$c$k$e$r\n"; ####### $; fun $; # A lone dollar? =$"; # Pod? $; # The return of the lone dollar? {Just=>another=>Perl=>Hacker=>} # Bare block? =$/; # More pod? print%; # No right operand for %? ####### @; fun @;=split//=>"Joel, Preach sartre knuth\n";$;=chr 65;%;=map{$;++=>$_} 0,22,13,16,5,14,21,1,23,11,2,7,12,6,8,15,3,19,24,14,10,20,18,17,4,25 ;print@;[@;{A..Z}]; EXPECT: $JaPh_c ####### %; fun $;=$";$;{Just=>another=>Perl=>Hacker=>}=$/;print%; ####### &func; $_ = "\112\165\163\1648\141\156\157\164\150\145\1628\120\145" . "\162\1548\110\141\143\153\145\162\0128\177" and &japh; sub japh {print "@_" and return if pop; split /\d/ and &japh} ####### magic goto. sub _ {$_ = shift and y/b-yB-Y/a-yB-Y/ xor !@ _? exit print : print and push @_ => shift and goto &{(caller (0)) [3]}} split // => "KsvQtbuf fbsodpmu\ni flsI " xor & _ ####### $: fun 1 :$:=~s:$":Just$&another$&:;$:=~s: :Perl$"Hacker$&:;chop$:;print$:#: ####### $: fun 2 :;$:=~s: -:;another Perl Hacker :;chop $:;$:=~y :;::d;print+Just. $:; ####### $: fun 3 :;$:=~s: -:;another Perl Hacker :;chop $:;$:=~y:;::d;print+Just.$: ####### $! s[$,][join$,,(split$,,($!=85))[(q[0006143730380126152532042307]. q[41342211132019313505])=~m[..]g]]e and y[yIbp][HJkP] and print; SKIP: Platform dependent. ####### die 1 eval {die ["Just another Perl Hacker"]}; print ${$@}[$#{@${@}}] ####### die 2 eval {die ["Just another Perl Hacker\n"]}; print ${$@}[$#{@${@}}] ####### die 3 eval {die ["Just another Perl Hacker"]}; print ${${@}}[$#{@{${@}}}] ####### die 4 eval {die ["Just another Perl Hacker\n"]}; print ${${@}}[$#{@{${@}}}] ####### die 5 eval {die [[qq [Just another Perl Hacker]]]};; print ${${${@}}[$#{@{${@}}}]}[$#{${@{${@}}}[$#{@{${@}}}]}] SKIP: Abuses a fixed bug; what is in $#{...} must be an arrayref, not an array ####### Closure returning itself. $_ = "\nrekcaH lreP rehtona tsuJ"; my $chop; $chop = sub {print chop; $chop}; $chop -> () -> () -> () -> () -> () -> () -> () -> () -> () -> () -> () -> () -> () -> () -> () -> () -> () -> () -> () -> () -> () -> () -> () -> () -> () ####### Special blocks 1 BEGIN {print "Just " } CHECK {print "another "} INIT {print "Perl " } END {print "Hacker\n"} ####### Special blocks 2 END {print "Hacker\n"} INIT {print "Perl " } CHECK {print "another "} BEGIN {print "Just " } ####### Recursive regex. my $qr = qr/^.+?(;).+?\1|;Just another Perl Hacker;|;.+$/; $qr =~ s/$qr//g; print $qr, "\n"; ####### use lib 'coderef' use lib sub {($\) = split /\./ => pop; print $"}; eval "use Just" || eval "use another" || eval "use Perl" || eval "use Hacker"; EXPECT Just another Perl Hacker perl-5.12.0-RC0/regcomp.pl0000444000175000017500000001275111325125742014126 0ustar jessejesse#!/usr/bin/perl # # Regenerate (overwriting only if changed): # # regnodes.h # # from information stored in # # regcomp.sym # regexp.h # # Accepts the standard regen_lib -q and -v args. # # This script is normally invoked from regen.pl. BEGIN { # Get function prototypes require 'regen_lib.pl'; } #use Fatal qw(open close rename chmod unlink); use strict; use warnings; open DESC, 'regcomp.sym'; my $ind = 0; my (@name,@rest,@type,@code,@args,@longj); my ($desc,$lastregop); while () { s/#.*$//; next if /^\s*$/; s/\s*\z//; if (/^-+\s*$/) { $lastregop= $ind; next; } unless ($lastregop) { $ind++; ($name[$ind], $desc, $rest[$ind]) = split /\t+/, $_, 3; ($type[$ind], $code[$ind], $args[$ind], $longj[$ind]) = split /[,\s]\s*/, $desc, 4; } else { my ($type,@lists)=split /\s*\t+\s*/, $_; die "No list? $type" if !@lists; foreach my $list (@lists) { my ($names,$special)=split /:/, $list , 2; $special ||= ""; foreach my $name (split /,/,$names) { my $real= $name eq 'resume' ? "resume_$type" : "${type}_$name"; my @suffix; if (!$special) { @suffix=(""); } elsif ($special=~/\d/) { @suffix=(1..$special); } elsif ($special eq 'FAIL') { @suffix=("","_fail"); } else { die "unknown :type ':$special'"; } foreach my $suffix (@suffix) { $ind++; $name[$ind]="$real$suffix"; $type[$ind]=$type; $rest[$ind]="state for $type"; } } } } } # use fixed width to keep the diffs between regcomp.pl recompiles # as small as possible. my ($width,$rwidth,$twidth)=(22,12,9); $lastregop ||= $ind; my $tot = $ind; close DESC; die "Too many regexp/state opcodes! Maximum is 256, but there are $lastregop in file!" if $lastregop>256; my $tmp_h = 'regnodes.h-new'; unlink $tmp_h if -f $tmp_h; my $out = safer_open($tmp_h); printf $out < $lastregop - 1, -$width, REGMATCH_STATE_MAX => $tot - 1 ; for ($ind=1; $ind <= $lastregop ; $ind++) { my $oind = $ind - 1; printf $out "#define\t%*s\t%d\t/* %#04x %s */\n", -$width, $name[$ind], $ind-1, $ind-1, $rest[$ind]; } print $out "\t/* ------------ States ------------- */\n"; for ( ; $ind <= $tot ; $ind++) { printf $out "#define\t%*s\t(REGNODE_MAX + %d)\t/* %s */\n", -$width, $name[$ind], $ind - $lastregop, $rest[$ind]; } print $out <) { if (/#define\s+(RXf_\w+)\s+(0x[A-F\d]+)/i) { my $newval = eval $2; if($val & $newval) { die sprintf "Both $1 and $reverse{$newval} use %08X", $newval; } $val|=$newval; $rxfv{$1}= $newval; $reverse{$newval} = $1; } } my %vrxf=reverse %rxfv; printf $out "\t/* Bits in extflags defined: %032b */\n",$val; for (0..31) { my $n=$vrxf{2**$_}||"UNUSED_BIT_$_"; $n=~s/^RXf_(PMf_)?//; printf $out qq(\t%-20s/* 0x%08x */\n), qq("$n",),2**$_; } print $out < AvFILLp(av) + 1) AvARRAY(av)[--key] = &PL_sv_undef; while (key) { SV * const sv = AvARRAY(av)[--key]; assert(sv); if (sv != &PL_sv_undef) SvREFCNT_inc_simple_void_NN(sv); } key = AvARRAY(av) - AvALLOC(av); while (key) AvALLOC(av)[--key] = &PL_sv_undef; AvREIFY_off(av); AvREAL_on(av); } /* =for apidoc av_extend Pre-extend an array. The C is the index to which the array should be extended. =cut */ void Perl_av_extend(pTHX_ AV *av, I32 key) { dVAR; MAGIC *mg; PERL_ARGS_ASSERT_AV_EXTEND; assert(SvTYPE(av) == SVt_PVAV); mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied); if (mg) { dSP; ENTER; SAVETMPS; PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); EXTEND(SP,2); PUSHs(SvTIED_obj(MUTABLE_SV(av), mg)); mPUSHi(key + 1); PUTBACK; call_method("EXTEND", G_SCALAR|G_DISCARD); POPSTACK; FREETMPS; LEAVE; return; } if (key > AvMAX(av)) { SV** ary; I32 tmp; I32 newmax; if (AvALLOC(av) != AvARRAY(av)) { ary = AvALLOC(av) + AvFILLp(av) + 1; tmp = AvARRAY(av) - AvALLOC(av); Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*); AvMAX(av) += tmp; AvARRAY(av) = AvALLOC(av); if (AvREAL(av)) { while (tmp) ary[--tmp] = &PL_sv_undef; } if (key > AvMAX(av) - 10) { newmax = key + AvMAX(av); goto resize; } } else { #ifdef PERL_MALLOC_WRAP static const char oom_array_extend[] = "Out of memory during array extend"; /* Duplicated in pp_hot.c */ #endif if (AvALLOC(av)) { #if !defined(STRANGE_MALLOC) && !defined(MYMALLOC) MEM_SIZE bytes; IV itmp; #endif #ifdef Perl_safesysmalloc_size /* Whilst it would be quite possible to move this logic around (as I did in the SV code), so as to set AvMAX(av) early, based on calling Perl_safesysmalloc_size() immediately after allocation, I'm not convinced that it is a great idea here. In an array we have to loop round setting everything to &PL_sv_undef, which means writing to memory, potentially lots of it, whereas for the SV buffer case we don't touch the "bonus" memory. So there there is no cost in telling the world about it, whereas here we have to do work before we can tell the world about it, and that work involves writing to memory that might never be read. So, I feel, better to keep the current lazy system of only writing to it if our caller has a need for more space. NWC */ newmax = Perl_safesysmalloc_size((void*)AvALLOC(av)) / sizeof(const SV *) - 1; if (key <= newmax) goto resized; #endif newmax = key + AvMAX(av) / 5; resize: MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend); #if defined(STRANGE_MALLOC) || defined(MYMALLOC) Renew(AvALLOC(av),newmax+1, SV*); #else bytes = (newmax + 1) * sizeof(const SV *); #define MALLOC_OVERHEAD 16 itmp = MALLOC_OVERHEAD; while ((MEM_SIZE)(itmp - MALLOC_OVERHEAD) < bytes) itmp += itmp; itmp -= MALLOC_OVERHEAD; itmp /= sizeof(const SV *); assert(itmp > newmax); newmax = itmp - 1; assert(newmax >= AvMAX(av)); Newx(ary, newmax+1, SV*); Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*); if (AvMAX(av) > 64) offer_nice_chunk(AvALLOC(av), (AvMAX(av)+1) * sizeof(const SV *)); else Safefree(AvALLOC(av)); AvALLOC(av) = ary; #endif #ifdef Perl_safesysmalloc_size resized: #endif ary = AvALLOC(av) + AvMAX(av) + 1; tmp = newmax - AvMAX(av); if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */ PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base); PL_stack_base = AvALLOC(av); PL_stack_max = PL_stack_base + newmax; } } else { newmax = key < 3 ? 3 : key; MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend); Newx(AvALLOC(av), newmax+1, SV*); ary = AvALLOC(av) + 1; tmp = newmax; AvALLOC(av)[0] = &PL_sv_undef; /* For the stacks */ } if (AvREAL(av)) { while (tmp) ary[--tmp] = &PL_sv_undef; } AvARRAY(av) = AvALLOC(av); AvMAX(av) = newmax; } } } /* =for apidoc av_fetch Returns the SV at the specified index in the array. The C is the index. If C is set then the fetch will be part of a store. Check that the return value is non-null before dereferencing it to a C. See L for more information on how to use this function on tied arrays. =cut */ SV** Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval) { dVAR; PERL_ARGS_ASSERT_AV_FETCH; assert(SvTYPE(av) == SVt_PVAV); if (SvRMAGICAL(av)) { const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied); if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) { SV *sv; if (key < 0) { I32 adjust_index = 1; if (tied_magic) { /* Handle negative array indices 20020222 MJD */ SV * const * const negative_indices_glob = hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av), tied_magic))), NEGATIVE_INDICES_VAR, 16, 0); if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob))) adjust_index = 0; } if (adjust_index) { key += AvFILL(av) + 1; if (key < 0) return NULL; } } sv = sv_newmortal(); sv_upgrade(sv, SVt_PVLV); mg_copy(MUTABLE_SV(av), sv, 0, key); LvTYPE(sv) = 't'; LvTARG(sv) = sv; /* fake (SV**) */ return &(LvTARG(sv)); } } if (key < 0) { key += AvFILL(av) + 1; if (key < 0) return NULL; } if (key > AvFILLp(av)) { if (!lval) return NULL; return av_store(av,key,newSV(0)); } if (AvARRAY(av)[key] == &PL_sv_undef) { emptyness: if (lval) return av_store(av,key,newSV(0)); return NULL; } else if (AvREIFY(av) && (!AvARRAY(av)[key] /* eg. @_ could have freed elts */ || SvIS_FREED(AvARRAY(av)[key]))) { AvARRAY(av)[key] = &PL_sv_undef; /* 1/2 reify */ goto emptyness; } return &AvARRAY(av)[key]; } /* =for apidoc av_store Stores an SV in an array. The array index is specified as C. The return value will be NULL if the operation failed or if the value did not need to be actually stored within the array (as in the case of tied arrays). Otherwise it can be dereferenced to get the original C. Note that the caller is responsible for suitably incrementing the reference count of C before the call, and decrementing it if the function returned NULL. See L for more information on how to use this function on tied arrays. =cut */ SV** Perl_av_store(pTHX_ register AV *av, I32 key, SV *val) { dVAR; SV** ary; PERL_ARGS_ASSERT_AV_STORE; assert(SvTYPE(av) == SVt_PVAV); /* S_regclass relies on being able to pass in a NULL sv (unicode_alternate may be NULL). */ if (!val) val = &PL_sv_undef; if (SvRMAGICAL(av)) { const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied); if (tied_magic) { /* Handle negative array indices 20020222 MJD */ if (key < 0) { bool adjust_index = 1; SV * const * const negative_indices_glob = hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av), tied_magic))), NEGATIVE_INDICES_VAR, 16, 0); if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob))) adjust_index = 0; if (adjust_index) { key += AvFILL(av) + 1; if (key < 0) return 0; } } if (val != &PL_sv_undef) { mg_copy(MUTABLE_SV(av), val, 0, key); } return NULL; } } if (key < 0) { key += AvFILL(av) + 1; if (key < 0) return NULL; } if (SvREADONLY(av) && key >= AvFILL(av)) Perl_croak(aTHX_ "%s", PL_no_modify); if (!AvREAL(av) && AvREIFY(av)) av_reify(av); if (key > AvMAX(av)) 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)] = &PL_sv_undef; } while (AvFILLp(av) < key); } AvFILLp(av) = key; } else if (AvREAL(av)) SvREFCNT_dec(ary[key]); ary[key] = val; if (SvSMAGICAL(av)) { const MAGIC* const mg = SvMAGIC(av); if (val != &PL_sv_undef) { 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; else mg_set(MUTABLE_SV(av)); } return &ary[key]; } /* =for apidoc av_make Creates a new AV and populates it with a list of SVs. The SVs are copied into the array, so they may be freed after the call to av_make. The new AV will have a reference count of 1. =cut */ AV * Perl_av_make(pTHX_ register I32 size, register SV **strp) { register AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV)); /* sv_upgrade does AvREAL_only() */ PERL_ARGS_ASSERT_AV_MAKE; assert(SvTYPE(av) == SVt_PVAV); if (size) { /* "defined" was returning undef for size==0 anyway. */ register SV** ary; register I32 i; Newx(ary,size,SV*); AvALLOC(av) = ary; AvARRAY(av) = ary; AvFILLp(av) = AvMAX(av) = size - 1; 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) */ ary[i] = newSV(0); sv_setsv_flags(ary[i], *strp, SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL); strp++; } } return av; } /* =for apidoc av_clear Clears an array, making it empty. Does not free the memory used by the array itself. =cut */ void Perl_av_clear(pTHX_ register AV *av) { dVAR; I32 extra; PERL_ARGS_ASSERT_AV_CLEAR; assert(SvTYPE(av) == SVt_PVAV); #ifdef DEBUGGING if (SvREFCNT(av) == 0) { Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array"); } #endif if (SvREADONLY(av)) Perl_croak(aTHX_ "%s", PL_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; else mg_clear(MUTABLE_SV(av)); } if (AvMAX(av) < 0) return; if (AvREAL(av)) { SV** const ary = AvARRAY(av); I32 index = AvFILLp(av) + 1; 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] = &PL_sv_undef; SvREFCNT_dec(sv); } } extra = AvARRAY(av) - AvALLOC(av); if (extra) { AvMAX(av) += extra; AvARRAY(av) = AvALLOC(av); } AvFILLp(av) = -1; } /* =for apidoc av_undef Undefines the array. Frees the memory used by the array itself. =cut */ void Perl_av_undef(pTHX_ register AV *av) { PERL_ARGS_ASSERT_AV_UNDEF; assert(SvTYPE(av) == SVt_PVAV); /* Give any tie a chance to cleanup first */ if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied)) av_fill(av, -1); if (AvREAL(av)) { register I32 key = AvFILLp(av) + 1; while (key) SvREFCNT_dec(AvARRAY(av)[--key]); } Safefree(AvALLOC(av)); AvALLOC(av) = NULL; AvARRAY(av) = NULL; AvMAX(av) = AvFILLp(av) = -1; if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av)); } /* =for apidoc av_create_and_push Push an SV onto the end of the array, creating the array if necessary. A small internal helper function to remove a commonly duplicated idiom. =cut */ void Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val) { PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH; if (!*avp) *avp = newAV(); av_push(*avp, val); } /* =for apidoc av_push Pushes an SV onto the end of the array. The array will grow automatically to accommodate the addition. Like C, this takes ownership of one reference count. =cut */ void Perl_av_push(pTHX_ register AV *av, SV *val) { dVAR; MAGIC *mg; PERL_ARGS_ASSERT_AV_PUSH; assert(SvTYPE(av) == SVt_PVAV); if (SvREADONLY(av)) Perl_croak(aTHX_ "%s", PL_no_modify); if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { dSP; PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); EXTEND(SP,2); PUSHs(SvTIED_obj(MUTABLE_SV(av), mg)); PUSHs(val); PUTBACK; ENTER; call_method("PUSH", G_SCALAR|G_DISCARD); LEAVE; POPSTACK; return; } av_store(av,AvFILLp(av)+1,val); } /* =for apidoc av_pop Pops an SV off the end of the array. Returns C<&PL_sv_undef> if the array is empty. =cut */ SV * Perl_av_pop(pTHX_ register AV *av) { dVAR; SV *retval; MAGIC* mg; PERL_ARGS_ASSERT_AV_POP; assert(SvTYPE(av) == SVt_PVAV); if (SvREADONLY(av)) Perl_croak(aTHX_ "%s", PL_no_modify); if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { dSP; PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); XPUSHs(SvTIED_obj(MUTABLE_SV(av), mg)); PUTBACK; ENTER; if (call_method("POP", G_SCALAR)) { retval = newSVsv(*PL_stack_sp--); } else { retval = &PL_sv_undef; } LEAVE; POPSTACK; return retval; } if (AvFILL(av) < 0) return &PL_sv_undef; retval = AvARRAY(av)[AvFILLp(av)]; AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef; if (SvSMAGICAL(av)) mg_set(MUTABLE_SV(av)); return retval; } /* =for apidoc av_create_and_unshift_one Unshifts an SV onto the beginning of the array, creating the array if necessary. A small internal helper function to remove a commonly duplicated idiom. =cut */ SV ** 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(); av_unshift(*avp, 1); return av_store(*avp, 0, val); } /* =for apidoc av_unshift Unshift the given number of C values onto the beginning of the array. The array will grow automatically to accommodate the addition. You must then use C to assign values to these new elements. =cut */ void Perl_av_unshift(pTHX_ register AV *av, register I32 num) { dVAR; register I32 i; MAGIC* mg; PERL_ARGS_ASSERT_AV_UNSHIFT; assert(SvTYPE(av) == SVt_PVAV); if (SvREADONLY(av)) Perl_croak(aTHX_ "%s", PL_no_modify); if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { dSP; PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); EXTEND(SP,1+num); PUSHs(SvTIED_obj(MUTABLE_SV(av), mg)); while (num-- > 0) { PUSHs(&PL_sv_undef); } PUTBACK; ENTER; call_method("UNSHIFT", G_SCALAR|G_DISCARD); LEAVE; POPSTACK; return; } if (num <= 0) return; if (!AvREAL(av) && AvREIFY(av)) av_reify(av); i = AvARRAY(av) - AvALLOC(av); if (i) { if (i > num) i = num; num -= i; AvMAX(av) += i; AvFILLp(av) += i; AvARRAY(av) = AvARRAY(av) - i; } if (num) { register SV **ary; const I32 i = AvFILLp(av); /* Create extra elements */ const I32 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] = &PL_sv_undef; } while (num); /* Make extra elements into a buffer */ AvMAX(av) -= slide; AvFILLp(av) -= slide; AvARRAY(av) = AvARRAY(av) + slide; } } /* =for apidoc av_shift Shifts an SV off the beginning of the array. Returns C<&PL_sv_undef> if the array is empty. =cut */ SV * Perl_av_shift(pTHX_ register AV *av) { dVAR; SV *retval; MAGIC* mg; PERL_ARGS_ASSERT_AV_SHIFT; assert(SvTYPE(av) == SVt_PVAV); if (SvREADONLY(av)) Perl_croak(aTHX_ "%s", PL_no_modify); if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { dSP; PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); XPUSHs(SvTIED_obj(MUTABLE_SV(av), mg)); PUTBACK; ENTER; if (call_method("SHIFT", G_SCALAR)) { retval = newSVsv(*PL_stack_sp--); } else { retval = &PL_sv_undef; } LEAVE; POPSTACK; return retval; } if (AvFILL(av) < 0) return &PL_sv_undef; retval = *AvARRAY(av); if (AvREAL(av)) *AvARRAY(av) = &PL_sv_undef; AvARRAY(av) = AvARRAY(av) + 1; AvMAX(av)--; AvFILLp(av)--; if (SvSMAGICAL(av)) mg_set(MUTABLE_SV(av)); return retval; } /* =for apidoc av_len Returns the highest index in the array. The number of elements in the array is C. Returns -1 if the array is empty. =cut */ I32 Perl_av_len(pTHX_ AV *av) { PERL_ARGS_ASSERT_AV_LEN; assert(SvTYPE(av) == SVt_PVAV); return AvFILL(av); } /* =for apidoc av_fill Set the highest index in the array to the given number, equivalent to Perl's C<$#array = $fill;>. The number of elements in the an array will be C after av_fill() returns. If the array was previously shorter then the additional elements appended are set to C. If the array was longer, then the excess elements are freed. C is the same as C. =cut */ void Perl_av_fill(pTHX_ register AV *av, I32 fill) { dVAR; MAGIC *mg; PERL_ARGS_ASSERT_AV_FILL; assert(SvTYPE(av) == SVt_PVAV); if (fill < 0) fill = -1; if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { dSP; ENTER; SAVETMPS; PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); EXTEND(SP,2); PUSHs(SvTIED_obj(MUTABLE_SV(av), mg)); mPUSHi(fill + 1); PUTBACK; call_method("STORESIZE", G_SCALAR|G_DISCARD); POPSTACK; FREETMPS; LEAVE; return; } if (fill <= AvMAX(av)) { I32 key = AvFILLp(av); SV** const ary = AvARRAY(av); if (AvREAL(av)) { while (key > fill) { SvREFCNT_dec(ary[key]); ary[key--] = &PL_sv_undef; } } else { while (key < fill) ary[++key] = &PL_sv_undef; } AvFILLp(av) = fill; if (SvSMAGICAL(av)) mg_set(MUTABLE_SV(av)); } else (void)av_store(av,fill,&PL_sv_undef); } /* =for apidoc av_delete Deletes the element indexed by C from the array. Returns the deleted element. If C equals C, the element is freed and null is returned. =cut */ SV * Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags) { dVAR; SV *sv; PERL_ARGS_ASSERT_AV_DELETE; assert(SvTYPE(av) == SVt_PVAV); if (SvREADONLY(av)) Perl_croak(aTHX_ "%s", PL_no_modify); if (SvRMAGICAL(av)) { const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied); if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) { /* Handle negative array indices 20020222 MJD */ SV **svp; if (key < 0) { unsigned adjust_index = 1; if (tied_magic) { SV * const * const negative_indices_glob = hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av), tied_magic))), NEGATIVE_INDICES_VAR, 16, 0); if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob))) adjust_index = 0; } if (adjust_index) { key += AvFILL(av) + 1; if (key < 0) return NULL; } } svp = av_fetch(av, key, TRUE); if (svp) { sv = *svp; mg_clear(sv); if (mg_find(sv, PERL_MAGIC_tiedelem)) { sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */ return sv; } return NULL; } } } if (key < 0) { key += AvFILL(av) + 1; if (key < 0) return NULL; } if (key > AvFILLp(av)) return NULL; else { if (!AvREAL(av) && AvREIFY(av)) av_reify(av); sv = AvARRAY(av)[key]; if (key == AvFILLp(av)) { AvARRAY(av)[key] = &PL_sv_undef; do { AvFILLp(av)--; } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef); } else AvARRAY(av)[key] = &PL_sv_undef; if (SvSMAGICAL(av)) mg_set(MUTABLE_SV(av)); } if (flags & G_DISCARD) { SvREFCNT_dec(sv); sv = NULL; } else if (AvREAL(av)) sv = sv_2mortal(sv); return sv; } /* =for apidoc av_exists Returns true if the element indexed by C has been initialized. This relies on the fact that uninitialized array elements are set to C<&PL_sv_undef>. =cut */ bool Perl_av_exists(pTHX_ AV *av, I32 key) { dVAR; PERL_ARGS_ASSERT_AV_EXISTS; assert(SvTYPE(av) == SVt_PVAV); if (SvRMAGICAL(av)) { const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied); if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) { SV * const sv = sv_newmortal(); MAGIC *mg; /* Handle negative array indices 20020222 MJD */ if (key < 0) { unsigned adjust_index = 1; if (tied_magic) { SV * const * const negative_indices_glob = hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av), tied_magic))), NEGATIVE_INDICES_VAR, 16, 0); if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob))) adjust_index = 0; } if (adjust_index) { key += AvFILL(av) + 1; if (key < 0) return FALSE; } } mg_copy(MUTABLE_SV(av), sv, 0, key); mg = mg_find(sv, PERL_MAGIC_tiedelem); if (mg) { magic_existspack(sv, mg); return (bool)SvTRUE(sv); } } } if (key < 0) { key += AvFILL(av) + 1; if (key < 0) return FALSE; } if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef && AvARRAY(av)[key]) { return TRUE; } else return FALSE; } static MAGIC * S_get_aux_mg(pTHX_ AV *av) { dVAR; MAGIC *mg; PERL_ARGS_ASSERT_GET_AUX_MG; assert(SvTYPE(av) == SVt_PVAV); 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; } return mg; } SV ** Perl_av_arylen_p(pTHX_ AV *av) { MAGIC *const mg = get_aux_mg(av); PERL_ARGS_ASSERT_AV_ARYLEN_P; assert(SvTYPE(av) == SVt_PVAV); return &(mg->mg_obj); } IV * Perl_av_iter_p(pTHX_ AV *av) { MAGIC *const mg = get_aux_mg(av); PERL_ARGS_ASSERT_AV_ITER_P; assert(SvTYPE(av) == SVt_PVAV); #if IVSIZE == I32SIZE 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; #endif } /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */ perl-5.12.0-RC0/README.epoc0000444000175000017500000000707411325127001013732 0ustar jessejesseIf you read this file _as_is_, just ignore the funny characters you see. It is written in the POD format (see pod/perlpod.pod) which is specially designed to be readable as is. =head1 NAME README.epoc - Perl for EPOC =head1 SYNOPSIS Perl 5 README file for the EPOC Release 5 operating system. =head1 INTRODUCTION EPOC is an OS for palmtops and mobile phones. For more informations look at: http://www.symbian.com/ This is a port of perl to the epocemx SDK by Eberhard Mattes, which itself uses the SDK by symbian. Essentially epocemx it is a POSIX look alike environment for the EPOC OS. For more information look at: http://epocemx.sourceforge.net/ perl and epocemx runs on Epoc Release 5 machines: Psion 5mx, 5mx Pro, Psion Revo, Psion Netbook and on the Ericsson M128. It may run on Epoc Release 3 Hardware (Series 5 classic), too. For more information about this hardware please refer to http://www.psion.com/ Vendors which like to have support for their devices are free to send me a sample. =head1 INSTALLING PERL ON EPOC You can download a ready-to-install version from http://www.oflebbe.de/perl/perl5.html You will need at least ~6MB free space in order to install and run perl. Please install the emxusr.sis package from http://epocemx.sourceforge.net/ first. Install perl.sis on the EPOC machine. If you do not know how to do that, consult your PsiWin documentation. Perl itself and its standard library is using 4 MB disk space. Unicode support and some other modules are left out. (For details, please look into epoc/createpkg.pl). If you like to use these modules, you are free to copy them from a current perl release. =head1 STARTING PERL ON EPOC Please use the epocemx shell to start perl. perl integrates with the conventions of epocemx. =head2 Features of Perl on Epoc The built-in function EPOC::getcwd returns the current directory. =head2 Restrictions of Perl on Epoc Features are left out, because of restrictions of the POSIX support in EPOC: =over 4 =item * socket IO is only implemented poorly. You can only use sysread and syswrite on them. The commands read, write, print, <> do not work for sockets. This may change iff epocemx supports sockets. =item * kill, alarm and signals. Do not try to use them. This may be impossible to implement on EPOC. =item * select is missing. =item * binmode does not exist. (No CR LF to LF translation for text files) =item * EPOC does not handle the notion of current drive and current directory very well (i.e. not at all, but it tries hard to emulate one). See PATH. =item * Heap is limited to 4MB. =item * Dynamic loading is not implemented. =back =head2 Compiling Perl 5 on the EPOC cross compiling environment Sorry, this is far too short. =over 4 =item * You will need the epocemx SDK from Eberhard Mattes. =item * Get the Perl sources from your nearest CPAN site. =item * Unpack the sources. =item * Build a native perl from this sources... Make sure to save the miniperl executable as miniperl.native. Start again from scratch cp epoc/* . ./Configure -S make cp miniperl.native miniperl touch miniperl.exe make perl createpkg.pl emxsis perl.pkg perl.sis =back =head1 SUPPORT STATUS OF PERL ON EPOC I'm offering this port "as is". You can ask me questions, but I can't guarantee I'll be able to answer them. Since the port to epocemx is quite new, please check the web for updates first. Very special thanks to Eberhard Mattes for epocemx. =head1 AUTHOR Olaf Flebbe http://www.oflebbe.de/perl/perl5.html =head1 LAST UPDATE 2003-01-18 =cut perl-5.12.0-RC0/XSUB.h0000444000175000017500000005134511325127001013057 0ustar jessejesse/* XSUB.h * * Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, * 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ #ifndef _INC_PERL_XSUB_H #define _INC_PERL_XSUB_H 1 /* first, some documentation for xsubpp-generated items */ /* =head1 Variables created by C and C internal functions =for apidoc Amn|char*|CLASS Variable which is setup by C to indicate the class name for a C++ XS constructor. This is always a C. See C. =for apidoc Amn|(whatever)|RETVAL Variable which is setup by C to hold the return value for an XSUB. This is always the proper type for the XSUB. See L. =for apidoc Amn|(whatever)|THIS Variable which is setup by C to designate the object in a C++ XSUB. This is always the proper type for the C++ object. See C and L. =for apidoc Amn|I32|ax Variable which is setup by C to indicate the stack base offset, used by the C, C and C macros. The C macro must be called prior to setup the C variable. =for apidoc Amn|I32|items Variable which is setup by C to indicate the number of items on the stack. See L. =for apidoc Amn|I32|ix Variable which is setup by C to indicate which of an XSUB's aliases was used to invoke it. See L. =for apidoc Am|SV*|ST|int ix Used to access elements on the XSUB's stack. =for apidoc AmU||XS Macro to declare an XSUB and its C parameter list. This is handled by C. =for apidoc Ams||dAX Sets up the C variable. This is usually handled automatically by C by calling C. =for apidoc Ams||dAXMARK Sets up the C variable and stack marker variable C. This is usually handled automatically by C by calling C. =for apidoc Ams||dITEMS Sets up the C variable. This is usually handled automatically by C by calling C. =for apidoc Ams||dXSARGS Sets up stack and mark pointers for an XSUB, calling dSP and dMARK. Sets up the C and C variables by calling C and C. This is usually handled automatically by C. =for apidoc Ams||dXSI32 Sets up the C variable for an XSUB which has aliases. This is usually handled automatically by C. =for apidoc Ams||dUNDERBAR Sets up the C variable for an XSUB that wishes to use C. =for apidoc AmU||UNDERBAR The SV* corresponding to the $_ variable. Works even if there is a lexical $_ in scope. =cut */ #ifndef PERL_UNUSED_ARG # if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */ # include # define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x)) # else # define PERL_UNUSED_ARG(x) ((void)x) # endif #endif #ifndef PERL_UNUSED_VAR # define PERL_UNUSED_VAR(x) ((void)x) #endif #define ST(off) PL_stack_base[ax + (off)] /* XSPROTO() is also used by SWIG like this: * * typedef XSPROTO(SwigPerlWrapper); * typedef SwigPerlWrapper *SwigPerlWrapperPtr; * * This code needs to be compilable under both C and C++. * * Don't forget to change the __attribute__unused__ version of XS() * below too if you change XSPROTO() here. */ #define XSPROTO(name) void name(pTHX_ CV* cv) #undef XS #if defined(__CYGWIN__) && defined(USE_DYNAMIC_LOADING) # define XS(name) __declspec(dllexport) XSPROTO(name) #endif #if defined(__SYMBIAN32__) # define XS(name) EXPORT_C XSPROTO(name) #endif #ifndef XS # if defined(HASATTRIBUTE_UNUSED) && !defined(__cplusplus) # define XS(name) void name(pTHX_ CV* cv __attribute__unused__) # else # ifdef __cplusplus # define XS(name) extern "C" XSPROTO(name) # else # define XS(name) XSPROTO(name) # endif # endif #endif #define dAX const I32 ax = (I32)(MARK - PL_stack_base + 1) #define dAXMARK \ I32 ax = POPMARK; \ register SV **mark = PL_stack_base + ax++ #define dITEMS I32 items = (I32)(SP - MARK) #if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */ # define dXSARGS \ NOTE(ARGUNUSED(cv)) \ dSP; dAXMARK; dITEMS #else # define dXSARGS \ dSP; dAXMARK; dITEMS #endif #define dXSTARG SV * const targ = ((PL_op->op_private & OPpENTERSUB_HASTARG) \ ? PAD_SV(PL_op->op_targ) : sv_newmortal()) /* Should be used before final PUSHi etc. if not in PPCODE section. */ #define XSprePUSH (sp = PL_stack_base + ax - 1) #define XSANY CvXSUBANY(cv) #define dXSI32 I32 ix = XSANY.any_i32 #ifdef __cplusplus # define XSINTERFACE_CVT(ret,name) ret (*name)(...) # define XSINTERFACE_CVT_ANON(ret) ret (*)(...) #else # define XSINTERFACE_CVT(ret,name) ret (*name)() # define XSINTERFACE_CVT_ANON(ret) ret (*)() #endif #define dXSFUNCTION(ret) XSINTERFACE_CVT(ret,XSFUNCTION) #define XSINTERFACE_FUNC(ret,cv,f) ((XSINTERFACE_CVT_ANON(ret))(f)) #define XSINTERFACE_FUNC_SET(cv,f) \ CvXSUBANY(cv).any_dxptr = (void (*) (pTHX_ void*))(f) #define dUNDERBAR PADOFFSET padoff_du = find_rundefsvoffset() #define UNDERBAR ((padoff_du == NOT_IN_PAD \ || PAD_COMPNAME_FLAGS_isOUR(padoff_du)) \ ? DEFSV : PAD_SVl(padoff_du)) /* Simple macros to put new mortal values onto the stack. */ /* Typically used to return values from XS functions. */ /* =head1 Stack Manipulation Macros =for apidoc Am|void|XST_mIV|int pos|IV iv Place an integer into the specified position C on the stack. The value is stored in a new mortal SV. =for apidoc Am|void|XST_mNV|int pos|NV nv Place a double into the specified position C on the stack. The value is stored in a new mortal SV. =for apidoc Am|void|XST_mPV|int pos|char* str Place a copy of a string into the specified position C on the stack. The value is stored in a new mortal SV. =for apidoc Am|void|XST_mNO|int pos Place C<&PL_sv_no> into the specified position C on the stack. =for apidoc Am|void|XST_mYES|int pos Place C<&PL_sv_yes> into the specified position C on the stack. =for apidoc Am|void|XST_mUNDEF|int pos Place C<&PL_sv_undef> into the specified position C on the stack. =for apidoc Am|void|XSRETURN|int nitems Return from XSUB, indicating number of items on the stack. This is usually handled by C. =for apidoc Am|void|XSRETURN_IV|IV iv Return an integer from an XSUB immediately. Uses C. =for apidoc Am|void|XSRETURN_UV|IV uv Return an integer from an XSUB immediately. Uses C. =for apidoc Am|void|XSRETURN_NV|NV nv Return a double from an XSUB immediately. Uses C. =for apidoc Am|void|XSRETURN_PV|char* str Return a copy of a string from an XSUB immediately. Uses C. =for apidoc Ams||XSRETURN_NO Return C<&PL_sv_no> from an XSUB immediately. Uses C. =for apidoc Ams||XSRETURN_YES Return C<&PL_sv_yes> from an XSUB immediately. Uses C. =for apidoc Ams||XSRETURN_UNDEF Return C<&PL_sv_undef> from an XSUB immediately. Uses C. =for apidoc Ams||XSRETURN_EMPTY Return an empty list from an XSUB immediately. =head1 Variables created by C and C internal functions =for apidoc AmU||newXSproto|char* name|XSUBADDR_t f|char* filename|const char *proto Used by C to hook up XSUBs as Perl subs. Adds Perl prototypes to the subs. =for apidoc AmU||XS_VERSION The version identifier for an XS module. This is usually handled automatically by C. See C. =for apidoc Ams||XS_VERSION_BOOTCHECK Macro to verify that a PM module's $VERSION variable matches the XS module's C variable. This is usually handled automatically by C. See L. =head1 Simple Exception Handling Macros =for apidoc Ams||dXCPT Set up necessary local variables for exception handling. See L. =for apidoc AmU||XCPT_TRY_START Starts a try block. See L. =for apidoc AmU||XCPT_TRY_END Ends a try block. See L. =for apidoc AmU||XCPT_CATCH Introduces a catch block. See L. =for apidoc Ams||XCPT_RETHROW Rethrows a previously caught exception. See L. =cut */ #define XST_mIV(i,v) (ST(i) = sv_2mortal(newSViv(v)) ) #define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) ) #define XST_mNV(i,v) (ST(i) = sv_2mortal(newSVnv(v)) ) #define XST_mPV(i,v) (ST(i) = sv_2mortal(newSVpv(v,0))) #define XST_mPVN(i,v,n) (ST(i) = newSVpvn_flags(v,n, SVs_TEMP)) #define XST_mNO(i) (ST(i) = &PL_sv_no ) #define XST_mYES(i) (ST(i) = &PL_sv_yes ) #define XST_mUNDEF(i) (ST(i) = &PL_sv_undef) #define XSRETURN(off) \ STMT_START { \ const IV tmpXSoff = (off); \ PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); \ return; \ } STMT_END #define XSRETURN_IV(v) STMT_START { XST_mIV(0,v); XSRETURN(1); } STMT_END #define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END #define XSRETURN_NV(v) STMT_START { XST_mNV(0,v); XSRETURN(1); } STMT_END #define XSRETURN_PV(v) STMT_START { XST_mPV(0,v); XSRETURN(1); } STMT_END #define XSRETURN_PVN(v,n) STMT_START { XST_mPVN(0,v,n); XSRETURN(1); } STMT_END #define XSRETURN_NO STMT_START { XST_mNO(0); XSRETURN(1); } STMT_END #define XSRETURN_YES STMT_START { XST_mYES(0); XSRETURN(1); } STMT_END #define XSRETURN_UNDEF STMT_START { XST_mUNDEF(0); XSRETURN(1); } STMT_END #define XSRETURN_EMPTY STMT_START { XSRETURN(0); } STMT_END #define newXSproto(a,b,c,d) newXS_flags(a,b,c,d,0) #ifdef XS_VERSION # define XS_VERSION_BOOTCHECK \ STMT_START { \ SV *_sv; \ const char *vn = NULL, *module = SvPV_nolen_const(ST(0)); \ if (items >= 2) /* version supplied as bootstrap arg */ \ _sv = ST(1); \ else { \ /* XXX GV_ADDWARN */ \ _sv = get_sv(Perl_form(aTHX_ "%s::%s", module, \ vn = "XS_VERSION"), FALSE); \ if (!_sv || !SvOK(_sv)) \ _sv = get_sv(Perl_form(aTHX_ "%s::%s", module, \ vn = "VERSION"), FALSE); \ } \ if (_sv) { \ SV *xssv = Perl_newSVpv(aTHX_ XS_VERSION, 0); \ xssv = new_version(xssv); \ if ( !sv_derived_from(_sv, "version") ) \ _sv = new_version(_sv); \ if ( vcmp(_sv,xssv) ) \ Perl_croak(aTHX_ "%s object version %"SVf" does not match %s%s%s%s %"SVf,\ module, SVfARG(vstringify(xssv)), \ vn ? "$" : "", vn ? module : "", vn ? "::" : "", \ vn ? vn : "bootstrap parameter", SVfARG(vstringify(_sv)));\ } \ } STMT_END #else # define XS_VERSION_BOOTCHECK #endif #ifdef NO_XSLOCKS # define dXCPT dJMPENV; int rEtV = 0 # define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0) # define XCPT_TRY_END JMPENV_POP; # define XCPT_CATCH if (rEtV != 0) # define XCPT_RETHROW JMPENV_JUMP(rEtV) #endif /* The DBM_setFilter & DBM_ckFilter macros are only used by the *DB*_File modules */ #define DBM_setFilter(db_type,code) \ STMT_START { \ if (db_type) \ RETVAL = sv_mortalcopy(db_type) ; \ ST(0) = RETVAL ; \ if (db_type && (code == &PL_sv_undef)) { \ SvREFCNT_dec(db_type) ; \ db_type = NULL ; \ } \ else if (code) { \ if (db_type) \ sv_setsv(db_type, code) ; \ else \ db_type = newSVsv(code) ; \ } \ } STMT_END #define DBM_ckFilter(arg,type,name) \ STMT_START { \ if (db->type) { \ if (db->filtering) { \ croak("recursion detected in %s", name) ; \ } \ ENTER ; \ SAVETMPS ; \ SAVEINT(db->filtering) ; \ db->filtering = TRUE ; \ SAVE_DEFSV ; \ if (name[7] == 's') \ arg = newSVsv(arg); \ DEFSV_set(arg) ; \ SvTEMP_off(arg) ; \ PUSHMARK(SP) ; \ PUTBACK ; \ (void) perl_call_sv(db->type, G_DISCARD); \ SPAGAIN ; \ PUTBACK ; \ FREETMPS ; \ LEAVE ; \ if (name[7] == 's'){ \ arg = sv_2mortal(arg); \ } \ } } STMT_END #if 1 /* for compatibility */ # define VTBL_sv &PL_vtbl_sv # define VTBL_env &PL_vtbl_env # define VTBL_envelem &PL_vtbl_envelem # define VTBL_sig &PL_vtbl_sig # define VTBL_sigelem &PL_vtbl_sigelem # define VTBL_pack &PL_vtbl_pack # define VTBL_packelem &PL_vtbl_packelem # define VTBL_dbline &PL_vtbl_dbline # define VTBL_isa &PL_vtbl_isa # define VTBL_isaelem &PL_vtbl_isaelem # define VTBL_arylen &PL_vtbl_arylen # define VTBL_glob &PL_vtbl_glob # define VTBL_mglob &PL_vtbl_mglob # define VTBL_nkeys &PL_vtbl_nkeys # define VTBL_taint &PL_vtbl_taint # define VTBL_substr &PL_vtbl_substr # define VTBL_vec &PL_vtbl_vec # define VTBL_pos &PL_vtbl_pos # define VTBL_bm &PL_vtbl_bm # define VTBL_fm &PL_vtbl_fm # define VTBL_uvar &PL_vtbl_uvar # define VTBL_defelem &PL_vtbl_defelem # define VTBL_regexp &PL_vtbl_regexp # define VTBL_regdata &PL_vtbl_regdata # define VTBL_regdatum &PL_vtbl_regdatum # ifdef USE_LOCALE_COLLATE # define VTBL_collxfrm &PL_vtbl_collxfrm # endif # define VTBL_amagic &PL_vtbl_amagic # define VTBL_amagicelem &PL_vtbl_amagicelem #endif #include "perlapi.h" #if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_NO_GET_CONTEXT) && !defined(PERL_CORE) # undef aTHX # undef aTHX_ # define aTHX PERL_GET_THX # define aTHX_ aTHX, #endif #if defined(PERL_IMPLICIT_SYS) && !defined(PERL_CORE) # ifndef NO_XSLOCKS # if defined (NETWARE) && defined (USE_STDIO) # define times PerlProc_times # define setuid PerlProc_setuid # define setgid PerlProc_setgid # define getpid PerlProc_getpid # define pause PerlProc_pause # define exit PerlProc_exit # define _exit PerlProc__exit # else # undef closedir # undef opendir # undef stdin # undef stdout # undef stderr # undef feof # undef ferror # undef fgetpos # undef ioctl # undef getlogin # undef setjmp # undef getc # undef ungetc # undef fileno /* Following symbols were giving redefinition errors while building extensions - sgp 17th Oct 2000 */ #ifdef NETWARE # undef readdir # undef fstat # undef stat # undef longjmp # undef endhostent # undef endnetent # undef endprotoent # undef endservent # undef gethostbyaddr # undef gethostbyname # undef gethostent # undef getnetbyaddr # undef getnetbyname # undef getnetent # undef getprotobyname # undef getprotobynumber # undef getprotoent # undef getservbyname # undef getservbyport # undef getservent # undef inet_ntoa # undef sethostent # undef setnetent # undef setprotoent # undef setservent #endif /* NETWARE */ /* to avoid warnings: "xyz" redefined */ #ifdef WIN32 # undef popen # undef pclose #endif /* WIN32 */ # undef socketpair # define mkdir PerlDir_mkdir # define chdir PerlDir_chdir # define rmdir PerlDir_rmdir # define closedir PerlDir_close # define opendir PerlDir_open # define readdir PerlDir_read # define rewinddir PerlDir_rewind # define seekdir PerlDir_seek # define telldir PerlDir_tell # define putenv PerlEnv_putenv # define getenv PerlEnv_getenv # define uname PerlEnv_uname # define stdin PerlSIO_stdin # define stdout PerlSIO_stdout # define stderr PerlSIO_stderr # define fopen PerlSIO_fopen # define fclose PerlSIO_fclose # define feof PerlSIO_feof # define ferror PerlSIO_ferror # define clearerr PerlSIO_clearerr # define getc PerlSIO_getc # define fputc PerlSIO_fputc # define fputs PerlSIO_fputs # define fflush PerlSIO_fflush # define ungetc PerlSIO_ungetc # define fileno PerlSIO_fileno # define fdopen PerlSIO_fdopen # define freopen PerlSIO_freopen # define fread PerlSIO_fread # define fwrite PerlSIO_fwrite # define setbuf PerlSIO_setbuf # define setvbuf PerlSIO_setvbuf # define setlinebuf PerlSIO_setlinebuf # define stdoutf PerlSIO_stdoutf # define vfprintf PerlSIO_vprintf # define ftell PerlSIO_ftell # define fseek PerlSIO_fseek # define fgetpos PerlSIO_fgetpos # define fsetpos PerlSIO_fsetpos # define frewind PerlSIO_rewind # define tmpfile PerlSIO_tmpfile # define access PerlLIO_access # define chmod PerlLIO_chmod # define chsize PerlLIO_chsize # define close PerlLIO_close # define dup PerlLIO_dup # define dup2 PerlLIO_dup2 # define flock PerlLIO_flock # define fstat PerlLIO_fstat # define ioctl PerlLIO_ioctl # define isatty PerlLIO_isatty # define link PerlLIO_link # define lseek PerlLIO_lseek # define lstat PerlLIO_lstat # define mktemp PerlLIO_mktemp # define open PerlLIO_open # define read PerlLIO_read # define rename PerlLIO_rename # define setmode PerlLIO_setmode # define stat(buf,sb) PerlLIO_stat(buf,sb) # define tmpnam PerlLIO_tmpnam # define umask PerlLIO_umask # define unlink PerlLIO_unlink # define utime PerlLIO_utime # define write PerlLIO_write # define malloc PerlMem_malloc # define realloc PerlMem_realloc # define free PerlMem_free # define abort PerlProc_abort # define exit PerlProc_exit # define _exit PerlProc__exit # define execl PerlProc_execl # define execv PerlProc_execv # define execvp PerlProc_execvp # define getuid PerlProc_getuid # define geteuid PerlProc_geteuid # define getgid PerlProc_getgid # define getegid PerlProc_getegid # define getlogin PerlProc_getlogin # define kill PerlProc_kill # define killpg PerlProc_killpg # define pause PerlProc_pause # define popen PerlProc_popen # define pclose PerlProc_pclose # define pipe PerlProc_pipe # define setuid PerlProc_setuid # define setgid PerlProc_setgid # define sleep PerlProc_sleep # define times PerlProc_times # define wait PerlProc_wait # define setjmp PerlProc_setjmp # define longjmp PerlProc_longjmp # define signal PerlProc_signal # define getpid PerlProc_getpid # define gettimeofday PerlProc_gettimeofday # define htonl PerlSock_htonl # define htons PerlSock_htons # define ntohl PerlSock_ntohl # define ntohs PerlSock_ntohs # define accept PerlSock_accept # define bind PerlSock_bind # define connect PerlSock_connect # define endhostent PerlSock_endhostent # define endnetent PerlSock_endnetent # define endprotoent PerlSock_endprotoent # define endservent PerlSock_endservent # define gethostbyaddr PerlSock_gethostbyaddr # define gethostbyname PerlSock_gethostbyname # define gethostent PerlSock_gethostent # define gethostname PerlSock_gethostname # define getnetbyaddr PerlSock_getnetbyaddr # define getnetbyname PerlSock_getnetbyname # define getnetent PerlSock_getnetent # define getpeername PerlSock_getpeername # define getprotobyname PerlSock_getprotobyname # define getprotobynumber PerlSock_getprotobynumber # define getprotoent PerlSock_getprotoent # define getservbyname PerlSock_getservbyname # define getservbyport PerlSock_getservbyport # define getservent PerlSock_getservent # define getsockname PerlSock_getsockname # define getsockopt PerlSock_getsockopt # define inet_addr PerlSock_inet_addr # define inet_ntoa PerlSock_inet_ntoa # define listen PerlSock_listen # define recv PerlSock_recv # define recvfrom PerlSock_recvfrom # define select PerlSock_select # define send PerlSock_send # define sendto PerlSock_sendto # define sethostent PerlSock_sethostent # define setnetent PerlSock_setnetent # define setprotoent PerlSock_setprotoent # define setservent PerlSock_setservent # define setsockopt PerlSock_setsockopt # define shutdown PerlSock_shutdown # define socket PerlSock_socket # define socketpair PerlSock_socketpair # endif /* NETWARE && USE_STDIO */ # ifdef USE_SOCKETS_AS_HANDLES # undef fd_set # undef FD_SET # undef FD_CLR # undef FD_ISSET # undef FD_ZERO # define fd_set Perl_fd_set # define FD_SET(n,p) PERL_FD_SET(n,p) # define FD_CLR(n,p) PERL_FD_CLR(n,p) # define FD_ISSET(n,p) PERL_FD_ISSET(n,p) # define FD_ZERO(p) PERL_FD_ZERO(p) # endif /* USE_SOCKETS_AS_HANDLES */ # endif /* NO_XSLOCKS */ #endif /* PERL_IMPLICIT_SYS && !PERL_CORE */ #endif /* _INC_PERL_XSUB_H */ /* include guard */ /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */ perl-5.12.0-RC0/proto.h0000644000175000017500000067573511340037012013461 0ustar jessejesse/* -*- buffer-read-only: t -*- * * proto.h * * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * * !!!!!!! DO NOT EDIT THIS FILE !!!!!!! * This file is built by embed.pl from data in embed.fnc, embed.pl, * pp.sym, intrpvar.h, and perlvars.h. * Any changes made here will be lost! * * Edit those files and run 'make regen_headers' to effect changes. */ START_EXTERN_C #if defined(PERL_IMPLICIT_SYS) PERL_CALLCONV PerlInterpreter* perl_alloc_using(struct IPerlMem *ipM, struct IPerlMem *ipMS, struct IPerlMem *ipMP, struct IPerlEnv *ipE, struct IPerlStdIO *ipStd, struct IPerlLIO *ipLIO, struct IPerlDir *ipD, struct IPerlSock *ipS, struct IPerlProc *ipP) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__nonnull__(3) __attribute__nonnull__(4) __attribute__nonnull__(5) __attribute__nonnull__(6) __attribute__nonnull__(7) __attribute__nonnull__(8) __attribute__nonnull__(9); #define PERL_ARGS_ASSERT_PERL_ALLOC_USING \ assert(ipM); assert(ipMS); assert(ipMP); assert(ipE); assert(ipStd); assert(ipLIO); assert(ipD); assert(ipS); assert(ipP) #endif PERL_CALLCONV PerlInterpreter* perl_alloc(void); PERL_CALLCONV void perl_construct(PerlInterpreter *my_perl) __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_PERL_CONSTRUCT \ assert(my_perl) PERL_CALLCONV int perl_destruct(PerlInterpreter *my_perl) __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_PERL_DESTRUCT \ assert(my_perl) PERL_CALLCONV void perl_free(PerlInterpreter *my_perl) __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_PERL_FREE \ assert(my_perl) PERL_CALLCONV int perl_run(PerlInterpreter *my_perl) __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_PERL_RUN \ assert(my_perl) PERL_CALLCONV int perl_parse(PerlInterpreter *my_perl, XSINIT_t xsinit, int argc, char** argv, char** env) __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_PERL_PARSE \ assert(my_perl) PERL_CALLCONV bool Perl_doing_taint(int argc, char** argv, char** env) __attribute__warn_unused_result__; #if defined(USE_ITHREADS) PERL_CALLCONV PerlInterpreter* perl_clone(PerlInterpreter *proto_perl, UV flags) __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_PERL_CLONE \ assert(proto_perl) # if defined(PERL_IMPLICIT_SYS) PERL_CALLCONV PerlInterpreter* perl_clone_using(PerlInterpreter *proto_perl, UV flags, struct IPerlMem* ipM, struct IPerlMem* ipMS, struct IPerlMem* ipMP, struct IPerlEnv* ipE, struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO, struct IPerlDir* ipD, struct IPerlSock* ipS, struct IPerlProc* ipP) __attribute__nonnull__(1) __attribute__nonnull__(3) __attribute__nonnull__(4) __attribute__nonnull__(5) __attribute__nonnull__(6) __attribute__nonnull__(7) __attribute__nonnull__(8) __attribute__nonnull__(9) __attribute__nonnull__(10) __attribute__nonnull__(11); #define PERL_ARGS_ASSERT_PERL_CLONE_USING \ assert(proto_perl); assert(ipM); assert(ipMS); assert(ipMP); assert(ipE); assert(ipStd); assert(ipLIO); assert(ipD); assert(ipS); assert(ipP) # endif #endif PERL_CALLCONV Malloc_t Perl_malloc(MEM_SIZE nbytes) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV Malloc_t Perl_calloc(MEM_SIZE elements, MEM_SIZE size) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV Malloc_t Perl_realloc(Malloc_t where, MEM_SIZE nbytes) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV Free_t Perl_mfree(Malloc_t where); #if defined(MYMALLOC) PERL_CALLCONV MEM_SIZE Perl_malloced_size(void *p) __attribute__warn_unused_result__ __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_MALLOCED_SIZE \ assert(p) PERL_CALLCONV MEM_SIZE Perl_malloc_good_size(size_t nbytes) __attribute__warn_unused_result__; #endif PERL_CALLCONV void* Perl_get_context(void) __attribute__warn_unused_result__; PERL_CALLCONV void Perl_set_context(void *t) __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_SET_CONTEXT \ assert(t) PERL_CALLCONV I32 Perl_regcurly(const char *s) __attribute__warn_unused_result__ __attribute__pure__ __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_REGCURLY \ assert(s) END_EXTERN_C /* functions with flag 'n' should come before here */ START_EXTERN_C # include "pp_proto.h" PERL_CALLCONV SV* Perl_amagic_call(pTHX_ SV* left, SV* right, int method, int dir) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_AMAGIC_CALL \ assert(left); assert(right) PERL_CALLCONV int Perl_Gv_AMupdate(pTHX_ HV* stash, bool destructing) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GV_AMUPDATE \ assert(stash) PERL_CALLCONV CV* Perl_gv_handler(pTHX_ HV* stash, I32 id) __attribute__warn_unused_result__; PERL_CALLCONV OP* Perl_append_elem(pTHX_ I32 optype, OP* first, OP* last); PERL_CALLCONV OP* Perl_append_list(pTHX_ I32 optype, LISTOP* first, LISTOP* last); PERL_CALLCONV I32 Perl_apply(pTHX_ I32 type, SV** mark, SV** sp) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_APPLY \ assert(mark); assert(sp) PERL_CALLCONV void Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv, const char *attrstr, STRLEN len) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_APPLY_ATTRS_STRING \ assert(stashpv); assert(cv); assert(attrstr) PERL_CALLCONV void Perl_av_clear(pTHX_ AV *av) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_AV_CLEAR \ assert(av) PERL_CALLCONV SV* Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_AV_DELETE \ assert(av) PERL_CALLCONV bool Perl_av_exists(pTHX_ AV *av, I32 key) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_AV_EXISTS \ assert(av) PERL_CALLCONV void Perl_av_extend(pTHX_ AV *av, I32 key) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_AV_EXTEND \ assert(av) PERL_CALLCONV SV** Perl_av_fetch(pTHX_ AV *av, I32 key, I32 lval) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_AV_FETCH \ assert(av) PERL_CALLCONV void Perl_av_fill(pTHX_ AV *av, I32 fill) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_AV_FILL \ assert(av) PERL_CALLCONV I32 Perl_av_len(pTHX_ AV *av) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_AV_LEN \ assert(av) PERL_CALLCONV AV* Perl_av_make(pTHX_ I32 size, SV **strp) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_AV_MAKE \ assert(strp) PERL_CALLCONV SV* Perl_av_pop(pTHX_ AV *av) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_AV_POP \ assert(av) PERL_CALLCONV void Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH \ assert(avp); assert(val) PERL_CALLCONV void Perl_av_push(pTHX_ AV *av, SV *val) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_AV_PUSH \ assert(av); assert(val) PERL_CALLCONV void Perl_av_reify(pTHX_ AV *av) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_AV_REIFY \ assert(av) PERL_CALLCONV SV* Perl_av_shift(pTHX_ AV *av) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_AV_SHIFT \ assert(av) PERL_CALLCONV SV** Perl_av_store(pTHX_ AV *av, I32 key, SV *val) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_AV_STORE \ assert(av) PERL_CALLCONV void Perl_av_undef(pTHX_ AV *av) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_AV_UNDEF \ assert(av) PERL_CALLCONV SV** Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE \ assert(avp); assert(val) PERL_CALLCONV void Perl_av_unshift(pTHX_ AV *av, I32 num) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_AV_UNSHIFT \ assert(av) PERL_CALLCONV SV** Perl_av_arylen_p(pTHX_ AV *av) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_AV_ARYLEN_P \ assert(av) PERL_CALLCONV IV* Perl_av_iter_p(pTHX_ AV *av) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_AV_ITER_P \ assert(av) #if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT) STATIC MAGIC* S_get_aux_mg(pTHX_ AV *av) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GET_AUX_MG \ assert(av) #endif PERL_CALLCONV OP* Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_BIND_MATCH \ assert(left); assert(right) PERL_CALLCONV OP* Perl_block_end(pTHX_ I32 floor, OP* seq) __attribute__warn_unused_result__; PERL_CALLCONV I32 Perl_block_gimme(pTHX) __attribute__warn_unused_result__; PERL_CALLCONV int Perl_block_start(pTHX_ int full) __attribute__warn_unused_result__; PERL_CALLCONV void Perl_boot_core_UNIVERSAL(pTHX); PERL_CALLCONV void Perl_boot_core_PerlIO(pTHX); PERL_CALLCONV void Perl_call_list(pTHX_ I32 oldscope, AV *paramList) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_CALL_LIST \ assert(paramList) PERL_CALLCONV bool Perl_cando(pTHX_ Mode_t mode, bool effective, const Stat_t* statbufp) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_CANDO \ assert(statbufp) PERL_CALLCONV U32 Perl_cast_ulong(pTHX_ NV f) __attribute__warn_unused_result__; PERL_CALLCONV I32 Perl_cast_i32(pTHX_ NV f) __attribute__warn_unused_result__; PERL_CALLCONV IV Perl_cast_iv(pTHX_ NV f) __attribute__warn_unused_result__; PERL_CALLCONV UV Perl_cast_uv(pTHX_ NV f) __attribute__warn_unused_result__; #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP) PERL_CALLCONV I32 Perl_my_chsize(pTHX_ int fd, Off_t length) __attribute__warn_unused_result__; #endif PERL_CALLCONV OP* Perl_convert(pTHX_ I32 optype, I32 flags, OP* o) __attribute__warn_unused_result__; PERL_CALLCONV PERL_CONTEXT* Perl_create_eval_scope(pTHX_ U32 flags); PERL_CALLCONV void Perl_croak(pTHX_ const char* pat, ...) __attribute__noreturn__ __attribute__format__null_ok__(__printf__,pTHX_1,pTHX_2); PERL_CALLCONV void Perl_vcroak(pTHX_ const char* pat, va_list* args) __attribute__noreturn__; PERL_CALLCONV void Perl_croak_xs_usage(pTHX_ const CV *const cv, const char *const params) __attribute__noreturn__ __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_CROAK_XS_USAGE \ assert(cv); assert(params) #if defined(PERL_IMPLICIT_CONTEXT) PERL_CALLCONV void Perl_croak_nocontext(const char* pat, ...) __attribute__noreturn__ __attribute__format__null_ok__(__printf__,1,2); PERL_CALLCONV OP* Perl_die_nocontext(const char* pat, ...) __attribute__format__null_ok__(__printf__,1,2); PERL_CALLCONV void Perl_deb_nocontext(const char* pat, ...) __attribute__format__(__printf__,1,2) __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_DEB_NOCONTEXT \ assert(pat) PERL_CALLCONV char* Perl_form_nocontext(const char* pat, ...) __attribute__format__(__printf__,1,2) __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_FORM_NOCONTEXT \ assert(pat) PERL_CALLCONV void Perl_load_module_nocontext(U32 flags, SV* name, SV* ver, ...) __attribute__nonnull__(2); #define PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT \ assert(name) PERL_CALLCONV SV* Perl_mess_nocontext(const char* pat, ...) __attribute__format__(__printf__,1,2) __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_MESS_NOCONTEXT \ assert(pat) PERL_CALLCONV void Perl_warn_nocontext(const char* pat, ...) __attribute__format__(__printf__,1,2) __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_WARN_NOCONTEXT \ assert(pat) PERL_CALLCONV void Perl_warner_nocontext(U32 err, const char* pat, ...) __attribute__format__(__printf__,2,3) __attribute__nonnull__(2); #define PERL_ARGS_ASSERT_WARNER_NOCONTEXT \ assert(pat) PERL_CALLCONV SV* Perl_newSVpvf_nocontext(const char *const pat, ...) __attribute__format__(__printf__,1,2) __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT \ assert(pat) PERL_CALLCONV void Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...) __attribute__format__(__printf__,2,3) __attribute__nonnull__(1) __attribute__nonnull__(2); #define PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT \ assert(sv); assert(pat) PERL_CALLCONV void Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...) __attribute__format__(__printf__,2,3) __attribute__nonnull__(1) __attribute__nonnull__(2); #define PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT \ assert(sv); assert(pat) PERL_CALLCONV void Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...) __attribute__format__(__printf__,2,3) __attribute__nonnull__(1) __attribute__nonnull__(2); #define PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT \ assert(sv); assert(pat) PERL_CALLCONV void Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...) __attribute__format__(__printf__,2,3) __attribute__nonnull__(1) __attribute__nonnull__(2); #define PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT \ assert(sv); assert(pat) PERL_CALLCONV int Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...) __attribute__format__(__printf__,2,3) __attribute__nonnull__(1) __attribute__nonnull__(2); #define PERL_ARGS_ASSERT_FPRINTF_NOCONTEXT \ assert(stream); assert(format) PERL_CALLCONV int Perl_printf_nocontext(const char *format, ...) __attribute__format__(__printf__,1,2) __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_PRINTF_NOCONTEXT \ assert(format) #endif PERL_CALLCONV void Perl_cv_ckproto_len(pTHX_ const CV* cv, const GV* gv, const char* p, const STRLEN len) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CV_CKPROTO_LEN \ assert(cv) PERL_CALLCONV CV* Perl_cv_clone(pTHX_ CV* proto) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CV_CLONE \ assert(proto) PERL_CALLCONV SV* Perl_gv_const_sv(pTHX_ GV* gv) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GV_CONST_SV \ assert(gv) PERL_CALLCONV SV* Perl_cv_const_sv(pTHX_ const CV *const cv) __attribute__warn_unused_result__; PERL_CALLCONV SV* Perl_op_const_sv(pTHX_ const OP* o, CV* cv) __attribute__warn_unused_result__; PERL_CALLCONV void Perl_cv_undef(pTHX_ CV* cv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CV_UNDEF \ assert(cv) PERL_CALLCONV void Perl_cx_dump(pTHX_ PERL_CONTEXT* cx) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CX_DUMP \ assert(cx) PERL_CALLCONV SV* Perl_filter_add(pTHX_ filter_t funcp, SV* datasv); PERL_CALLCONV void Perl_filter_del(pTHX_ filter_t funcp) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_FILTER_DEL \ assert(funcp) PERL_CALLCONV I32 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_FILTER_READ \ assert(buf_sv) PERL_CALLCONV char** Perl_get_op_descs(pTHX) __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV char** Perl_get_op_names(pTHX) __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV const char* Perl_get_no_modify(pTHX) __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV U32* Perl_get_opargs(pTHX) __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV PPADDR_t* Perl_get_ppaddr(pTHX) __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV I32 Perl_cxinc(pTHX) __attribute__warn_unused_result__; PERL_CALLCONV void Perl_deb(pTHX_ const char* pat, ...) __attribute__format__(__printf__,pTHX_1,pTHX_2) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DEB \ assert(pat) PERL_CALLCONV void Perl_vdeb(pTHX_ const char* pat, va_list* args) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_VDEB \ assert(pat) PERL_CALLCONV void Perl_debprofdump(pTHX); PERL_CALLCONV I32 Perl_debop(pTHX_ const OP* o) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DEBOP \ assert(o) PERL_CALLCONV I32 Perl_debstack(pTHX); PERL_CALLCONV I32 Perl_debstackptrs(pTHX); PERL_CALLCONV char* Perl_delimcpy(char* to, const char* toend, const char* from, const char* fromend, int delim, I32* retlen) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__nonnull__(3) __attribute__nonnull__(4) __attribute__nonnull__(6); #define PERL_ARGS_ASSERT_DELIMCPY \ assert(to); assert(toend); assert(from); assert(fromend); assert(retlen) PERL_CALLCONV void Perl_delete_eval_scope(pTHX); PERL_CALLCONV OP* Perl_die(pTHX_ const char* pat, ...) __attribute__format__null_ok__(__printf__,pTHX_1,pTHX_2); #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) STATIC OP* S_vdie(pTHX_ const char* pat, va_list* args); #endif PERL_CALLCONV void Perl_die_where(pTHX_ SV* msv) __attribute__noreturn__; PERL_CALLCONV void Perl_dounwind(pTHX_ I32 cxix); /* PERL_CALLCONV bool Perl_do_aexec(pTHX_ SV* really, SV** mark, SV** sp) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); */ #define PERL_ARGS_ASSERT_DO_AEXEC \ assert(mark); assert(sp) PERL_CALLCONV bool Perl_do_aexec5(pTHX_ SV* really, SV** mark, SV** sp, int fd, int do_report) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_DO_AEXEC5 \ assert(mark); assert(sp) PERL_CALLCONV int Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DO_BINMODE \ assert(fp) PERL_CALLCONV void Perl_do_chop(pTHX_ SV *astr, SV *sv) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_DO_CHOP \ assert(astr); assert(sv) PERL_CALLCONV bool Perl_do_close(pTHX_ GV* gv, bool not_implicit); PERL_CALLCONV bool Perl_do_eof(pTHX_ GV* gv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DO_EOF \ assert(gv) #ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION /* PERL_CALLCONV bool Perl_do_exec(pTHX_ const char* cmd) __attribute__nonnull__(pTHX_1); */ #define PERL_ARGS_ASSERT_DO_EXEC \ assert(cmd) #else PERL_CALLCONV bool Perl_do_exec(pTHX_ const char* cmd) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DO_EXEC \ assert(cmd) #endif #if defined(WIN32) || defined(__SYMBIAN32__) || defined(VMS) PERL_CALLCONV int Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_DO_ASPAWN \ assert(mark); assert(sp) PERL_CALLCONV int Perl_do_spawn(pTHX_ char* cmd) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DO_SPAWN \ assert(cmd) PERL_CALLCONV int Perl_do_spawn_nowait(pTHX_ char* cmd) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT \ assert(cmd) #endif #if !defined(WIN32) PERL_CALLCONV bool Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DO_EXEC3 \ assert(incmd) #endif PERL_CALLCONV void Perl_do_execfree(pTHX); #if defined(PERL_IN_DOIO_C) || defined(PERL_DECL_PROT) STATIC void S_exec_failed(pTHX_ const char *cmd, int fd, int do_report) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_EXEC_FAILED \ assert(cmd) #endif #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) PERL_CALLCONV I32 Perl_do_ipcctl(pTHX_ I32 optype, SV** mark, SV** sp) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_DO_IPCCTL \ assert(mark); assert(sp) PERL_CALLCONV I32 Perl_do_ipcget(pTHX_ I32 optype, SV** mark, SV** sp) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_DO_IPCGET \ assert(mark); assert(sp) PERL_CALLCONV I32 Perl_do_msgrcv(pTHX_ SV** mark, SV** sp) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_DO_MSGRCV \ assert(mark); assert(sp) PERL_CALLCONV I32 Perl_do_msgsnd(pTHX_ SV** mark, SV** sp) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_DO_MSGSND \ assert(mark); assert(sp) PERL_CALLCONV I32 Perl_do_semop(pTHX_ SV** mark, SV** sp) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_DO_SEMOP \ assert(mark); assert(sp) PERL_CALLCONV I32 Perl_do_shmio(pTHX_ I32 optype, SV** mark, SV** sp) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_DO_SHMIO \ assert(mark); assert(sp) #endif PERL_CALLCONV void Perl_do_join(pTHX_ SV *sv, SV *delim, SV **mark, SV **sp) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3) __attribute__nonnull__(pTHX_4); #define PERL_ARGS_ASSERT_DO_JOIN \ assert(sv); assert(delim); assert(mark); assert(sp) PERL_CALLCONV OP* Perl_do_kv(pTHX); /* PERL_CALLCONV bool Perl_do_open(pTHX_ GV* gv, const char* name, I32 len, int as_raw, int rawmode, int rawperm, PerlIO* supplied_fp) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); */ #define PERL_ARGS_ASSERT_DO_OPEN \ assert(gv); assert(name) PERL_CALLCONV bool Perl_do_open9(pTHX_ GV *gv, const char *name, I32 len, int as_raw, int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs, I32 num) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_8); #define PERL_ARGS_ASSERT_DO_OPEN9 \ assert(gv); assert(name); assert(svs) PERL_CALLCONV 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) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_DO_OPENN \ assert(gv); assert(oname) PERL_CALLCONV bool Perl_do_print(pTHX_ SV* sv, PerlIO* fp) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_DO_PRINT \ assert(fp) PERL_CALLCONV OP* Perl_do_readline(pTHX) __attribute__warn_unused_result__; PERL_CALLCONV I32 Perl_do_chomp(pTHX_ SV* sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DO_CHOMP \ assert(sv) PERL_CALLCONV bool Perl_do_seek(pTHX_ GV* gv, Off_t pos, int whence); PERL_CALLCONV void Perl_do_sprintf(pTHX_ SV* sv, I32 len, SV** sarg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_DO_SPRINTF \ assert(sv); assert(sarg) PERL_CALLCONV Off_t Perl_do_sysseek(pTHX_ GV* gv, Off_t pos, int whence) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DO_SYSSEEK \ assert(gv) PERL_CALLCONV Off_t Perl_do_tell(pTHX_ GV* gv) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DO_TELL \ assert(gv) PERL_CALLCONV I32 Perl_do_trans(pTHX_ SV* sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DO_TRANS \ assert(sv) PERL_CALLCONV UV Perl_do_vecget(pTHX_ SV* sv, I32 offset, I32 size) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DO_VECGET \ assert(sv) PERL_CALLCONV void Perl_do_vecset(pTHX_ SV* sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DO_VECSET \ assert(sv) PERL_CALLCONV void Perl_do_vop(pTHX_ I32 optype, SV* sv, SV* left, SV* right) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3) __attribute__nonnull__(pTHX_4); #define PERL_ARGS_ASSERT_DO_VOP \ assert(sv); assert(left); assert(right) PERL_CALLCONV OP* Perl_dofile(pTHX_ OP* term, I32 force_builtin) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DOFILE \ assert(term) PERL_CALLCONV I32 Perl_dowantarray(pTHX) __attribute__warn_unused_result__; PERL_CALLCONV void Perl_dump_all(pTHX); PERL_CALLCONV void Perl_dump_all_perl(pTHX_ bool justperl); PERL_CALLCONV void Perl_dump_eval(pTHX); #if defined(DUMP_FDS) PERL_CALLCONV void Perl_dump_fds(pTHX_ char* s) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DUMP_FDS \ assert(s) #endif PERL_CALLCONV void Perl_dump_form(pTHX_ const GV* gv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DUMP_FORM \ assert(gv) PERL_CALLCONV void Perl_gv_dump(pTHX_ GV* gv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GV_DUMP \ assert(gv) PERL_CALLCONV void Perl_op_dump(pTHX_ const OP *o) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_OP_DUMP \ assert(o) PERL_CALLCONV void Perl_pmop_dump(pTHX_ PMOP* pm); PERL_CALLCONV void Perl_dump_packsubs(pTHX_ const HV* stash) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DUMP_PACKSUBS \ assert(stash) PERL_CALLCONV void Perl_dump_packsubs_perl(pTHX_ const HV* stash, bool justperl) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL \ assert(stash) PERL_CALLCONV void Perl_dump_sub(pTHX_ const GV* gv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DUMP_SUB \ assert(gv) PERL_CALLCONV void Perl_dump_sub_perl(pTHX_ const GV* gv, bool justperl) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DUMP_SUB_PERL \ assert(gv) PERL_CALLCONV void Perl_fbm_compile(pTHX_ SV* sv, U32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_FBM_COMPILE \ assert(sv) PERL_CALLCONV char* Perl_fbm_instr(pTHX_ unsigned char* big, unsigned char* bigend, SV* littlestr, U32 flags) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_FBM_INSTR \ assert(big); assert(bigend); assert(littlestr) PERL_CALLCONV char* Perl_find_script(pTHX_ const char *scriptname, bool dosearch, const char *const *const search_ext, I32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_FIND_SCRIPT \ assert(scriptname) #if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) STATIC OP* S_force_list(pTHX_ OP* arg); STATIC OP* S_fold_constants(pTHX_ OP *o) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_FOLD_CONSTANTS \ assert(o) #endif PERL_CALLCONV char* Perl_form(pTHX_ const char* pat, ...) __attribute__format__(__printf__,pTHX_1,pTHX_2) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_FORM \ assert(pat) PERL_CALLCONV char* Perl_vform(pTHX_ const char* pat, va_list* args) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_VFORM \ assert(pat) PERL_CALLCONV void Perl_free_tmps(pTHX); #if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) STATIC OP* S_gen_constant_list(pTHX_ OP* o); #endif #if !defined(HAS_GETENV_LEN) PERL_CALLCONV char* Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_GETENV_LEN \ assert(env_elem); assert(len) #endif PERL_CALLCONV void Perl_get_db_sub(pTHX_ SV **svp, CV *cv) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_GET_DB_SUB \ assert(cv) PERL_CALLCONV void Perl_gp_free(pTHX_ GV* gv); PERL_CALLCONV GP* Perl_gp_ref(pTHX_ GP* gp); PERL_CALLCONV GV* Perl_gv_add_by_type(pTHX_ GV *gv, svtype type); /* PERL_CALLCONV GV* Perl_gv_AVadd(pTHX_ GV *gv); */ /* PERL_CALLCONV GV* Perl_gv_HVadd(pTHX_ GV *gv); */ /* PERL_CALLCONV GV* Perl_gv_IOadd(pTHX_ GV* gv); */ PERL_CALLCONV GV* Perl_gv_autoload4(pTHX_ HV* stash, const char* name, STRLEN len, I32 method) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_GV_AUTOLOAD4 \ assert(name) PERL_CALLCONV void Perl_gv_check(pTHX_ const HV* stash) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GV_CHECK \ assert(stash) PERL_CALLCONV void Perl_gv_efullname(pTHX_ SV* sv, const GV* gv) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_GV_EFULLNAME \ assert(sv); assert(gv) /* PERL_CALLCONV void Perl_gv_efullname3(pTHX_ SV* sv, const GV* gv, const char* prefix) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); */ #define PERL_ARGS_ASSERT_GV_EFULLNAME3 \ assert(sv); assert(gv) PERL_CALLCONV void Perl_gv_efullname4(pTHX_ SV* sv, const GV* gv, const char* prefix, bool keepmain) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_GV_EFULLNAME4 \ assert(sv); assert(gv) PERL_CALLCONV GV* Perl_gv_fetchfile(pTHX_ const char* name) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GV_FETCHFILE \ assert(name) PERL_CALLCONV GV* Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN len, const U32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS \ assert(name) PERL_CALLCONV GV* Perl_gv_fetchmeth(pTHX_ HV* stash, const char* name, STRLEN len, I32 level) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_GV_FETCHMETH \ assert(name) PERL_CALLCONV GV* Perl_gv_fetchmeth_autoload(pTHX_ HV* stash, const char* name, STRLEN len, I32 level) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_GV_FETCHMETH_AUTOLOAD \ assert(name) /* PERL_CALLCONV GV* Perl_gv_fetchmethod(pTHX_ HV* stash, const char* name) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); */ #define PERL_ARGS_ASSERT_GV_FETCHMETHOD \ assert(stash); assert(name) PERL_CALLCONV GV* Perl_gv_fetchmethod_autoload(pTHX_ HV* stash, const char* name, I32 autoload) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD \ assert(stash); assert(name) PERL_CALLCONV GV* Perl_gv_fetchmethod_flags(pTHX_ HV* stash, const char* name, U32 flags) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_GV_FETCHMETHOD_FLAGS \ assert(stash); assert(name) PERL_CALLCONV GV* Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GV_FETCHPV \ assert(nambeg) PERL_CALLCONV void Perl_gv_fullname(pTHX_ SV* sv, const GV* gv) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_GV_FULLNAME \ assert(sv); assert(gv) /* PERL_CALLCONV void Perl_gv_fullname3(pTHX_ SV* sv, const GV* gv, const char* prefix) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); */ #define PERL_ARGS_ASSERT_GV_FULLNAME3 \ assert(sv); assert(gv) PERL_CALLCONV void Perl_gv_fullname4(pTHX_ SV* sv, const GV* gv, const char* prefix, bool keepmain) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_GV_FULLNAME4 \ assert(sv); assert(gv) PERL_CALLCONV GP * Perl_newGP(pTHX_ GV *const gv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_NEWGP \ assert(gv) PERL_CALLCONV void Perl_gv_init(pTHX_ GV* gv, HV* stash, const char* name, STRLEN len, int multi) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_GV_INIT \ assert(gv); assert(name) PERL_CALLCONV void Perl_gv_name_set(pTHX_ GV* gv, const char *name, U32 len, U32 flags) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_GV_NAME_SET \ assert(gv); assert(name) PERL_CALLCONV void Perl_gv_try_downgrade(pTHX_ GV* gv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE \ assert(gv) PERL_CALLCONV HV* Perl_gv_stashpv(pTHX_ const char* name, I32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GV_STASHPV \ assert(name) PERL_CALLCONV HV* Perl_gv_stashpvn(pTHX_ const char* name, U32 namelen, I32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GV_STASHPVN \ assert(name) PERL_CALLCONV HV* Perl_gv_stashsv(pTHX_ SV* sv, I32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GV_STASHSV \ assert(sv) PERL_CALLCONV void Perl_hv_clear(pTHX_ HV *hv); PERL_CALLCONV HV * Perl_hv_copy_hints_hv(pTHX_ HV *const ohv); PERL_CALLCONV void Perl_hv_delayfree_ent(pTHX_ HV *hv, HE *entry) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_HV_DELAYFREE_ENT \ assert(hv) /* PERL_CALLCONV SV* Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags) __attribute__nonnull__(pTHX_2); */ #define PERL_ARGS_ASSERT_HV_DELETE \ assert(key) /* PERL_CALLCONV SV* Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash) __attribute__nonnull__(pTHX_2); */ #define PERL_ARGS_ASSERT_HV_DELETE_ENT \ assert(keysv) /* PERL_CALLCONV bool Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_2); */ #define PERL_ARGS_ASSERT_HV_EXISTS \ assert(key) /* PERL_CALLCONV bool Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_2); */ #define PERL_ARGS_ASSERT_HV_EXISTS_ENT \ assert(keysv) /* PERL_CALLCONV SV** Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval) __attribute__nonnull__(pTHX_2); */ #define PERL_ARGS_ASSERT_HV_FETCH \ assert(key) /* PERL_CALLCONV HE* Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, U32 hash) __attribute__nonnull__(pTHX_2); */ #define PERL_ARGS_ASSERT_HV_FETCH_ENT \ assert(keysv) PERL_CALLCONV void* Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char* key, STRLEN klen, int flags, int action, SV *val, U32 hash); PERL_CALLCONV void* Perl_hv_common_key_len(pTHX_ HV *hv, const char *key, I32 klen_i32, const int action, SV *val, const U32 hash) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_HV_COMMON_KEY_LEN \ assert(key) PERL_CALLCONV void Perl_hv_free_ent(pTHX_ HV *hv, HE *entryK) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_HV_FREE_ENT \ assert(hv) PERL_CALLCONV I32 Perl_hv_iterinit(pTHX_ HV *hv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_HV_ITERINIT \ assert(hv) PERL_CALLCONV char* Perl_hv_iterkey(pTHX_ HE* entry, I32* retlen) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_HV_ITERKEY \ assert(entry); assert(retlen) PERL_CALLCONV SV* Perl_hv_iterkeysv(pTHX_ HE* entry) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_HV_ITERKEYSV \ assert(entry) /* PERL_CALLCONV HE* Perl_hv_iternext(pTHX_ HV *hv) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); */ #define PERL_ARGS_ASSERT_HV_ITERNEXT \ assert(hv) PERL_CALLCONV SV* Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_HV_ITERNEXTSV \ assert(hv); assert(key); assert(retlen) PERL_CALLCONV HE* Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_HV_ITERNEXT_FLAGS \ assert(hv) PERL_CALLCONV SV* Perl_hv_iterval(pTHX_ HV *hv, HE *entry) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_HV_ITERVAL \ assert(hv); assert(entry) PERL_CALLCONV void Perl_hv_ksplit(pTHX_ HV *hv, IV newmax) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_HV_KSPLIT \ assert(hv) /* PERL_CALLCONV void Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how) __attribute__nonnull__(pTHX_1); */ #define PERL_ARGS_ASSERT_HV_MAGIC \ assert(hv) PERL_CALLCONV HV * Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *c); PERL_CALLCONV SV * Perl_refcounted_he_fetch(pTHX_ const struct refcounted_he *chain, SV *keysv, const char *key, STRLEN klen, int flags, U32 hash); PERL_CALLCONV void Perl_refcounted_he_free(pTHX_ struct refcounted_he *he); PERL_CALLCONV struct refcounted_he * Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent, SV *const key, SV *const value); #if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT) STATIC struct refcounted_he * S_refcounted_he_new_common(pTHX_ struct refcounted_he *const parent, const char *const key_p, const STRLEN key_len, const char flags, char value_type, const void *value, const STRLEN value_len) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_6); #define PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_COMMON \ assert(key_p); assert(value) #endif /* PERL_CALLCONV SV** Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash); */ /* PERL_CALLCONV HE* Perl_hv_store_ent(pTHX_ HV *hv, SV *key, SV *val, U32 hash); */ /* PERL_CALLCONV SV** Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash, int flags); */ PERL_CALLCONV void Perl_hv_undef(pTHX_ HV *hv); PERL_CALLCONV I32 Perl_ibcmp(const char* a, const char* b, I32 len) __attribute__pure__ __attribute__nonnull__(1) __attribute__nonnull__(2); #define PERL_ARGS_ASSERT_IBCMP \ assert(a); assert(b) PERL_CALLCONV I32 Perl_ibcmp_locale(const char* a, const char* b, I32 len) __attribute__pure__ __attribute__nonnull__(1) __attribute__nonnull__(2); #define PERL_ARGS_ASSERT_IBCMP_LOCALE \ assert(a); assert(b) PERL_CALLCONV I32 Perl_ibcmp_utf8(pTHX_ const char *s1, char **pe1, UV l1, bool u1, const char *s2, char **pe2, UV l2, bool u2) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_5); #define PERL_ARGS_ASSERT_IBCMP_UTF8 \ assert(s1); assert(s2) #if defined(PERL_IN_DOIO_C) || defined(PERL_DECL_PROT) STATIC bool S_ingroup(pTHX_ Gid_t testgid, bool effective) __attribute__warn_unused_result__; #endif PERL_CALLCONV void Perl_init_argv_symbols(pTHX_ int argc, char **argv) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS \ assert(argv) PERL_CALLCONV void Perl_init_debugger(pTHX); PERL_CALLCONV void Perl_init_stacks(pTHX); PERL_CALLCONV void Perl_init_tm(pTHX_ struct tm *ptm) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_INIT_TM \ assert(ptm) PERL_CALLCONV U32 Perl_intro_my(pTHX); PERL_CALLCONV char* Perl_instr(const char* big, const char* little) __attribute__warn_unused_result__ __attribute__pure__ __attribute__nonnull__(1) __attribute__nonnull__(2); #define PERL_ARGS_ASSERT_INSTR \ assert(big); assert(little) PERL_CALLCONV bool Perl_io_close(pTHX_ IO* io, bool not_implicit) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_IO_CLOSE \ assert(io) PERL_CALLCONV OP* Perl_invert(pTHX_ OP* cmd) __attribute__warn_unused_result__; PERL_CALLCONV I32 Perl_is_lvalue_sub(pTHX) __attribute__warn_unused_result__; PERL_CALLCONV U32 Perl_to_uni_upper_lc(pTHX_ U32 c) __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV U32 Perl_to_uni_title_lc(pTHX_ U32 c) __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV U32 Perl_to_uni_lower_lc(pTHX_ U32 c) __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV bool Perl_is_uni_alnum(pTHX_ UV c) __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV bool Perl_is_uni_idfirst(pTHX_ UV c) __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV bool Perl_is_uni_alpha(pTHX_ UV c) __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV bool Perl_is_uni_ascii(pTHX_ UV c) __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV bool Perl_is_uni_space(pTHX_ UV c) __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV bool Perl_is_uni_cntrl(pTHX_ UV c) __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV bool Perl_is_uni_graph(pTHX_ UV c) __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV bool Perl_is_uni_digit(pTHX_ UV c) __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV bool Perl_is_uni_upper(pTHX_ UV c) __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV bool Perl_is_uni_lower(pTHX_ UV c) __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV bool Perl_is_uni_print(pTHX_ UV c) __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV bool Perl_is_uni_punct(pTHX_ UV c) __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV bool Perl_is_uni_xdigit(pTHX_ UV c) __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV UV Perl_to_uni_upper(pTHX_ UV c, U8 *p, STRLEN *lenp) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_TO_UNI_UPPER \ assert(p); assert(lenp) PERL_CALLCONV UV Perl_to_uni_title(pTHX_ UV c, U8 *p, STRLEN *lenp) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_TO_UNI_TITLE \ assert(p); assert(lenp) PERL_CALLCONV UV Perl_to_uni_lower(pTHX_ UV c, U8 *p, STRLEN *lenp) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_TO_UNI_LOWER \ assert(p); assert(lenp) PERL_CALLCONV UV Perl_to_uni_fold(pTHX_ UV c, U8 *p, STRLEN *lenp) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_TO_UNI_FOLD \ assert(p); assert(lenp) PERL_CALLCONV bool Perl_is_uni_alnum_lc(pTHX_ UV c) __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV bool Perl_is_uni_idfirst_lc(pTHX_ UV c) __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV bool Perl_is_uni_alpha_lc(pTHX_ UV c) __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV bool Perl_is_uni_ascii_lc(pTHX_ UV c) __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV bool Perl_is_uni_space_lc(pTHX_ UV c) __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV bool Perl_is_uni_cntrl_lc(pTHX_ UV c) __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV bool Perl_is_uni_graph_lc(pTHX_ UV c) __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV bool Perl_is_uni_digit_lc(pTHX_ UV c) __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV bool Perl_is_uni_upper_lc(pTHX_ UV c) __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV bool Perl_is_uni_lower_lc(pTHX_ UV c) __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV bool Perl_is_uni_print_lc(pTHX_ UV c) __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV bool Perl_is_uni_punct_lc(pTHX_ UV c) __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV bool Perl_is_uni_xdigit_lc(pTHX_ UV c) __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV bool Perl_is_ascii_string(const U8 *s, STRLEN len) __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_IS_ASCII_STRING \ assert(s) PERL_CALLCONV STRLEN Perl_is_utf8_char(const U8 *s) __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_IS_UTF8_CHAR \ assert(s) PERL_CALLCONV bool Perl_is_utf8_string(const U8 *s, STRLEN len) __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_IS_UTF8_STRING \ assert(s) /* PERL_CALLCONV bool Perl_is_utf8_string_loc(const U8 *s, STRLEN len, const U8 **p) __attribute__nonnull__(1); */ #define PERL_ARGS_ASSERT_IS_UTF8_STRING_LOC \ assert(s) PERL_CALLCONV bool Perl_is_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el) __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN \ assert(s) PERL_CALLCONV bool Perl_is_utf8_alnum(pTHX_ const U8 *p) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_IS_UTF8_ALNUM \ assert(p) PERL_CALLCONV bool Perl_is_utf8_idfirst(pTHX_ const U8 *p) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_IS_UTF8_IDFIRST \ assert(p) PERL_CALLCONV bool Perl_is_utf8_idcont(pTHX_ const U8 *p) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_IS_UTF8_IDCONT \ assert(p) PERL_CALLCONV bool Perl_is_utf8_alpha(pTHX_ const U8 *p) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_IS_UTF8_ALPHA \ assert(p) PERL_CALLCONV bool Perl_is_utf8_ascii(pTHX_ const U8 *p) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_IS_UTF8_ASCII \ assert(p) PERL_CALLCONV bool Perl_is_utf8_space(pTHX_ const U8 *p) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_IS_UTF8_SPACE \ assert(p) PERL_CALLCONV bool Perl_is_utf8_perl_space(pTHX_ const U8 *p) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_IS_UTF8_PERL_SPACE \ assert(p) PERL_CALLCONV bool Perl_is_utf8_perl_word(pTHX_ const U8 *p) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_IS_UTF8_PERL_WORD \ assert(p) PERL_CALLCONV bool Perl_is_utf8_cntrl(pTHX_ const U8 *p) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_IS_UTF8_CNTRL \ assert(p) PERL_CALLCONV bool Perl_is_utf8_digit(pTHX_ const U8 *p) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_IS_UTF8_DIGIT \ assert(p) PERL_CALLCONV bool Perl_is_utf8_posix_digit(pTHX_ const U8 *p) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_IS_UTF8_POSIX_DIGIT \ assert(p) PERL_CALLCONV bool Perl_is_utf8_graph(pTHX_ const U8 *p) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_IS_UTF8_GRAPH \ assert(p) PERL_CALLCONV bool Perl_is_utf8_upper(pTHX_ const U8 *p) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_IS_UTF8_UPPER \ assert(p) PERL_CALLCONV bool Perl_is_utf8_lower(pTHX_ const U8 *p) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_IS_UTF8_LOWER \ assert(p) PERL_CALLCONV bool Perl_is_utf8_print(pTHX_ const U8 *p) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_IS_UTF8_PRINT \ assert(p) PERL_CALLCONV bool Perl_is_utf8_punct(pTHX_ const U8 *p) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_IS_UTF8_PUNCT \ assert(p) PERL_CALLCONV bool Perl_is_utf8_xdigit(pTHX_ const U8 *p) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_IS_UTF8_XDIGIT \ assert(p) PERL_CALLCONV bool Perl_is_utf8_mark(pTHX_ const U8 *p) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_IS_UTF8_MARK \ assert(p) PERL_CALLCONV bool Perl_is_utf8_X_begin(pTHX_ const U8 *p) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_IS_UTF8_X_BEGIN \ assert(p) PERL_CALLCONV bool Perl_is_utf8_X_extend(pTHX_ const U8 *p) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_IS_UTF8_X_EXTEND \ assert(p) PERL_CALLCONV bool Perl_is_utf8_X_prepend(pTHX_ const U8 *p) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_IS_UTF8_X_PREPEND \ assert(p) PERL_CALLCONV bool Perl_is_utf8_X_non_hangul(pTHX_ const U8 *p) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_IS_UTF8_X_NON_HANGUL \ assert(p) PERL_CALLCONV bool Perl_is_utf8_X_L(pTHX_ const U8 *p) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_IS_UTF8_X_L \ assert(p) PERL_CALLCONV bool Perl_is_utf8_X_LV(pTHX_ const U8 *p) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_IS_UTF8_X_LV \ assert(p) PERL_CALLCONV bool Perl_is_utf8_X_LVT(pTHX_ const U8 *p) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_IS_UTF8_X_LVT \ assert(p) PERL_CALLCONV bool Perl_is_utf8_X_LV_LVT_V(pTHX_ const U8 *p) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_IS_UTF8_X_LV_LVT_V \ assert(p) PERL_CALLCONV bool Perl_is_utf8_X_T(pTHX_ const U8 *p) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_IS_UTF8_X_T \ assert(p) PERL_CALLCONV bool Perl_is_utf8_X_V(pTHX_ const U8 *p) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_IS_UTF8_X_V \ assert(p) PERL_CALLCONV OP* Perl_jmaybe(pTHX_ OP *o) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_JMAYBE \ assert(o) PERL_CALLCONV I32 Perl_keyword(pTHX_ const char *name, I32 len, bool all_keywords) __attribute__pure__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_KEYWORD \ assert(name) #if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) STATIC OP* S_opt_scalarhv(pTHX_ OP* rep_op) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_OPT_SCALARHV \ assert(rep_op) STATIC OP* S_is_inplace_av(pTHX_ OP* o, OP* oright) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_IS_INPLACE_AV \ assert(o) #endif PERL_CALLCONV void Perl_leave_scope(pTHX_ I32 base); PERL_CALLCONV void Perl_lex_end(pTHX); PERL_CALLCONV void Perl_lex_start(pTHX_ SV* line, PerlIO *rsfp, bool new_filter); PERL_CALLCONV bool Perl_lex_bufutf8(pTHX); PERL_CALLCONV char* Perl_lex_grow_linestr(pTHX_ STRLEN len); PERL_CALLCONV void Perl_lex_stuff_pvn(pTHX_ char* pv, STRLEN len, U32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_LEX_STUFF_PVN \ assert(pv) PERL_CALLCONV void Perl_lex_stuff_sv(pTHX_ SV* sv, U32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_LEX_STUFF_SV \ assert(sv) PERL_CALLCONV void Perl_lex_unstuff(pTHX_ char* ptr) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_LEX_UNSTUFF \ assert(ptr) PERL_CALLCONV void Perl_lex_read_to(pTHX_ char* ptr) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_LEX_READ_TO \ assert(ptr) PERL_CALLCONV void Perl_lex_discard_to(pTHX_ char* ptr) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_LEX_DISCARD_TO \ assert(ptr) PERL_CALLCONV bool Perl_lex_next_chunk(pTHX_ U32 flags); PERL_CALLCONV I32 Perl_lex_peek_unichar(pTHX_ U32 flags); PERL_CALLCONV I32 Perl_lex_read_unichar(pTHX_ U32 flags); PERL_CALLCONV void Perl_lex_read_space(pTHX_ U32 flags); PERL_CALLCONV void Perl_op_null(pTHX_ OP* o) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_OP_NULL \ assert(o) PERL_CALLCONV void Perl_op_clear(pTHX_ OP* o) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_OP_CLEAR \ assert(o) PERL_CALLCONV void Perl_op_refcnt_lock(pTHX); PERL_CALLCONV void Perl_op_refcnt_unlock(pTHX); #if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) STATIC OP* S_linklist(pTHX_ OP *o) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_LINKLIST \ assert(o) STATIC OP* S_listkids(pTHX_ OP* o); #endif PERL_CALLCONV OP* Perl_list(pTHX_ OP* o); PERL_CALLCONV void Perl_load_module(pTHX_ U32 flags, SV* name, SV* ver, ...) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_LOAD_MODULE \ assert(name) PERL_CALLCONV void Perl_vload_module(pTHX_ U32 flags, SV* name, SV* ver, va_list* args) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_VLOAD_MODULE \ assert(name) PERL_CALLCONV OP* Perl_localize(pTHX_ OP *o, I32 lex) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_LOCALIZE \ assert(o) PERL_CALLCONV I32 Perl_looks_like_number(pTHX_ SV *const sv) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER \ assert(sv) PERL_CALLCONV UV Perl_grok_bin(pTHX_ const char* start, STRLEN* len_p, I32* flags, NV *result) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_GROK_BIN \ assert(start); assert(len_p); assert(flags) PERL_CALLCONV UV Perl_grok_hex(pTHX_ const char* start, STRLEN* len_p, I32* flags, NV *result) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_GROK_HEX \ assert(start); assert(len_p); assert(flags) PERL_CALLCONV int Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GROK_NUMBER \ assert(pv) PERL_CALLCONV bool Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_GROK_NUMERIC_RADIX \ assert(sp); assert(send) PERL_CALLCONV UV Perl_grok_oct(pTHX_ const char* start, STRLEN* len_p, I32* flags, NV *result) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_GROK_OCT \ assert(start); assert(len_p); assert(flags) PERL_CALLCONV int Perl_magic_clearenv(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_CLEARENV \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_clear_all_env(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_clearhint(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_CLEARHINT \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_clearhints(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_CLEARHINTS \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_clearisa(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_CLEARISA \ assert(mg) PERL_CALLCONV int Perl_magic_clearpack(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_CLEARPACK \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_clearsig(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_CLEARSIG \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_existspack(pTHX_ SV* sv, const MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_EXISTSPACK \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_freeovrld(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_FREEOVRLD \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_get(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_GET \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_getarylen(pTHX_ SV* sv, const MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_GETARYLEN \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_getdefelem(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_GETDEFELEM \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_getnkeys(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_GETNKEYS \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_getpack(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_GETPACK \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_getpos(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_GETPOS \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_getsig(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_GETSIG \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_getsubstr(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_GETSUBSTR \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_gettaint(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_GETTAINT \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_getuvar(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_GETUVAR \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_getvec(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_GETVEC \ assert(sv); assert(mg) PERL_CALLCONV U32 Perl_magic_len(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_LEN \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_MAGIC_NEXTPACK \ assert(sv); assert(mg); assert(key) PERL_CALLCONV U32 Perl_magic_regdata_cnt(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_regdatum_get(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_regdatum_set(pTHX_ SV* sv, MAGIC* mg) __attribute__noreturn__ __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_set(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_SET \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_setamagic(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_SETAMAGIC \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_setarylen(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_SETARYLEN \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_freearylen_p(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_setdbline(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_SETDBLINE \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_setdefelem(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_SETDEFELEM \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_setenv(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_SETENV \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_sethint(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_SETHINT \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_setisa(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_SETISA \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_setmglob(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_SETMGLOB \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_setnkeys(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_SETNKEYS \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_setpack(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_SETPACK \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_setpos(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_SETPOS \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_setregexp(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_SETREGEXP \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_setsig(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_SETSIG \ assert(mg) PERL_CALLCONV int Perl_magic_setsubstr(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_SETSUBSTR \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_settaint(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_SETTAINT \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_setuvar(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_SETUVAR \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_setvec(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_SETVEC \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_setutf8(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_SETUTF8 \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_set_all_env(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV \ assert(sv); assert(mg) PERL_CALLCONV U32 Perl_magic_sizepack(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_SIZEPACK \ assert(sv); assert(mg) PERL_CALLCONV int Perl_magic_wipepack(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_WIPEPACK \ assert(sv); assert(mg) PERL_CALLCONV void Perl_markstack_grow(pTHX); #if defined(USE_LOCALE_COLLATE) PERL_CALLCONV int Perl_magic_setcollxfrm(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM \ assert(sv); assert(mg) PERL_CALLCONV char* Perl_mem_collxfrm(pTHX_ const char* s, STRLEN len, STRLEN* xlen) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_MEM_COLLXFRM \ assert(s); assert(xlen) #endif PERL_CALLCONV SV* Perl_mess(pTHX_ const char* pat, ...) __attribute__format__(__printf__,pTHX_1,pTHX_2) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_MESS \ assert(pat) PERL_CALLCONV SV* Perl_vmess(pTHX_ const char* pat, va_list* args) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_VMESS \ assert(pat) PERL_CALLCONV void Perl_qerror(pTHX_ SV* err) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_QERROR \ assert(err) PERL_CALLCONV void Perl_sortsv(pTHX_ SV** array, size_t num_elts, SVCOMPARE_t cmp) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_SORTSV \ assert(cmp) PERL_CALLCONV void Perl_sortsv_flags(pTHX_ SV** array, size_t num_elts, SVCOMPARE_t cmp, U32 flags) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_SORTSV_FLAGS \ assert(cmp) PERL_CALLCONV int Perl_mg_clear(pTHX_ SV* sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_MG_CLEAR \ assert(sv) PERL_CALLCONV int Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MG_COPY \ assert(sv); assert(nsv) PERL_CALLCONV void Perl_mg_localize(pTHX_ SV* sv, SV* nsv, bool setmagic) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MG_LOCALIZE \ assert(sv); assert(nsv) PERL_CALLCONV MAGIC* Perl_mg_find(pTHX_ const SV* sv, int type) __attribute__warn_unused_result__; PERL_CALLCONV int Perl_mg_free(pTHX_ SV* sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_MG_FREE \ assert(sv) PERL_CALLCONV int Perl_mg_get(pTHX_ SV* sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_MG_GET \ assert(sv) PERL_CALLCONV U32 Perl_mg_length(pTHX_ SV* sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_MG_LENGTH \ assert(sv) PERL_CALLCONV void Perl_mg_magical(pTHX_ SV* sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_MG_MAGICAL \ assert(sv) PERL_CALLCONV int Perl_mg_set(pTHX_ SV* sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_MG_SET \ assert(sv) PERL_CALLCONV I32 Perl_mg_size(pTHX_ SV* sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_MG_SIZE \ assert(sv) PERL_CALLCONV void Perl_mini_mktime(pTHX_ struct tm *ptm) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_MINI_MKTIME \ assert(ptm) PERL_CALLCONV OP* Perl_mod(pTHX_ OP* o, I32 type); PERL_CALLCONV int Perl_mode_from_discipline(pTHX_ const char* s, STRLEN len); PERL_CALLCONV const char* Perl_moreswitches(pTHX_ const char* s) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_MORESWITCHES \ assert(s) PERL_CALLCONV NV Perl_my_atof(pTHX_ const char *s) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_MY_ATOF \ assert(s) #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY)) PERL_CALLCONV char* Perl_my_bcopy(const char* from, char* to, I32 len) __attribute__nonnull__(1) __attribute__nonnull__(2); #define PERL_ARGS_ASSERT_MY_BCOPY \ assert(from); assert(to) #endif #if !defined(HAS_BZERO) && !defined(HAS_MEMSET) PERL_CALLCONV char* Perl_my_bzero(char* loc, I32 len) __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_MY_BZERO \ assert(loc) #endif PERL_CALLCONV void Perl_my_exit(pTHX_ U32 status) __attribute__noreturn__; PERL_CALLCONV void Perl_my_failure_exit(pTHX) __attribute__noreturn__; PERL_CALLCONV I32 Perl_my_fflush_all(pTHX); PERL_CALLCONV Pid_t Perl_my_fork(void); PERL_CALLCONV void Perl_atfork_lock(void); PERL_CALLCONV void Perl_atfork_unlock(void); PERL_CALLCONV I32 Perl_my_lstat(pTHX); #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP) PERL_CALLCONV I32 Perl_my_memcmp(const char* s1, const char* s2, I32 len) __attribute__pure__ __attribute__nonnull__(1) __attribute__nonnull__(2); #define PERL_ARGS_ASSERT_MY_MEMCMP \ assert(s1); assert(s2) #endif #if !defined(HAS_MEMSET) PERL_CALLCONV void* Perl_my_memset(char* loc, I32 ch, I32 len) __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_MY_MEMSET \ assert(loc) #endif PERL_CALLCONV I32 Perl_my_pclose(pTHX_ PerlIO* ptr); PERL_CALLCONV PerlIO* Perl_my_popen(pTHX_ const char* cmd, const char* mode) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MY_POPEN \ assert(cmd); assert(mode) PERL_CALLCONV PerlIO* Perl_my_popen_list(pTHX_ const char* mode, int n, SV ** args) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_MY_POPEN_LIST \ assert(mode); assert(args) PERL_CALLCONV void Perl_my_setenv(pTHX_ const char* nam, const char* val); PERL_CALLCONV I32 Perl_my_stat(pTHX); PERL_CALLCONV char * Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_MY_STRFTIME \ assert(fmt) #if defined(MYSWAP) PERL_CALLCONV short Perl_my_swap(pTHX_ short s) __attribute__malloc__ __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV long Perl_my_htonl(pTHX_ long l) __attribute__malloc__ __attribute__warn_unused_result__ __attribute__pure__; PERL_CALLCONV long Perl_my_ntohl(pTHX_ long l) __attribute__malloc__ __attribute__warn_unused_result__ __attribute__pure__; #endif PERL_CALLCONV void Perl_my_unexec(pTHX); PERL_CALLCONV OP* Perl_newANONLIST(pTHX_ OP* o) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV OP* Perl_newANONHASH(pTHX_ OP* o) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV OP* Perl_newANONSUB(pTHX_ I32 floor, OP* proto, OP* block); PERL_CALLCONV OP* Perl_newASSIGNOP(pTHX_ I32 flags, OP* left, I32 optype, OP* right) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV OP* Perl_newCONDOP(pTHX_ I32 flags, OP* first, OP* trueop, OP* falseop) __attribute__malloc__ __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_NEWCONDOP \ assert(first) PERL_CALLCONV CV* Perl_newCONSTSUB(pTHX_ HV* stash, const char* name, SV* sv); #ifdef PERL_MAD PERL_CALLCONV OP* Perl_newFORM(pTHX_ I32 floor, OP* o, OP* block); #else PERL_CALLCONV void Perl_newFORM(pTHX_ I32 floor, OP* o, OP* block); #endif PERL_CALLCONV OP* Perl_newFOROP(pTHX_ I32 flags, char* label, line_t forline, OP* sv, OP* expr, OP* block, OP* cont) __attribute__malloc__ __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_5); #define PERL_ARGS_ASSERT_NEWFOROP \ assert(expr) PERL_CALLCONV OP* Perl_newGIVENOP(pTHX_ OP* cond, OP* block, PADOFFSET defsv_off) __attribute__malloc__ __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_NEWGIVENOP \ assert(cond); assert(block) PERL_CALLCONV OP* Perl_newLOGOP(pTHX_ I32 optype, I32 flags, OP *first, OP *other) __attribute__malloc__ __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_3) __attribute__nonnull__(pTHX_4); #define PERL_ARGS_ASSERT_NEWLOGOP \ assert(first); assert(other) PERL_CALLCONV OP* Perl_newLOOPEX(pTHX_ I32 type, OP* label) __attribute__malloc__ __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_NEWLOOPEX \ assert(label) PERL_CALLCONV OP* Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP* expr, OP* block) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV OP* Perl_newNULLLIST(pTHX) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV OP* Perl_newOP(pTHX_ I32 optype, I32 flags) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV void Perl_newPROG(pTHX_ OP* o) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_NEWPROG \ assert(o) PERL_CALLCONV OP* Perl_newRANGE(pTHX_ I32 flags, OP* left, OP* right) __attribute__malloc__ __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_NEWRANGE \ assert(left); assert(right) PERL_CALLCONV OP* Perl_newSLICEOP(pTHX_ I32 flags, OP* subscript, OP* listop) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV OP* Perl_newSTATEOP(pTHX_ I32 flags, char* label, OP* o) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV CV* Perl_newSUB(pTHX_ I32 floor, OP* o, OP* proto, OP* block); PERL_CALLCONV CV * Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr, const char *const filename, const char *const proto, U32 flags) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_NEWXS_FLAGS \ assert(subaddr); assert(filename) PERL_CALLCONV CV* Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_NEWXS \ assert(subaddr); assert(filename) /* PERL_CALLCONV AV* Perl_newAV(pTHX) __attribute__warn_unused_result__; */ PERL_CALLCONV OP* Perl_newAVREF(pTHX_ OP* o) __attribute__malloc__ __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_NEWAVREF \ assert(o) PERL_CALLCONV OP* Perl_newBINOP(pTHX_ I32 type, I32 flags, OP* first, OP* last) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV OP* Perl_newCVREF(pTHX_ I32 flags, OP* o) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV OP* Perl_newGVOP(pTHX_ I32 type, I32 flags, GV* gv) __attribute__malloc__ __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_NEWGVOP \ assert(gv) PERL_CALLCONV GV* Perl_newGVgen(pTHX_ const char* pack) __attribute__malloc__ __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_NEWGVGEN \ assert(pack) PERL_CALLCONV OP* Perl_newGVREF(pTHX_ I32 type, OP* o) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV OP* Perl_newHVREF(pTHX_ OP* o) __attribute__malloc__ __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_NEWHVREF \ assert(o) /* PERL_CALLCONV HV* Perl_newHV(pTHX) __attribute__warn_unused_result__; */ PERL_CALLCONV HV* Perl_newHVhv(pTHX_ HV *hv) __attribute__malloc__ __attribute__warn_unused_result__; /* PERL_CALLCONV IO* Perl_newIO(pTHX) __attribute__malloc__ __attribute__warn_unused_result__; */ PERL_CALLCONV OP* Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP* first, OP* last) __attribute__malloc__ __attribute__warn_unused_result__; #ifdef USE_ITHREADS PERL_CALLCONV OP* Perl_newPADOP(pTHX_ I32 type, I32 flags, SV* sv) __attribute__malloc__ __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_NEWPADOP \ assert(sv) #endif PERL_CALLCONV OP* Perl_newPMOP(pTHX_ I32 type, I32 flags) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV OP* Perl_newPVOP(pTHX_ I32 type, I32 flags, char* pv) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV SV* Perl_newRV(pTHX_ SV *const sv) __attribute__malloc__ __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_NEWRV \ assert(sv) PERL_CALLCONV SV* Perl_newRV_noinc(pTHX_ SV *const sv) __attribute__malloc__ __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_NEWRV_NOINC \ assert(sv) PERL_CALLCONV SV* Perl_newSV(pTHX_ const STRLEN len) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV OP* Perl_newSVREF(pTHX_ OP* o) __attribute__malloc__ __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_NEWSVREF \ assert(o) PERL_CALLCONV OP* Perl_newSVOP(pTHX_ I32 type, I32 flags, SV* sv) __attribute__malloc__ __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_NEWSVOP \ assert(sv) PERL_CALLCONV SV* Perl_newSViv(pTHX_ const IV i) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV SV* Perl_newSVuv(pTHX_ const UV u) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV SV* Perl_newSVnv(pTHX_ const NV n) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV SV* Perl_newSVpv(pTHX_ const char *const s, const STRLEN len) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV SV* Perl_newSVpvn(pTHX_ const char *const s, const STRLEN len) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV SV* Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV SV* Perl_newSVhek(pTHX_ const HEK *const hek) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV SV* Perl_newSVpvn_share(pTHX_ const char* s, I32 len, U32 hash) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV SV* Perl_newSVpvf(pTHX_ const char *const pat, ...) __attribute__malloc__ __attribute__warn_unused_result__ __attribute__format__(__printf__,pTHX_1,pTHX_2) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_NEWSVPVF \ assert(pat) PERL_CALLCONV SV* Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args) __attribute__malloc__ __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_VNEWSVPVF \ assert(pat) PERL_CALLCONV SV* Perl_newSVrv(pTHX_ SV *const rv, const char *const classname) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_NEWSVRV \ assert(rv) PERL_CALLCONV SV* Perl_newSVsv(pTHX_ SV *const old) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV SV* Perl_newSV_type(pTHX_ const svtype type) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV OP* Perl_newUNOP(pTHX_ I32 type, I32 flags, OP* first) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV OP* Perl_newWHENOP(pTHX_ OP* cond, OP* block) __attribute__malloc__ __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_NEWWHENOP \ assert(block) PERL_CALLCONV OP* Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP* loop, I32 whileline, OP* expr, OP* block, OP* cont, I32 has_my) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV PERL_SI* Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV char* Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_SCAN_VSTRING \ assert(s); assert(e); assert(sv) PERL_CALLCONV const char* Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SCAN_VERSION \ assert(s); assert(rv) PERL_CALLCONV const char* Perl_prescan_version(pTHX_ const char *s, bool strict, const char** errstr, bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_PRESCAN_VERSION \ assert(s) PERL_CALLCONV SV* Perl_new_version(pTHX_ SV *ver) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_NEW_VERSION \ assert(ver) PERL_CALLCONV SV* Perl_upg_version(pTHX_ SV *ver, bool qv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_UPG_VERSION \ assert(ver) PERL_CALLCONV bool Perl_vverify(pTHX_ SV *vs) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_VVERIFY \ assert(vs) PERL_CALLCONV SV* Perl_vnumify(pTHX_ SV *vs) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_VNUMIFY \ assert(vs) PERL_CALLCONV SV* Perl_vnormal(pTHX_ SV *vs) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_VNORMAL \ assert(vs) PERL_CALLCONV SV* Perl_vstringify(pTHX_ SV *vs) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_VSTRINGIFY \ assert(vs) PERL_CALLCONV int Perl_vcmp(pTHX_ SV *lhv, SV *rhv) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_VCMP \ assert(lhv); assert(rhv) PERL_CALLCONV PerlIO* Perl_nextargv(pTHX_ GV* gv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_NEXTARGV \ assert(gv) PERL_CALLCONV char* Perl_ninstr(const char* big, const char* bigend, const char* little, const char* lend) __attribute__pure__ __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__nonnull__(3) __attribute__nonnull__(4); #define PERL_ARGS_ASSERT_NINSTR \ assert(big); assert(bigend); assert(little); assert(lend) PERL_CALLCONV void Perl_op_free(pTHX_ OP* arg); #ifdef PERL_MAD PERL_CALLCONV OP* Perl_package(pTHX_ OP* o) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_PACKAGE \ assert(o) #else PERL_CALLCONV void Perl_package(pTHX_ OP* o) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_PACKAGE \ assert(o) #endif PERL_CALLCONV void Perl_package_version(pTHX_ OP* v) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_PACKAGE_VERSION \ assert(v) PERL_CALLCONV PADOFFSET Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype); PERL_CALLCONV PADOFFSET Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_ALLOCMY \ assert(name) PERL_CALLCONV PADOFFSET Perl_pad_findmy(pTHX_ const char* name, STRLEN len, U32 flags) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_PAD_FINDMY \ assert(name) PERL_CALLCONV PADOFFSET Perl_find_rundefsvoffset(pTHX); PERL_CALLCONV OP* Perl_oopsAV(pTHX_ OP* o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_OOPSAV \ assert(o) PERL_CALLCONV OP* Perl_oopsHV(pTHX_ OP* o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_OOPSHV \ assert(o) PERL_CALLCONV void Perl_pad_leavemy(pTHX); #ifdef DEBUGGING PERL_CALLCONV SV* Perl_pad_sv(pTHX_ PADOFFSET po); #endif PERL_CALLCONV void Perl_pad_free(pTHX_ PADOFFSET po); #if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT) STATIC void S_pad_reset(pTHX); #endif PERL_CALLCONV void Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust); PERL_CALLCONV void Perl_peep(pTHX_ OP* o); PERL_CALLCONV PerlIO* Perl_start_glob(pTHX_ SV *tmpglob, IO *io) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_START_GLOB \ assert(tmpglob); assert(io) #if defined(USE_REENTRANT_API) PERL_CALLCONV void Perl_reentrant_size(pTHX); PERL_CALLCONV void Perl_reentrant_init(pTHX); PERL_CALLCONV void Perl_reentrant_free(pTHX); PERL_CALLCONV void* Perl_reentrant_retry(const char *f, ...) __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_REENTRANT_RETRY \ assert(f) #endif PERL_CALLCONV void Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr); PERL_CALLCONV I32 Perl_call_argv(pTHX_ const char* sub_name, I32 flags, char** argv) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_CALL_ARGV \ assert(sub_name); assert(argv) PERL_CALLCONV I32 Perl_call_method(pTHX_ const char* methname, I32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CALL_METHOD \ assert(methname) PERL_CALLCONV I32 Perl_call_pv(pTHX_ const char* sub_name, I32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CALL_PV \ assert(sub_name) PERL_CALLCONV I32 Perl_call_sv(pTHX_ SV* sv, VOL I32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CALL_SV \ assert(sv) PERL_CALLCONV void Perl_despatch_signals(pTHX); PERL_CALLCONV OP * Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DOREF \ assert(o) PERL_CALLCONV SV* Perl_eval_pv(pTHX_ const char* p, I32 croak_on_error) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_EVAL_PV \ assert(p) PERL_CALLCONV I32 Perl_eval_sv(pTHX_ SV* sv, I32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_EVAL_SV \ assert(sv) PERL_CALLCONV SV* Perl_get_sv(pTHX_ const char *name, I32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GET_SV \ assert(name) PERL_CALLCONV AV* Perl_get_av(pTHX_ const char *name, I32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GET_AV \ assert(name) PERL_CALLCONV HV* Perl_get_hv(pTHX_ const char *name, I32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GET_HV \ assert(name) PERL_CALLCONV CV* Perl_get_cv(pTHX_ const char* name, I32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GET_CV \ assert(name) PERL_CALLCONV CV* Perl_get_cvn_flags(pTHX_ const char* name, STRLEN len, I32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GET_CVN_FLAGS \ assert(name) PERL_CALLCONV int Perl_init_i18nl10n(pTHX_ int printwarn); PERL_CALLCONV int Perl_init_i18nl14n(pTHX_ int printwarn); PERL_CALLCONV void Perl_new_collate(pTHX_ const char* newcoll); PERL_CALLCONV void Perl_new_ctype(pTHX_ const char* newctype) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_NEW_CTYPE \ assert(newctype) PERL_CALLCONV void Perl_new_numeric(pTHX_ const char* newcoll); PERL_CALLCONV void Perl_set_numeric_local(pTHX); PERL_CALLCONV void Perl_set_numeric_radix(pTHX); PERL_CALLCONV void Perl_set_numeric_standard(pTHX); PERL_CALLCONV void Perl_require_pv(pTHX_ const char* pv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_REQUIRE_PV \ assert(pv) PERL_CALLCONV void Perl_pack_cat(pTHX_ SV *cat, const char *pat, const char *patend, SV **beglist, SV **endlist, SV ***next_in_list, U32 flags) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3) __attribute__nonnull__(pTHX_4) __attribute__nonnull__(pTHX_5) __attribute__nonnull__(pTHX_6); #define PERL_ARGS_ASSERT_PACK_CAT \ assert(cat); assert(pat); assert(patend); assert(beglist); assert(endlist); assert(next_in_list) PERL_CALLCONV void Perl_packlist(pTHX_ SV *cat, const char *pat, const char *patend, SV **beglist, SV **endlist) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3) __attribute__nonnull__(pTHX_4) __attribute__nonnull__(pTHX_5); #define PERL_ARGS_ASSERT_PACKLIST \ assert(cat); assert(pat); assert(patend); assert(beglist); assert(endlist) #if defined(PERL_USES_PL_PIDSTATUS) && defined(PERL_IN_UTIL_C) STATIC void S_pidgone(pTHX_ Pid_t pid, int status); #endif PERL_CALLCONV void Perl_pmflag(pTHX_ U32 *pmfl, int ch) __attribute__deprecated__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_PMFLAG \ assert(pmfl) PERL_CALLCONV OP* Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_PMRUNTIME \ assert(o); assert(expr) #if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) STATIC OP* S_pmtrans(pTHX_ OP* o, OP* expr, OP* repl) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_PMTRANS \ assert(o); assert(expr); assert(repl) #endif PERL_CALLCONV void Perl_pop_scope(pTHX); PERL_CALLCONV OP* Perl_prepend_elem(pTHX_ I32 optype, OP* head, OP* tail); PERL_CALLCONV void Perl_push_scope(pTHX); /* PERL_CALLCONV OP* Perl_ref(pTHX_ OP* o, I32 type); */ #if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) STATIC OP* S_refkids(pTHX_ OP* o, I32 type); #endif PERL_CALLCONV void Perl_regdump(pTHX_ const regexp* r) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_REGDUMP \ assert(r) PERL_CALLCONV void Perl_regdump(pTHX_ const regexp* r) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_REGDUMP \ assert(r) PERL_CALLCONV SV* Perl_regclass_swash(pTHX_ const regexp *prog, const struct regnode *node, bool doinit, SV **listsvp, SV **altsvp) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_REGCLASS_SWASH \ assert(node) PERL_CALLCONV I32 Perl_pregexec(pTHX_ REGEXP * const prog, char* stringarg, char* strend, char* strbeg, I32 minend, SV* screamer, U32 nosave) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3) __attribute__nonnull__(pTHX_4) __attribute__nonnull__(pTHX_6); #define PERL_ARGS_ASSERT_PREGEXEC \ assert(prog); assert(stringarg); assert(strend); assert(strbeg); assert(screamer) PERL_CALLCONV void Perl_pregfree(pTHX_ REGEXP* r); PERL_CALLCONV void Perl_pregfree2(pTHX_ REGEXP *rx) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_PREGFREE2 \ assert(rx) PERL_CALLCONV REGEXP* Perl_reg_temp_copy(pTHX_ REGEXP* ret_x, REGEXP* rx) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_REG_TEMP_COPY \ assert(rx) PERL_CALLCONV void Perl_regfree_internal(pTHX_ REGEXP *const rx) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_REGFREE_INTERNAL \ assert(rx) #if defined(USE_ITHREADS) PERL_CALLCONV void* Perl_regdupe_internal(pTHX_ REGEXP * const r, CLONE_PARAMS* param) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_REGDUPE_INTERNAL \ assert(r); assert(param) #endif PERL_CALLCONV REGEXP* Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_PREGCOMP \ assert(pattern) PERL_CALLCONV REGEXP* Perl_re_compile(pTHX_ SV * const pattern, U32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_RE_COMPILE \ assert(pattern) PERL_CALLCONV char* Perl_re_intuit_start(pTHX_ REGEXP * const rx, SV* sv, char* strpos, char* strend, const U32 flags, re_scream_pos_data *data) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_3) __attribute__nonnull__(pTHX_4); #define PERL_ARGS_ASSERT_RE_INTUIT_START \ assert(rx); assert(strpos); assert(strend) PERL_CALLCONV SV* Perl_re_intuit_string(pTHX_ REGEXP *const r) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_RE_INTUIT_STRING \ assert(r) PERL_CALLCONV I32 Perl_regexec_flags(pTHX_ REGEXP *const rx, char *stringarg, char *strend, char *strbeg, I32 minend, SV *sv, void *data, U32 flags) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3) __attribute__nonnull__(pTHX_4) __attribute__nonnull__(pTHX_6); #define PERL_ARGS_ASSERT_REGEXEC_FLAGS \ assert(rx); assert(stringarg); assert(strend); assert(strbeg); assert(sv) PERL_CALLCONV regnode* Perl_regnext(pTHX_ regnode* p) __attribute__warn_unused_result__; PERL_CALLCONV SV* Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value, const U32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_REG_NAMED_BUFF \ assert(rx) PERL_CALLCONV SV* Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey, const U32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER \ assert(rx) PERL_CALLCONV SV* Perl_reg_named_buff_fetch(pTHX_ REGEXP * const rx, SV * const namesv, const U32 flags) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH \ assert(rx); assert(namesv) PERL_CALLCONV bool Perl_reg_named_buff_exists(pTHX_ REGEXP * const rx, SV * const key, const U32 flags) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS \ assert(rx); assert(key) PERL_CALLCONV SV* Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const rx, const U32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY \ assert(rx) PERL_CALLCONV SV* Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const rx, const U32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY \ assert(rx) PERL_CALLCONV SV* Perl_reg_named_buff_scalar(pTHX_ REGEXP * const rx, const U32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR \ assert(rx) PERL_CALLCONV SV* Perl_reg_named_buff_all(pTHX_ REGEXP * const rx, const U32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL \ assert(rx) PERL_CALLCONV void Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const rx, const I32 paren, SV * const sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH \ assert(rx) PERL_CALLCONV void Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren, SV const * const value) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE \ assert(rx) PERL_CALLCONV I32 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const rx, const SV * const sv, const I32 paren) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH \ assert(rx); assert(sv) PERL_CALLCONV SV* Perl_reg_qr_package(pTHX_ REGEXP * const rx) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_REG_QR_PACKAGE \ assert(rx) PERL_CALLCONV void Perl_regprop(pTHX_ const regexp *prog, SV* sv, const regnode* o) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_REGPROP \ assert(sv); assert(o) PERL_CALLCONV void Perl_repeatcpy(char* to, const char* from, I32 len, I32 count) __attribute__nonnull__(1) __attribute__nonnull__(2); #define PERL_ARGS_ASSERT_REPEATCPY \ assert(to); assert(from) PERL_CALLCONV char* Perl_rninstr(const char* big, const char* bigend, const char* little, const char* lend) __attribute__pure__ __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__nonnull__(3) __attribute__nonnull__(4); #define PERL_ARGS_ASSERT_RNINSTR \ assert(big); assert(bigend); assert(little); assert(lend) PERL_CALLCONV Sighandler_t Perl_rsignal(pTHX_ int i, Sighandler_t t); PERL_CALLCONV int Perl_rsignal_restore(pTHX_ int i, Sigsave_t* t); PERL_CALLCONV int Perl_rsignal_save(pTHX_ int i, Sighandler_t t1, Sigsave_t* save) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_RSIGNAL_SAVE \ assert(save) PERL_CALLCONV Sighandler_t Perl_rsignal_state(pTHX_ int i); #if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT) STATIC void S_rxres_free(pTHX_ void** rsp) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_RXRES_FREE \ assert(rsp) STATIC void S_rxres_restore(pTHX_ void **rsp, REGEXP *rx) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_RXRES_RESTORE \ assert(rsp); assert(rx) #endif PERL_CALLCONV void Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_RXRES_SAVE \ assert(rsp); assert(rx) #if !defined(HAS_RENAME) PERL_CALLCONV I32 Perl_same_dirent(pTHX_ const char* a, const char* b) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SAME_DIRENT \ assert(a); assert(b) #endif PERL_CALLCONV char* Perl_savepv(pTHX_ const char* pv) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV char* Perl_savepvn(pTHX_ const char* pv, I32 len) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV char* Perl_savesharedpv(pTHX_ const char* pv) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV char* Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len) __attribute__malloc__ __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SAVESHAREDPVN \ assert(pv) PERL_CALLCONV char* Perl_savesvpv(pTHX_ SV* sv) __attribute__malloc__ __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SAVESVPV \ assert(sv) PERL_CALLCONV void Perl_savestack_grow(pTHX); PERL_CALLCONV void Perl_savestack_grow_cnt(pTHX_ I32 need); /* PERL_CALLCONV void Perl_save_aelem(pTHX_ AV* av, I32 idx, SV **sptr) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_3); */ PERL_CALLCONV void Perl_save_aelem_flags(pTHX_ AV* av, I32 idx, SV **sptr, const U32 flags) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_SAVE_AELEM_FLAGS \ assert(av); assert(sptr) PERL_CALLCONV I32 Perl_save_alloc(pTHX_ I32 size, I32 pad); PERL_CALLCONV void Perl_save_aptr(pTHX_ AV** aptr) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SAVE_APTR \ assert(aptr) PERL_CALLCONV AV* Perl_save_ary(pTHX_ GV* gv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SAVE_ARY \ assert(gv) PERL_CALLCONV void Perl_save_bool(pTHX_ bool* boolp) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SAVE_BOOL \ assert(boolp) PERL_CALLCONV void Perl_save_clearsv(pTHX_ SV** svp) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SAVE_CLEARSV \ assert(svp) PERL_CALLCONV void Perl_save_delete(pTHX_ HV *hv, char *key, I32 klen) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SAVE_DELETE \ assert(hv); assert(key) PERL_CALLCONV void Perl_save_hdelete(pTHX_ HV *hv, SV *keysv) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SAVE_HDELETE \ assert(hv); assert(keysv) PERL_CALLCONV void Perl_save_adelete(pTHX_ AV *av, I32 key) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SAVE_ADELETE \ assert(av) PERL_CALLCONV void Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SAVE_DESTRUCTOR \ assert(p) PERL_CALLCONV void Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p); /* PERL_CALLCONV void Perl_save_freesv(pTHX_ SV* sv); */ /* PERL_CALLCONV void Perl_save_freeop(pTHX_ OP* o); */ /* PERL_CALLCONV void Perl_save_freepv(pTHX_ char* pv); */ PERL_CALLCONV void Perl_save_generic_svref(pTHX_ SV** sptr) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SAVE_GENERIC_SVREF \ assert(sptr) PERL_CALLCONV void Perl_save_generic_pvref(pTHX_ char** str) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SAVE_GENERIC_PVREF \ assert(str) PERL_CALLCONV void Perl_save_shared_pvref(pTHX_ char** str) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SAVE_SHARED_PVREF \ assert(str) PERL_CALLCONV void Perl_save_gp(pTHX_ GV* gv, I32 empty) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SAVE_GP \ assert(gv) PERL_CALLCONV HV* Perl_save_hash(pTHX_ GV* gv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SAVE_HASH \ assert(gv) PERL_CALLCONV void Perl_save_hints(pTHX); /* PERL_CALLCONV void Perl_save_helem(pTHX_ HV *hv, SV *key, SV **sptr) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); */ PERL_CALLCONV void Perl_save_helem_flags(pTHX_ HV *hv, SV *key, SV **sptr, const U32 flags) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_SAVE_HELEM_FLAGS \ assert(hv); assert(key); assert(sptr) PERL_CALLCONV void Perl_save_hptr(pTHX_ HV** hptr) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SAVE_HPTR \ assert(hptr) PERL_CALLCONV void Perl_save_I16(pTHX_ I16* intp) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SAVE_I16 \ assert(intp) PERL_CALLCONV void Perl_save_I32(pTHX_ I32* intp) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SAVE_I32 \ assert(intp) PERL_CALLCONV void Perl_save_I8(pTHX_ I8* bytep) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SAVE_I8 \ assert(bytep) PERL_CALLCONV void Perl_save_int(pTHX_ int* intp) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SAVE_INT \ assert(intp) PERL_CALLCONV void Perl_save_item(pTHX_ SV* item) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SAVE_ITEM \ assert(item) PERL_CALLCONV void Perl_save_iv(pTHX_ IV *ivp) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SAVE_IV \ assert(ivp) PERL_CALLCONV void Perl_save_list(pTHX_ SV** sarg, I32 maxsarg) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SAVE_LIST \ assert(sarg) PERL_CALLCONV void Perl_save_long(pTHX_ long* longp) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SAVE_LONG \ assert(longp) /* PERL_CALLCONV void Perl_save_mortalizesv(pTHX_ SV* sv) __attribute__nonnull__(pTHX_1); */ #define PERL_ARGS_ASSERT_SAVE_MORTALIZESV \ assert(sv) PERL_CALLCONV void Perl_save_nogv(pTHX_ GV* gv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SAVE_NOGV \ assert(gv) /* PERL_CALLCONV void Perl_save_op(pTHX); */ PERL_CALLCONV SV* Perl_save_scalar(pTHX_ GV* gv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SAVE_SCALAR \ assert(gv) PERL_CALLCONV void Perl_save_pptr(pTHX_ char** pptr) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SAVE_PPTR \ assert(pptr) PERL_CALLCONV void Perl_save_vptr(pTHX_ void *ptr) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SAVE_VPTR \ assert(ptr) PERL_CALLCONV void Perl_save_re_context(pTHX); PERL_CALLCONV void Perl_save_padsv_and_mortalize(pTHX_ PADOFFSET off); PERL_CALLCONV void Perl_save_sptr(pTHX_ SV** sptr) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SAVE_SPTR \ assert(sptr) PERL_CALLCONV SV* Perl_save_svref(pTHX_ SV** sptr) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SAVE_SVREF \ assert(sptr) PERL_CALLCONV void Perl_save_pushptr(pTHX_ void *const ptr, const int type); PERL_CALLCONV void Perl_save_pushi32ptr(pTHX_ const I32 i, void *const ptr, const int type); PERL_CALLCONV void Perl_save_pushptrptr(pTHX_ void *const ptr1, void *const ptr2, const int type); #if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT) STATIC void S_save_pushptri32ptr(pTHX_ void *const ptr1, const I32 i, void *const ptr2, const int type); #endif PERL_CALLCONV OP* Perl_sawparens(pTHX_ OP* o); PERL_CALLCONV OP* Perl_scalar(pTHX_ OP* o); #if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) STATIC OP* S_scalarkids(pTHX_ OP* o); STATIC OP* S_scalarseq(pTHX_ OP* o); #endif PERL_CALLCONV OP* Perl_scalarvoid(pTHX_ OP* o) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SCALARVOID \ assert(o) PERL_CALLCONV NV Perl_scan_bin(pTHX_ const char* start, STRLEN len, STRLEN* retlen) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_SCAN_BIN \ assert(start); assert(retlen) PERL_CALLCONV NV Perl_scan_hex(pTHX_ const char* start, STRLEN len, STRLEN* retlen) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_SCAN_HEX \ assert(start); assert(retlen) PERL_CALLCONV char* Perl_scan_num(pTHX_ const char* s, YYSTYPE *lvalp) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SCAN_NUM \ assert(s); assert(lvalp) PERL_CALLCONV NV Perl_scan_oct(pTHX_ const char* start, STRLEN len, STRLEN* retlen) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_SCAN_OCT \ assert(start); assert(retlen) PERL_CALLCONV OP* Perl_scope(pTHX_ OP* o); PERL_CALLCONV char* Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_5); #define PERL_ARGS_ASSERT_SCREAMINSTR \ assert(bigstr); assert(littlestr); assert(old_posp) PERL_CALLCONV void Perl_setdefout(pTHX_ GV* gv); PERL_CALLCONV HEK* Perl_share_hek(pTHX_ const char* str, I32 len, U32 hash) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SHARE_HEK \ assert(str) #if defined(HAS_SIGACTION) && defined(SA_SIGINFO) PERL_CALLCONV Signal_t Perl_sighandler(int sig, siginfo_t *info, void *uap); PERL_CALLCONV Signal_t Perl_csighandler(int sig, siginfo_t *info, void *uap); #else PERL_CALLCONV Signal_t Perl_sighandler(int sig); PERL_CALLCONV Signal_t Perl_csighandler(int sig); #endif PERL_CALLCONV SV** Perl_stack_grow(pTHX_ SV** sp, SV** p, int n) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_STACK_GROW \ assert(sp); assert(p) PERL_CALLCONV I32 Perl_start_subparse(pTHX_ I32 is_format, U32 flags); PERL_CALLCONV void Perl_sub_crush_depth(pTHX_ CV* cv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH \ assert(cv) PERL_CALLCONV bool Perl_sv_2bool(pTHX_ SV *const sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_2BOOL \ assert(sv) PERL_CALLCONV CV* Perl_sv_2cv(pTHX_ SV* sv, HV **const st, GV **const gvp, const I32 lref) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_SV_2CV \ assert(st); assert(gvp) PERL_CALLCONV IO* Perl_sv_2io(pTHX_ SV *const sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_2IO \ assert(sv) #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) STATIC bool S_glob_2number(pTHX_ GV* const gv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GLOB_2NUMBER \ assert(gv) #endif /* PERL_CALLCONV IV Perl_sv_2iv(pTHX_ SV *sv); */ PERL_CALLCONV IV Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags); PERL_CALLCONV SV* Perl_sv_2mortal(pTHX_ SV *const sv); PERL_CALLCONV NV Perl_sv_2nv(pTHX_ SV *const sv); PERL_CALLCONV SV* Perl_sv_2num(pTHX_ SV *const sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_2NUM \ assert(sv) /* PERL_CALLCONV char* Perl_sv_2pv(pTHX_ SV *sv, STRLEN *lp); */ PERL_CALLCONV char* Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags); PERL_CALLCONV char* Perl_sv_2pvutf8(pTHX_ SV *const sv, STRLEN *const lp) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_2PVUTF8 \ assert(sv) PERL_CALLCONV char* Perl_sv_2pvbyte(pTHX_ SV *const sv, STRLEN *const lp) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_2PVBYTE \ assert(sv) PERL_CALLCONV char* Perl_sv_pvn_nomg(pTHX_ SV* sv, STRLEN* lp) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_PVN_NOMG \ assert(sv) /* PERL_CALLCONV UV Perl_sv_2uv(pTHX_ SV *sv); */ PERL_CALLCONV UV Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags); PERL_CALLCONV IV Perl_sv_iv(pTHX_ SV* sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_IV \ assert(sv) PERL_CALLCONV UV Perl_sv_uv(pTHX_ SV* sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_UV \ assert(sv) PERL_CALLCONV NV Perl_sv_nv(pTHX_ SV* sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_NV \ assert(sv) PERL_CALLCONV char* Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_PVN \ assert(sv); assert(lp) PERL_CALLCONV char* Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_PVUTF8N \ assert(sv); assert(lp) PERL_CALLCONV char* Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_PVBYTEN \ assert(sv); assert(lp) PERL_CALLCONV I32 Perl_sv_true(pTHX_ SV *const sv); #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) STATIC void S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_ADD_ARENA \ assert(ptr) #endif PERL_CALLCONV int Perl_sv_backoff(pTHX_ SV *const sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_BACKOFF \ assert(sv) PERL_CALLCONV SV* Perl_sv_bless(pTHX_ SV *const sv, HV *const stash) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_BLESS \ assert(sv); assert(stash) PERL_CALLCONV void Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...) __attribute__format__(__printf__,pTHX_2,pTHX_3) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_CATPVF \ assert(sv); assert(pat) PERL_CALLCONV void Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_VCATPVF \ assert(sv); assert(pat) PERL_CALLCONV void Perl_sv_catpv(pTHX_ SV *const sv, const char* ptr) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_CATPV \ assert(sv) /* PERL_CALLCONV void Perl_sv_catpvn(pTHX_ SV *dsv, const char *sstr, STRLEN len) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); */ #define PERL_ARGS_ASSERT_SV_CATPVN \ assert(dsv); assert(sstr) /* PERL_CALLCONV void Perl_sv_catsv(pTHX_ SV *dstr, SV *sstr) __attribute__nonnull__(pTHX_1); */ #define PERL_ARGS_ASSERT_SV_CATSV \ assert(dstr) PERL_CALLCONV void Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_CHOP \ assert(sv) PERL_CALLCONV I32 Perl_sv_clean_all(pTHX); PERL_CALLCONV void Perl_sv_clean_objs(pTHX); PERL_CALLCONV void Perl_sv_clear(pTHX_ SV *const sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_CLEAR \ assert(sv) PERL_CALLCONV I32 Perl_sv_cmp(pTHX_ SV *const sv1, SV *const sv2); PERL_CALLCONV I32 Perl_sv_cmp_locale(pTHX_ SV *const sv1, SV *const sv2); #if defined(USE_LOCALE_COLLATE) PERL_CALLCONV char* Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_COLLXFRM \ assert(sv); assert(nxp) #endif PERL_CALLCONV OP* Perl_sv_compile_2op(pTHX_ SV *sv, OP **startop, const char *code, PAD **padp) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3) __attribute__nonnull__(pTHX_4); #define PERL_ARGS_ASSERT_SV_COMPILE_2OP \ assert(sv); assert(startop); assert(code); assert(padp) PERL_CALLCONV int Perl_getcwd_sv(pTHX_ SV* sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GETCWD_SV \ assert(sv) PERL_CALLCONV void Perl_sv_dec(pTHX_ SV *const sv); PERL_CALLCONV void Perl_sv_dump(pTHX_ SV* sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_DUMP \ assert(sv) PERL_CALLCONV bool Perl_sv_derived_from(pTHX_ SV* sv, const char *const name) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_DERIVED_FROM \ assert(sv); assert(name) PERL_CALLCONV bool Perl_sv_does(pTHX_ SV* sv, const char *const name) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_DOES \ assert(sv); assert(name) PERL_CALLCONV I32 Perl_sv_eq(pTHX_ SV* sv1, SV* sv2); PERL_CALLCONV void Perl_sv_free(pTHX_ SV *const sv); PERL_CALLCONV void Perl_sv_free2(pTHX_ SV *const sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_FREE2 \ assert(sv) PERL_CALLCONV void Perl_sv_free_arenas(pTHX); PERL_CALLCONV char* Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_GETS \ assert(sv); assert(fp) PERL_CALLCONV char* Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_GROW \ assert(sv) PERL_CALLCONV void Perl_sv_inc(pTHX_ SV *const sv); /* PERL_CALLCONV void Perl_sv_insert(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_4); */ #define PERL_ARGS_ASSERT_SV_INSERT \ assert(bigstr); assert(little) PERL_CALLCONV void Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_4); #define PERL_ARGS_ASSERT_SV_INSERT_FLAGS \ assert(bigstr); assert(little) PERL_CALLCONV int Perl_sv_isa(pTHX_ SV* sv, const char *const name) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_ISA \ assert(name) PERL_CALLCONV int Perl_sv_isobject(pTHX_ SV* sv); PERL_CALLCONV STRLEN Perl_sv_len(pTHX_ SV *const sv); PERL_CALLCONV STRLEN Perl_sv_len_utf8(pTHX_ SV *const sv); PERL_CALLCONV void Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how, const char *const name, const I32 namlen) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_MAGIC \ assert(sv) PERL_CALLCONV MAGIC * Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how, const MGVTBL *const vtbl, const char *const name, const I32 namlen) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_MAGICEXT \ assert(sv) PERL_CALLCONV SV* Perl_sv_mortalcopy(pTHX_ SV *const oldsv) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV SV* Perl_sv_newmortal(pTHX) __attribute__warn_unused_result__; PERL_CALLCONV SV* Perl_sv_newref(pTHX_ SV *const sv); PERL_CALLCONV char* Perl_sv_peek(pTHX_ SV* sv); PERL_CALLCONV void Perl_sv_pos_u2b(pTHX_ SV *const sv, I32 *const offsetp, I32 *const lenp) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_POS_U2B \ assert(offsetp) PERL_CALLCONV STRLEN Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp, U32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_POS_U2B_FLAGS \ assert(sv) PERL_CALLCONV void Perl_sv_pos_b2u(pTHX_ SV *const sv, I32 *const offsetp) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_POS_B2U \ assert(offsetp) /* PERL_CALLCONV char* Perl_sv_pvn_force(pTHX_ SV* sv, STRLEN* lp) __attribute__nonnull__(pTHX_1); */ #define PERL_ARGS_ASSERT_SV_PVN_FORCE \ assert(sv) PERL_CALLCONV char* Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE \ assert(sv) PERL_CALLCONV char* Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE \ assert(sv) PERL_CALLCONV char* Perl_sv_recode_to_utf8(pTHX_ SV* sv, SV *encoding) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8 \ assert(sv); assert(encoding) PERL_CALLCONV bool Perl_sv_cat_decode(pTHX_ SV* dsv, SV *encoding, SV *ssv, int *offset, char* tstr, int tlen) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3) __attribute__nonnull__(pTHX_4) __attribute__nonnull__(pTHX_5); #define PERL_ARGS_ASSERT_SV_CAT_DECODE \ assert(dsv); assert(encoding); assert(ssv); assert(offset); assert(tstr) PERL_CALLCONV const char* Perl_sv_reftype(pTHX_ const SV *const sv, const int ob) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_REFTYPE \ assert(sv) PERL_CALLCONV void Perl_sv_replace(pTHX_ SV *const sv, SV *const nsv) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_REPLACE \ assert(sv); assert(nsv) PERL_CALLCONV void Perl_sv_report_used(pTHX); PERL_CALLCONV void Perl_sv_reset(pTHX_ const char* s, HV *const stash) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_RESET \ assert(s) PERL_CALLCONV void Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...) __attribute__format__(__printf__,pTHX_2,pTHX_3) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_SETPVF \ assert(sv); assert(pat) PERL_CALLCONV void Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_VSETPVF \ assert(sv); assert(pat) PERL_CALLCONV void Perl_sv_setiv(pTHX_ SV *const sv, const IV num) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_SETIV \ assert(sv) PERL_CALLCONV void Perl_sv_setpviv(pTHX_ SV *const sv, const IV num) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_SETPVIV \ assert(sv) PERL_CALLCONV void Perl_sv_setuv(pTHX_ SV *const sv, const UV num) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_SETUV \ assert(sv) PERL_CALLCONV void Perl_sv_setnv(pTHX_ SV *const sv, const NV num) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_SETNV \ assert(sv) PERL_CALLCONV SV* Perl_sv_setref_iv(pTHX_ SV *const rv, const char *const classname, const IV iv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_SETREF_IV \ assert(rv) PERL_CALLCONV SV* Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_SETREF_UV \ assert(rv) PERL_CALLCONV SV* Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_SETREF_NV \ assert(rv) PERL_CALLCONV SV* Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_SETREF_PV \ assert(rv) PERL_CALLCONV SV* Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname, const char *const pv, const STRLEN n) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_SV_SETREF_PVN \ assert(rv); assert(pv) PERL_CALLCONV void Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_SETPV \ assert(sv) PERL_CALLCONV void Perl_sv_setpvn(pTHX_ SV *const sv, const char *const ptr, const STRLEN len) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_SETPVN \ assert(sv) /* PERL_CALLCONV void Perl_sv_setsv(pTHX_ SV *dstr, SV *sstr) __attribute__nonnull__(pTHX_1); */ #define PERL_ARGS_ASSERT_SV_SETSV \ assert(dstr) /* PERL_CALLCONV void Perl_sv_taint(pTHX_ SV* sv) __attribute__nonnull__(pTHX_1); */ #define PERL_ARGS_ASSERT_SV_TAINT \ assert(sv) PERL_CALLCONV bool Perl_sv_tainted(pTHX_ SV *const sv) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_TAINTED \ assert(sv) PERL_CALLCONV int Perl_sv_unmagic(pTHX_ SV *const sv, const int type) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_UNMAGIC \ assert(sv) /* PERL_CALLCONV void Perl_sv_unref(pTHX_ SV* sv) __attribute__nonnull__(pTHX_1); */ #define PERL_ARGS_ASSERT_SV_UNREF \ assert(sv) PERL_CALLCONV void Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_UNREF_FLAGS \ assert(ref) PERL_CALLCONV void Perl_sv_untaint(pTHX_ SV *const sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_UNTAINT \ assert(sv) PERL_CALLCONV void Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_UPGRADE \ assert(sv) /* PERL_CALLCONV void Perl_sv_usepvn(pTHX_ SV* sv, char* ptr, STRLEN len) __attribute__nonnull__(pTHX_1); */ #define PERL_ARGS_ASSERT_SV_USEPVN \ assert(sv) PERL_CALLCONV void Perl_sv_usepvn_flags(pTHX_ SV *const sv, char* ptr, const STRLEN len, const U32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_USEPVN_FLAGS \ assert(sv) PERL_CALLCONV void Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_VCATPVFN \ assert(sv); assert(pat) PERL_CALLCONV void Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_VSETPVFN \ assert(sv); assert(pat) PERL_CALLCONV NV Perl_str_to_version(pTHX_ SV *sv) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_STR_TO_VERSION \ assert(sv) PERL_CALLCONV SV* Perl_swash_init(pTHX_ const char* pkg, const char* name, SV* listsv, I32 minbits, I32 none) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_SWASH_INIT \ assert(pkg); assert(name); assert(listsv) PERL_CALLCONV UV Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SWASH_FETCH \ assert(swash); assert(ptr) PERL_CALLCONV void Perl_taint_env(pTHX); PERL_CALLCONV void Perl_taint_proper(pTHX_ const char* f, const char *const s) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_TAINT_PROPER \ assert(s) PERL_CALLCONV UV Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp, const char *normal, const char *special) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_4) __attribute__nonnull__(pTHX_5) __attribute__nonnull__(pTHX_6); #define PERL_ARGS_ASSERT_TO_UTF8_CASE \ assert(p); assert(ustrp); assert(swashp); assert(normal); assert(special) PERL_CALLCONV UV Perl_to_utf8_lower(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_TO_UTF8_LOWER \ assert(p); assert(ustrp) PERL_CALLCONV UV Perl_to_utf8_upper(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_TO_UTF8_UPPER \ assert(p); assert(ustrp) PERL_CALLCONV UV Perl_to_utf8_title(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_TO_UTF8_TITLE \ assert(p); assert(ustrp) PERL_CALLCONV UV Perl_to_utf8_fold(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_TO_UTF8_FOLD \ assert(p); assert(ustrp) #if defined(UNLINK_ALL_VERSIONS) PERL_CALLCONV I32 Perl_unlnk(pTHX_ const char* f) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_UNLNK \ assert(f) #endif PERL_CALLCONV I32 Perl_unpack_str(pTHX_ const char *pat, const char *patend, const char *s, const char *strbeg, const char *strend, char **new_s, I32 ocnt, U32 flags) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3) __attribute__nonnull__(pTHX_5); #define PERL_ARGS_ASSERT_UNPACK_STR \ assert(pat); assert(patend); assert(s); assert(strend) PERL_CALLCONV I32 Perl_unpackstring(pTHX_ const char *pat, const char *patend, const char *s, const char *strend, U32 flags) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3) __attribute__nonnull__(pTHX_4); #define PERL_ARGS_ASSERT_UNPACKSTRING \ assert(pat); assert(patend); assert(s); assert(strend) PERL_CALLCONV void Perl_unsharepvn(pTHX_ const char* sv, I32 len, U32 hash); PERL_CALLCONV void Perl_unshare_hek(pTHX_ HEK* hek); #ifdef PERL_MAD PERL_CALLCONV OP * Perl_utilize(pTHX_ int aver, I32 floor, OP* version, OP* idop, OP* arg) __attribute__nonnull__(pTHX_4); #define PERL_ARGS_ASSERT_UTILIZE \ assert(idop) #else PERL_CALLCONV void Perl_utilize(pTHX_ int aver, I32 floor, OP* version, OP* idop, OP* arg) __attribute__nonnull__(pTHX_4); #define PERL_ARGS_ASSERT_UTILIZE \ assert(idop) #endif PERL_CALLCONV U8* Perl_utf16_to_utf8(pTHX_ U8* p, U8 *d, I32 bytelen, I32 *newlen) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_4); #define PERL_ARGS_ASSERT_UTF16_TO_UTF8 \ assert(p); assert(d); assert(newlen) PERL_CALLCONV U8* Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8 *d, I32 bytelen, I32 *newlen) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_4); #define PERL_ARGS_ASSERT_UTF16_TO_UTF8_REVERSED \ assert(p); assert(d); assert(newlen) PERL_CALLCONV STRLEN Perl_utf8_length(pTHX_ const U8* s, const U8 *e) __attribute__warn_unused_result__ __attribute__pure__ __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_UTF8_LENGTH \ assert(s); assert(e) PERL_CALLCONV IV Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b) __attribute__warn_unused_result__ __attribute__pure__ __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_UTF8_DISTANCE \ assert(a); assert(b) PERL_CALLCONV U8* Perl_utf8_hop(pTHX_ const U8 *s, I32 off) __attribute__warn_unused_result__ __attribute__pure__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_UTF8_HOP \ assert(s) PERL_CALLCONV U8* Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_UTF8_TO_BYTES \ assert(s); assert(len) PERL_CALLCONV U8* Perl_bytes_from_utf8(pTHX_ const U8 *s, STRLEN *len, bool *is_utf8) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_BYTES_FROM_UTF8 \ assert(s); assert(len) PERL_CALLCONV U8* Perl_bytes_to_utf8(pTHX_ const U8 *s, STRLEN *len) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_BYTES_TO_UTF8 \ assert(s); assert(len) PERL_CALLCONV UV Perl_utf8_to_uvchr(pTHX_ const U8 *s, STRLEN *retlen) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_UTF8_TO_UVCHR \ assert(s) PERL_CALLCONV UV Perl_utf8_to_uvuni(pTHX_ const U8 *s, STRLEN *retlen) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_UTF8_TO_UVUNI \ assert(s) #ifdef EBCDIC PERL_CALLCONV UV Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_UTF8N_TO_UVCHR \ assert(s) #else /* PERL_CALLCONV UV Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags) __attribute__nonnull__(pTHX_1); */ #define PERL_ARGS_ASSERT_UTF8N_TO_UVCHR \ assert(s) #endif PERL_CALLCONV UV Perl_utf8n_to_uvuni(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_UTF8N_TO_UVUNI \ assert(s) #ifdef EBCDIC PERL_CALLCONV U8* Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_UVCHR_TO_UTF8 \ assert(d) #else /* PERL_CALLCONV U8* Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv) __attribute__nonnull__(pTHX_1); */ #define PERL_ARGS_ASSERT_UVCHR_TO_UTF8 \ assert(d) #endif /* PERL_CALLCONV U8* Perl_uvuni_to_utf8(pTHX_ U8 *d, UV uv) __attribute__nonnull__(pTHX_1); */ #define PERL_ARGS_ASSERT_UVUNI_TO_UTF8 \ assert(d) PERL_CALLCONV U8* Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_UVCHR_TO_UTF8_FLAGS \ assert(d) PERL_CALLCONV U8* Perl_uvuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_UVUNI_TO_UTF8_FLAGS \ assert(d) PERL_CALLCONV char* Perl_pv_uni_display(pTHX_ SV *dsv, const U8 *spv, STRLEN len, STRLEN pvlim, UV flags) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_PV_UNI_DISPLAY \ assert(dsv); assert(spv) PERL_CALLCONV char* Perl_sv_uni_display(pTHX_ SV *dsv, SV *ssv, STRLEN pvlim, UV flags) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_UNI_DISPLAY \ assert(dsv); assert(ssv) PERL_CALLCONV void Perl_vivify_defelem(pTHX_ SV* sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_VIVIFY_DEFELEM \ assert(sv) PERL_CALLCONV void Perl_vivify_ref(pTHX_ SV* sv, U32 to_what) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_VIVIFY_REF \ assert(sv) PERL_CALLCONV I32 Perl_wait4pid(pTHX_ Pid_t pid, int* statusp, int flags) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_WAIT4PID \ assert(statusp) PERL_CALLCONV U32 Perl_parse_unicode_opts(pTHX_ const char **popt) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS \ assert(popt) PERL_CALLCONV U32 Perl_seed(pTHX); PERL_CALLCONV UV Perl_get_hash_seed(pTHX) __attribute__warn_unused_result__; PERL_CALLCONV void Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op); PERL_CALLCONV void Perl_report_uninit(pTHX_ const SV *uninit_sv); PERL_CALLCONV void Perl_warn(pTHX_ const char* pat, ...) __attribute__format__(__printf__,pTHX_1,pTHX_2) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_WARN \ assert(pat) PERL_CALLCONV void Perl_vwarn(pTHX_ const char* pat, va_list* args) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_VWARN \ assert(pat) PERL_CALLCONV void Perl_warner(pTHX_ U32 err, const char* pat, ...) __attribute__format__(__printf__,pTHX_2,pTHX_3) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_WARNER \ assert(pat) PERL_CALLCONV void Perl_ck_warner(pTHX_ U32 err, const char* pat, ...) __attribute__format__(__printf__,pTHX_2,pTHX_3) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_CK_WARNER \ assert(pat) PERL_CALLCONV void Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...) __attribute__format__(__printf__,pTHX_2,pTHX_3) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_CK_WARNER_D \ assert(pat) PERL_CALLCONV void Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_VWARNER \ assert(pat) PERL_CALLCONV void Perl_watch(pTHX_ char** addr) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_WATCH \ assert(addr) PERL_CALLCONV I32 Perl_whichsig(pTHX_ const char* sig) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_WHICHSIG \ assert(sig) PERL_CALLCONV void Perl_write_to_stderr(pTHX_ SV* msv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_WRITE_TO_STDERR \ assert(msv) PERL_CALLCONV int Perl_yyerror(pTHX_ const char *const s) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_YYERROR \ assert(s) PERL_CALLCONV int Perl_yylex(pTHX); PERL_CALLCONV int Perl_yyparse(pTHX); PERL_CALLCONV void Perl_parser_free(pTHX_ const yy_parser *parser) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_PARSER_FREE \ assert(parser) #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT) STATIC int S_yywarn(pTHX_ const char *const s) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_YYWARN \ assert(s) #endif #if defined(MYMALLOC) PERL_CALLCONV void Perl_dump_mstats(pTHX_ const char* s) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DUMP_MSTATS \ assert(s) PERL_CALLCONV int Perl_get_mstats(pTHX_ perl_mstats_t *buf, int buflen, int level) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GET_MSTATS \ assert(buf) #endif PERL_CALLCONV Malloc_t Perl_safesysmalloc(MEM_SIZE nbytes) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV Malloc_t Perl_safesyscalloc(MEM_SIZE elements, MEM_SIZE size) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV Malloc_t Perl_safesysrealloc(Malloc_t where, MEM_SIZE nbytes) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV Free_t Perl_safesysfree(Malloc_t where); #if defined(PERL_GLOBAL_STRUCT) PERL_CALLCONV struct perl_vars * Perl_GetVars(pTHX); PERL_CALLCONV struct perl_vars* Perl_init_global_struct(pTHX); PERL_CALLCONV void Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT \ assert(plvarsp) #endif PERL_CALLCONV int Perl_runops_standard(pTHX); PERL_CALLCONV int Perl_runops_debug(pTHX); PERL_CALLCONV void Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...) __attribute__format__(__printf__,pTHX_2,pTHX_3) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_CATPVF_MG \ assert(sv); assert(pat) PERL_CALLCONV void Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_VCATPVF_MG \ assert(sv); assert(pat) PERL_CALLCONV void Perl_sv_catpv_mg(pTHX_ SV *const sv, const char *const ptr) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_CATPV_MG \ assert(sv) /* PERL_CALLCONV void Perl_sv_catpvn_mg(pTHX_ SV *sv, const char *ptr, STRLEN len) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); */ #define PERL_ARGS_ASSERT_SV_CATPVN_MG \ assert(sv); assert(ptr) /* PERL_CALLCONV void Perl_sv_catsv_mg(pTHX_ SV *dsv, SV *ssv) __attribute__nonnull__(pTHX_1); */ #define PERL_ARGS_ASSERT_SV_CATSV_MG \ assert(dsv) PERL_CALLCONV void Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...) __attribute__format__(__printf__,pTHX_2,pTHX_3) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_SETPVF_MG \ assert(sv); assert(pat) PERL_CALLCONV void Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_VSETPVF_MG \ assert(sv); assert(pat) PERL_CALLCONV void Perl_sv_setiv_mg(pTHX_ SV *const sv, const IV i) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_SETIV_MG \ assert(sv) PERL_CALLCONV void Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_SETPVIV_MG \ assert(sv) PERL_CALLCONV void Perl_sv_setuv_mg(pTHX_ SV *const sv, const UV u) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_SETUV_MG \ assert(sv) PERL_CALLCONV void Perl_sv_setnv_mg(pTHX_ SV *const sv, const NV num) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_SETNV_MG \ assert(sv) PERL_CALLCONV void Perl_sv_setpv_mg(pTHX_ SV *const sv, const char *const ptr) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_SETPV_MG \ assert(sv) PERL_CALLCONV void Perl_sv_setpvn_mg(pTHX_ SV *const sv, const char *const ptr, const STRLEN len) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_SETPVN_MG \ assert(sv); assert(ptr) PERL_CALLCONV void Perl_sv_setsv_mg(pTHX_ SV *const dstr, SV *const sstr) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_SETSV_MG \ assert(dstr) /* PERL_CALLCONV void Perl_sv_usepvn_mg(pTHX_ SV *sv, char *ptr, STRLEN len) __attribute__nonnull__(pTHX_1); */ #define PERL_ARGS_ASSERT_SV_USEPVN_MG \ assert(sv) PERL_CALLCONV MGVTBL* Perl_get_vtbl(pTHX_ int vtbl_id) __attribute__warn_unused_result__; PERL_CALLCONV char* Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_PV_DISPLAY \ assert(dsv); assert(pv) PERL_CALLCONV char* Perl_pv_escape(pTHX_ SV *dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_PV_ESCAPE \ assert(dsv); assert(str) PERL_CALLCONV char* Perl_pv_pretty(pTHX_ SV *dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_PV_PRETTY \ assert(dsv); assert(str) PERL_CALLCONV void Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...) __attribute__format__(__printf__,pTHX_3,pTHX_4) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_DUMP_INDENT \ assert(file); assert(pat) PERL_CALLCONV void Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_DUMP_VINDENT \ assert(file); assert(pat) PERL_CALLCONV void Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_DO_GV_DUMP \ assert(file); assert(name) PERL_CALLCONV void Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_DO_GVGV_DUMP \ assert(file); assert(name) PERL_CALLCONV void Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_DO_HV_DUMP \ assert(file); assert(name) PERL_CALLCONV void Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_DO_MAGIC_DUMP \ assert(file); assert(mg) PERL_CALLCONV void Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_DO_OP_DUMP \ assert(file) PERL_CALLCONV void Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_DO_PMOP_DUMP \ assert(file) PERL_CALLCONV void Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_DO_SV_DUMP \ assert(file) PERL_CALLCONV void Perl_magic_dump(pTHX_ const MAGIC *mg); PERL_CALLCONV void Perl_reginitcolors(pTHX); /* PERL_CALLCONV char* Perl_sv_2pv_nolen(pTHX_ SV* sv) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); */ #define PERL_ARGS_ASSERT_SV_2PV_NOLEN \ assert(sv) /* PERL_CALLCONV char* Perl_sv_2pvutf8_nolen(pTHX_ SV* sv) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); */ #define PERL_ARGS_ASSERT_SV_2PVUTF8_NOLEN \ assert(sv) /* PERL_CALLCONV char* Perl_sv_2pvbyte_nolen(pTHX_ SV* sv) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); */ #define PERL_ARGS_ASSERT_SV_2PVBYTE_NOLEN \ assert(sv) /* PERL_CALLCONV char* Perl_sv_pv(pTHX_ SV *sv) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); */ #define PERL_ARGS_ASSERT_SV_PV \ assert(sv) /* PERL_CALLCONV char* Perl_sv_pvutf8(pTHX_ SV *sv) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); */ #define PERL_ARGS_ASSERT_SV_PVUTF8 \ assert(sv) /* PERL_CALLCONV char* Perl_sv_pvbyte(pTHX_ SV *sv) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); */ #define PERL_ARGS_ASSERT_SV_PVBYTE \ assert(sv) /* PERL_CALLCONV STRLEN Perl_sv_utf8_upgrade(pTHX_ SV *sv) __attribute__nonnull__(pTHX_1); */ #define PERL_ARGS_ASSERT_SV_UTF8_UPGRADE \ assert(sv) /* PERL_CALLCONV STRLEN sv_utf8_upgrade_nomg(pTHX_ SV *sv) __attribute__nonnull__(pTHX_1); */ PERL_CALLCONV bool Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE \ assert(sv) PERL_CALLCONV void Perl_sv_utf8_encode(pTHX_ SV *const sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_UTF8_ENCODE \ assert(sv) PERL_CALLCONV bool Perl_sv_utf8_decode(pTHX_ SV *const sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_UTF8_DECODE \ assert(sv) /* PERL_CALLCONV void Perl_sv_force_normal(pTHX_ SV *sv) __attribute__nonnull__(pTHX_1); */ #define PERL_ARGS_ASSERT_SV_FORCE_NORMAL \ assert(sv) PERL_CALLCONV void Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS \ assert(sv) PERL_CALLCONV void Perl_tmps_grow(pTHX_ I32 n); PERL_CALLCONV SV* Perl_sv_rvweaken(pTHX_ SV *const sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_RVWEAKEN \ assert(sv) PERL_CALLCONV int Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS \ assert(sv); assert(mg) PERL_CALLCONV OP* Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block); PERL_CALLCONV CV* Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block); #ifdef PERL_MAD PERL_CALLCONV OP * Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) __attribute__noreturn__; #else PERL_CALLCONV void Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) __attribute__noreturn__; #endif PERL_CALLCONV OP * Perl_my_attrs(pTHX_ OP *o, OP *attrs) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_MY_ATTRS \ assert(o) #if defined(USE_ITHREADS) PERL_CALLCONV PERL_CONTEXT* Perl_cx_dup(pTHX_ PERL_CONTEXT* cx, I32 ix, I32 max, CLONE_PARAMS* param) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_4); #define PERL_ARGS_ASSERT_CX_DUP \ assert(param) PERL_CALLCONV PERL_SI* Perl_si_dup(pTHX_ PERL_SI* si, CLONE_PARAMS* param) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SI_DUP \ assert(param) PERL_CALLCONV ANY* Perl_ss_dup(pTHX_ PerlInterpreter* proto_perl, CLONE_PARAMS* param) __attribute__malloc__ __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SS_DUP \ assert(proto_perl); assert(param) PERL_CALLCONV void* Perl_any_dup(pTHX_ void* v, const PerlInterpreter* proto_perl) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_ANY_DUP \ assert(proto_perl) PERL_CALLCONV HE* Perl_he_dup(pTHX_ const HE* e, bool shared, CLONE_PARAMS* param) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_HE_DUP \ assert(param) PERL_CALLCONV HEK* Perl_hek_dup(pTHX_ HEK* e, CLONE_PARAMS* param) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_HEK_DUP \ assert(param) PERL_CALLCONV void Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS* param) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_RE_DUP_GUTS \ assert(sstr); assert(dstr); assert(param) PERL_CALLCONV PerlIO* Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_FP_DUP \ assert(param) PERL_CALLCONV DIR* Perl_dirp_dup(pTHX_ DIR *const dp) __attribute__warn_unused_result__; PERL_CALLCONV GP* Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_GP_DUP \ assert(param) PERL_CALLCONV MAGIC* Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MG_DUP \ assert(param) #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) STATIC SV ** S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest, SSize_t items, CLONE_PARAMS *const param) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_4); #define PERL_ARGS_ASSERT_SV_DUP_INC_MULTIPLE \ assert(source); assert(dest); assert(param) #endif PERL_CALLCONV SV* Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_DUP \ assert(param) PERL_CALLCONV void Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_RVPV_DUP \ assert(dstr); assert(sstr); assert(param) PERL_CALLCONV yy_parser* Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_PARSER_DUP \ assert(param) #endif PERL_CALLCONV PTR_TBL_t* Perl_ptr_table_new(pTHX) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV void* Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_PTR_TABLE_FETCH \ assert(tbl) PERL_CALLCONV void Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_PTR_TABLE_STORE \ assert(tbl); assert(newsv) PERL_CALLCONV void Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_PTR_TABLE_SPLIT \ assert(tbl) PERL_CALLCONV void Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl); PERL_CALLCONV void Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl); #if defined(USE_ITHREADS) # if defined(HAVE_INTERP_INTERN) PERL_CALLCONV void Perl_sys_intern_dup(pTHX_ struct interp_intern* src, struct interp_intern* dst) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SYS_INTERN_DUP \ assert(src); assert(dst) # endif #endif #if defined(HAVE_INTERP_INTERN) PERL_CALLCONV void Perl_sys_intern_clear(pTHX); PERL_CALLCONV void Perl_sys_intern_init(pTHX); #endif PERL_CALLCONV const char * Perl_custom_op_name(pTHX_ const OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CUSTOM_OP_NAME \ assert(o) PERL_CALLCONV const char * Perl_custom_op_desc(pTHX_ const OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CUSTOM_OP_DESC \ assert(o) PERL_CALLCONV void Perl_sv_nosharing(pTHX_ SV *sv); /* PERL_CALLCONV void Perl_sv_nolocking(pTHX_ SV *sv); */ PERL_CALLCONV bool Perl_sv_destroyable(pTHX_ SV *sv); #ifdef NO_MATHOMS /* PERL_CALLCONV void Perl_sv_nounlocking(pTHX_ SV *sv); */ #else PERL_CALLCONV void Perl_sv_nounlocking(pTHX_ SV *sv); #endif PERL_CALLCONV int Perl_nothreadhook(pTHX); END_EXTERN_C #if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT) STATIC I32 S_do_trans_simple(pTHX_ SV * const sv) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DO_TRANS_SIMPLE \ assert(sv) STATIC I32 S_do_trans_count(pTHX_ SV * const sv) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DO_TRANS_COUNT \ assert(sv) STATIC I32 S_do_trans_complex(pTHX_ SV * const sv) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DO_TRANS_COMPLEX \ assert(sv) STATIC I32 S_do_trans_simple_utf8(pTHX_ SV * const sv) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DO_TRANS_SIMPLE_UTF8 \ assert(sv) STATIC I32 S_do_trans_count_utf8(pTHX_ SV * const sv) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DO_TRANS_COUNT_UTF8 \ assert(sv) STATIC I32 S_do_trans_complex_utf8(pTHX_ SV * const sv) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DO_TRANS_COMPLEX_UTF8 \ assert(sv) #endif #if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT) STATIC void S_gv_init_sv(pTHX_ GV *gv, const svtype sv_type) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GV_INIT_SV \ assert(gv) STATIC HV* S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GV_GET_SUPER_PKG \ assert(name) STATIC HV* S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv, const U32 flags) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3) __attribute__nonnull__(pTHX_4); #define PERL_ARGS_ASSERT_REQUIRE_TIE_MOD \ assert(gv); assert(varpv); assert(namesv); assert(methpv) #endif PERL_CALLCONV void* Perl_get_arena(pTHX_ const size_t arenasize, const svtype bodytype) __attribute__malloc__ __attribute__warn_unused_result__; #if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT) STATIC void S_hsplit(pTHX_ HV *hv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_HSPLIT \ assert(hv) STATIC void S_hfreeentries(pTHX_ HV *hv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_HFREEENTRIES \ assert(hv) STATIC I32 S_anonymise_cv(pTHX_ HEK *stash, SV *val) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_ANONYMISE_CV \ assert(val) STATIC HE* S_new_he(pTHX) __attribute__malloc__ __attribute__warn_unused_result__; STATIC HEK* S_save_hek_flags(const char *str, I32 len, U32 hash, int flags) __attribute__malloc__ __attribute__warn_unused_result__ __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_SAVE_HEK_FLAGS \ assert(str) STATIC void S_hv_magic_check(HV *hv, bool *needs_copy, bool *needs_store) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__nonnull__(3); #define PERL_ARGS_ASSERT_HV_MAGIC_CHECK \ assert(hv); assert(needs_copy); assert(needs_store) STATIC void S_unshare_hek_or_pvn(pTHX_ const HEK* hek, const char* str, I32 len, U32 hash); STATIC HEK* S_share_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SHARE_HEK_FLAGS \ assert(str) STATIC void S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen, const char *msg) __attribute__noreturn__ __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_4); #define PERL_ARGS_ASSERT_HV_NOTALLOWED \ assert(key); assert(msg) STATIC struct xpvhv_aux* S_hv_auxinit(HV *hv) __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_HV_AUXINIT \ assert(hv) STATIC SV* S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, int k_flags, I32 d_flags, U32 hash); STATIC void S_clear_placeholders(pTHX_ HV *hv, U32 items) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CLEAR_PLACEHOLDERS \ assert(hv) STATIC SV * S_refcounted_he_value(pTHX_ const struct refcounted_he *he) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_REFCOUNTED_HE_VALUE \ assert(he) #endif #if defined(PERL_IN_MG_C) || defined(PERL_DECL_PROT) STATIC void S_save_magic(pTHX_ I32 mgs_ix, SV *sv) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SAVE_MAGIC \ assert(sv) STATIC int S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_MAGIC_METHPACK \ assert(sv); assert(mg); assert(meth) STATIC int S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 f, int n, SV *val) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_MAGIC_METHCALL \ assert(sv); assert(mg); assert(meth) STATIC void S_restore_magic(pTHX_ const void *p); STATIC void S_unwind_handler_stack(pTHX_ const void *p) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_UNWIND_HANDLER_STACK \ assert(p) #endif #if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) PERL_CALLCONV OP* Perl_ck_anoncode(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_ANONCODE \ assert(o) PERL_CALLCONV OP* Perl_ck_bitop(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_BITOP \ assert(o) PERL_CALLCONV OP* Perl_ck_concat(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_CONCAT \ assert(o) PERL_CALLCONV OP* Perl_ck_defined(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_DEFINED \ assert(o) PERL_CALLCONV OP* Perl_ck_delete(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_DELETE \ assert(o) PERL_CALLCONV OP* Perl_ck_die(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_DIE \ assert(o) PERL_CALLCONV OP* Perl_ck_eof(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_EOF \ assert(o) PERL_CALLCONV OP* Perl_ck_eval(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_EVAL \ assert(o) PERL_CALLCONV OP* Perl_ck_exec(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_EXEC \ assert(o) PERL_CALLCONV OP* Perl_ck_exists(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_EXISTS \ assert(o) PERL_CALLCONV OP* Perl_ck_exit(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_EXIT \ assert(o) PERL_CALLCONV OP* Perl_ck_ftst(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_FTST \ assert(o) PERL_CALLCONV OP* Perl_ck_fun(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_FUN \ assert(o) PERL_CALLCONV OP* Perl_ck_glob(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_GLOB \ assert(o) PERL_CALLCONV OP* Perl_ck_grep(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_GREP \ assert(o) PERL_CALLCONV OP* Perl_ck_index(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_INDEX \ assert(o) PERL_CALLCONV OP* Perl_ck_join(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_JOIN \ assert(o) PERL_CALLCONV OP* Perl_ck_lfun(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_LFUN \ assert(o) PERL_CALLCONV OP* Perl_ck_listiob(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_LISTIOB \ assert(o) PERL_CALLCONV OP* Perl_ck_match(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_MATCH \ assert(o) PERL_CALLCONV OP* Perl_ck_method(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_METHOD \ assert(o) PERL_CALLCONV OP* Perl_ck_null(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_NULL \ assert(o) PERL_CALLCONV OP* Perl_ck_open(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_OPEN \ assert(o) PERL_CALLCONV OP* Perl_ck_readline(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_READLINE \ assert(o) PERL_CALLCONV OP* Perl_ck_repeat(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_REPEAT \ assert(o) PERL_CALLCONV OP* Perl_ck_require(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_REQUIRE \ assert(o) PERL_CALLCONV OP* Perl_ck_return(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_RETURN \ assert(o) PERL_CALLCONV OP* Perl_ck_rfun(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_RFUN \ assert(o) PERL_CALLCONV OP* Perl_ck_rvconst(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_RVCONST \ assert(o) PERL_CALLCONV OP* Perl_ck_sassign(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_SASSIGN \ assert(o) PERL_CALLCONV OP* Perl_ck_select(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_SELECT \ assert(o) PERL_CALLCONV OP* Perl_ck_shift(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_SHIFT \ assert(o) PERL_CALLCONV OP* Perl_ck_sort(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_SORT \ assert(o) PERL_CALLCONV OP* Perl_ck_spair(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_SPAIR \ assert(o) PERL_CALLCONV OP* Perl_ck_split(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_SPLIT \ assert(o) PERL_CALLCONV OP* Perl_ck_subr(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_SUBR \ assert(o) PERL_CALLCONV OP* Perl_ck_substr(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_SUBSTR \ assert(o) PERL_CALLCONV OP* Perl_ck_svconst(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_SVCONST \ assert(o) PERL_CALLCONV OP* Perl_ck_trunc(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_TRUNC \ assert(o) PERL_CALLCONV OP* Perl_ck_unpack(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_UNPACK \ assert(o) PERL_CALLCONV OP* Perl_ck_each(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_EACH \ assert(o) STATIC bool S_is_handle_constructor(const OP *o, I32 numargs) __attribute__warn_unused_result__ __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR \ assert(o) STATIC I32 S_is_list_assignment(pTHX_ const OP *o) __attribute__warn_unused_result__; # ifdef USE_ITHREADS STATIC void S_forget_pmop(pTHX_ PMOP *const o, U32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_FORGET_PMOP \ assert(o) # else STATIC void S_forget_pmop(pTHX_ PMOP *const o) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_FORGET_PMOP \ assert(o) # endif STATIC void S_find_and_forget_pmops(pTHX_ OP *o) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS \ assert(o) STATIC void S_cop_free(pTHX_ COP *cop) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_COP_FREE \ assert(cop) STATIC OP* S_modkids(pTHX_ OP *o, I32 type); STATIC OP* S_scalarboolean(pTHX_ OP *o) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SCALARBOOLEAN \ assert(o) STATIC OP* S_newDEFSVOP(pTHX) __attribute__warn_unused_result__; STATIC OP* S_search_const(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SEARCH_CONST \ assert(o) STATIC OP* S_new_logop(pTHX_ I32 type, I32 flags, OP **firstp, OP **otherp) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_3) __attribute__nonnull__(pTHX_4); #define PERL_ARGS_ASSERT_NEW_LOGOP \ assert(firstp); assert(otherp) STATIC void S_simplify_sort(pTHX_ OP *o) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SIMPLIFY_SORT \ assert(o) STATIC const char* S_gv_ename(pTHX_ GV *gv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GV_ENAME \ assert(gv) STATIC bool S_scalar_mod_type(const OP *o, I32 type) __attribute__warn_unused_result__ __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_SCALAR_MOD_TYPE \ assert(o) STATIC OP * S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_MY_KID \ assert(imopsp) STATIC OP * S_dup_attrlist(pTHX_ OP *o) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DUP_ATTRLIST \ assert(o) STATIC void S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_APPLY_ATTRS \ assert(stash); assert(target) STATIC void S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_4); #define PERL_ARGS_ASSERT_APPLY_ATTRS_MY \ assert(stash); assert(target); assert(imopsp) STATIC void S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3) __attribute__nonnull__(pTHX_4); #define PERL_ARGS_ASSERT_BAD_TYPE \ assert(t); assert(name); assert(kid) STATIC void S_no_bareword_allowed(pTHX_ const OP *o) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED \ assert(o) STATIC OP* S_no_fh_allowed(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_NO_FH_ALLOWED \ assert(o) STATIC OP* S_too_few_arguments(pTHX_ OP *o, const char* name) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS \ assert(o); assert(name) STATIC OP* S_too_many_arguments(pTHX_ OP *o, const char* name) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS \ assert(o); assert(name) STATIC bool S_looks_like_bool(pTHX_ const OP* o) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL \ assert(o) STATIC OP* S_newGIVWHENOP(pTHX_ OP* cond, OP *block, I32 enter_opcode, I32 leave_opcode, PADOFFSET entertarg) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_NEWGIVWHENOP \ assert(block) STATIC OP* S_ref_array_or_hash(pTHX_ OP* cond); STATIC void S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv, CV *const cv) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS \ assert(fullname); assert(gv); assert(cv) #endif #if defined(PL_OP_SLAB_ALLOC) PERL_CALLCONV void* Perl_Slab_Alloc(pTHX_ size_t sz) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV void Perl_Slab_Free(pTHX_ void *op) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SLAB_FREE \ assert(op) # if defined(PERL_DEBUG_READONLY_OPS) PERL_CALLCONV void Perl_pending_Slabs_to_ro(pTHX); PERL_CALLCONV OP * Perl_op_refcnt_inc(pTHX_ OP *o); PERL_CALLCONV PADOFFSET Perl_op_refcnt_dec(pTHX_ OP *o) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_OP_REFCNT_DEC \ assert(o) # if defined(PERL_IN_OP_C) STATIC void S_Slab_to_rw(pTHX_ void *op) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SLAB_TO_RW \ assert(op) # endif # endif #endif #if defined(PERL_IN_PERL_C) || defined(PERL_DECL_PROT) STATIC void S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_FIND_BEGINNING \ assert(linestr_sv); assert(rsfp) STATIC void S_forbid_setid(pTHX_ const char flag, const bool suidscript); STATIC void S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_INCPUSH \ assert(dir) STATIC void S_incpush_use_sep(pTHX_ const char *p, STRLEN len, U32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_INCPUSH_USE_SEP \ assert(p) STATIC void S_init_interp(pTHX); STATIC void S_init_ids(pTHX); STATIC void S_init_main_stash(pTHX); STATIC void S_init_perllib(pTHX); STATIC void S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS \ assert(argv) STATIC void S_init_predump_symbols(pTHX); STATIC void S_my_exit_jump(pTHX) __attribute__noreturn__; STATIC void S_nuke_stacks(pTHX); STATIC int S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript, PerlIO **rsfpp) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_3) __attribute__nonnull__(pTHX_4); #define PERL_ARGS_ASSERT_OPEN_SCRIPT \ assert(scriptname); assert(suidscript); assert(rsfpp) STATIC void S_usage(pTHX_ const char *name) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_USAGE \ assert(name) #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW STATIC void S_validate_suid(pTHX_ PerlIO *rsfp) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_VALIDATE_SUID \ assert(rsfp) #endif STATIC void* S_parse_body(pTHX_ char **env, XSINIT_t xsinit); STATIC void S_run_body(pTHX_ I32 oldscope) __attribute__noreturn__; STATIC SV * S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS \ assert(av); assert(dir); assert(stem) #endif #if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT) STATIC OP* S_do_delete_local(pTHX); STATIC SV* S_refto(pTHX_ SV* sv) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_REFTO \ assert(sv) #endif #if defined(PERL_IN_PP_C) || defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT) PERL_CALLCONV GV* Perl_softref2xv(pTHX_ SV *const sv, const char *const what, const svtype type, SV ***spp) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_4); #define PERL_ARGS_ASSERT_SOFTREF2XV \ assert(sv); assert(what); assert(spp) #endif #if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT) STATIC I32 S_unpack_rec(pTHX_ struct tempsym* symptr, const char *s, const char *strbeg, const char *strend, const char **new_s) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3) __attribute__nonnull__(pTHX_4); #define PERL_ARGS_ASSERT_UNPACK_REC \ assert(symptr); assert(s); assert(strbeg); assert(strend) STATIC SV ** S_pack_rec(pTHX_ SV *cat, struct tempsym* symptr, SV **beglist, SV **endlist) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3) __attribute__nonnull__(pTHX_4); #define PERL_ARGS_ASSERT_PACK_REC \ assert(cat); assert(symptr); assert(beglist); assert(endlist) STATIC SV* S_mul128(pTHX_ SV *sv, U8 m) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_MUL128 \ assert(sv) STATIC I32 S_measure_struct(pTHX_ struct tempsym* symptr) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_MEASURE_STRUCT \ assert(symptr) STATIC bool S_next_symbol(pTHX_ struct tempsym* symptr) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_NEXT_SYMBOL \ assert(symptr) STATIC SV* S_is_an_int(pTHX_ const char *s, STRLEN l) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_IS_AN_INT \ assert(s) STATIC int S_div128(pTHX_ SV *pnum, bool *done) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_DIV128 \ assert(pnum); assert(done) STATIC const char * S_group_end(pTHX_ const char *patptr, const char *patend, char ender) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_GROUP_END \ assert(patptr); assert(patend) STATIC const char * S_get_num(pTHX_ const char *patptr, I32 *lenptr) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_GET_NUM \ assert(patptr); assert(lenptr) STATIC bool S_need_utf8(const char *pat, const char *patend) __attribute__nonnull__(1) __attribute__nonnull__(2); #define PERL_ARGS_ASSERT_NEED_UTF8 \ assert(pat); assert(patend) STATIC char S_first_symbol(const char *pat, const char *patend) __attribute__nonnull__(1) __attribute__nonnull__(2); #define PERL_ARGS_ASSERT_FIRST_SYMBOL \ assert(pat); assert(patend) STATIC char * S_sv_exp_grow(pTHX_ SV *sv, STRLEN needed) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_EXP_GROW \ assert(sv) STATIC char * S_bytes_to_uni(const U8 *start, STRLEN len, char *dest) __attribute__warn_unused_result__ __attribute__nonnull__(1) __attribute__nonnull__(3); #define PERL_ARGS_ASSERT_BYTES_TO_UNI \ assert(start); assert(dest) #endif #if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT) STATIC OP* S_docatch(pTHX_ OP *o) __attribute__warn_unused_result__; STATIC OP* S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3) __attribute__nonnull__(pTHX_4); #define PERL_ARGS_ASSERT_DOFINDLABEL \ assert(o); assert(label); assert(opstack); assert(oplimit) STATIC OP* S_doparseform(pTHX_ SV *sv) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DOPARSEFORM \ assert(sv) STATIC bool S_num_overflow(NV value, I32 fldsize, I32 frcsize) __attribute__warn_unused_result__; STATIC I32 S_dopoptoeval(pTHX_ I32 startingblock) __attribute__warn_unused_result__; STATIC I32 S_dopoptogiven(pTHX_ I32 startingblock) __attribute__warn_unused_result__; STATIC I32 S_dopoptolabel(pTHX_ const char *label) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DOPOPTOLABEL \ assert(label) STATIC I32 S_dopoptoloop(pTHX_ I32 startingblock) __attribute__warn_unused_result__; STATIC I32 S_dopoptosub_at(pTHX_ const PERL_CONTEXT* cxstk, I32 startingblock) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DOPOPTOSUB_AT \ assert(cxstk) STATIC I32 S_dopoptowhen(pTHX_ I32 startingblock) __attribute__warn_unused_result__; STATIC void S_save_lines(pTHX_ AV *array, SV *sv) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SAVE_LINES \ assert(sv) STATIC bool S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq); STATIC PerlIO * S_check_type_and_open(pTHX_ const char *name) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN \ assert(name) #ifndef PERL_DISABLE_PMC STATIC PerlIO * S_doopen_pm(pTHX_ const char *name, const STRLEN namelen) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DOOPEN_PM \ assert(name) #endif STATIC bool S_path_is_absolute(const char *name) __attribute__warn_unused_result__ __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE \ assert(name) STATIC I32 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_RUN_USER_FILTER \ assert(buf_sv) STATIC PMOP* S_make_matcher(pTHX_ REGEXP* re) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_MAKE_MATCHER \ assert(re) STATIC bool S_matcher_matches_sv(pTHX_ PMOP* matcher, SV* sv) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MATCHER_MATCHES_SV \ assert(matcher); assert(sv) STATIC void S_destroy_matcher(pTHX_ PMOP* matcher) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DESTROY_MATCHER \ assert(matcher) STATIC OP* S_do_smartmatch(pTHX_ HV* seen_this, HV* seen_other); #endif #if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT) STATIC void S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_DO_ODDBALL \ assert(hash); assert(relem); assert(firstrelem) STATIC SV* S_method_common(pTHX_ SV* meth, U32* hashp) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_METHOD_COMMON \ assert(meth) #endif #if defined(PERL_IN_PP_SORT_C) || defined(PERL_DECL_PROT) STATIC I32 S_sv_ncmp(pTHX_ SV *const a, SV *const b) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_NCMP \ assert(a); assert(b) STATIC I32 S_sv_i_ncmp(pTHX_ SV *const a, SV *const b) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_I_NCMP \ assert(a); assert(b) STATIC I32 S_amagic_ncmp(pTHX_ SV *const a, SV *const b) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_AMAGIC_NCMP \ assert(a); assert(b) STATIC I32 S_amagic_i_ncmp(pTHX_ SV *const a, SV *const b) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_AMAGIC_I_NCMP \ assert(a); assert(b) STATIC I32 S_amagic_cmp(pTHX_ SV *const str1, SV *const str2) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_AMAGIC_CMP \ assert(str1); assert(str2) STATIC I32 S_amagic_cmp_locale(pTHX_ SV *const str1, SV *const str2) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_AMAGIC_CMP_LOCALE \ assert(str1); assert(str2) STATIC I32 S_sortcv(pTHX_ SV *const a, SV *const b) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SORTCV \ assert(a); assert(b) STATIC I32 S_sortcv_xsub(pTHX_ SV *const a, SV *const b) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SORTCV_XSUB \ assert(a); assert(b) STATIC I32 S_sortcv_stacked(pTHX_ SV *const a, SV *const b) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SORTCV_STACKED \ assert(a); assert(b) STATIC void S_qsortsvu(pTHX_ SV** array, size_t num_elts, SVCOMPARE_t compare) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_QSORTSVU \ assert(compare) #endif #if defined(PERL_IN_PP_SYS_C) || defined(PERL_DECL_PROT) STATIC OP* S_doform(pTHX_ CV *cv, GV *gv, OP *retop) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_DOFORM \ assert(cv); assert(gv); assert(retop) # if !defined(HAS_MKDIR) || !defined(HAS_RMDIR) STATIC int S_dooneliner(pTHX_ const char *cmd, const char *filename) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_DOONELINER \ assert(cmd); assert(filename) # endif STATIC SV * S_space_join_names_mortal(pTHX_ char *const *array) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL \ assert(array) #endif #if defined(PERL_IN_REGCOMP_C) || defined(PERL_DECL_PROT) STATIC regnode* S_reg(pTHX_ struct RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_REG \ assert(pRExC_state); assert(flagp) STATIC regnode* S_reganode(pTHX_ struct RExC_state_t *pRExC_state, U8 op, U32 arg) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_REGANODE \ assert(pRExC_state) STATIC regnode* S_regatom(pTHX_ struct RExC_state_t *pRExC_state, I32 *flagp, U32 depth) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_REGATOM \ assert(pRExC_state); assert(flagp) STATIC regnode* S_regbranch(pTHX_ struct RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_REGBRANCH \ assert(pRExC_state); assert(flagp) STATIC STRLEN S_reguni(pTHX_ const struct RExC_state_t *pRExC_state, UV uv, char *s) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_REGUNI \ assert(pRExC_state); assert(s) STATIC regnode* S_regclass(pTHX_ struct RExC_state_t *pRExC_state, U32 depth) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_REGCLASS \ assert(pRExC_state) STATIC regnode* S_reg_node(pTHX_ struct RExC_state_t *pRExC_state, U8 op) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_REG_NODE \ assert(pRExC_state) STATIC UV S_reg_recode(pTHX_ const char value, SV **encp) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_REG_RECODE \ assert(encp) STATIC regnode* S_regpiece(pTHX_ struct RExC_state_t *pRExC_state, I32 *flagp, U32 depth) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_REGPIECE \ assert(pRExC_state); assert(flagp) STATIC regnode* S_reg_namedseq(pTHX_ struct RExC_state_t *pRExC_state, UV *valuep, I32 *flagp) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_REG_NAMEDSEQ \ assert(pRExC_state) STATIC void S_reginsert(pTHX_ struct RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_REGINSERT \ assert(pRExC_state); assert(opnd) STATIC void S_regtail(pTHX_ struct RExC_state_t *pRExC_state, regnode *p, const regnode *val, U32 depth) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_REGTAIL \ assert(pRExC_state); assert(p); assert(val) STATIC SV * S_reg_scan_name(pTHX_ struct RExC_state_t *pRExC_state, U32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_REG_SCAN_NAME \ assert(pRExC_state) STATIC U32 S_join_exact(pTHX_ struct RExC_state_t *pRExC_state, regnode *scan, I32 *min, U32 flags, regnode *val, U32 depth) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_JOIN_EXACT \ assert(pRExC_state); assert(scan); assert(min) STATIC char * S_regwhite(struct RExC_state_t *pRExC_state, char *p) __attribute__warn_unused_result__ __attribute__nonnull__(1) __attribute__nonnull__(2); #define PERL_ARGS_ASSERT_REGWHITE \ assert(pRExC_state); assert(p) STATIC char * S_nextchar(pTHX_ struct RExC_state_t *pRExC_state) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_NEXTCHAR \ assert(pRExC_state) STATIC bool S_reg_skipcomment(pTHX_ struct RExC_state_t *pRExC_state) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_REG_SKIPCOMMENT \ assert(pRExC_state) STATIC void S_scan_commit(pTHX_ const struct RExC_state_t *pRExC_state, struct scan_data_t *data, I32 *minlenp, int is_inf) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_SCAN_COMMIT \ assert(pRExC_state); assert(data); assert(minlenp) STATIC void S_cl_anything(const struct RExC_state_t *pRExC_state, struct regnode_charclass_class *cl) __attribute__nonnull__(1) __attribute__nonnull__(2); #define PERL_ARGS_ASSERT_CL_ANYTHING \ assert(pRExC_state); assert(cl) STATIC int S_cl_is_anything(const struct regnode_charclass_class *cl) __attribute__warn_unused_result__ __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_CL_IS_ANYTHING \ assert(cl) STATIC void S_cl_init(const struct RExC_state_t *pRExC_state, struct regnode_charclass_class *cl) __attribute__nonnull__(1) __attribute__nonnull__(2); #define PERL_ARGS_ASSERT_CL_INIT \ assert(pRExC_state); assert(cl) STATIC void S_cl_init_zero(const struct RExC_state_t *pRExC_state, struct regnode_charclass_class *cl) __attribute__nonnull__(1) __attribute__nonnull__(2); #define PERL_ARGS_ASSERT_CL_INIT_ZERO \ assert(pRExC_state); assert(cl) STATIC void S_cl_and(struct regnode_charclass_class *cl, const struct regnode_charclass_class *and_with) __attribute__nonnull__(1) __attribute__nonnull__(2); #define PERL_ARGS_ASSERT_CL_AND \ assert(cl); assert(and_with) STATIC void S_cl_or(const struct RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, const struct regnode_charclass_class *or_with) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__nonnull__(3); #define PERL_ARGS_ASSERT_CL_OR \ assert(pRExC_state); assert(cl); assert(or_with) STATIC I32 S_study_chunk(pTHX_ struct RExC_state_t *pRExC_state, regnode **scanp, I32 *minlenp, I32 *deltap, regnode *last, struct scan_data_t *data, I32 stopparen, U8* recursed, struct regnode_charclass_class *and_withp, U32 flags, U32 depth) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3) __attribute__nonnull__(pTHX_4) __attribute__nonnull__(pTHX_5); #define PERL_ARGS_ASSERT_STUDY_CHUNK \ assert(pRExC_state); assert(scanp); assert(minlenp); assert(deltap); assert(last) STATIC U32 S_add_data(struct RExC_state_t *pRExC_state, U32 n, const char *s) __attribute__warn_unused_result__ __attribute__nonnull__(1) __attribute__nonnull__(3); #define PERL_ARGS_ASSERT_ADD_DATA \ assert(pRExC_state); assert(s) STATIC void S_re_croak2(pTHX_ const char* pat1, const char* pat2, ...) __attribute__noreturn__ __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_RE_CROAK2 \ assert(pat1); assert(pat2) STATIC I32 S_regpposixcc(pTHX_ struct RExC_state_t *pRExC_state, I32 value) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_REGPPOSIXCC \ assert(pRExC_state) STATIC void S_checkposixcc(pTHX_ struct RExC_state_t *pRExC_state) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CHECKPOSIXCC \ assert(pRExC_state) STATIC I32 S_make_trie(pTHX_ struct RExC_state_t *pRExC_state, regnode *startbranch, regnode *first, regnode *last, regnode *tail, U32 word_count, U32 flags, U32 depth) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3) __attribute__nonnull__(pTHX_4) __attribute__nonnull__(pTHX_5); #define PERL_ARGS_ASSERT_MAKE_TRIE \ assert(pRExC_state); assert(startbranch); assert(first); assert(last); assert(tail) STATIC void S_make_trie_failtable(pTHX_ struct RExC_state_t *pRExC_state, regnode *source, regnode *stclass, U32 depth) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_MAKE_TRIE_FAILTABLE \ assert(pRExC_state); assert(source); assert(stclass) # ifdef DEBUGGING STATIC void S_regdump_extflags(pTHX_ const char *lead, const U32 flags); 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) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3) __attribute__nonnull__(pTHX_6); #define PERL_ARGS_ASSERT_DUMPUNTIL \ assert(r); assert(start); assert(node); assert(sv) STATIC void S_put_byte(pTHX_ SV* sv, int c) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_PUT_BYTE \ assert(sv) STATIC void S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV* widecharmap, AV *revcharmap, U32 depth) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_DUMP_TRIE \ assert(trie); assert(revcharmap) STATIC void S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie, HV* widecharmap, AV *revcharmap, U32 next_alloc, U32 depth) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST \ assert(trie); assert(revcharmap) STATIC void S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie, HV* widecharmap, AV *revcharmap, U32 next_alloc, U32 depth) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE \ assert(trie); assert(revcharmap) STATIC U8 S_regtail_study(pTHX_ struct RExC_state_t *pRExC_state, regnode *p, const regnode *val, U32 depth) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_REGTAIL_STUDY \ assert(pRExC_state); assert(p); assert(val) # endif #endif #if defined(PERL_IN_REGEXEC_C) || defined(PERL_DECL_PROT) STATIC I32 S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_REGMATCH \ assert(reginfo); assert(prog) STATIC I32 S_regrepeat(pTHX_ const regexp *prog, const regnode *p, I32 max, int depth) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_REGREPEAT \ assert(prog); assert(p) STATIC I32 S_regtry(pTHX_ regmatch_info *reginfo, char **startpos) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_REGTRY \ assert(reginfo); assert(startpos) STATIC bool S_reginclass(pTHX_ const regexp *prog, const regnode *n, const U8 *p, STRLEN *lenp, bool do_utf8sv_is_utf8) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_REGINCLASS \ assert(n); assert(p) STATIC CHECKPOINT S_regcppush(pTHX_ I32 parenfloor); STATIC char* S_regcppop(pTHX_ const regexp *rex) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_REGCPPOP \ assert(rex) STATIC U8* S_reghop3(U8 *s, I32 off, const U8 *lim) __attribute__warn_unused_result__ __attribute__nonnull__(1) __attribute__nonnull__(3); #define PERL_ARGS_ASSERT_REGHOP3 \ assert(s); assert(lim) #ifdef XXX_dmq STATIC U8* S_reghop4(U8 *s, I32 off, const U8 *llim, const U8 *rlim) __attribute__warn_unused_result__ __attribute__nonnull__(1) __attribute__nonnull__(3) __attribute__nonnull__(4); #define PERL_ARGS_ASSERT_REGHOP4 \ assert(s); assert(llim); assert(rlim) #endif STATIC U8* S_reghopmaybe3(U8 *s, I32 off, const U8 *lim) __attribute__warn_unused_result__ __attribute__nonnull__(1) __attribute__nonnull__(3); #define PERL_ARGS_ASSERT_REGHOPMAYBE3 \ assert(s); assert(lim) STATIC char* S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, const char *strend, regmatch_info *reginfo) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3) __attribute__nonnull__(pTHX_4); #define PERL_ARGS_ASSERT_FIND_BYCLASS \ assert(prog); assert(c); assert(s); assert(strend) STATIC void S_to_utf8_substr(pTHX_ regexp * prog) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_TO_UTF8_SUBSTR \ assert(prog) STATIC void S_to_byte_substr(pTHX_ regexp * prog) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_TO_BYTE_SUBSTR \ assert(prog) STATIC I32 S_reg_check_named_buff_matched(pTHX_ const regexp *rex, const regnode *scan) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_REG_CHECK_NAMED_BUFF_MATCHED \ assert(rex); assert(scan) # ifdef DEBUGGING STATIC void S_dump_exec_pos(pTHX_ const char *locinput, const regnode *scan, const char *loc_regeol, const char *loc_bostr, const char *loc_reg_starttry, const bool do_utf8) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3) __attribute__nonnull__(pTHX_4) __attribute__nonnull__(pTHX_5); #define PERL_ARGS_ASSERT_DUMP_EXEC_POS \ assert(locinput); assert(scan); assert(loc_regeol); assert(loc_bostr); assert(loc_reg_starttry) STATIC void S_debug_start_match(pTHX_ const REGEXP *prog, const bool do_utf8, const char *start, const char *end, const char *blurb) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_3) __attribute__nonnull__(pTHX_4) __attribute__nonnull__(pTHX_5); #define PERL_ARGS_ASSERT_DEBUG_START_MATCH \ assert(prog); assert(start); assert(end); assert(blurb) # endif #endif #if defined(PERL_IN_DUMP_C) || defined(PERL_DECL_PROT) STATIC CV* S_deb_curcv(pTHX_ const I32 ix); STATIC void S_debprof(pTHX_ const OP *o) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DEBPROF \ assert(o) STATIC void S_sequence(pTHX_ const OP *o); STATIC void S_sequence_tail(pTHX_ const OP *o); STATIC UV S_sequence_num(pTHX_ const OP *o); STATIC SV* S_pm_description(pTHX_ const PMOP *pm) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_PM_DESCRIPTION \ assert(pm) #endif #if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT) STATIC SV* S_save_scalar_at(pTHX_ SV **sptr, const U32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SAVE_SCALAR_AT \ assert(sptr) #endif #if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT) PERL_CALLCONV void Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_ADD_BACKREF \ assert(tsv); assert(sv) #endif #if defined(PERL_IN_HV_C) || defined(PERL_IN_MG_C) || defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) PERL_CALLCONV int Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_KILL_BACKREFS \ assert(sv); assert(av) #endif #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) STATIC char * S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob) __attribute__warn_unused_result__ __attribute__nonnull__(1) __attribute__nonnull__(5); #define PERL_ARGS_ASSERT_UIV_2BUF \ assert(buf); assert(peob) STATIC void S_sv_unglob(pTHX_ SV *const sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_UNGLOB \ assert(sv) STATIC void S_not_a_number(pTHX_ SV *const sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_NOT_A_NUMBER \ assert(sv) STATIC I32 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_VISIT \ assert(f) STATIC void S_sv_del_backref(pTHX_ SV *const tsv, SV *const sv) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_DEL_BACKREF \ assert(tsv); assert(sv) STATIC SV * S_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ, const SV *const keyname, I32 aindex, int subscript_type) __attribute__warn_unused_result__; # ifdef DEBUGGING STATIC void S_del_sv(pTHX_ SV *p) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DEL_SV \ assert(p) # endif # if !defined(NV_PRESERVES_UV) # ifdef DEBUGGING STATIC int S_sv_2iuv_non_preserve(pTHX_ SV *const sv, I32 numtype) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE \ assert(sv) # else STATIC int S_sv_2iuv_non_preserve(pTHX_ SV *const sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE \ assert(sv) # endif # endif STATIC I32 S_expect_number(pTHX_ char **const pattern) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_EXPECT_NUMBER \ assert(pattern) # STATIC STRLEN S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send, STRLEN uoffset) __attribute__nonnull__(1) __attribute__nonnull__(2); #define PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS \ assert(start); assert(send) STATIC STRLEN S_sv_pos_u2b_midway(const U8 *const start, const U8 *send, const STRLEN uoffset, const STRLEN uend) __attribute__nonnull__(1) __attribute__nonnull__(2); #define PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY \ assert(start); assert(send) STATIC STRLEN S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start, const U8 *const send, const STRLEN uoffset, STRLEN uoffset0, STRLEN boffset0) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3) __attribute__nonnull__(pTHX_4); #define PERL_ARGS_ASSERT_SV_POS_U2B_CACHED \ assert(sv); assert(mgp); assert(start); assert(send) STATIC void S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN byte, const STRLEN utf8, const STRLEN blen) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE \ assert(sv); assert(mgp) STATIC STRLEN S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target, const U8 *end, STRLEN endu) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY \ assert(s); assert(target); assert(end) STATIC char * S_F0convert(NV nv, char *const endbuf, STRLEN *const len) __attribute__nonnull__(2) __attribute__nonnull__(3); #define PERL_ARGS_ASSERT_F0CONVERT \ assert(endbuf); assert(len) # if defined(PERL_OLD_COPY_ON_WRITE) STATIC void S_sv_release_COW(pTHX_ SV *sv, const char *pvx, SV *after) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_SV_RELEASE_COW \ assert(sv); assert(pvx); assert(after) # endif STATIC SV * S_more_sv(pTHX); STATIC void * S_more_bodies(pTHX_ const svtype sv_type); STATIC bool S_sv_2iuv_common(pTHX_ SV *const sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_2IUV_COMMON \ assert(sv) STATIC void S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB \ assert(dstr); assert(sstr) STATIC void S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_GLOB_ASSIGN_REF \ assert(dstr); assert(sstr) STATIC PTR_TBL_ENT_t * S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv) __attribute__warn_unused_result__ __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_PTR_TABLE_FIND \ assert(tbl) #endif #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT) STATIC void S_check_uni(pTHX); STATIC void S_force_next(pTHX_ I32 type); STATIC char* S_force_version(pTHX_ char *s, int guessing) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_FORCE_VERSION \ assert(s) STATIC char* S_force_strict_version(pTHX_ char *s) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_FORCE_STRICT_VERSION \ assert(s) STATIC char* S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack, int allow_tick) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_FORCE_WORD \ assert(start) STATIC SV* S_tokeq(pTHX_ SV *sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_TOKEQ \ assert(sv) STATIC void S_readpipe_override(pTHX); STATIC char* S_scan_const(pTHX_ char *start) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SCAN_CONST \ assert(start) STATIC char* S_scan_formline(pTHX_ char *s) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SCAN_FORMLINE \ assert(s) STATIC char* S_scan_heredoc(pTHX_ char *s) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SCAN_HEREDOC \ assert(s) STATIC char* S_scan_ident(pTHX_ char *s, const char *send, char *dest, STRLEN destlen, I32 ck_uni) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_SCAN_IDENT \ assert(s); assert(send); assert(dest) STATIC char* S_scan_inputsymbol(pTHX_ char *start) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL \ assert(start) STATIC char* S_scan_pat(pTHX_ char *start, I32 type) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SCAN_PAT \ assert(start) STATIC char* S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SCAN_STR \ assert(start) STATIC char* S_scan_subst(pTHX_ char *start) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SCAN_SUBST \ assert(start) STATIC char* S_scan_trans(pTHX_ char *start) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SCAN_TRANS \ assert(start) STATIC char* S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_5); #define PERL_ARGS_ASSERT_SCAN_WORD \ assert(s); assert(dest); assert(slp) STATIC void S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len); STATIC char* S_skipspace(pTHX_ char *s) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SKIPSPACE \ assert(s) STATIC char* S_swallow_bom(pTHX_ U8 *s) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SWALLOW_BOM \ assert(s) #ifndef PERL_NO_UTF16_FILTER STATIC I32 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_UTF16_TEXTFILTER \ assert(sv) STATIC U8* S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER \ assert(s) #endif STATIC void S_checkcomma(pTHX_ const char *s, const char *name, const char *what) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_CHECKCOMMA \ assert(s); assert(name); assert(what) STATIC bool S_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_FEATURE_IS_ENABLED \ assert(name) STATIC void S_force_ident(pTHX_ const char *s, int kind) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_FORCE_IDENT \ assert(s) STATIC void S_incline(pTHX_ const char *s) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_INCLINE \ assert(s) STATIC int S_intuit_method(pTHX_ char *s, GV *gv, CV *cv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_INTUIT_METHOD \ assert(s) STATIC int S_intuit_more(pTHX_ char *s) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_INTUIT_MORE \ assert(s) STATIC I32 S_lop(pTHX_ I32 f, int x, char *s) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_LOP \ assert(s) STATIC void S_missingterm(pTHX_ char *s) __attribute__noreturn__; STATIC void S_no_op(pTHX_ const char *const what, char *s) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_NO_OP \ assert(what) STATIC I32 S_sublex_done(pTHX) __attribute__warn_unused_result__; STATIC I32 S_sublex_push(pTHX) __attribute__warn_unused_result__; STATIC I32 S_sublex_start(pTHX) __attribute__warn_unused_result__; STATIC char * S_filter_gets(pTHX_ SV *sv, STRLEN append) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_FILTER_GETS \ assert(sv) STATIC HV * S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_FIND_IN_MY_STASH \ assert(pkgname) STATIC char * S_tokenize_use(pTHX_ int is_use, char *s) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_TOKENIZE_USE \ assert(s) STATIC SV* S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen, SV *sv, SV *pv, const char *type, STRLEN typelen) __attribute__nonnull__(pTHX_3) __attribute__nonnull__(pTHX_5); #define PERL_ARGS_ASSERT_NEW_CONSTANT \ assert(key); assert(sv) STATIC int S_deprecate_commaless_var_list(pTHX); STATIC int S_ao(pTHX_ int toketype); # if defined(PERL_CR_FILTER) STATIC I32 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen); STATIC void S_strip_return(pTHX_ SV *sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_STRIP_RETURN \ assert(sv) # endif # if defined(DEBUGGING) STATIC int S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_TOKEREPORT \ assert(lvalp) STATIC void S_printbuf(pTHX_ const char *const fmt, const char *const s) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_PRINTBUF \ assert(fmt); assert(s) # endif #endif #if defined(PERL_IN_UNIVERSAL_C) || defined(PERL_DECL_PROT) STATIC bool S_isa_lookup(pTHX_ HV *stash, const char * const name) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_ISA_LOOKUP \ assert(stash); assert(name) STATIC HV * S_get_isa_hash(pTHX_ HV *const stash) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GET_ISA_HASH \ assert(stash) #endif #if defined(PERL_IN_LOCALE_C) || defined(PERL_DECL_PROT) #if defined(USE_LOCALE_NUMERIC) || defined(USE_LOCALE_COLLATE) STATIC char* S_stdize_locale(pTHX_ char* locs) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_STDIZE_LOCALE \ assert(locs) #endif #endif #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) STATIC const COP* S_closest_cop(pTHX_ const COP *cop, const OP *o) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CLOSEST_COP \ assert(cop) STATIC SV* S_mess_alloc(pTHX); STATIC SV * S_vdie_croak_common(pTHX_ const char *pat, va_list *args); STATIC bool S_vdie_common(pTHX_ SV *message, bool warn); STATIC char * S_write_no_mem(pTHX) __attribute__noreturn__; #if defined(PERL_MEM_LOG) && !defined(PERL_MEM_LOG_NOIMPL) 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) __attribute__nonnull__(4) __attribute__nonnull__(8) __attribute__nonnull__(10); #define PERL_ARGS_ASSERT_MEM_LOG_COMMON \ assert(type_name); assert(filename); assert(funcname) #endif #endif #if defined(PERL_IN_NUMERIC_C) || defined(PERL_DECL_PROT) STATIC NV S_mulexp10(NV value, I32 exponent); #endif #if defined(PERL_IN_UTF8_C) || defined(PERL_DECL_PROT) STATIC STRLEN S_is_utf8_char_slow(const U8 *s, const STRLEN len) __attribute__warn_unused_result__ __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_IS_UTF8_CHAR_SLOW \ assert(s) STATIC bool S_is_utf8_common(pTHX_ const U8 *const p, SV **swash, const char * const swashname) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_IS_UTF8_COMMON \ assert(p); assert(swash); assert(swashname) STATIC SV* S_swash_get(pTHX_ SV* swash, UV start, UV span) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SWASH_GET \ assert(swash) #endif START_EXTERN_C PERL_CALLCONV void Perl_sv_setsv_flags(pTHX_ SV *dstr, SV *sstr, const I32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_SETSV_FLAGS \ assert(dstr) PERL_CALLCONV void Perl_sv_catpvn_flags(pTHX_ SV *const dstr, const char *sstr, const STRLEN len, const I32 flags) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_CATPVN_FLAGS \ assert(dstr); assert(sstr) PERL_CALLCONV void Perl_sv_catsv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_CATSV_FLAGS \ assert(dsv) /* PERL_CALLCONV STRLEN Perl_sv_utf8_upgrade_flags(pTHX_ SV *const sv, const I32 flags) __attribute__nonnull__(pTHX_1); */ PERL_CALLCONV STRLEN Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW \ assert(sv) PERL_CALLCONV char* Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS \ assert(sv) PERL_CALLCONV void Perl_sv_copypv(pTHX_ SV *const dsv, SV *const ssv) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_COPYPV \ assert(dsv); assert(ssv) PERL_CALLCONV char* Perl_my_atof2(pTHX_ const char *s, NV* value) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MY_ATOF2 \ assert(s); assert(value) PERL_CALLCONV int Perl_my_socketpair(int family, int type, int protocol, int fd[2]); PERL_CALLCONV int Perl_my_dirfd(pTHX_ DIR* dir); #ifdef PERL_OLD_COPY_ON_WRITE PERL_CALLCONV SV* Perl_sv_setsv_cow(pTHX_ SV* dstr, SV* sstr) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_SETSV_COW \ assert(sstr) #endif PERL_CALLCONV const char * Perl_PerlIO_context_layers(pTHX_ const char *mode); #if defined(USE_PERLIO) && !defined(USE_SFIO) PERL_CALLCONV int Perl_PerlIO_close(pTHX_ PerlIO *f); PERL_CALLCONV int Perl_PerlIO_fill(pTHX_ PerlIO *f); PERL_CALLCONV int Perl_PerlIO_fileno(pTHX_ PerlIO *f); PERL_CALLCONV int Perl_PerlIO_eof(pTHX_ PerlIO *f); PERL_CALLCONV int Perl_PerlIO_error(pTHX_ PerlIO *f); PERL_CALLCONV int Perl_PerlIO_flush(pTHX_ PerlIO *f); PERL_CALLCONV void Perl_PerlIO_clearerr(pTHX_ PerlIO *f); PERL_CALLCONV void Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt); PERL_CALLCONV void Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR *ptr, int cnt); PERL_CALLCONV void Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f); PERL_CALLCONV SSize_t Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_PERLIO_READ \ assert(vbuf) PERL_CALLCONV SSize_t Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_PERLIO_WRITE \ assert(vbuf) PERL_CALLCONV SSize_t Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_PERLIO_UNREAD \ assert(vbuf) PERL_CALLCONV Off_t Perl_PerlIO_tell(pTHX_ PerlIO *f); PERL_CALLCONV int Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence); PERL_CALLCONV STDCHAR * Perl_PerlIO_get_base(pTHX_ PerlIO *f); PERL_CALLCONV STDCHAR * Perl_PerlIO_get_ptr(pTHX_ PerlIO *f); PERL_CALLCONV int Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f) __attribute__warn_unused_result__; PERL_CALLCONV int Perl_PerlIO_get_cnt(pTHX_ PerlIO *f) __attribute__warn_unused_result__; PERL_CALLCONV PerlIO * Perl_PerlIO_stdin(pTHX) __attribute__warn_unused_result__; PERL_CALLCONV PerlIO * Perl_PerlIO_stdout(pTHX) __attribute__warn_unused_result__; PERL_CALLCONV PerlIO * Perl_PerlIO_stderr(pTHX) __attribute__warn_unused_result__; #endif /* PERLIO_LAYERS */ PERL_CALLCONV void Perl_deb_stack_all(pTHX); #if defined(PERL_IN_DEB_C) || defined(PERL_DECL_PROT) STATIC void S_deb_stack_n(pTHX_ SV** stack_base, I32 stack_min, I32 stack_max, I32 mark_min, I32 mark_max) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DEB_STACK_N \ assert(stack_base) #endif PERL_CALLCONV PADLIST* Perl_pad_new(pTHX_ int flags) __attribute__malloc__ __attribute__warn_unused_result__; PERL_CALLCONV void Perl_pad_undef(pTHX_ CV* cv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_PAD_UNDEF \ assert(cv) PERL_CALLCONV PADOFFSET Perl_pad_add_name(pTHX_ const char *name, const STRLEN len, const U32 flags, HV *typestash, HV *ourstash) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_PAD_ADD_NAME \ assert(name) PERL_CALLCONV PADOFFSET Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_PAD_ADD_ANON \ assert(sv) #if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT) STATIC void S_pad_check_dup(pTHX_ SV *name, const U32 flags, const HV *ourstash) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_PAD_CHECK_DUP \ assert(name) #endif #ifdef DEBUGGING PERL_CALLCONV void Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_PAD_SETSV \ assert(sv) #endif PERL_CALLCONV void Perl_pad_block_start(pTHX_ int full); PERL_CALLCONV void Perl_pad_tidy(pTHX_ padtidy_type type); PERL_CALLCONV void Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_DO_DUMP_PAD \ assert(file) PERL_CALLCONV void Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS \ assert(padlist); assert(old_cv); assert(new_cv) PERL_CALLCONV void Perl_pad_push(pTHX_ PADLIST *padlist, int depth) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_PAD_PUSH \ assert(padlist) PERL_CALLCONV HV* Perl_pad_compname_type(pTHX_ const PADOFFSET po) __attribute__warn_unused_result__; #if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT) STATIC PADOFFSET S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn, SV** out_capture, SV** out_name_sv, int *out_flags) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_6) __attribute__nonnull__(pTHX_7); #define PERL_ARGS_ASSERT_PAD_FINDLEX \ assert(name); assert(cv); assert(out_name_sv); assert(out_flags) STATIC PADOFFSET S_pad_add_name_sv(pTHX_ SV *namesv, const U32 flags, HV *typestash, HV *ourstash) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_PAD_ADD_NAME_SV \ assert(namesv) # if defined(DEBUGGING) STATIC void S_cv_dump(pTHX_ const CV *cv, const char *title) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_CV_DUMP \ assert(cv); assert(title) # endif #endif PERL_CALLCONV CV* Perl_find_runcv(pTHX_ U32 *db_seqp) __attribute__warn_unused_result__; PERL_CALLCONV void Perl_free_tied_hv_pool(pTHX); #if defined(DEBUGGING) PERL_CALLCONV int Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GET_DEBUG_OPTS \ assert(s) #endif PERL_CALLCONV void Perl_save_set_svflags(pTHX_ SV *sv, U32 mask, U32 val) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SAVE_SET_SVFLAGS \ assert(sv) #ifdef DEBUGGING PERL_CALLCONV void Perl_hv_assert(pTHX_ HV *hv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_HV_ASSERT \ assert(hv) #endif PERL_CALLCONV SV* Perl_hv_scalar(pTHX_ HV *hv) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_HV_SCALAR \ assert(hv) PERL_CALLCONV I32* Perl_hv_riter_p(pTHX_ HV *hv) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_HV_RITER_P \ assert(hv) PERL_CALLCONV HE** Perl_hv_eiter_p(pTHX_ HV *hv) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_HV_EITER_P \ assert(hv) PERL_CALLCONV void Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_HV_RITER_SET \ assert(hv) PERL_CALLCONV void Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_HV_EITER_SET \ assert(hv) PERL_CALLCONV void Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_HV_NAME_SET \ assert(hv) PERL_CALLCONV AV** Perl_hv_backreferences_p(pTHX_ HV *hv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_HV_BACKREFERENCES_P \ assert(hv) #if defined(PERL_IN_DUMP_C) || defined(PERL_IN_HV_C) || defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) PERL_CALLCONV void Perl_hv_kill_backrefs(pTHX_ HV *hv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_HV_KILL_BACKREFS \ assert(hv) #endif PERL_CALLCONV void Perl_hv_clear_placeholders(pTHX_ HV *hv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_HV_CLEAR_PLACEHOLDERS \ assert(hv) PERL_CALLCONV I32* Perl_hv_placeholders_p(pTHX_ HV *hv) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_HV_PLACEHOLDERS_P \ assert(hv) PERL_CALLCONV I32 Perl_hv_placeholders_get(pTHX_ const HV *hv) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_HV_PLACEHOLDERS_GET \ assert(hv) PERL_CALLCONV void Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET \ assert(hv) PERL_CALLCONV SV* Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_SCALARPACK \ assert(hv); assert(mg) #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) STATIC SV * S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT \ assert(val) STATIC I32 S_find_array_subscript(pTHX_ const AV *const av, const SV *const val) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT \ assert(val) STATIC SV* S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, bool top); #endif #ifdef PERL_NEED_MY_HTOLE16 PERL_CALLCONV U16 Perl_my_htole16(U16 n); #endif #ifdef PERL_NEED_MY_LETOH16 PERL_CALLCONV U16 Perl_my_letoh16(U16 n); #endif #ifdef PERL_NEED_MY_HTOBE16 PERL_CALLCONV U16 Perl_my_htobe16(U16 n); #endif #ifdef PERL_NEED_MY_BETOH16 PERL_CALLCONV U16 Perl_my_betoh16(U16 n); #endif #ifdef PERL_NEED_MY_HTOLE32 PERL_CALLCONV U32 Perl_my_htole32(U32 n); #endif #ifdef PERL_NEED_MY_LETOH32 PERL_CALLCONV U32 Perl_my_letoh32(U32 n); #endif #ifdef PERL_NEED_MY_HTOBE32 PERL_CALLCONV U32 Perl_my_htobe32(U32 n); #endif #ifdef PERL_NEED_MY_BETOH32 PERL_CALLCONV U32 Perl_my_betoh32(U32 n); #endif #ifdef PERL_NEED_MY_HTOLE64 PERL_CALLCONV U64 Perl_my_htole64(U64 n); #endif #ifdef PERL_NEED_MY_LETOH64 PERL_CALLCONV U64 Perl_my_letoh64(U64 n); #endif #ifdef PERL_NEED_MY_HTOBE64 PERL_CALLCONV U64 Perl_my_htobe64(U64 n); #endif #ifdef PERL_NEED_MY_BETOH64 PERL_CALLCONV U64 Perl_my_betoh64(U64 n); #endif #ifdef PERL_NEED_MY_HTOLES PERL_CALLCONV short Perl_my_htoles(short n); #endif #ifdef PERL_NEED_MY_LETOHS PERL_CALLCONV short Perl_my_letohs(short n); #endif #ifdef PERL_NEED_MY_HTOBES PERL_CALLCONV short Perl_my_htobes(short n); #endif #ifdef PERL_NEED_MY_BETOHS PERL_CALLCONV short Perl_my_betohs(short n); #endif #ifdef PERL_NEED_MY_HTOLEI PERL_CALLCONV int Perl_my_htolei(int n); #endif #ifdef PERL_NEED_MY_LETOHI PERL_CALLCONV int Perl_my_letohi(int n); #endif #ifdef PERL_NEED_MY_HTOBEI PERL_CALLCONV int Perl_my_htobei(int n); #endif #ifdef PERL_NEED_MY_BETOHI PERL_CALLCONV int Perl_my_betohi(int n); #endif #ifdef PERL_NEED_MY_HTOLEL PERL_CALLCONV long Perl_my_htolel(long n); #endif #ifdef PERL_NEED_MY_LETOHL PERL_CALLCONV long Perl_my_letohl(long n); #endif #ifdef PERL_NEED_MY_HTOBEL PERL_CALLCONV long Perl_my_htobel(long n); #endif #ifdef PERL_NEED_MY_BETOHL PERL_CALLCONV long Perl_my_betohl(long n); #endif PERL_CALLCONV void Perl_my_swabn(void* ptr, int n) __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_MY_SWABN \ assert(ptr) PERL_CALLCONV GV* Perl_gv_fetchpvn_flags(pTHX_ const char* name, STRLEN len, I32 flags, const svtype sv_type) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS \ assert(name) PERL_CALLCONV GV* Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GV_FETCHSV \ assert(name) PERL_CALLCONV bool Perl_is_gv_magical_sv(pTHX_ SV *const name_sv, U32 flags) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_IS_GV_MAGICAL_SV \ assert(name_sv) PERL_CALLCONV bool Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_STASHPV_HVNAME_MATCH \ assert(c); assert(hv) #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP PERL_CALLCONV void Perl_dump_sv_child(pTHX_ SV *sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DUMP_SV_CHILD \ assert(sv) #endif #ifdef PERL_DONT_CREATE_GVSV /* PERL_CALLCONV GV* Perl_gv_SVadd(pTHX_ GV *gv); */ #endif #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) STATIC bool S_ckwarn_common(pTHX_ U32 w); #endif PERL_CALLCONV bool Perl_ckwarn(pTHX_ U32 w); PERL_CALLCONV bool Perl_ckwarn_d(pTHX_ U32 w); PERL_CALLCONV STRLEN * Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits, STRLEN size) __attribute__malloc__ __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD \ assert(bits) PERL_CALLCONV void Perl_offer_nice_chunk(pTHX_ void *const chunk, const U32 chunk_size) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_OFFER_NICE_CHUNK \ assert(chunk) #ifndef SPRINTF_RETURNS_STRLEN PERL_CALLCONV int Perl_my_sprintf(char *buffer, const char *pat, ...) __attribute__nonnull__(1) __attribute__nonnull__(2); #define PERL_ARGS_ASSERT_MY_SPRINTF \ assert(buffer); assert(pat) #endif PERL_CALLCONV int Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...) __attribute__format__(__printf__,3,4) __attribute__nonnull__(1) __attribute__nonnull__(3); #define PERL_ARGS_ASSERT_MY_SNPRINTF \ assert(buffer); assert(format) PERL_CALLCONV int Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap) __attribute__nonnull__(1) __attribute__nonnull__(3); #define PERL_ARGS_ASSERT_MY_VSNPRINTF \ assert(buffer); assert(format) PERL_CALLCONV void Perl_my_clearenv(pTHX); #ifdef PERL_IMPLICIT_CONTEXT #ifdef PERL_GLOBAL_STRUCT_PRIVATE PERL_CALLCONV void* Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_MY_CXT_INIT \ assert(my_cxt_key) PERL_CALLCONV int Perl_my_cxt_index(pTHX_ const char *my_cxt_key) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_MY_CXT_INDEX \ assert(my_cxt_key) #else PERL_CALLCONV void* Perl_my_cxt_init(pTHX_ int *index, size_t size) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_MY_CXT_INIT \ assert(index) #endif #endif #ifndef HAS_STRLCAT PERL_CALLCONV Size_t Perl_my_strlcat(char *dst, const char *src, Size_t size); #endif #ifndef HAS_STRLCPY PERL_CALLCONV Size_t Perl_my_strlcpy(char *dst, const char *src, Size_t size); #endif #ifdef PERL_MAD PERL_CALLCONV void Perl_pad_peg(const char* s) __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_PAD_PEG \ assert(s) #if defined(PERL_IN_DUMP_C) || defined(PERL_DECL_PROT) STATIC void S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...) __attribute__format__(__printf__,pTHX_3,pTHX_4) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_XMLDUMP_ATTR \ assert(file); assert(pat) #endif PERL_CALLCONV void Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...) __attribute__format__(__printf__,pTHX_3,pTHX_4) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_XMLDUMP_INDENT \ assert(file); assert(pat) PERL_CALLCONV void Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_XMLDUMP_VINDENT \ assert(file); assert(pat) PERL_CALLCONV void Perl_xmldump_all(pTHX); PERL_CALLCONV void Perl_xmldump_all_perl(pTHX_ bool justperl); PERL_CALLCONV void Perl_xmldump_packsubs(pTHX_ const HV* stash) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS \ assert(stash) PERL_CALLCONV void Perl_xmldump_packsubs_perl(pTHX_ const HV* stash, bool justperl) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL \ assert(stash) PERL_CALLCONV void Perl_xmldump_sub(pTHX_ const GV* gv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_XMLDUMP_SUB \ assert(gv) PERL_CALLCONV void Perl_xmldump_sub_perl(pTHX_ const GV* gv, bool justperl) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL \ assert(gv) PERL_CALLCONV void Perl_xmldump_form(pTHX_ const GV* gv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_XMLDUMP_FORM \ assert(gv) PERL_CALLCONV void Perl_xmldump_eval(pTHX); PERL_CALLCONV char* Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_CATXMLSV \ assert(dsv); assert(ssv) PERL_CALLCONV char* Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_SV_CATXMLPVN \ assert(dsv); assert(pv) PERL_CALLCONV char* Perl_sv_xmlpeek(pTHX_ SV* sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_XMLPEEK \ assert(sv) PERL_CALLCONV void Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP \ assert(file) PERL_CALLCONV void Perl_pmop_xmldump(pTHX_ const PMOP* pm); PERL_CALLCONV void Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_DO_OP_XMLDUMP \ assert(file) PERL_CALLCONV void Perl_op_xmldump(pTHX_ const OP *o) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_OP_XMLDUMP \ assert(o) PERL_CALLCONV TOKEN* Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop); PERL_CALLCONV void Perl_token_free(pTHX_ TOKEN *tk) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_TOKEN_FREE \ assert(tk) PERL_CALLCONV void Perl_token_getmad(pTHX_ TOKEN *tk, OP *o, char slot) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_TOKEN_GETMAD \ assert(tk) PERL_CALLCONV void Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot); PERL_CALLCONV void Perl_op_getmad(pTHX_ OP* from, OP* o, char slot); PERL_CALLCONV void Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot); PERL_CALLCONV void Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot); PERL_CALLCONV void Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot); PERL_CALLCONV MADPROP* Perl_newMADsv(pTHX_ char key, SV* sv) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_NEWMADSV \ assert(sv) PERL_CALLCONV MADPROP* Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen); PERL_CALLCONV void Perl_mad_free(pTHX_ MADPROP* mp); # if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT) STATIC char* S_skipspace0(pTHX_ char *s) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SKIPSPACE0 \ assert(s) STATIC char* S_skipspace1(pTHX_ char *s) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SKIPSPACE1 \ assert(s) STATIC char* S_skipspace2(pTHX_ char *s, SV **sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SKIPSPACE2 \ assert(s) STATIC void S_start_force(pTHX_ int where); STATIC void S_curmad(pTHX_ char slot, SV *sv); # endif PERL_CALLCONV int Perl_madlex(pTHX); PERL_CALLCONV int Perl_madparse(pTHX); #endif #if !defined(HAS_SIGNBIT) PERL_CALLCONV int Perl_signbit(NV f) __attribute__pure__; #endif PERL_CALLCONV void Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_EMULATE_COP_IO \ assert(c); assert(sv) PERL_CALLCONV REGEXP * Perl_get_re_arg(pTHX_ SV *sv); PERL_CALLCONV SV* Perl_mro_get_private_data(pTHX_ struct mro_meta *const smeta, const struct mro_alg *const which) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MRO_GET_PRIVATE_DATA \ assert(smeta); assert(which) PERL_CALLCONV SV* Perl_mro_set_private_data(pTHX_ struct mro_meta *const smeta, const struct mro_alg *const which, SV *const data) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_MRO_SET_PRIVATE_DATA \ assert(smeta); assert(which); assert(data) PERL_CALLCONV const struct mro_alg * Perl_mro_get_from_name(pTHX_ SV *name) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_MRO_GET_FROM_NAME \ assert(name) PERL_CALLCONV void Perl_mro_register(pTHX_ const struct mro_alg *mro) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_MRO_REGISTER \ assert(mro) PERL_CALLCONV void Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MRO_SET_MRO \ assert(meta); assert(name) PERL_CALLCONV struct mro_meta* Perl_mro_meta_init(pTHX_ HV* stash) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_MRO_META_INIT \ assert(stash) #if defined(USE_ITHREADS) PERL_CALLCONV struct mro_meta* Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MRO_META_DUP \ assert(smeta); assert(param) #endif PERL_CALLCONV AV* Perl_mro_get_linear_isa(pTHX_ HV* stash) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA \ assert(stash) #if defined(PERL_IN_MRO_C) || defined(PERL_DECL_PROT) STATIC AV* S_mro_get_linear_isa_dfs(pTHX_ HV* stash, U32 level) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS \ assert(stash) #endif PERL_CALLCONV void Perl_mro_isa_changed_in(pTHX_ HV* stash) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN \ assert(stash) PERL_CALLCONV void Perl_mro_method_changed_in(pTHX_ HV* stash) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN \ assert(stash) PERL_CALLCONV void Perl_boot_core_mro(pTHX); PERL_CALLCONV void Perl_sys_init(int* argc, char*** argv) __attribute__nonnull__(1) __attribute__nonnull__(2); #define PERL_ARGS_ASSERT_SYS_INIT \ assert(argc); assert(argv) PERL_CALLCONV void Perl_sys_init3(int* argc, char*** argv, char*** env) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__nonnull__(3); #define PERL_ARGS_ASSERT_SYS_INIT3 \ assert(argc); assert(argv); assert(env) PERL_CALLCONV void Perl_sys_term(void); PERL_CALLCONV const char * Perl_fetch_cop_label(pTHX_ struct refcounted_he *const chain, STRLEN *len, U32 *flags); PERL_CALLCONV struct refcounted_he * Perl_store_cop_label(pTHX_ struct refcounted_he *const chain, const char *label) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_STORE_COP_LABEL \ assert(label) PERL_CALLCONV int Perl_keyword_plugin_standard(pTHX_ char* keyword_ptr, STRLEN keyword_len, OP** op_ptr) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD \ assert(keyword_ptr); assert(op_ptr) END_EXTERN_C /* * ex: set ts=8 sts=4 sw=4 noet: */ /* ex: set ro: */ perl-5.12.0-RC0/configure.gnu0000555000175000017500000000506711143650473014640 0ustar jessejesse#! /bin/sh # # $Id: configure,v 3.0.1.1 1995/07/25 14:16:21 ram Exp $ # # GNU configure-like front end to metaconfig's Configure. # # Written by Andy Dougherty # and Matthew Green . # # Reformatted and modified for inclusion in the dist-3.0 package by # Raphael Manfredi . # # This script belongs to the public domain and may be freely redistributed. # # The remaining of this leading shell comment may be removed if you # include this script in your own package. # # $Log: configure,v $ # Revision 3.0.1.1 1995/07/25 14:16:21 ram # patch56: created # (exit $?0) || exec sh $0 $argv:q case "$0" in *configure) if cmp $0 `echo $0 | sed -e s/configure/Configure/` >/dev/null; then echo "Your configure and Configure scripts seem to be identical." echo "This can happen on filesystems that aren't fully case sensitive." echo "You'll have to explicitly extract Configure and run that." exit 1 fi ;; esac opts='' verbose='' create='-e' while test $# -gt 0; do case $1 in --help) cat </dev/null 2>&1 shift ;; --verbose) verbose=true shift ;; --version) copt="$copt -V" shift ;; --*) opt=`echo $1 | sed 's/=.*//'` echo "This GNU configure front end does not understand $opt" exit 1 ;; *) opts="$opts '$1'" shift ;; esac done case "$CC" in '') ;; *) opts="$opts -Dcc='$CC'";; esac # Join DEFS and CFLAGS together. ccflags='' case "$DEFS" in '') ;; *) ccflags=$DEFS;; esac case "$CFLAGS" in '') ;; *) ccflags="$ccflags $CFLAGS";; esac case "$ccflags" in '') ;; *) opts="$opts -Dccflags='$ccflags'";; esac case "$LDFLAGS" in '') ;; *) ldflags="$ldflags $LDFLAGS";; esac case "$ldflags" in '') ;; *) opts="$opts -Dldflags='$ldflags'";; esac # Don't use -s if they want verbose mode case "$verbose" in '') copt="$copt -ds";; *) copt="$copt -d";; esac eval "set X sh Configure $copt $create $opts" shift echo "$@" exec "$@" perl-5.12.0-RC0/README.os20000444000175000017500000026477011347250766013542 0ustar jessejesseIf you read this file _as_is_, just ignore the funny characters you see. It is written in the POD format (see perlpod manpage) which is specially designed to be readable as is. =head1 NAME perlos2 - Perl under OS/2, DOS, Win0.3*, Win0.95 and WinNT. =head1 SYNOPSIS One can read this document in the following formats: man perlos2 view perl perlos2 explorer perlos2.html info perlos2 to list some (not all may be available simultaneously), or it may be read I: either as F, or F. To read the F<.INF> version of documentation (B recommended) outside of OS/2, one needs an IBM's reader (may be available on IBM ftp sites (?) (URL anyone?)) or shipped with PC DOS 7.0 and IBM's Visual Age C++ 3.5. A copy of a Win* viewer is contained in the "Just add OS/2 Warp" package ftp://ftp.software.ibm.com/ps/products/os2/tools/jaow/jaow.zip in F. This gives one an access to EMX's F<.INF> docs as well (text form is available in F in EMX's distribution). There is also a different viewer named xview. Note that if you have F or F installed, you can follow WWW links from this document in F<.INF> format. If you have EMX docs installed correctly, you can follow library links (you need to have C working by setting C environment variable as it is described in EMX docs). =cut Contents (This may be a little bit obsolete) perlos2 - Perl under OS/2, DOS, Win0.3*, Win0.95 and WinNT. NAME SYNOPSIS DESCRIPTION - Target - Other OSes - Prerequisites - Starting Perl programs under OS/2 (and DOS and...) - Starting OS/2 (and DOS) programs under Perl Frequently asked questions - "It does not work" - I cannot run external programs - I cannot embed perl into my program, or use perl.dll from my - `` and pipe-open do not work under DOS. - Cannot start find.exe "pattern" file INSTALLATION - Automatic binary installation - Manual binary installation - Warning Accessing documentation - OS/2 .INF file - Plain text - Manpages - HTML - GNU info files - PDF files - LaTeX docs BUILD - The short story - Prerequisites - Getting perl source - Application of the patches - Hand-editing - Making - Testing - Installing the built perl - a.out-style build Build FAQ - Some / became \ in pdksh. - 'errno' - unresolved external - Problems with tr or sed - Some problem (forget which ;-) - Library ... not found - Segfault in make - op/sprintf test failure Specific (mis)features of OS/2 port - setpriority, getpriority - system() - extproc on the first line - Additional modules: - Prebuilt methods: - Prebuilt variables: - Misfeatures - Modifications - Identifying DLLs - Centralized management of resources Perl flavors - perl.exe - perl_.exe - perl__.exe - perl___.exe - Why strange names? - Why dynamic linking? - Why chimera build? ENVIRONMENT - PERLLIB_PREFIX - PERL_BADLANG - PERL_BADFREE - PERL_SH_DIR - USE_PERL_FLOCK - TMP or TEMP Evolution - Text-mode filehandles - Priorities - DLL name mangling: pre 5.6.2 - DLL name mangling: 5.6.2 and beyond - DLL forwarder generation - Threading - Calls to external programs - Memory allocation - Threads BUGS AUTHOR SEE ALSO =head1 DESCRIPTION =head2 Target The target is to make OS/2 one of the best supported platform for using/building/developing Perl and I, as well as make Perl the best language to use under OS/2. The secondary target is to try to make this work under DOS and Win* as well (but not B hard). The current state is quite close to this target. Known limitations: =over 5 =item * Some *nix programs use fork() a lot; with the mostly useful flavors of perl for OS/2 (there are several built simultaneously) this is supported; but some flavors do not support this (e.g., when Perl is called from inside REXX). Using fork() after Iing dynamically loading extensions would not work with I old versions of EMX. =item * You need a separate perl executable F (see L) if you want to use PM code in your application (as Perl/Tk or OpenGL Perl modules do) without having a text-mode window present. While using the standard F from a text-mode window is possible too, I have seen cases when this causes degradation of the system stability. Using F avoids such a degradation. =item * There is no simple way to access WPS objects. The only way I know is via C and C extensions (see L, L). However, we do not have access to convenience methods of Object-REXX. (Is it possible at all? I know of no Object-REXX API.) The C extension (currently in alpha-text) may eventually remove this shortcoming; however, due to the fact that DII is not supported by the C module, using C is not as convenient as one would like it. =back Please keep this list up-to-date by informing me about other items. =head2 Other OSes Since OS/2 port of perl uses a remarkable EMX environment, it can run (and build extensions, and - possibly - be built itself) under any environment which can run EMX. The current list is DOS, DOS-inside-OS/2, Win0.3*, Win0.95 and WinNT. Out of many perl flavors, only one works, see L<"perl_.exe">. Note that not all features of Perl are available under these environments. This depends on the features the I - most probably RSX - decided to implement. Cf. L. =head2 Prerequisites =over 6 =item EMX EMX runtime is required (may be substituted by RSX). Note that it is possible to make F to run under DOS without any external support by binding F/F to it, see L. Note that under DOS for best results one should use RSX runtime, which has much more functions working (like C, C and so on). In fact RSX is required if there is no VCPI present. Note the RSX requires DPMI. Many implementations of DPMI are known to be very buggy, beware! Only the latest runtime is supported, currently C<0.9d fix 03>. Perl may run under earlier versions of EMX, but this is not tested. One can get different parts of EMX from, say ftp://crydee.sai.msu.ru/pub/comp/os/os2/leo/gnu/emx+gcc/ http://hobbes.nmsu.edu/h-browse.php?dir=/pub/os2/dev/emx/v0.9d/ The runtime component should have the name F. B. When using F/F, it is enough to have them on your path. One does not need to specify them explicitly (though this emx perl_.exe -de 0 will work as well.) =item RSX To run Perl on DPMI platforms one needs RSX runtime. This is needed under DOS-inside-OS/2, Win0.3*, Win0.95 and WinNT (see L<"Other OSes">). RSX would not work with VCPI only, as EMX would, it requires DMPI. Having RSX and the latest F one gets a fully functional B<*nix>-ish environment under DOS, say, C, C<``> and pipe-C work. In fact, MakeMaker works (for static build), so one can have Perl development environment under DOS. One can get RSX from, say http://cd.textfiles.com/hobbesos29804/disk1/EMX09C/ ftp://crydee.sai.msu.ru/pub/comp/os/os2/leo/gnu/emx+gcc/contrib/ Contact the author on C. The latest F with DOS hooks is available in http://www.ilyaz.org/software/os2/ as F or under similar names starting with C, C etc. =item HPFS Perl does not care about file systems, but the perl library contains many files with long names, so to install it intact one needs a file system which supports long file names. Note that if you do not plan to build the perl itself, it may be possible to fool EMX to truncate file names. This is not supported, read EMX docs to see how to do it. =item pdksh To start external programs with complicated command lines (like with pipes in between, and/or quoting of arguments), Perl uses an external shell. With EMX port such shell should be named F, and located either in the wired-in-during-compile locations (usually F), or in configurable location (see L<"PERL_SH_DIR">). For best results use EMX pdksh. The standard binary (5.2.14 or later) runs under DOS (with L) as well, see http://www.ilyaz.org/software/os2/ =back =head2 Starting Perl programs under OS/2 (and DOS and...) Start your Perl program F with arguments C the same way as on any other platform, by perl foo.pl arg1 arg2 arg3 If you want to specify perl options C<-my_opts> to the perl itself (as opposed to your program), use perl -my_opts foo.pl arg1 arg2 arg3 Alternately, if you use OS/2-ish shell, like CMD or 4os2, put the following at the start of your perl script: extproc perl -S -my_opts rename your program to F, and start it by typing foo arg1 arg2 arg3 Note that because of stupid OS/2 limitations the full path of the perl script is not available when you use C, thus you are forced to use C<-S> perl switch, and your script should be on the C. As a plus side, if you know a full path to your script, you may still start it with perl ../../blah/foo.cmd arg1 arg2 arg3 (note that the argument C<-my_opts> is taken care of by the C line in your script, see L on the first line>). To understand what the above I does, read perl docs about C<-S> switch - see L, and cmdref about C: view perl perlrun man perlrun view cmdref extproc help extproc or whatever method you prefer. There are also endless possibilities to use I of 4os2, I of WPS and so on... However, if you use *nixish shell (like F supplied in the binary distribution), you need to follow the syntax specified in L. Note that B<-S> switch supports scripts with additional extensions F<.cmd>, F<.btm>, F<.bat>, F<.pl> as well. =head2 Starting OS/2 (and DOS) programs under Perl This is what system() (see L), C<``> (see L), and I (see L) are for. (Avoid exec() (see L) unless you know what you do). Note however that to use some of these operators you need to have a sh-syntax shell installed (see L<"Pdksh">, L<"Frequently asked questions">), and perl should be able to find it (see L<"PERL_SH_DIR">). The cases when the shell is used are: =over =item 1 One-argument system() (see L), exec() (see L) with redirection or shell meta-characters; =item 2 Pipe-open (see L) with the command which contains redirection or shell meta-characters; =item 3 Backticks C<``> (see L) with the command which contains redirection or shell meta-characters; =item 4 If the executable called by system()/exec()/pipe-open()/C<``> is a script with the "magic" C<#!> line or C line which specifies shell; =item 5 If the executable called by system()/exec()/pipe-open()/C<``> is a script without "magic" line, and C<$ENV{EXECSHELL}> is set to shell; =item 6 If the executable called by system()/exec()/pipe-open()/C<``> is not found (is not this remark obsolete?); =item 7 For globbing (see L, L) (obsolete? Perl uses builtin globbing nowadays...). =back For the sake of speed for a common case, in the above algorithms backslashes in the command name are not considered as shell metacharacters. Perl starts scripts which begin with cookies C or C<#!> directly, without an intervention of shell. Perl uses the same algorithm to find the executable as F: if the path on C<#!> line does not work, and contains C, then the directory part of the executable is ignored, and the executable is searched in F<.> and on C. To find arguments for these scripts Perl uses a different algorithm than F: up to 3 arguments are recognized, and trailing whitespace is stripped. If a script does not contain such a cooky, then to avoid calling F, Perl uses the same algorithm as F: if C<$ENV{EXECSHELL}> is set, the script is given as the first argument to this command, if not set, then C<$ENV{COMSPEC} /c> is used (or a hardwired guess if C<$ENV{COMSPEC}> is not set). When starting scripts directly, Perl uses exactly the same algorithm as for the search of script given by B<-S> command-line option: it will look in the current directory, then on components of C<$ENV{PATH}> using the following order of appended extensions: no extension, F<.cmd>, F<.btm>, F<.bat>, F<.pl>. Note that Perl will start to look for scripts only if OS/2 cannot start the specified application, thus C will not look for a script if there is an executable file F I on C. In other words, C is essentially searched twice: once by the OS for an executable, then by Perl for scripts. Note also that executable files on OS/2 can have an arbitrary extension, but F<.exe> will be automatically appended if no dot is present in the name. The workaround is as simple as that: since F and F denote the same file (at list on FAT and HPFS file systems), to start an executable residing in file F (no extension) give an argument C (dot appended) to system(). Perl will start PM programs from VIO (=text-mode) Perl process in a separate PM session; the opposite is not true: when you start a non-PM program from a PM Perl process, Perl would not run it in a separate session. If a separate session is desired, either ensure that shell will be used, as in C, or start it using optional arguments to system() documented in C module. This is considered to be a feature. =head1 Frequently asked questions =head2 "It does not work" Perl binary distributions come with a F script which tries to detect common problems with misconfigured installations. There is a pretty large chance it will discover which step of the installation you managed to goof. C<;-)> =head2 I cannot run external programs =over 4 =item * Did you run your programs with C<-w> switch? See L. =item * Do you try to run I shell commands, like C<`copy a b`> (internal for F), or C<`glob a*b`> (internal for ksh)? You need to specify your shell explicitly, like C<`cmd /c copy a b`>, since Perl cannot deduce which commands are internal to your shell. =back =head2 I cannot embed perl into my program, or use F from my program. =over 4 =item Is your program EMX-compiled with C<-Zmt -Zcrtdll>? Well, nowadays Perl DLL should be usable from a differently compiled program too... If you can run Perl code from REXX scripts (see L), then there are some other aspect of interaction which are overlooked by the current hackish code to support differently-compiled principal programs. If everything else fails, you need to build a stand-alone DLL for perl. Contact me, I did it once. Sockets would not work, as a lot of other stuff. =item Did you use L? Some time ago I had reports it does not work. Nowadays it is checked in the Perl test suite, so grep F<./t> subdirectory of the build tree (as well as F<*.t> files in the F<./lib> subdirectory) to find how it should be done "correctly". =back =head2 C<``> and pipe-C do not work under DOS. This may a variant of just L<"I cannot run external programs">, or a deeper problem. Basically: you I RSX (see L<"Prerequisites">) for these commands to work, and you may need a port of F which understands command arguments. One of such ports is listed in L<"Prerequisites"> under RSX. Do not forget to set variable C> as well. DPMI is required for RSX. =head2 Cannot start C The whole idea of the "standard C API to start applications" is that the forms C and C<"foo"> of program arguments are completely interchangable. F breaks this paradigm; find "pattern" file find pattern file are not equivalent; F cannot be started directly using the above API. One needs a way to surround the doublequotes in some other quoting construction, necessarily having an extra non-Unixish shell in between. Use one of system 'cmd', '/c', 'find "pattern" file'; `cmd /c 'find "pattern" file'` This would start F via F via C via C, but this is a price to pay if you want to use non-conforming program. =head1 INSTALLATION =head2 Automatic binary installation The most convenient way of installing a binary distribution of perl is via perl installer F. Just follow the instructions, and 99% of the installation blues would go away. Note however, that you need to have F on your path, and EMX environment I. The latter means that if you just installed EMX, and made all the needed changes to F, you may need to reboot in between. Check EMX runtime by running emxrev Binary installer also creates a folder on your desktop with some useful objects. If you need to change some aspects of the work of the binary installer, feel free to edit the file F. This may be useful e.g., if you need to run the installer many times and do not want to make many interactive changes in the GUI. B =over 15 =item C may be needed if you change your codepage I perl installation, and the new value is not supported by EMX. See L<"PERL_BADLANG">. =item C see L<"PERL_BADFREE">. =item F This file resides somewhere deep in the location you installed your perl library, find it out by perl -MConfig -le "print $INC{'Config.pm'}" While most important values in this file I updated by the binary installer, some of them may need to be hand-edited. I know no such data, please keep me informed if you find one. Moreover, manual changes to the installed version may need to be accompanied by an edit of this file. =back B. Because of a typo the binary installer of 5.00305 would install a variable C into F. Please remove this variable and put C> instead. =head2 Manual binary installation As of version 5.00305, OS/2 perl binary distribution comes split into 11 components. Unfortunately, to enable configurable binary installation, the file paths in the zip files are not absolute, but relative to some directory. Note that the extraction with the stored paths is still necessary (default with unzip, specify C<-d> to pkunzip). However, you need to know where to extract the files. You need also to manually change entries in F to reflect where did you put the files. Note that if you have some primitive unzipper (like C), you may get a lot of warnings/errors during unzipping. Upgrade to C<(w)unzip>. Below is the sample of what to do to reproduce the configuration on my machine. In F you can press C now, and cut-and-paste from the resulting file - created in the directory you started F from. For each component, we mention environment variables related to each installation directory. Either choose directories to match your values of the variables, or create/append-to variables to take into account the directories. =over 3 =item Perl VIO and PM executables (dynamically linked) unzip perl_exc.zip *.exe *.ico -d f:/emx.add/bin unzip perl_exc.zip *.dll -d f:/emx.add/dll (have the directories with C<*.exe> on PATH, and C<*.dll> on LIBPATH); =item Perl_ VIO executable (statically linked) unzip perl_aou.zip -d f:/emx.add/bin (have the directory on PATH); =item Executables for Perl utilities unzip perl_utl.zip -d f:/emx.add/bin (have the directory on PATH); =item Main Perl library unzip perl_mlb.zip -d f:/perllib/lib If this directory is exactly the same as the prefix which was compiled into F, you do not need to change anything. However, for perl to find the library if you use a different path, you need to C in F, see L<"PERLLIB_PREFIX">. =item Additional Perl modules unzip perl_ste.zip -d f:/perllib/lib/site_perl/5.12.0/ Same remark as above applies. Additionally, if this directory is not one of directories on @INC (and @INC is influenced by C), you need to put this directory and subdirectory F<./os2> in C or C variable. Do not use C unless you have it set already. See L. B<[Check whether this extraction directory is still applicable with the new directory structure layout!]> =item Tools to compile Perl modules unzip perl_blb.zip -d f:/perllib/lib Same remark as for F. =item Manpages for Perl and utilities unzip perl_man.zip -d f:/perllib/man This directory should better be on C. You need to have a working F to access these files. =item Manpages for Perl modules unzip perl_mam.zip -d f:/perllib/man This directory should better be on C. You need to have a working man to access these files. =item Source for Perl documentation unzip perl_pod.zip -d f:/perllib/lib This is used by the C program (see L), and may be used to generate HTML documentation usable by WWW browsers, and documentation in zillions of other formats: C, C, C, C and so on. [Use programs such as F etc.] =item Perl manual in F<.INF> format unzip perl_inf.zip -d d:/os2/book This directory should better be on C. =item Pdksh unzip perl_sh.zip -d f:/bin This is used by perl to run external commands which explicitly require shell, like the commands using I and I. It is also used instead of explicit F. Set C (see L<"PERL_SH_DIR">) if you move F from the above location. B It may be possible to use some other sh-compatible shell (untested). =back After you installed the components you needed and updated the F correspondingly, you need to hand-edit F. This file resides somewhere deep in the location you installed your perl library, find it out by perl -MConfig -le "print $INC{'Config.pm'}" You need to correct all the entries which look like file paths (they currently start with C). =head2 B The automatic and manual perl installation leave precompiled paths inside perl executables. While these paths are overwriteable (see L<"PERLLIB_PREFIX">, L<"PERL_SH_DIR">), some people may prefer binary editing of paths inside the executables/DLLs. =head1 Accessing documentation Depending on how you built/installed perl you may have (otherwise identical) Perl documentation in the following formats: =head2 OS/2 F<.INF> file Most probably the most convenient form. Under OS/2 view it as view perl view perl perlfunc view perl less view perl ExtUtils::MakeMaker (currently the last two may hit a wrong location, but this may improve soon). Under Win* see L<"SYNOPSIS">. If you want to build the docs yourself, and have I, run pod2ipf > perl.ipf in F directory, then ipfc /inf perl.ipf (Expect a lot of errors during the both steps.) Now move it on your BOOKSHELF path. =head2 Plain text If you have perl documentation in the source form, perl utilities installed, and GNU groff installed, you may use perldoc perlfunc perldoc less perldoc ExtUtils::MakeMaker to access the perl documentation in the text form (note that you may get better results using perl manpages). Alternately, try running pod2text on F<.pod> files. =head2 Manpages If you have F installed on your system, and you installed perl manpages, use something like this: man perlfunc man 3 less man ExtUtils.MakeMaker to access documentation for different components of Perl. Start with man perl Note that dot (F<.>) is used as a package separator for documentation for packages, and as usual, sometimes you need to give the section - C<3> above - to avoid shadowing by the I. Make sure that the directory B the directory with manpages is on our C, like this set MANPATH=c:/man;f:/perllib/man for Perl manpages in C etc. =head2 HTML If you have some WWW browser available, installed the Perl documentation in the source form, and Perl utilities, you can build HTML docs. Cd to directory with F<.pod> files, and do like this cd f:/perllib/lib/pod pod2html After this you can direct your browser the file F in this directory, and go ahead with reading docs, like this: explore file:///f:/perllib/lib/pod/perl.html Alternatively you may be able to get these docs prebuilt from CPAN. =head2 GNU C files Users of Emacs would appreciate it very much, especially with C mode loaded. You need to get latest C from C, or, alternately, the prebuilt info pages. =head2 F files for C are available on CPAN (may be for slightly older version of perl). =head2 C docs can be constructed using C. =head1 BUILD Here we discuss how to build Perl under OS/2. =head2 The short story Assume that you are a seasoned porter, so are sure that all the necessary tools are already present on your system, and you know how to get the Perl source distribution. Untar it, change to the extract directory, and gnupatch -p0 < os2\diff.configure sh Configure -des -D prefix=f:/perllib make make test make install make aout_test make aout_install This puts the executables in f:/perllib/bin. Manually move them to the C, manually move the built F to C (here for Perl DLL F<*> is a not-very-meaningful hex checksum), and run make installcmd INSTALLCMDDIR=d:/ir/on/path Assuming that the C-files were put on an appropriate location, this completes the installation of minimal Perl system. (The binary distribution contains also a lot of additional modules, and the documentation in INF format.) What follows is a detailed guide through these steps. =head2 Prerequisites You need to have the latest EMX development environment, the full GNU tool suite (gawk renamed to awk, and GNU F earlier on path than the OS/2 F, same with F, to check use find --version sort --version ). You need the latest version of F installed as F. Check that you have B libraries and headers installed, and - optionally - Berkeley DB headers and libraries, and crypt. Possible locations to get the files: ftp://ftp.uni-heidelberg.de/pub/os2/unix/ http://hobbes.nmsu.edu/h-browse.php?dir=/pub/os2 http://cd.textfiles.com/hobbesos29804/disk1/DEV32/ http://cd.textfiles.com/hobbesos29804/disk1/EMX09C/ It is reported that the following archives contain enough utils to build perl: F, F, F, F, F, F, F, F, F and F (or a later version). Note that all these utilities are known to be available from LEO: ftp://crydee.sai.msu.ru/pub/comp/os/os2/leo/gnu/ Note also that the F and F from the EMX distribution are not suitable for multi-threaded compile (even single-threaded flavor of Perl uses multi-threaded C RTL, for compatibility with XFree86-OS/2). Get a corrected one from http://www.ilyaz.org/software/os2/db_mt.zip If you have I installed already, make sure that no copies or perl are currently running. Later steps of the build may fail since an older version of F loaded into memory may be found. Running C becomes meaningless, since the test are checking a previous build of perl (this situation is detected and reported by F test). Do not forget to unset C in environment. Also make sure that you have F directory on the current drive, and F<.> directory in your C. One may try to correct the latter condition by set BEGINLIBPATH .\. if you use something like F or latest versions of F<4os2.exe>. (Setting BEGINLIBPATH to just C<.> is ignored by the OS/2 kernel.) Make sure your gcc is good for C<-Zomf> linking: run C script in F directory. Check that you have link386 installed. It comes standard with OS/2, but may be not installed due to customization. If typing link386 shows you do not have it, do I, and choose C in I. If you get into link386 prompts, press C to exit. =head2 Getting perl source You need to fetch the latest perl source (including developers releases). With some probability it is located in http://www.cpan.org/src/ http://www.cpan.org/src/unsupported If not, you may need to dig in the indices to find it in the directory of the current maintainer. Quick cycle of developers release may break the OS/2 build time to time, looking into http://www.cpan.org/ports/os2/ may indicate the latest release which was publicly released by the maintainer. Note that the release may include some additional patches to apply to the current source of perl. Extract it like this tar vzxf perl5.00409.tar.gz You may see a message about errors while extracting F. This is because there is a conflict with a similarly-named file F. Change to the directory of extraction. =head2 Application of the patches You need to apply the patches in F<./os2/diff.*> like this: gnupatch -p0 < os2\diff.configure You may also need to apply the patches supplied with the binary distribution of perl. It also makes sense to look on the perl5-porters mailing list for the latest OS/2-related patches (see L). Such patches usually contain strings C and C, so it makes sense looking for these strings. =head2 Hand-editing You may look into the file F<./hints/os2.sh> and correct anything wrong you find there. I do not expect it is needed anywhere. =head2 Making sh Configure -des -D prefix=f:/perllib C means: where to install the resulting perl library. Giving correct prefix you may avoid the need to specify C, see L<"PERLLIB_PREFIX">. I, and about C<-c> option to tr>. The latter is most probably already fixed, if you see it and can trace where the latter spurious warning comes from, please inform me. Now make At some moment the built may die, reporting a I or I>. This means that you do not have F<.> in your LIBPATH, so F cannot find the needed F (treat these hex digits as line noise). After this is fixed the build should finish without a lot of fuss. =head2 Testing Now run make test All tests should succeed (with some of them skipped). If you have the same version of Perl installed, it is crucial that you have C<.> early in your LIBPATH (or in BEGINLIBPATH), otherwise your tests will most probably test the wrong version of Perl. Some tests may generate extra messages similar to =over 4 =item A lot of C in database tests related to Berkeley DB. I If it persists, you may disable this warnings, see L<"PERL_BADFREE">. =item Process terminated by SIGTERM/SIGINT This is a standard message issued by OS/2 applications. *nix applications die in silence. It is considered to be a feature. One can easily disable this by appropriate sighandlers. However the test engine bleeds these message to screen in unexpected moments. Two messages of this kind I be present during testing. =back To get finer test reports, call perl t/harness The report with F failing may look like this: Failed Test Status Wstat Total Fail Failed List of failed ------------------------------------------------------------ io/pipe.t 12 1 8.33% 9 7 tests skipped, plus 56 subtests skipped. Failed 1/195 test scripts, 99.49% okay. 1/6542 subtests failed, 99.98% okay. The reasons for most important skipped tests are: =over 8 =item F =over 4 =item 18 Checks C and C of C - unfortunately, HPFS provides only 2sec time granularity (for compatibility with FAT?). =item 25 Checks C on a filehandle just opened for write - I do not know why this should or should not work. =back =item F Checks C. Tests: =over 4 =item 4 Checks C and C of C - unfortunately, HPFS provides only 2sec time granularity (for compatibility with FAT?). =back =back =head2 Installing the built perl If you haven't yet moved C onto LIBPATH, do it now. Run make install It would put the generated files into needed locations. Manually put F, F and F to a location on your PATH, F to a location on your LIBPATH. Run make installcmd INSTALLCMDDIR=d:/ir/on/path to convert perl utilities to F<.cmd> files and put them on PATH. You need to put F<.EXE>-utilities on path manually. They are installed in C<$prefix/bin>, here C<$prefix> is what you gave to F, see L. If you use C, either move the installed F<*/man/> directories to your C, or modify C to match the location. (One could have avoided this by providing a correct C option to F<./Configure>, or editing F<./config.sh> between configuring and making steps.) =head2 C-style build Proceed as above, but make F (see L<"perl_.exe">) by make perl_ test and install by make aout_test make aout_install Manually put F to a location on your PATH. B The build process for C I about all the dependencies, so you should make sure that anything is up-to-date, say, by doing make perl_dll first. =head1 Building a binary distribution [This section provides a short overview only...] Building should proceed differently depending on whether the version of perl you install is already present and used on your system, or is a new version not yet used. The description below assumes that the version is new, so installing its DLLs and F<.pm> files will not disrupt the operation of your system even if some intermediate steps are not yet fully working. The other cases require a little bit more convoluted procedures. Below I suppose that the current version of Perl is C<5.8.2>, so the executables are named accordingly. =over =item 1. Fully build and test the Perl distribution. Make sure that no tests are failing with C and C targets; fix the bugs in Perl and the Perl test suite detected by these tests. Make sure that C make target runs as clean as possible. Check that C runs fine. =item 2. Fully install Perl, including C target. Copy the generated DLLs to C; copy the numbered Perl executables (as in F) to C; copy C to C as C. Think whether you need backward-compatibility DLLs. In most cases you do not need to install them yet; but sometime this may simplify the following steps. =item 3. Make sure that C can download files from CPAN. If not, you may need to manually install C. =item 4. Install the bundle C perl5.8.2 -MCPAN -e "install Bundle::OS2_default" < nul |& tee 00cpan_i_1 This may take a couple of hours on 1GHz processor (when run the first time). And this should not be necessarily a smooth procedure. Some modules may not specify required dependencies, so one may need to repeat this procedure several times until the results stabilize. perl5.8.2 -MCPAN -e "install Bundle::OS2_default" < nul |& tee 00cpan_i_2 perl5.8.2 -MCPAN -e "install Bundle::OS2_default" < nul |& tee 00cpan_i_3 Even after they stabilize, some tests may fail. Fix as many discovered bugs as possible. Document all the bugs which are not fixed, and all the failures with unknown reasons. Inspect the produced logs F<00cpan_i_1> to find suspiciously skipped tests, and other fishy events. Keep in mind that I of some modules may fail too: for example, the DLLs to update may be already loaded by F. Inspect the C logs (in the example above F<00cpan_i_1> etc) for errors, and install things manually, as in cd $CPANHOME/.cpan/build/Digest-MD5-2.31 make install Some distributions may fail some tests, but you may want to install them anyway (as above, or via C command of C shell-mode). Since this procedure may take quite a long time to complete, it makes sense to "freeze" your CPAN configuration by disabling periodic updates of the local copy of CPAN index: set C to some big value (I use 365), then save the settings CPAN> o conf index_expire 365 CPAN> o conf commit Reset back to the default value C<1> when you are finished. =item 5. When satisfied with the results, rerun the C target. Now you can copy C to C, and install the other OMF-build executables: C etc. They are ready to be used. =item 6. Change to the C<./pod> directory of the build tree, download the Perl logo F, and run ( perl2ipf > perl.ipf ) |& tee 00ipf ipfc /INF perl.ipf |& tee 00inf This produces the Perl docs online book C. Install in on C path. =item 7. Now is the time to build statically linked executable F which includes newly-installed via C modules. Doing testing via C is going to be painfully slow, since it statically links a new executable per XS extension. Here is a possible workaround: create a toplevel F in F<$CPANHOME/.cpan/build/> with contents being (compare with L) use ExtUtils::MakeMaker; WriteMakefile NAME => 'dummy'; execute this as perl_5.8.2.exe Makefile.PL 's in subdirectories may be buggy, and would not run as "child" scripts. The interdependency of modules can strike you; however, since non-XS modules are already installed, the prerequisites of most modules have a very good chance to be present. If you discover some glitches, move directories of problematic modules to a different location; if these modules are non-XS modules, you may just ignore them - they are already installed; the remaining, XS, modules you need to install manually one by one. After each such removal you need to rerun the C/C process; usually this procedure converges soon. (But be sure to convert all the necessary external C libraries from F<.lib> format to F<.a> format: run one of emxaout foo.lib emximp -o foo.a foo.lib whichever is appropriate.) Also, make sure that the DLLs for external libraries are usable with with executables compiled without C<-Zmtd> options. When you are sure that only a few subdirectories lead to failures, you may want to add C<-j4> option to C to speed up skipping subdirectories with already finished build. When you are satisfied with the results of tests, install the build C libraries for extensions: make install |& tee 00aout_i Now you can rename the file F<./perl.exe> generated during the last phase to F; place it on C; if there is an inter-dependency between some XS modules, you may need to repeat the C/C loop with this new executable and some excluded modules - until the procedure converges. Now you have all the necessary F<.a> libraries for these Perl modules in the places where Perl builder can find it. Use the perl builder: change to an empty directory, create a "dummy" F again, and run perl_5.8.2.exe Makefile.PL |& tee 00c make perl |& tee 00p This should create an executable F<./perl.exe> with all the statically loaded extensions built in. Compare the generated F files to make sure that during the iterations the number of loaded extensions only increases. Rename F<./perl.exe> to F on C. When it converges, you got a functional variant of F; copy it to C. You are done with generation of the local Perl installation. =item 8. Make sure that the installed modules are actually installed in the location of the new Perl, and are not inherited from entries of @INC given for inheritance from the older versions of Perl: set C to redirect the new version of Perl to a new location, and copy the installed files to this new location. Redo the tests to make sure that the versions of modules inherited from older versions of Perl are not needed. Actually, the log output of L during the step 6 gives a very detailed info about which modules are loaded from which place; so you may use it as an additional verification tool. Check that some temporary files did not make into the perl install tree. Run something like this pfind . -f "!(/\.(pm|pl|ix|al|h|a|lib|txt|pod|imp|bs|dll|ld|bs|inc|xbm|yml|cgi|uu|e2x|skip|packlist|eg|cfg|html|pub|enc|all|ini|po|pot)$/i or /^\w+$/") | less in the install tree (both top one and F one). Compress all the DLLs with F. The tiny F<.exe> can be compressed with C (the bug only appears when there is a fixup in the last 6 bytes of a page (?); since the tiny executables are much smaller than a page, the bug will not hit). Do not compress C - it would not work under DOS. =item 9. Now you can generate the binary distribution. This is done by running the test of the CPAN distribution C. Tune up the file F to suit the layout of current version of Perl first. Do not forget to pack the necessary external DLLs accordingly. Include the description of the bugs and test suite failures you could not fix. Include the small-stack versions of Perl executables from Perl build directory. Include F so that people can relink the perl DLL preserving the binary compatibility, or can create compatibility DLLs. Include the diff files (C) of fixes you did so that people can rebuild your version. Include F so that one can use remote debugging. =item 10. Share what you did with the other people. Relax. Enjoy fruits of your work. =item 11. Brace yourself for thanks, bug reports, hate mail and spam coming as result of the previous step. No good deed should remain unpunished! =back =head1 Building custom F<.EXE> files The Perl executables can be easily rebuilt at any moment. Moreover, one can use the I interface (see L) to make very customized executables. =head2 Making executables with a custom collection of statically loaded extensions It is a little bit easier to do so while I the list of statically loaded extensions. We discuss this case only here. =over =item 1. Change to an empty directory, and create a placeholder : use ExtUtils::MakeMaker; WriteMakefile NAME => 'dummy'; =item 2. Run it with the flavor of Perl (F or F) you want to rebuild. perl_ Makefile.PL =item 3. Ask it to create new Perl executable: make perl (you may need to manually add C to this commandline on some versions of Perl; the symptom is that the command-line globbing does not work from OS/2 shells with the newly-compiled executable; check with .\perl.exe -wle "print for @ARGV" * ). =item 4. The previous step created F which contains a list of newXS() calls near the end. Removing unnecessary calls, and rerunning make perl will produce a customized executable. =back =head2 Making executables with a custom search-paths The default perl executable is flexible enough to support most usages. However, one may want something yet more flexible; for example, one may want to find Perl DLL relatively to the location of the EXE file; or one may want to ignore the environment when setting the Perl-library search patch, etc. If you fill comfortable with I interface (see L), such things are easy to do repeating the steps outlined in L, and doing more comprehensive edits to main() of F. The people with little desire to understand Perl can just rename main(), and do necessary modification in a custom main() which calls the renamed function in appropriate time. However, there is a third way: perl DLL exports the main() function and several callbacks to customize the search path. Below is a complete example of a "Perl loader" which =over =item 1. Looks for Perl DLL in the directory C<$exedir/../dll>; =item 2. Prepends the above directory to C; =item 3. Fails if the Perl DLL found via C is different from what was loaded on step 1; e.g., another process could have loaded it from C or from a different value of C. In these cases one needs to modify the setting of the system so that this other process either does not run, or loads the DLL from C with C (available with kernels after September 2000). =item 4. Loads Perl library from C<$exedir/../dll/lib/>. =item 5. Uses Bourne shell from C<$exedir/../dll/sh/ksh.exe>. =back For best results compile the C file below with the same options as the Perl DLL. However, a lot of functionality will work even if the executable is not an EMX applications, e.g., if compiled with gcc -Wall -DDOSISH -DOS2=1 -O2 -s -Zomf -Zsys perl-starter.c -DPERL_DLL_BASENAME=\"perl312F\" -Zstack 8192 -Zlinker /PM:VIO Here is the sample C file: #define INCL_DOS #define INCL_NOPM /* These are needed for compile if os2.h includes os2tk.h, not os2emx.h */ #define INCL_DOSPROCESS #include #include "EXTERN.h" #define PERL_IN_MINIPERLMAIN_C #include "perl.h" static char *me; HMODULE handle; static void die_with(char *msg1, char *msg2, char *msg3, char *msg4) { ULONG c; char *s = " error: "; DosWrite(2, me, strlen(me), &c); DosWrite(2, s, strlen(s), &c); DosWrite(2, msg1, strlen(msg1), &c); DosWrite(2, msg2, strlen(msg2), &c); DosWrite(2, msg3, strlen(msg3), &c); DosWrite(2, msg4, strlen(msg4), &c); DosWrite(2, "\r\n", 2, &c); exit(255); } typedef ULONG (*fill_extLibpath_t)(int type, char *pre, char *post, int replace, char *msg); typedef int (*main_t)(int type, char *argv[], char *env[]); typedef int (*handler_t)(void* data, int which); #ifndef PERL_DLL_BASENAME # define PERL_DLL_BASENAME "perl" #endif static HMODULE load_perl_dll(char *basename) { char buf[300], fail[260]; STRLEN l, dirl; fill_extLibpath_t f; ULONG rc_fullname; HMODULE handle, handle1; if (_execname(buf, sizeof(buf) - 13) != 0) die_with("Can't find full path: ", strerror(errno), "", ""); /* XXXX Fill `me' with new value */ l = strlen(buf); while (l && buf[l-1] != '/' && buf[l-1] != '\\') l--; dirl = l - 1; strcpy(buf + l, basename); l += strlen(basename); strcpy(buf + l, ".dll"); if ( (rc_fullname = DosLoadModule(fail, sizeof fail, buf, &handle)) != 0 && DosLoadModule(fail, sizeof fail, basename, &handle) != 0 ) die_with("Can't load DLL ", buf, "", ""); if (rc_fullname) return handle; /* was loaded with short name; all is fine */ if (DosQueryProcAddr(handle, 0, "fill_extLibpath", (PFN*)&f)) die_with(buf, ": DLL exports no symbol ", "fill_extLibpath", ""); buf[dirl] = 0; if (f(0 /*BEGINLIBPATH*/, buf /* prepend */, NULL /* append */, 0 /* keep old value */, me)) die_with(me, ": prepending BEGINLIBPATH", "", ""); if (DosLoadModule(fail, sizeof fail, basename, &handle1) != 0) die_with(me, ": finding perl DLL again via BEGINLIBPATH", "", ""); buf[dirl] = '\\'; if (handle1 != handle) { if (DosQueryModuleName(handle1, sizeof(fail), fail)) strcpy(fail, "???"); die_with(buf, ":\n\tperl DLL via BEGINLIBPATH is different: \n\t", fail, "\n\tYou may need to manipulate global BEGINLIBPATH and LIBPATHSTRICT" "\n\tso that the other copy is loaded via BEGINLIBPATH."); } return handle; } int main(int argc, char **argv, char **env) { main_t f; handler_t h; me = argv[0]; /**/ handle = load_perl_dll(PERL_DLL_BASENAME); if (DosQueryProcAddr(handle, 0, "Perl_OS2_handler_install", (PFN*)&h)) die_with(PERL_DLL_BASENAME, ": DLL exports no symbol ", "Perl_OS2_handler_install", ""); if ( !h((void *)"~installprefix", Perlos2_handler_perllib_from) || !h((void *)"~dll", Perlos2_handler_perllib_to) || !h((void *)"~dll/sh/ksh.exe", Perlos2_handler_perl_sh) ) die_with(PERL_DLL_BASENAME, ": Can't install @INC manglers", "", ""); if (DosQueryProcAddr(handle, 0, "dll_perlmain", (PFN*)&f)) die_with(PERL_DLL_BASENAME, ": DLL exports no symbol ", "dll_perlmain", ""); return f(argc, argv, env); } =head1 Build FAQ =head2 Some C became C<\> in pdksh. You have a very old pdksh. See L. =head2 C<'errno'> - unresolved external You do not have MT-safe F. See L. =head2 Problems with tr or sed reported with very old version of tr and sed. =head2 Some problem (forget which ;-) You have an older version of F on your LIBPATH, which broke the build of extensions. =head2 Library ... not found You did not run C. See L. =head2 Segfault in make You use an old version of GNU make. See L. =head2 op/sprintf test failure This can result from a bug in emx sprintf which was fixed in 0.9d fix 03. =head1 Specific (mis)features of OS/2 port =head2 C, C Note that these functions are compatible with *nix, not with the older ports of '94 - 95. The priorities are absolute, go from 32 to -95, lower is quicker. 0 is the default priority. B. Calling C on a non-existing process could lock the system before Warp3 fixpak22. Starting with Warp3, Perl will use a workaround: it aborts getpriority() if the process is not present. This is not possible on older versions C<2.*>, and has a race condition anyway. =head2 C Multi-argument form of C allows an additional numeric argument. The meaning of this argument is described in L. When finding a program to run, Perl first asks the OS to look for executables on C (OS/2 adds extension F<.exe> if no extension is present). If not found, it looks for a script with possible extensions added in this order: no extension, F<.cmd>, F<.btm>, F<.bat>, F<.pl>. If found, Perl checks the start of the file for magic strings C<"#!"> and C<"extproc ">. If found, Perl uses the rest of the first line as the beginning of the command line to run this script. The only mangling done to the first line is extraction of arguments (currently up to 3), and ignoring of the path-part of the "interpreter" name if it can't be found using the full path. E.g., C may lead Perl to finding F with the first line being extproc /bin/bash -x -c If F is not found, then Perl looks for an executable F on C. If found in F, then the above system() is translated to system qw(C:/emx.add/bin/bash.exe -x -c C:/emx/bin/foo.cmd bar baz) One additional translation is performed: instead of F Perl uses the hardwired-or-customized shell (see C>). The above search for "interpreter" is recursive: if F executable is not found, but F is found, Perl will investigate its first line etc. The only hardwired limit on the recursion depth is implicit: there is a limit 4 on the number of additional arguments inserted before the actual arguments given to system(). In particular, if no additional arguments are specified on the "magic" first lines, then the limit on the depth is 4. If Perl finds that the found executable is of PM type when the current session is not, it will start the new process in a separate session of necessary type. Call via C to disable this magic. B. Due to the described logic, you need to explicitly specify F<.com> extension if needed. Moreover, if the executable F is requested, Perl will not look for F. [This may change in the future.] =head2 C on the first line If the first chars of a Perl script are C<"extproc ">, this line is treated as C<#!>-line, thus all the switches on this line are processed (twice if script was started via cmd.exe). See L. =head2 Additional modules: L, L, L, L, L. These modules provide access to additional numeric argument for C and to the information about the running process, to DLLs having functions with REXX signature and to the REXX runtime, to OS/2 databases in the F<.INI> format, and to Extended Attributes. Two additional extensions by Andreas Kaiser, C, and C, are included into C directory, mirrored on CPAN. Other OS/2-related extensions are available too. =head2 Prebuilt methods: =over 4 =item C used by C, see L. =item C used by C for DLL name mangling. =item C Self explanatory. =item C leaves drive as it is. =item C chanes the "current" drive. =item C means has drive letter and is_rooted. =item C means has leading C<[/\\]> (maybe after a drive-letter:). =item C means changes with current dir. =item C Interface to cwd from EMX. Used by C. =item C Really really odious function to implement. Returns absolute name of file which would have C if CWD were C. C defaults to the current dir. =item C Get current value of extended library search path. If C is present and positive, works with C, if negative, works with C, otherwise with C. =item C Set current value of extended library search path. If C is present and positive, works with , if negative, works with C, otherwise with C. =item C Returns C if it was not called yet, otherwise bit 1 is set if on the previous call do_harderror was enabled, bit 2 is set if on previous call do_exception was enabled. This function enables/disables error popups associated with hardware errors (Disk not ready etc.) and software exceptions. I know of no way to find out the state of popups I the first call to this function. =item C Returns C if it was not called yet, otherwise return false if errors were not requested to be written to a hard drive, or the drive letter if this was requested. This function may redirect error popups associated with hardware errors (Disk not ready etc.) and software exceptions to the file POPUPLOG.OS2 at the root directory of the specified drive. Overrides OS2::Error() specified by individual programs. Given argument undef will disable redirection. Has global effect, persists after the application exits. I know of no way to find out the state of redirection of popups to the disk I the first call to this function. =item OS2::SysInfo() Returns a hash with system information. The keys of the hash are MAX_PATH_LENGTH, MAX_TEXT_SESSIONS, MAX_PM_SESSIONS, MAX_VDM_SESSIONS, BOOT_DRIVE, DYN_PRI_VARIATION, MAX_WAIT, MIN_SLICE, MAX_SLICE, PAGE_SIZE, VERSION_MAJOR, VERSION_MINOR, VERSION_REVISION, MS_COUNT, TIME_LOW, TIME_HIGH, TOTPHYSMEM, TOTRESMEM, TOTAVAILMEM, MAXPRMEM, MAXSHMEM, TIMER_INTERVAL, MAX_COMP_LENGTH, FOREGROUND_FS_SESSION, FOREGROUND_PROCESS =item OS2::BootDrive() Returns a letter without colon. =item C, C Transforms the current application into a PM application and back. The argument true means that a real message loop is going to be served. OS2::MorphPM() returns the PM message queue handle as an integer. See L<"Centralized management of resources"> for additional details. =item C Fake on-demand retrieval of outstanding PM messages. If C is false, will not dispatch messages if a real message loop is known to be present. Returns number of messages retrieved. Dies with "QUITing..." if WM_QUIT message is obtained. =item C Retrieval of PM messages until window creation/destruction. If C is false, will not dispatch messages if a real message loop is known to be present. Returns change in number of windows. If C is given, it is incremented by the number of messages retrieved. Dies with "QUITing..." if WM_QUIT message is obtained. =item C the same as L<_control87(3)> of EMX. Takes integers as arguments, returns the previous coprocessor control word as an integer. Only bits in C which are present in C are changed in the control word. =item OS2::get_control87() gets the coprocessor control word as an integer. =item C The variant of OS2::_control87() with default values good for handling exception mask: if no C, uses exception mask part of C only. If no C, disables all the floating point exceptions. See L<"Misfeatures"> for details. =item C Gives the information about the Perl DLL or the DLL containing the C function bound to by C<&xsub>. The meaning of C is: default (2): full name; 0: handle; 1: module name. =back (Note that some of these may be moved to different libraries - eventually). =head2 Prebuilt variables: =over 4 =item $OS2::emx_rev numeric value is the same as _emx_rev of EMX, a string value the same as _emx_vprt (similar to C<0.9c>). =item $OS2::emx_env same as _emx_env of EMX, a number similar to 0x8001. =item $OS2::os_ver a number C. =item $OS2::is_aout true if the Perl library was compiled in AOUT format. =item $OS2::can_fork true if the current executable is an AOUT EMX executable, so Perl can fork. Do not use this, use the portable check for $Config::Config{dfork}. =item $OS2::nsyserror This variable (default is 1) controls whether to enforce the contents of $^E to start with C-like id. If set to 0, then the string value of $^E is what is available from the OS/2 message file. (Some messages in this file have an C-like id prepended, some not.) =back =head2 Misfeatures =over 4 =item * Since L is present in EMX, but is not functional, it is emulated by perl. To disable the emulations, set environment variable C. =item * Here is the list of things which may be "broken" on EMX (from EMX docs): =over 4 =item * The functions L, L, and L are not implemented. =item * L is not required and not implemented. =item * L is not yet implemented (dummy function). (Perl has a workaround.) =item * L: Special treatment of PID=0, PID=1 and PID=-1 is not implemented. =item * L: WUNTRACED Not implemented. waitpid() is not implemented for negative values of PID. =back Note that C does not work with the current version of EMX. =item * See L<"Text-mode filehandles">. =item * Unix-domain sockets on OS/2 live in a pseudo-file-system C. To avoid a failure to create a socket with a name of a different form, C<"/socket/"> is prepended to the socket name (unless it starts with this already). This may lead to problems later in case the socket is accessed via the "usual" file-system calls using the "initial" name. =item * Apparently, IBM used a compiler (for some period of time around '95?) which changes FP mask right and left. This is not I bad for IBM's programs, but the same compiler was used for DLLs which are used with general-purpose applications. When these DLLs are used, the state of floating-point flags in the application is not predictable. What is much worse, some DLLs change the floating point flags when in _DLLInitTerm() (e.g., F). This means that even if you do not I any function in the DLL, just the act of loading this DLL will reset your flags. What is worse, the same compiler was used to compile some HOOK DLLs. Given that HOOK dlls are executed in the context of I the applications in the system, this means a complete unpredictablity of floating point flags on systems using such HOOK DLLs. E.g., F of B origin changes the floating point flags on each write to the TTY of a VIO (windowed text-mode) applications. Some other (not completely debugged) situations when FP flags change include some video drivers (?), and some operations related to creation of the windows. People who code B may have more experience on this. Perl is generally used in the situation when all the floating-point exceptions are ignored, as is the default under EMX. If they are not ignored, some benign Perl programs would get a C and would die a horrible death. To circumvent this, Perl uses two hacks. They help against I type of damage only: FP flags changed when loading a DLL. One of the hacks is to disable floating point exceptions on Perl startup (as is the default with EMX). This helps only with compile-time-linked DLLs changing the flags before main() had a chance to be called. The other hack is to restore FP flags after a call to dlopen(). This helps against similar damage done by DLLs _DLLInitTerm() at runtime. Currently no way to switch these hacks off is provided. =back =head2 Modifications Perl modifies some standard C library calls in the following ways: =over 9 =item C C uses F if shell is required, cf. L<"PERL_SH_DIR">. =item C is created using C or C environment variable, via C. =item C If the current directory is not writable, file is created using modified C, so there may be a race condition. =item C a dummy implementation. =item C C special-cases F and F. =item C, C these EMX functions do not work if the path contains a trailing C. Perl contains a workaround for this. =item C Since L is present in EMX, but is not functional, it is emulated by perl. To disable the emulations, set environment variable C. =back =head2 Identifying DLLs All the DLLs built with the current versions of Perl have ID strings identifying the name of the extension, its version, and the version of Perl required for this DLL. Run C to find this info. =head2 Centralized management of resources Since to call certain OS/2 API one needs to have a correctly initialized C subsystem, OS/2-specific extensions may require getting Cs and Cs. If an extension would do it on its own, another extension could fail to initialize. Perl provides a centralized management of these resources: =over =item C To get the HAB, the extension should call C in C. After this call is performed, C may be accessed as C. There is no need to release the HAB after it is used. If by some reasons F cannot be included, use extern int Perl_hab_GET(void); instead. =item C There are two cases: =over =item * the extension needs an C only because some API will not work otherwise. Use C below. =item * the extension needs an C since it wants to engage in a PM event loop. Use C below. =back To get an C, the extension should call C in C. After this call is performed, C may be accessed as C. To signal to Perl that HMQ is not needed any more, call C. Perl process will automatically morph/unmorph itself into/from a PM process if HMQ is needed/not-needed. Perl will automatically enable/disable C message during shutdown if the message queue is served/not-served. B. If during a shutdown there is a message queue which did not disable WM_QUIT, and which did not process the received WM_QUIT message, the shutdown will be automatically cancelled. Do not call C unless you are going to process messages on an orderly basis. =item * Treating errors reported by OS/2 API There are two principal conventions (it is useful to call them C and C - though this part of the function signature is not always determined by the name of the API) of reporting the error conditions of OS/2 API. Most of C APIs report the error code as the result of the call (so 0 means success, and there are many types of errors). Most of C API report success/fail via the result being C/C; to find the reason for the failure one should call WinGetLastError() API. Some C entry points also overload a "meaningful" return value with the error indicator; having a 0 return value indicates an error. Yet some other C entry points overload things even more, and 0 return value may mean a successful call returning a valid value 0, as well as an error condition; in the case of a 0 return value one should call WinGetLastError() API to distinguish a successful call from a failing one. By convention, all the calls to OS/2 API should indicate their failures by resetting $^E. All the Perl-accessible functions which call OS/2 API may be broken into two classes: some die()s when an API error is encountered, the other report the error via a false return value (of course, this does not concern Perl-accessible functions which I a failure of the OS/2 API call, having some workarounds coded). Obviously, in the situation of the last type of the signature of an OS/2 API, it is must more convenient for the users if the failure is indicated by die()ing: one does not need to check $^E to know that something went wrong. If, however, this solution is not desirable by some reason, the code in question should reset $^E to 0 before making this OS/2 API call, so that the caller of this Perl-accessible function has a chance to distinguish a success-but-0-return value from a failure. (One may return undef as an alternative way of reporting an error.) The macros to simplify this type of error propagation are =over =item C Returns true on error, sets $^E. Expects expr() be a call of C-style API. =item C Returns true on error, sets $^E. Expects expr() be a call of C-style API. =item C Returns C, sets $^E from WinGetLastError() if C is false. =item C Returns C, sets $^E from WinGetLastError() if C is false, and die()s if C and $^E are true. The message to die is the concatenated strings C and C, separated by C<": "> from the contents of $^E. =item C Sets C to the return value of WinGetLastError(). =item C Sets C to the return value of WinGetLastError(), and sets $^E to the corresponding value. =item C Sets C to C, and sets $^E to the corresponding value. =back =item * Loading DLLs and ordinals in DLLs Some DLLs are only present in some versions of OS/2, or in some configurations of OS/2. Some exported entry points are present only in DLLs shipped with some versions of OS/2. If these DLLs and entry points were linked directly for a Perl executable/DLL or from a Perl extensions, this binary would work only with the specified versions/setups. Even if these entry points were not needed, the I of the executable (or DLL) would fail. For example, many newer useful APIs are not present in OS/2 v2; many PM-related APIs require DLLs not available on floppy-boot setup. To make these calls fail I, one should call these API via a dynamic linking API. There is a subsystem in Perl to simplify such type of calls. A large number of entry points available for such linking is provided (see C - and also C - in F). These ordinals can be accessed via the APIs: CallORD(), DeclFuncByORD(), DeclVoidFuncByORD(), DeclOSFuncByORD(), DeclWinFuncByORD(), AssignFuncPByORD(), DeclWinFuncByORD_CACHE(), DeclWinFuncByORD_CACHE_survive(), DeclWinFuncByORD_CACHE_resetError_survive(), DeclWinFunc_CACHE(), DeclWinFunc_CACHE_resetError(), DeclWinFunc_CACHE_survive(), DeclWinFunc_CACHE_resetError_survive() See the header files and the C code in the supplied OS/2-related modules for the details on usage of these functions. Some of these functions also combine dynaloading semantic with the error-propagation semantic discussed above. =back =head1 Perl flavors Because of idiosyncrasies of OS/2 one cannot have all the eggs in the same basket (though EMX environment tries hard to overcome this limitations, so the situation may somehow improve). There are 4 executables for Perl provided by the distribution: =head2 F The main workhorse. This is a chimera executable: it is compiled as an C-style executable, but is linked with C-style dynamic library F, and with dynamic CRT DLL. This executable is a VIO application. It can load perl dynamic extensions, and it can fork(). B Keep in mind that fork() is needed to open a pipe to yourself. =head2 F This is a statically linked C-style executable. It cannot load dynamic Perl extensions. The executable supplied in binary distributions has a lot of extensions prebuilt, thus the above restriction is important only if you use custom-built extensions. This executable is a VIO application. I The friends locked into C world would appreciate the fact that this executable runs under DOS, Win0.3*, Win0.95 and WinNT with an appropriate extender. See L<"Other OSes">. =head2 F This is the same executable as F, but it is a PM application. B Usually (unless explicitly redirected during the startup) STDIN, STDERR, and STDOUT of a PM application are redirected to F. However, it is possible to I them if you start C from a PM program which emulates a console window, like I of Emacs or EPM. Thus it I to use Perl debugger (see L) to debug your PM application (but beware of the message loop lockups - this will not work if you have a message queue to serve, unless you hook the serving into the getc() function of the debugger). Another way to see the output of a PM program is to run it as pm_prog args 2>&1 | cat - with a shell I from F, so that it does not create a link between a VIO session and the session of C. (Such a link closes the VIO window.) E.g., this works with F - or with Perl! open P, 'pm_prog args 2>&1 |' or die; print while

; The flavor F is required if you want to start your program without a VIO window present, but not Ced (run C for more info). Very useful for extensions which use PM, like C or C. Note also that the differences between PM and VIO executables are only in the I behaviour. One can start I executable in I kind of session by using the arguments C, C or C switches of the command C (of F or a similar shell). Alternatively, one can use the numeric first argument of the C Perl function (see L). =head2 F This is an C-style executable which is dynamically linked to F and CRT DLL. I know no advantages of this executable over C, but it cannot fork() at all. Well, one advantage is that the build process is not so convoluted as with C. It is a VIO application. =head2 Why strange names? Since Perl processes the C<#!>-line (cf. L, L, L, L), it should know when a program I. There is some naming convention which allows Perl to distinguish correct lines from wrong ones. The above names are almost the only names allowed by this convention which do not contain digits (which have absolutely different semantics). =head2 Why dynamic linking? Well, having several executables dynamically linked to the same huge library has its advantages, but this would not substantiate the additional work to make it compile. The reason is the complicated-to-developers but very quick and convenient-to-users "hard" dynamic linking used by OS/2. There are two distinctive features of the dyna-linking model of OS/2: first, all the references to external functions are resolved at the compile time; second, there is no runtime fixup of the DLLs after they are loaded into memory. The first feature is an enormous advantage over other models: it avoids conflicts when several DLLs used by an application export entries with the same name. In such cases "other" models of dyna-linking just choose between these two entry points using some random criterion - with predictable disasters as results. But it is the second feature which requires the build of F. The address tables of DLLs are patched only once, when they are loaded. The addresses of the entry points into DLLs are guaranteed to be the same for all the programs which use the same DLL. This removes the runtime fixup - once DLL is loaded, its code is read-only. While this allows some (significant?) performance advantages, this makes life much harder for developers, since the above scheme makes it impossible for a DLL to be "linked" to a symbol in the F<.EXE> file. Indeed, this would need a DLL to have different relocations tables for the (different) executables which use this DLL. However, a dynamically loaded Perl extension is forced to use some symbols from the perl executable, e.g., to know how to find the arguments to the functions: the arguments live on the perl internal evaluation stack. The solution is to put the main code of the interpreter into a DLL, and make the F<.EXE> file which just loads this DLL into memory and supplies command-arguments. The extension DLL cannot link to symbols in F<.EXE>, but it has no problem linking to symbols in the F<.DLL>. This I increases the load time for the application (as well as complexity of the compilation). Since interpreter is in a DLL, the C RTL is basically forced to reside in a DLL as well (otherwise extensions would not be able to use CRT). There are some advantages if you use different flavors of perl, such as running F and F simultaneously: they share the memory of F. B. There is one additional effect which makes DLLs more wasteful: DLLs are loaded in the shared memory region, which is a scarse resource given the 512M barrier of the "standard" OS/2 virtual memory. The code of F<.EXE> files is also shared by all the processes which use the particular F<.EXE>, but they are "shared in the private address space of the process"; this is possible because the address at which different sections of the F<.EXE> file are loaded is decided at compile-time, thus all the processes have these sections loaded at same addresses, and no fixup of internal links inside the F<.EXE> is needed. Since DLLs may be loaded at run time, to have the same mechanism for DLLs one needs to have the address range of I DLLs in the system to be available I which did not load a particular DLL yet. This is why the DLLs are mapped to the shared memory region. =head2 Why chimera build? Current EMX environment does not allow DLLs compiled using Unixish C format to export symbols for data (or at least some types of data). This forces C-style compile of F. Current EMX environment does not allow F<.EXE> files compiled in C format to fork(). fork() is needed for exactly three Perl operations: =over 4 =item * explicit fork() in the script, =item * C =item * C, in other words, opening pipes to itself. =back While these operations are not questions of life and death, they are needed for a lot of useful scripts. This forces C-style compile of F. =head1 ENVIRONMENT Here we list environment variables with are either OS/2- and DOS- and Win*-specific, or are more important under OS/2 than under other OSes. =head2 C Specific for EMX port. Should have the form path1;path2 or path1 path2 If the beginning of some prebuilt path matches F, it is substituted with F. Should be used if the perl library is moved from the default location in preference to C, since this would not leave wrong entries in @INC. For example, if the compiled version of perl looks for @INC in F, and you want to install the library in F, do set PERLLIB_PREFIX=f:/perllib/lib;h:/opt/gnu This will cause Perl with the prebuilt @INC of f:/perllib/lib/5.00553/os2 f:/perllib/lib/5.00553 f:/perllib/lib/site_perl/5.00553/os2 f:/perllib/lib/site_perl/5.00553 . to use the following @INC: h:/opt/gnu/5.00553/os2 h:/opt/gnu/5.00553 h:/opt/gnu/site_perl/5.00553/os2 h:/opt/gnu/site_perl/5.00553 . =head2 C If 0, perl ignores setlocale() failing. May be useful with some strange Is. =head2 C If 0, perl would not warn of in case of unwarranted free(). With older perls this might be useful in conjunction with the module DB_File, which was buggy when dynamically linked and OMF-built. Should not be set with newer Perls, since this may hide some I problems. =head2 C Specific for EMX port. Gives the directory part of the location for F. =head2 C Specific for EMX port. Since L is present in EMX, but is not functional, it is emulated by perl. To disable the emulations, set environment variable C. =head2 C or C Specific for EMX port. Used as storage place for temporary files. =head1 Evolution Here we list major changes which could make you by surprise. =head2 Text-mode filehandles Starting from version 5.8, Perl uses a builtin translation layer for text-mode files. This replaces the efficient well-tested EMX layer by some code which should be best characterized as a "quick hack". In addition to possible bugs and an inability to follow changes to the translation policy with off/on switches of TERMIO translation, this introduces a serious incompatible change: before sysread() on text-mode filehandles would go through the translation layer, now it would not. =head2 Priorities C and C are not compatible with earlier ports by Andreas Kaiser. See C<"setpriority, getpriority">. =head2 DLL name mangling: pre 5.6.2 With the release 5.003_01 the dynamically loadable libraries should be rebuilt when a different version of Perl is compiled. In particular, DLLs (including F) are now created with the names which contain a checksum, thus allowing workaround for OS/2 scheme of caching DLLs. It may be possible to code a simple workaround which would =over =item * find the old DLLs looking through the old @INC; =item * mangle the names according to the scheme of new perl and copy the DLLs to these names; =item * edit the internal C tables of DLL to reflect the change of the name (probably not needed for Perl extension DLLs, since the internally coded names are not used for "specific" DLLs, they used only for "global" DLLs). =item * edit the internal C tables and change the name of the "old" F to the "new" F. =back =head2 DLL name mangling: 5.6.2 and beyond In fact mangling of I DLLs was done due to misunderstanding of the OS/2 dynaloading model. OS/2 (effectively) maintains two different tables of loaded DLL: =over =item Global DLLs those loaded by the base name from C; including those associated at link time; =item specific DLLs loaded by the full name. =back When resolving a request for a global DLL, the table of already-loaded specific DLLs is (effectively) ignored; moreover, specific DLLs are I loaded from the prescribed path. There is/was a minor twist which makes this scheme fragile: what to do with DLLs loaded from =over =item C and C (which depend on the process) =item F<.> from C which I depends on the process (although C is the same for all the processes). =back Unless C is set to C (and the kernel is after 2000/09/01), such DLLs are considered to be global. When loading a global DLL it is first looked in the table of already-loaded global DLLs. Because of this the fact that one executable loaded a DLL from C and C, or F<.> from C may affect I DLL is loaded when I executable requests a DLL with the same name. I is the reason for version-specific mangling of the DLL name for perl DLL. Since the Perl extension DLLs are always loaded with the full path, there is no need to mangle their names in a version-specific ways: their directory already reflects the corresponding version of perl, and @INC takes into account binary compatibility with older version. Starting from C<5.6.2> the name mangling scheme is fixed to be the same as for Perl 5.005_53 (same as in a popular binary release). Thus new Perls will be able to I of old extension DLLs if @INC allows finding their directories. However, this still does not guarantee that these DLL may be loaded. The reason is the mangling of the name of the I. And since the extension DLLs link with the Perl DLL, extension DLLs for older versions would load an older Perl DLL, and would most probably segfault (since the data in this DLL is not properly initialized). There is a partial workaround (which can be made complete with newer OS/2 kernels): create a forwarder DLL with the same name as the DLL of the older version of Perl, which forwards the entry points to the newer Perl's DLL. Make this DLL accessible on (say) the C of the new Perl executable. When the new executable accesses old Perl's extension DLLs, they would request the old Perl's DLL by name, get the forwarder instead, so effectively will link with the currently running (new) Perl DLL. This may break in two ways: =over =item * Old perl executable is started when a new executable is running has loaded an extension compiled for the old executable (ouph!). In this case the old executable will get a forwarder DLL instead of the old perl DLL, so would link with the new perl DLL. While not directly fatal, it will behave the same as new executable. This beats the whole purpose of explicitly starting an old executable. =item * A new executable loads an extension compiled for the old executable when an old perl executable is running. In this case the extension will not pick up the forwarder - with fatal results. =back With support for C this may be circumvented - unless one of DLLs is started from F<.> from C (I do not know whether C affects this case). B. Unless newer kernels allow F<.> in C (older do not), this mess cannot be completely cleaned. (It turns out that as of the beginning of 2002, F<.> is not allowed, but F<.\.> is - and it has the same effect.) B. C, C and C are not environment variables, although F emulates them on C lines. From Perl they may be accessed by L and L. =head2 DLL forwarder generation Assume that the old DLL is named F (as is one for 5.005_53), and the new version is 5.6.1. Create a file F with LIBRARY 'perlE0AC' INITINSTANCE TERMINSTANCE DESCRIPTION '@#perl5-porters@perl.org:5.006001#@ Perl module for 5.00553 -> Perl 5.6.1 forwarder' CODE LOADONCALL DATA LOADONCALL NONSHARED MULTIPLE EXPORTS modifying the versions/names as needed. Run perl -wnle "next if 0../EXPORTS/; print qq( \"$1\") if /\"(\w+)\"/" perl5.def >lst in the Perl build directory (to make the DLL smaller replace perl5.def with the definition file for the older version of Perl if present). cat perl5shim.def-leader lst >perl5shim.def gcc -Zomf -Zdll -o perlE0AC.dll perl5shim.def -s -llibperl (ignore multiple C). =head2 Threading As of release 5.003_01 perl is linked to multithreaded C RTL DLL. If perl itself is not compiled multithread-enabled, so will not be perl's malloc(). However, extensions may use multiple thread on their own risk. This was needed to compile C for XFree86-OS/2 out-of-the-box, and link with DLLs for other useful libraries, which typically are compiled with C<-Zmt -Zcrtdll>. =head2 Calls to external programs Due to a popular demand the perl external program calling has been changed wrt Andreas Kaiser's port. I perl needs to call an external program I, the F will be called, or whatever is the override, see L<"PERL_SH_DIR">. Thus means that you need to get some copy of a F as well (I use one from pdksh). The path F above is set up automatically during the build to a correct value on the builder machine, but is overridable at runtime, B a consensus on C was that perl should use one non-overridable shell per platform. The obvious choices for OS/2 are F and F. Having perl build itself would be impossible with F as a shell, thus I picked up C. This assures almost 100% compatibility with the scripts coming from *nix. As an added benefit this works as well under DOS if you use DOS-enabled port of pdksh (see L<"Prerequisites">). B currently F of pdksh calls external programs via fork()/exec(), and there is I functioning exec() on OS/2. exec() is emulated by EMX by an asynchronous call while the caller waits for child completion (to pretend that the C did not change). This means that 1 I copy of F is made active via fork()/exec(), which may lead to some resources taken from the system (even if we do not count extra work needed for fork()ing). Note that this a lesser issue now when we do not spawn F unless needed (metachars found). One can always start F explicitly via system 'cmd', '/c', 'mycmd', 'arg1', 'arg2', ... If you need to use F, and do not want to hand-edit thousands of your scripts, the long-term solution proposed on p5-p is to have a directive use OS2::Cmd; which will override system(), exec(), C<``>, and C. With current perl you may override only system(), readpipe() - the explicit version of C<``>, and maybe exec(). The code will substitute the one-argument call to system() by C. If you have some working code for C, please send it to me, I will include it into distribution. I have no need for such a module, so cannot test it. For the details of the current situation with calling external programs, see L. Set us mention a couple of features: =over 4 =item * External scripts may be called by their basename. Perl will try the same extensions as when processing B<-S> command-line switch. =item * External scripts starting with C<#!> or C will be executed directly, without calling the shell, by calling the program specified on the rest of the first line. =back =head2 Memory allocation Perl uses its own malloc() under OS/2 - interpreters are usually malloc-bound for speed, but perl is not, since its malloc is lightning-fast. Perl-memory-usage-tuned benchmarks show that Perl's malloc is 5 times quicker than EMX one. I do not have convincing data about memory footprint, but a (pretty random) benchmark showed that Perl's one is 5% better. Combination of perl's malloc() and rigid DLL name resolution creates a special problem with library functions which expect their return value to be free()d by system's free(). To facilitate extensions which need to call such functions, system memory-allocation functions are still available with the prefix C added. (Currently only DLL perl has this, it should propagate to F shortly.) =head2 Threads One can build perl with thread support enabled by providing C<-D usethreads> option to F. Currently OS/2 support of threads is very preliminary. Most notable problems: =over 4 =item C may have a race condition (but probably does not due to edge-triggered nature of OS/2 Event semaphores). (Needs a reimplementation (in terms of chaining waiting threads, with the linked list stored in per-thread structure?)?) =item F has a couple of static variables used in OS/2-specific functions. (Need to be moved to per-thread structure, or serialized?) =back Note that these problems should not discourage experimenting, since they have a low probability of affecting small programs. =head1 BUGS This description is not updated often (since 5.6.1?), see F<./os2/Changes> (L) for more info. =cut OS/2 extensions ~~~~~~~~~~~~~~~ I include 3 extensions by Andreas Kaiser, OS2::REXX, OS2::UPM, and OS2::FTP, into my ftp directory, mirrored on CPAN. I made some minor changes needed to compile them by standard tools. I cannot test UPM and FTP, so I will appreciate your feedback. Other extensions there are OS2::ExtAttr, OS2::PrfDB for tied access to EAs and .INI files - and maybe some other extensions at the time you read it. Note that OS2 perl defines 2 pseudo-extension functions OS2::Copy::copy and DynaLoader::mod2fname (many more now, see L). The -R switch of older perl is deprecated. If you need to call a REXX code which needs access to variables, include the call into a REXX compartment created by REXX_call {...block...}; Two new functions are supported by REXX code, REXX_eval 'string'; REXX_eval_with 'string', REXX_function_name => \&perl_sub_reference; If you have some other extensions you want to share, send the code to me. At least two are available: tied access to EA's, and tied access to system databases. =head1 AUTHOR Ilya Zakharevich, cpan@ilyaz.org =head1 SEE ALSO perl(1). =cut perl-5.12.0-RC0/embed.pl0000555000175000017500000005724011325145331013547 0ustar jessejesse#!/usr/bin/perl -w # # Regenerate (overwriting only if changed): # # embed.h # embedvar.h # global.sym # perlapi.c # perlapi.h # proto.h # # from information stored in # # embed.fnc # intrpvar.h # perlvars.h # pp.sym (which has been generated by opcode.pl) # # plus from the values hardcoded into this script in @extvars. # # Accepts the standard regen_lib -q and -v args. # # This script is normally invoked from regen.pl. require 5.003; # keep this compatible, an old perl is all we may have before # we build the new one use strict; BEGIN { # Get function prototypes require 'regen_lib.pl'; } my $SPLINT = 0; # Turn true for experimental splint support http://www.splint.org # # See database of global and static function prototypes in embed.fnc # This is used to generate prototype headers under various configurations, # export symbols lists for different platforms, and macros to provide an # implicit interpreter context argument. # sub do_not_edit ($) { my $file = shift; my $years = '1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009'; $years =~ s/1999,/1999,\n / if length $years > 40; my $warning = <) { chomp; next if /^:/; while (s|\\$||) { $_ .= ; chomp; } s/\s+$//; my @args; if (/^\s*(#|$)/) { @args = $_; } else { @args = split /\s*\|\s*/, $_; } my @outs = &{$function}(@args); print $F @outs; # $function->(@args) is not 5.003 } print $F $trailer if $trailer; unless (ref $filename) { safer_close($F); rename_if_different("$filename-new", $filename); } } sub munge_c_files () { my $functions = {}; unless (@ARGV) { warn "\@ARGV empty, nothing to do\n"; return; } walk_table { if (@_ > 1) { $functions->{$_[2]} = \@_ if $_[@_-1] =~ /\.\.\./; } } '/dev/null', '', ''; local $^I = '.bak'; while (<>) { s{(\b(\w+)[ \t]*\([ \t]*(?!aTHX))} { my $repl = $1; my $f = $2; if (exists $functions->{$f}) { $repl .= "aTHX_ "; warn("$ARGV:$.:$`#$repl#$'"); } $repl; }eg; print; close ARGV if eof; # restart $. } exit; } #munge_c_files(); # generate proto.h my $wrote_protected = 0; sub write_protos { my $ret = ""; if (@_ == 1) { my $arg = shift; $ret .= "$arg\n"; } else { my ($flags,$retval,$plain_func,@args) = @_; my @nonnull; my $has_context = ( $flags !~ /n/ ); my $never_returns = ( $flags =~ /r/ ); my $commented_out = ( $flags =~ /m/ ); my $binarycompat = ( $flags =~ /b/ ); my $is_malloc = ( $flags =~ /a/ ); my $can_ignore = ( $flags !~ /R/ ) && !$is_malloc; my @names_of_nn; my $func; my $splint_flags = ""; if ( $SPLINT && !$commented_out ) { $splint_flags .= '/*@noreturn@*/ ' if $never_returns; if ($can_ignore && ($retval ne 'void') && ($retval !~ /\*/)) { $retval .= " /*\@alt void\@*/"; } } if ($flags =~ /s/) { $retval = "STATIC $splint_flags$retval"; $func = "S_$plain_func"; } else { $retval = "PERL_CALLCONV $splint_flags$retval"; if ($flags =~ /[bp]/) { $func = "Perl_$plain_func"; } else { $func = $plain_func; } } $ret .= "$retval\t$func("; if ( $has_context ) { $ret .= @args ? "pTHX_ " : "pTHX"; } if (@args) { my $n; for my $arg ( @args ) { ++$n; if ( $arg =~ /\*/ && $arg !~ /\b(NN|NULLOK)\b/ ) { warn "$func: $arg needs NN or NULLOK\n"; our $unflagged_pointers; ++$unflagged_pointers; } my $nn = ( $arg =~ s/\s*\bNN\b\s+// ); push( @nonnull, $n ) if $nn; my $nullok = ( $arg =~ s/\s*\bNULLOK\b\s+// ); # strip NULLOK with no effect # Make sure each arg has at least a type and a var name. # An arg of "int" is valid C, but want it to be "int foo". my $temp_arg = $arg; $temp_arg =~ s/\*//g; $temp_arg =~ s/\s*\bstruct\b\s*/ /g; if ( ($temp_arg ne "...") && ($temp_arg !~ /\w+\s+(\w+)(?:\[\d+\])?\s*$/) ) { warn "$func: $arg ($n) doesn't have a name\n"; } if ( $SPLINT && $nullok && !$commented_out ) { $arg = '/*@null@*/ ' . $arg; } if (defined $1 && $nn && !($commented_out && !$binarycompat)) { push @names_of_nn, $1; } } $ret .= join ", ", @args; } else { $ret .= "void" if !$has_context; } $ret .= ")"; my @attrs; if ( $flags =~ /r/ ) { push @attrs, "__attribute__noreturn__"; } if ( $flags =~ /D/ ) { push @attrs, "__attribute__deprecated__"; } if ( $is_malloc ) { push @attrs, "__attribute__malloc__"; } if ( !$can_ignore ) { push @attrs, "__attribute__warn_unused_result__"; } if ( $flags =~ /P/ ) { push @attrs, "__attribute__pure__"; } if( $flags =~ /f/ ) { my $prefix = $has_context ? 'pTHX_' : ''; my $args = scalar @args; my $pat = $args - 1; my $macro = @nonnull && $nonnull[-1] == $pat ? '__attribute__format__' : '__attribute__format__null_ok__'; push @attrs, sprintf "%s(__printf__,%s%d,%s%d)", $macro, $prefix, $pat, $prefix, $args; } if ( @nonnull ) { my @pos = map { $has_context ? "pTHX_$_" : $_ } @nonnull; push @attrs, map { sprintf( "__attribute__nonnull__(%s)", $_ ) } @pos; } if ( @attrs ) { $ret .= "\n"; $ret .= join( "\n", map { "\t\t\t$_" } @attrs ); } $ret .= ";"; $ret = "/* $ret */" if $commented_out; if (@names_of_nn) { $ret .= "\n#define PERL_ARGS_ASSERT_\U$plain_func\E\t\\\n\t" . join '; ', map "assert($_)", @names_of_nn; } $ret .= @attrs ? "\n\n" : "\n"; } $ret; } # generates global.sym (API export list) { my %seen; sub write_global_sym { my $ret = ""; if (@_ > 1) { my ($flags,$retval,$func,@args) = @_; # If a function is defined twice, for example before and after an # #else, only process the flags on the first instance for global.sym return $ret if $seen{$func}++; if ($flags =~ /[AX]/ && $flags !~ /[xm]/ || $flags =~ /b/) { # public API, so export $func = "Perl_$func" if $flags =~ /[pbX]/; $ret = "$func\n"; } } $ret; } } our $unflagged_pointers; walk_table(\&write_protos, "proto.h", undef, "/* ex: set ro: */\n"); warn "$unflagged_pointers pointer arguments to clean up\n" if $unflagged_pointers; walk_table(\&write_global_sym, "global.sym", undef, "# ex: set ro:\n"); # XXX others that may need adding # warnhook # hints # copline my @extvars = qw(sv_undef sv_yes sv_no na dowarn curcop compiling tainting tainted stack_base stack_sp sv_arenaroot no_modify curstash DBsub DBsingle DBassertion debstash rsfp stdingv defgv errgv rsfp_filters perldb diehook dirty perl_destruct_level ppaddr ); sub readsyms (\%$) { my ($syms, $file) = @_; local (*FILE, $_); open(FILE, "< $file") or die "embed.pl: Can't open $file: $!\n"; while () { s/[ \t]*#.*//; # Delete comments. if (/^\s*(\S+)\s*$/) { my $sym = $1; warn "duplicate symbol $sym while processing $file line $.\n" if exists $$syms{$sym}; $$syms{$sym} = 1; } } close(FILE); } # Perl_pp_* and Perl_ck_* are in pp.sym readsyms my %ppsym, 'pp.sym'; sub readvars(\%$$@) { my ($syms, $file,$pre,$keep_pre) = @_; local (*FILE, $_); open(FILE, "< $file") or die "embed.pl: Can't open $file: $!\n"; while () { s/[ \t]*#.*//; # Delete comments. if (/PERLVARA?I?S?C?\($pre(\w+)/) { my $sym = $1; $sym = $pre . $sym if $keep_pre; warn "duplicate symbol $sym while processing $file line $.\n" if exists $$syms{$sym}; $$syms{$sym} = $pre || 1; } } close(FILE); } my %intrp; my %globvar; readvars %intrp, 'intrpvar.h','I'; readvars %globvar, 'perlvars.h','G'; my $sym; sub undefine ($) { my ($sym) = @_; "#undef $sym\n"; } sub hide ($$) { my ($from, $to) = @_; my $t = int(length($from) / 8); "#define $from" . "\t" x ($t < 3 ? 3 - $t : 1) . "$to\n"; } sub bincompat_var ($$) { my ($pfx, $sym) = @_; my $arg = ($pfx eq 'G' ? 'NULL' : 'aTHX'); undefine("PL_$sym") . hide("PL_$sym", "(*Perl_${pfx}${sym}_ptr($arg))"); } sub multon ($$$) { my ($sym,$pre,$ptr) = @_; hide("PL_$sym", "($ptr$pre$sym)"); } sub multoff ($$) { my ($sym,$pre) = @_; return hide("PL_$pre$sym", "PL_$sym"); } my $em = safer_open('embed.h-new'); print $em do_not_edit ("embed.h"), <<'END'; /* (Doing namespace management portably in C is really gross.) */ /* By defining PERL_NO_SHORT_NAMES (not done by default) the short forms * (like warn instead of Perl_warn) for the API are not defined. * Not defining the short forms is a good thing for cleaner embedding. */ #ifndef PERL_NO_SHORT_NAMES /* Hide global symbols */ #if !defined(PERL_IMPLICIT_CONTEXT) END # Try to elimiate lots of repeated # #ifdef PERL_CORE # foo # #endif # #ifdef PERL_CORE # bar # #endif # by tracking state and merging foo and bar into one block. my $ifdef_state = ''; walk_table { my $ret = ""; my $new_ifdef_state = ''; if (@_ == 1) { my $arg = shift; $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/; } else { my ($flags,$retval,$func,@args) = @_; unless ($flags =~ /[om]/) { if ($flags =~ /s/) { $ret .= hide($func,"S_$func"); } elsif ($flags =~ /p/) { $ret .= hide($func,"Perl_$func"); } } if ($ret ne '' && $flags !~ /A/) { if ($flags =~ /E/) { $new_ifdef_state = "#if defined(PERL_CORE) || defined(PERL_EXT)\n"; } else { $new_ifdef_state = "#ifdef PERL_CORE\n"; } if ($new_ifdef_state ne $ifdef_state) { $ret = $new_ifdef_state . $ret; } } } if ($ifdef_state && $new_ifdef_state ne $ifdef_state) { # Close the old one ahead of opening the new one. $ret = "#endif\n$ret"; } # Remember the new state. $ifdef_state = $new_ifdef_state; $ret; } $em, ""; if ($ifdef_state) { print $em "#endif\n"; } for $sym (sort keys %ppsym) { $sym =~ s/^Perl_//; print $em hide($sym, "Perl_$sym"); } print $em <<'END'; #else /* PERL_IMPLICIT_CONTEXT */ END my @az = ('a'..'z'); $ifdef_state = ''; walk_table { my $ret = ""; my $new_ifdef_state = ''; if (@_ == 1) { my $arg = shift; $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/; } else { my ($flags,$retval,$func,@args) = @_; unless ($flags =~ /[om]/) { my $args = scalar @args; if ($args and $args[$args-1] =~ /\.\.\./) { # we're out of luck for varargs functions under CPP } elsif ($flags =~ /n/) { if ($flags =~ /s/) { $ret .= hide($func,"S_$func"); } elsif ($flags =~ /p/) { $ret .= hide($func,"Perl_$func"); } } else { my $alist = join(",", @az[0..$args-1]); $ret = "#define $func($alist)"; my $t = int(length($ret) / 8); $ret .= "\t" x ($t < 4 ? 4 - $t : 1); if ($flags =~ /s/) { $ret .= "S_$func(aTHX"; } elsif ($flags =~ /p/) { $ret .= "Perl_$func(aTHX"; } $ret .= "_ " if $alist; $ret .= $alist . ")\n"; } } unless ($flags =~ /A/) { if ($flags =~ /E/) { $new_ifdef_state = "#if defined(PERL_CORE) || defined(PERL_EXT)\n"; } else { $new_ifdef_state = "#ifdef PERL_CORE\n"; } if ($new_ifdef_state ne $ifdef_state) { $ret = $new_ifdef_state . $ret; } } } if ($ifdef_state && $new_ifdef_state ne $ifdef_state) { # Close the old one ahead of opening the new one. $ret = "#endif\n$ret"; } # Remember the new state. $ifdef_state = $new_ifdef_state; $ret; } $em, ""; if ($ifdef_state) { print $em "#endif\n"; } for $sym (sort keys %ppsym) { $sym =~ s/^Perl_//; if ($sym =~ /^ck_/) { print $em hide("$sym(a)", "Perl_$sym(aTHX_ a)"); } elsif ($sym =~ /^pp_/) { print $em hide("$sym()", "Perl_$sym(aTHX)"); } else { warn "Illegal symbol '$sym' in pp.sym"; } } print $em <<'END'; #endif /* PERL_IMPLICIT_CONTEXT */ #endif /* #ifndef PERL_NO_SHORT_NAMES */ END print $em <<'END'; /* Compatibility stubs. Compile extensions with -DPERL_NOCOMPAT to disable them. */ #if !defined(PERL_CORE) # define sv_setptrobj(rv,ptr,name) sv_setref_iv(rv,name,PTR2IV(ptr)) # define sv_setptrref(rv,ptr) sv_setref_iv(rv,NULL,PTR2IV(ptr)) #endif #if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) /* Compatibility for various misnamed functions. All functions in the API that begin with "perl_" (not "Perl_") take an explicit interpreter context pointer. The following are not like that, but since they had a "perl_" prefix in previous versions, we provide compatibility macros. */ # define perl_atexit(a,b) call_atexit(a,b) # define perl_call_argv(a,b,c) call_argv(a,b,c) # define perl_call_pv(a,b) call_pv(a,b) # define perl_call_method(a,b) call_method(a,b) # define perl_call_sv(a,b) call_sv(a,b) # define perl_eval_sv(a,b) eval_sv(a,b) # define perl_eval_pv(a,b) eval_pv(a,b) # define perl_require_pv(a) require_pv(a) # define perl_get_sv(a,b) get_sv(a,b) # define perl_get_av(a,b) get_av(a,b) # define perl_get_hv(a,b) get_hv(a,b) # define perl_get_cv(a,b) get_cv(a,b) # define perl_init_i18nl10n(a) init_i18nl10n(a) # define perl_init_i18nl14n(a) init_i18nl14n(a) # define perl_new_ctype(a) new_ctype(a) # define perl_new_collate(a) new_collate(a) # define perl_new_numeric(a) new_numeric(a) /* varargs functions can't be handled with CPP macros. :-( This provides a set of compatibility functions that don't take an extra argument but grab the context pointer using the macro dTHX. */ #if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_NO_SHORT_NAMES) # define croak Perl_croak_nocontext # define deb Perl_deb_nocontext # define die Perl_die_nocontext # define form Perl_form_nocontext # define load_module Perl_load_module_nocontext # define mess Perl_mess_nocontext # define newSVpvf Perl_newSVpvf_nocontext # define sv_catpvf Perl_sv_catpvf_nocontext # define sv_setpvf Perl_sv_setpvf_nocontext # define warn Perl_warn_nocontext # define warner Perl_warner_nocontext # define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext # define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext #endif #endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */ #if !defined(PERL_IMPLICIT_CONTEXT) /* undefined symbols, point them back at the usual ones */ # define Perl_croak_nocontext Perl_croak # define Perl_die_nocontext Perl_die # define Perl_deb_nocontext Perl_deb # define Perl_form_nocontext Perl_form # define Perl_load_module_nocontext Perl_load_module # define Perl_mess_nocontext Perl_mess # define Perl_newSVpvf_nocontext Perl_newSVpvf # define Perl_sv_catpvf_nocontext Perl_sv_catpvf # define Perl_sv_setpvf_nocontext Perl_sv_setpvf # define Perl_warn_nocontext Perl_warn # define Perl_warner_nocontext Perl_warner # define Perl_sv_catpvf_mg_nocontext Perl_sv_catpvf_mg # define Perl_sv_setpvf_mg_nocontext Perl_sv_setpvf_mg #endif /* ex: set ro: */ END safer_close($em); rename_if_different('embed.h-new', 'embed.h'); $em = safer_open('embedvar.h-new'); print $em do_not_edit ("embedvar.h"), <<'END'; /* (Doing namespace management portably in C is really gross.) */ /* The following combinations of MULTIPLICITY and PERL_IMPLICIT_CONTEXT are supported: 1) none 2) MULTIPLICITY # supported for compatibility 3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT All other combinations of these flags are errors. only #3 is supported directly, while #2 is a special case of #3 (supported by redefining vTHX appropriately). */ #if defined(MULTIPLICITY) /* cases 2 and 3 above */ # if defined(PERL_IMPLICIT_CONTEXT) # define vTHX aTHX # else # define vTHX PERL_GET_INTERP # endif END for $sym (sort keys %intrp) { print $em multon($sym,'I','vTHX->'); } print $em <<'END'; #else /* !MULTIPLICITY */ /* case 1 above */ END for $sym (sort keys %intrp) { print $em multoff($sym,'I'); } print $em <<'END'; END print $em <<'END'; #endif /* MULTIPLICITY */ #if defined(PERL_GLOBAL_STRUCT) END for $sym (sort keys %globvar) { print $em multon($sym, 'G','my_vars->'); print $em multon("G$sym",'', 'my_vars->'); } print $em <<'END'; #else /* !PERL_GLOBAL_STRUCT */ END for $sym (sort keys %globvar) { print $em multoff($sym,'G'); } print $em <<'END'; #endif /* PERL_GLOBAL_STRUCT */ #ifdef PERL_POLLUTE /* disabled by default in 5.6.0 */ END for $sym (sort @extvars) { print $em hide($sym,"PL_$sym"); } print $em <<'END'; #endif /* PERL_POLLUTE */ /* ex: set ro: */ END safer_close($em); rename_if_different('embedvar.h-new', 'embedvar.h'); my $capi = safer_open('perlapi.c-new'); my $capih = safer_open('perlapi.h-new'); print $capih do_not_edit ("perlapi.h"), <<'EOT'; /* declare accessor functions for Perl variables */ #ifndef __perlapi_h__ #define __perlapi_h__ #if defined (MULTIPLICITY) START_EXTERN_C #undef PERLVAR #undef PERLVARA #undef PERLVARI #undef PERLVARIC #undef PERLVARISC #define PERLVAR(v,t) EXTERN_C t* Perl_##v##_ptr(pTHX); #define PERLVARA(v,n,t) typedef t PL_##v##_t[n]; \ EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX); #define PERLVARI(v,t,i) PERLVAR(v,t) #define PERLVARIC(v,t,i) PERLVAR(v, const t) #define PERLVARISC(v,i) typedef const char PL_##v##_t[sizeof(i)]; \ EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX); #include "intrpvar.h" #include "perlvars.h" #undef PERLVAR #undef PERLVARA #undef PERLVARI #undef PERLVARIC #undef PERLVARISC #ifndef PERL_GLOBAL_STRUCT EXTERN_C Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX); EXTERN_C Perl_check_t** Perl_Gcheck_ptr(pTHX); EXTERN_C unsigned char** Perl_Gfold_locale_ptr(pTHX); #define Perl_ppaddr_ptr Perl_Gppaddr_ptr #define Perl_check_ptr Perl_Gcheck_ptr #define Perl_fold_locale_ptr Perl_Gfold_locale_ptr #endif END_EXTERN_C #if defined(PERL_CORE) /* accessor functions for Perl variables (provide binary compatibility) */ /* these need to be mentioned here, or most linkers won't put them in the perl executable */ #ifndef PERL_NO_FORCE_LINK START_EXTERN_C #ifndef DOINIT EXTCONST void * const PL_force_link_funcs[]; #else EXTCONST void * const PL_force_link_funcs[] = { #undef PERLVAR #undef PERLVARA #undef PERLVARI #undef PERLVARIC #define PERLVAR(v,t) (void*)Perl_##v##_ptr, #define PERLVARA(v,n,t) PERLVAR(v,t) #define PERLVARI(v,t,i) PERLVAR(v,t) #define PERLVARIC(v,t,i) PERLVAR(v,t) #define PERLVARISC(v,i) PERLVAR(v,char) /* In Tru64 (__DEC && __osf__) the cc option -std1 causes that one * cannot cast between void pointers and function pointers without * info level warnings. The PL_force_link_funcs[] would cause a few * hundred of those warnings. In code one can circumnavigate this by using * unions that overlay the different pointers, but in declarations one * cannot use this trick. Therefore we just disable the warning here * for the duration of the PL_force_link_funcs[] declaration. */ #if defined(__DECC) && defined(__osf__) #pragma message save #pragma message disable (nonstandcast) #endif #include "intrpvar.h" #include "perlvars.h" #if defined(__DECC) && defined(__osf__) #pragma message restore #endif #undef PERLVAR #undef PERLVARA #undef PERLVARI #undef PERLVARIC #undef PERLVARISC }; #endif /* DOINIT */ END_EXTERN_C #endif /* PERL_NO_FORCE_LINK */ #else /* !PERL_CORE */ EOT foreach $sym (sort keys %intrp) { print $capih bincompat_var('I',$sym); } foreach $sym (sort keys %globvar) { print $capih bincompat_var('G',$sym); } print $capih <<'EOT'; #endif /* !PERL_CORE */ #endif /* MULTIPLICITY */ #endif /* __perlapi_h__ */ /* ex: set ro: */ EOT safer_close($capih); rename_if_different('perlapi.h-new', 'perlapi.h'); print $capi do_not_edit ("perlapi.c"), <<'EOT'; #include "EXTERN.h" #include "perl.h" #include "perlapi.h" #if defined (MULTIPLICITY) /* accessor functions for Perl variables (provides binary compatibility) */ START_EXTERN_C #undef PERLVAR #undef PERLVARA #undef PERLVARI #undef PERLVARIC #undef PERLVARISC #define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \ { dVAR; PERL_UNUSED_CONTEXT; return &(aTHX->v); } #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \ { dVAR; PERL_UNUSED_CONTEXT; return &(aTHX->v); } #define PERLVARI(v,t,i) PERLVAR(v,t) #define PERLVARIC(v,t,i) PERLVAR(v, const t) #define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX) \ { dVAR; PERL_UNUSED_CONTEXT; return &(aTHX->v); } #include "intrpvar.h" #undef PERLVAR #undef PERLVARA #define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \ { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); } #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \ { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); } #undef PERLVARIC #undef PERLVARISC #define PERLVARIC(v,t,i) \ const t* Perl_##v##_ptr(pTHX) \ { PERL_UNUSED_CONTEXT; return (const t *)&(PL_##v); } #define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX) \ { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); } #include "perlvars.h" #undef PERLVAR #undef PERLVARA #undef PERLVARI #undef PERLVARIC #undef PERLVARISC #ifndef PERL_GLOBAL_STRUCT /* A few evil special cases. Could probably macrofy this. */ #undef PL_ppaddr #undef PL_check #undef PL_fold_locale Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX) { static Perl_ppaddr_t* const ppaddr_ptr = PL_ppaddr; PERL_UNUSED_CONTEXT; return (Perl_ppaddr_t**)&ppaddr_ptr; } Perl_check_t** Perl_Gcheck_ptr(pTHX) { static Perl_check_t* const check_ptr = PL_check; PERL_UNUSED_CONTEXT; return (Perl_check_t**)&check_ptr; } unsigned char** Perl_Gfold_locale_ptr(pTHX) { static unsigned char* const fold_locale_ptr = PL_fold_locale; PERL_UNUSED_CONTEXT; return (unsigned char**)&fold_locale_ptr; } #endif END_EXTERN_C #endif /* MULTIPLICITY */ /* ex: set ro: */ EOT safer_close($capi); rename_if_different('perlapi.c-new', 'perlapi.c'); # functions that take va_list* for implementing vararg functions # NOTE: makedef.pl must be updated if you add symbols to %vfuncs # XXX %vfuncs currently unused my %vfuncs = qw( Perl_croak Perl_vcroak Perl_warn Perl_vwarn Perl_warner Perl_vwarner Perl_die Perl_vdie Perl_form Perl_vform Perl_load_module Perl_vload_module Perl_mess Perl_vmess Perl_deb Perl_vdeb Perl_newSVpvf Perl_vnewSVpvf Perl_sv_setpvf Perl_sv_vsetpvf Perl_sv_setpvf_mg Perl_sv_vsetpvf_mg Perl_sv_catpvf Perl_sv_vcatpvf Perl_sv_catpvf_mg Perl_sv_vcatpvf_mg Perl_dump_indent Perl_dump_vindent Perl_default_protect Perl_vdefault_protect ); # ex: set ts=8 sts=4 sw=4 noet: perl-5.12.0-RC0/EXTERN.h0000444000175000017500000000342311143650473013311 0ustar jessejesse/* EXTERN.h * * Copyright (C) 1991, 1992, 1993, 1995, 1996, 1997, 1998, 1999, * 2000, 2001, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * EXT designates a global var which is defined in perl.h * dEXT designates a global var which is defined in another * file, so we can't count on finding it in perl.h * (this practice should be avoided). */ #undef EXT #undef dEXT #undef EXTCONST #undef dEXTCONST #if defined(VMS) && !defined(__GNUC__) /* Suppress portability warnings from DECC for VMS-specific extensions */ # ifdef __DECC # pragma message disable (GLOBALEXT,NOSHAREEXT,READONLYEXT) # endif # define EXT globalref # define dEXT globaldef {"$GLOBAL_RW_VARS"} noshare # define EXTCONST globalref # define dEXTCONST globaldef {"$GLOBAL_RO_VARS"} readonly #else # if (defined(WIN32) || defined(__SYMBIAN32__)) && !defined(PERL_STATIC_SYMS) # if defined(PERLDLL) || defined(__SYMBIAN32__) # define EXT extern __declspec(dllexport) # define dEXT # define EXTCONST extern __declspec(dllexport) const # define dEXTCONST const # else # define EXT extern __declspec(dllimport) # define dEXT # define EXTCONST extern __declspec(dllimport) const # define dEXTCONST const # endif # else # if defined(__CYGWIN__) && defined(USEIMPORTLIB) # define EXT extern __declspec(dllimport) # define dEXT # define EXTCONST extern __declspec(dllimport) const # define dEXTCONST const # else # define EXT extern # define dEXT # define EXTCONST extern const # define dEXTCONST const # endif # endif #endif #undef INIT #define INIT(x) #undef DOINIT perl-5.12.0-RC0/Makefile.micro0000444000175000017500000001123011325125741014673 0ustar jessejesseLD = $(CC) CCFLAGS = -c DEFINES = -DPERL_CORE -DPERL_MICRO -DSTANDARD_C -DPERL_USE_SAFE_PUTENV OPTIMIZE = CFLAGS = $(DEFINES) $(OPTIMIZE) LDFLAGS = LIBS = -lm _O = .o ENV = env PERL = perl _X = RUN = all: microperl O = uav$(_O) udeb$(_O) udoio$(_O) udoop$(_O) udump$(_O) \ uglobals$(_O) ugv$(_O) uhv$(_O) umro$(_O)\ umg$(_O) uperlmain$(_O) uop$(_O) ureentr$(_O) \ upad$(_O) uperl$(_O) uperlio$(_O) uperly$(_O) upp$(_O) \ upp_ctl$(_O) upp_hot$(_O) upp_sys$(_O) upp_pack$(_O) upp_sort$(_O) \ uregcomp$(_O) uregexec$(_O) urun$(_O) \ uscope$(_O) usv$(_O) utaint$(_O) utoke$(_O) \ unumeric$(_O) ulocale$(_O) umathoms$(_O) \ uuniversal$(_O) uutf8$(_O) uutil$(_O) uperlapi$(_O) microperl: $(O) $(LD) -o $@ $(O) $(LDFLAGS) $(LIBS) H = av.h uconfig.h cop.h cv.h embed.h embedvar.h form.h gv.h handy.h \ hv.h intrpvar.h iperlsys.h mg.h op.h opcode.h opnames.h pad.h \ patchlevel.h perl.h perlsdio.h perlvars.h perly.h pp.h \ pp_proto.h proto.h reentr.h regexp.h scope.h sv.h \ thread.h unixish.h utf8.h util.h uudmap.h warnings.h HE = $(H) EXTERN.h clean: -rm -f $(O) microperl generate_uudmap$(_X) uudmap.h distclean: clean # The microconfiguration. # Cannot use $$ in the command line itself, so using var expansion instead. Config = '$$Config{$$1}' patch_uconfig: $(PERL) -MConfig -pi -e "s/^((?:short|int|long(?:dbl|long)?|ptr|double|[iun]v|u?quad|[iu]\d+|fpos|lseek)(?:size|type)|byteorder|d_quad|quadkind|use64.+)=.*/\\1='"$(Config)"'/g" uconfig.shx regen_uconfig uconfig.h: uconfig.sh $(ENV) CONFIG_SH=uconfig.sh CONFIG_H=uconfig.h sh ./config_h.SH # Do not regenerate perly.c and perly.h. perly.c: perly.y -@echo perly.c is uptodate perly.h: perly.y -@echo perly.h is uptodate # The microperl objects. uav$(_O): $(HE) av.c $(CC) $(CCFLAGS) -o $@ $(CFLAGS) av.c udeb$(_O): $(HE) deb.c $(CC) $(CCFLAGS) -o $@ $(CFLAGS) deb.c udoio$(_O): $(HE) doio.c $(CC) $(CCFLAGS) -o $@ $(CFLAGS) doio.c udoop$(_O): $(HE) doop.c $(CC) $(CCFLAGS) -o $@ $(CFLAGS) doop.c udump$(_O): $(HE) dump.c regcomp.h regnodes.h $(CC) $(CCFLAGS) -o $@ $(CFLAGS) dump.c uglobals$(_O): $(H) globals.c INTERN.h perlapi.h $(CC) $(CCFLAGS) -o $@ $(CFLAGS) globals.c ugv$(_O): $(HE) gv.c $(CC) $(CCFLAGS) -o $@ $(CFLAGS) gv.c umro$(_O): $(HE) mro.c $(CC) $(CCFLAGS) -o $@ $(CFLAGS) mro.c uhv$(_O): $(HE) hv.c $(CC) $(CCFLAGS) -o $@ $(CFLAGS) hv.c umg$(_O): $(HE) mg.c $(CC) $(CCFLAGS) -o $@ $(CFLAGS) mg.c uperlmain$(_O): $(HE) miniperlmain.c $(CC) $(CCFLAGS) -o $@ $(CFLAGS) miniperlmain.c uop$(_O): $(HE) op.c keywords.h $(CC) $(CCFLAGS) -o $@ $(CFLAGS) -DPERL_EXTERNAL_GLOB op.c ureentr$(_O): $(HE) reentr.c $(CC) $(CCFLAGS) -o $@ $(CFLAGS) reentr.c upad$(_O): $(HE) pad.c $(CC) $(CCFLAGS) -o $@ $(CFLAGS) pad.c uperl$(_O): $(HE) perl.c $(CC) $(CCFLAGS) -o $@ $(CFLAGS) perl.c uperlio$(_O): $(HE) perlio.c $(CC) $(CCFLAGS) -o $@ $(CFLAGS) perlio.c uperly$(_O): $(HE) perly.c $(CC) $(CCFLAGS) -o $@ $(CFLAGS) perly.c upp$(_O): $(HE) pp.c $(CC) $(CCFLAGS) -o $@ $(CFLAGS) pp.c upp_ctl$(_O): $(HE) pp_ctl.c $(CC) $(CCFLAGS) -o $@ $(CFLAGS) pp_ctl.c upp_hot$(_O): $(HE) pp_hot.c $(CC) $(CCFLAGS) -o $@ $(CFLAGS) pp_hot.c upp_sys$(_O): $(HE) pp_sys.c $(CC) $(CCFLAGS) -o $@ $(CFLAGS) pp_sys.c upp_pack$(_O): $(HE) pp_pack.c $(CC) $(CCFLAGS) -o $@ $(CFLAGS) pp_pack.c upp_sort$(_O): $(HE) pp_sort.c $(CC) $(CCFLAGS) -o $@ $(CFLAGS) pp_sort.c uregcomp$(_O): $(HE) regcomp.c regcomp.h regnodes.h INTERN.h $(CC) $(CCFLAGS) -o $@ $(CFLAGS) regcomp.c uregexec$(_O): $(HE) regexec.c regcomp.h regnodes.h $(CC) $(CCFLAGS) -o $@ $(CFLAGS) regexec.c urun$(_O): $(HE) run.c $(CC) $(CCFLAGS) -o $@ $(CFLAGS) run.c uscope$(_O): $(HE) scope.c $(CC) $(CCFLAGS) -o $@ $(CFLAGS) scope.c usv$(_O): $(HE) sv.c $(CC) $(CCFLAGS) -o $@ $(CFLAGS) sv.c utaint$(_O): $(HE) taint.c $(CC) $(CCFLAGS) -o $@ $(CFLAGS) taint.c utoke$(_O): $(HE) toke.c keywords.h $(CC) $(CCFLAGS) -o $@ $(CFLAGS) toke.c ulocale$(_O): $(HE) locale.c $(CC) $(CCFLAGS) -o $@ $(CFLAGS) locale.c unumeric$(_O): $(HE) numeric.c $(CC) $(CCFLAGS) -o $@ $(CFLAGS) numeric.c umathoms$(_O): $(HE) mathoms.c $(CC) $(CCFLAGS) -o $@ $(CFLAGS) mathoms.c uuniversal$(_O): $(HE) universal.c XSUB.h $(CC) $(CCFLAGS) -o $@ $(CFLAGS) universal.c uutf8$(_O): $(HE) utf8.c $(CC) $(CCFLAGS) -o $@ $(CFLAGS) utf8.c uutil$(_O): $(HE) util.c $(CC) $(CCFLAGS) -o $@ $(CFLAGS) util.c uperlapi$(_O): $(HE) perlapi.c perlapi.h $(CC) $(CCFLAGS) -o $@ $(CFLAGS) perlapi.c uudmap.h: generate_uudmap$(_X) $(RUN) ./generate_uudmap$(_X) >uudmap.h generate_uudmap$(_O): generate_uudmap.c $(CC) $(CCFLAGS) -o $@ $(CFLAGS) generate_uudmap.c generate_uudmap$(_X): generate_uudmap$(_O) $(LD) -o generate_uudmap $(LDFLAGS) generate_uudmap$(_O) $(LIBS) # That's it, folks! perl-5.12.0-RC0/perly.y0000444000175000017500000011002311332316240013442 0ustar jessejesse/* perly.y * * Copyright (c) 1991-2002, 2003, 2004, 2005, 2006 Larry Wall * Copyright (c) 2007, 2008 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * 'I see,' laughed Strider. 'I look foul and feel fair. Is that it? * All that is gold does not glitter, not all those who wander are lost.' * * [p.171 of _The Lord of the Rings_, I/x: "Strider"] */ /* * This file holds the grammar for the Perl language. If edited, you need * to run regen_perly.pl, which re-creates the files perly.h, perly.tab * and perly.act which are derived from this. * * Note that these derived files are included and compiled twice; once * from perly.c, and once from madly.c. The second time, a number of MAD * macros are defined, which compile in extra code that allows the parse * tree to be accurately dumped. In particular: * * MAD defined if compiling madly.c * DO_MAD(A) expands to A under madly.c, to null otherwise * IF_MAD(a,b) expands to A under madly.c, to B otherwise * TOKEN_GETMAD() expands to token_getmad() under madly.c, to null otherwise * TOKEN_FREE() similarly * OP_GETMAD() similarly * IVAL(i) expands to (i)->tk_lval.ival or (i) * PVAL(p) expands to (p)->tk_lval.pval or (p) * * The main job of of this grammar is to call the various newFOO() * functions in op.c to build a syntax tree of OP structs. * It relies on the lexer in toke.c to do the tokenizing. * * Note: due to the way that the cleanup code works WRT to freeing ops on * the parse stack, it is dangerous to assign to the $n variables within * an action. */ /* Make the parser re-entrant. */ %pure_parser /* FIXME for MAD - is the new mintro on while and until important? */ %start prog %union { I32 ival; /* __DEFAULT__ (marker for regen_perly.pl; must always be 1st union member) */ char *pval; OP *opval; GV *gvval; #ifdef PERL_IN_MADLY_C TOKEN* p_tkval; TOKEN* i_tkval; #else char *p_tkval; I32 i_tkval; #endif #ifdef PERL_MAD TOKEN* tkval; #endif } %token '{' '}' '[' ']' '-' '+' '$' '@' '%' '*' '&' ';' %token WORD METHOD FUNCMETH THING PMFUNC PRIVATEREF %token FUNC0SUB UNIOPSUB LSTOPSUB %token PLUGEXPR PLUGSTMT %token LABEL %token FORMAT SUB ANONSUB PACKAGE USE %token WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE FOR %token GIVEN WHEN DEFAULT %token LOOPEX DOTDOT YADAYADA %token FUNC0 FUNC1 FUNC UNIOP LSTOP %token RELOP EQOP MULOP ADDOP %token DOLSHARP DO HASHBRACK NOAMP %token LOCAL MY MYSUB REQUIRE %token COLONATTR %type prog progstart remember mremember %type startsub startanonsub startformsub /* FIXME for MAD - are these two ival? */ %type mydefsv mintro %type decl format subrout mysubrout package use peg %type block mblock lineseq line loop cond else %type expr term subscripted scalar ary hsh arylen star amper sideff %type argexpr nexpr texpr iexpr mexpr mnexpr miexpr %type listexpr listexprcom indirob listop method %type formname subname proto subbody cont my_scalar %type subattrlist myattrlist myattrterm myterm %type termbinop termunop anonymous termdo %type switch case %type label %nonassoc PREC_LOW %nonassoc LOOPEX %left OROP DOROP %left ANDOP %right NOTOP %nonassoc LSTOP LSTOPSUB %left ',' %right ASSIGNOP %right '?' ':' %nonassoc DOTDOT YADAYADA %left OROR DORDOR %left ANDAND %left BITOROP %left BITANDOP %nonassoc EQOP %nonassoc RELOP %nonassoc UNIOP UNIOPSUB %nonassoc REQUIRE %left SHIFTOP %left ADDOP %left MULOP %left MATCHOP %right '!' '~' UMINUS REFGEN %right POWOP %nonassoc PREINC PREDEC POSTINC POSTDEC %left ARROW %nonassoc ')' %left '(' %left '[' '{' %token PEG %% /* RULES */ /* The whole program */ prog : progstart /*CONTINUED*/ lineseq { $$ = $1; newPROG(block_end($1,$2)); } ; /* An ordinary block */ block : '{' remember lineseq '}' { if (PL_parser->copline > (line_t)IVAL($1)) PL_parser->copline = (line_t)IVAL($1); $$ = block_end($2, $3); TOKEN_GETMAD($1,$$,'{'); TOKEN_GETMAD($4,$$,'}'); } ; remember: /* NULL */ /* start a full lexical scope */ { $$ = block_start(TRUE); } ; mydefsv: /* NULL */ /* lexicalize $_ */ { $$ = (I32) Perl_allocmy(aTHX_ STR_WITH_LEN("$_"), 0); } ; progstart: { PL_parser->expect = XSTATE; $$ = block_start(TRUE); } ; mblock : '{' mremember lineseq '}' { if (PL_parser->copline > (line_t)IVAL($1)) PL_parser->copline = (line_t)IVAL($1); $$ = block_end($2, $3); TOKEN_GETMAD($1,$$,'{'); TOKEN_GETMAD($4,$$,'}'); } ; mremember: /* NULL */ /* start a partial lexical scope */ { $$ = block_start(FALSE); } ; /* A collection of "lines" in the program */ lineseq : /* NULL */ { $$ = (OP*)NULL; } | lineseq decl { $$ = IF_MAD( append_list(OP_LINESEQ, (LISTOP*)$1, (LISTOP*)$2), $1); } | lineseq line { $$ = append_list(OP_LINESEQ, (LISTOP*)$1, (LISTOP*)$2); PL_pad_reset_pending = TRUE; if ($1 && $2) PL_hints |= HINT_BLOCK_SCOPE; } ; /* A "line" in the program */ line : label cond { $$ = newSTATEOP(0, PVAL($1), $2); TOKEN_GETMAD($1,((LISTOP*)$$)->op_first,'L'); } | loop /* loops add their own labels */ | switch /* ... and so do switches */ { $$ = $1; } | label case { $$ = newSTATEOP(0, PVAL($1), $2); } | label ';' { if (PVAL($1)) { $$ = newSTATEOP(0, PVAL($1), newOP(OP_NULL, 0)); TOKEN_GETMAD($1,$$,'L'); TOKEN_GETMAD($2,((LISTOP*)$$)->op_first,';'); } else { $$ = IF_MAD( newOP(OP_NULL, 0), (OP*)NULL); PL_parser->copline = NOLINE; TOKEN_FREE($1); TOKEN_GETMAD($2,$$,';'); } PL_parser->expect = XSTATE; } | label sideff ';' { $$ = newSTATEOP(0, PVAL($1), $2); PL_parser->expect = XSTATE; DO_MAD({ /* sideff might already have a nexstate */ OP* op = ((LISTOP*)$$)->op_first; if (op) { while (op->op_sibling && op->op_sibling->op_type == OP_NEXTSTATE) op = op->op_sibling; token_getmad($1,op,'L'); token_getmad($3,op,';'); } }) } | label PLUGSTMT { $$ = newSTATEOP(0, PVAL($1), $2); } ; /* An expression which may have a side-effect */ sideff : error { $$ = (OP*)NULL; } | expr { $$ = $1; } | expr IF expr { $$ = newLOGOP(OP_AND, 0, $3, $1); TOKEN_GETMAD($2,$$,'i'); } | expr UNLESS expr { $$ = newLOGOP(OP_OR, 0, $3, $1); TOKEN_GETMAD($2,$$,'i'); } | expr WHILE expr { $$ = newLOOPOP(OPf_PARENS, 1, scalar($3), $1); TOKEN_GETMAD($2,$$,'w'); } | expr UNTIL iexpr { $$ = newLOOPOP(OPf_PARENS, 1, $3, $1); TOKEN_GETMAD($2,$$,'w'); } | expr FOR expr { $$ = newFOROP(0, NULL, (line_t)IVAL($2), (OP*)NULL, $3, $1, (OP*)NULL); TOKEN_GETMAD($2,((LISTOP*)$$)->op_first->op_sibling,'w'); } | expr WHEN expr { $$ = newWHENOP($3, scope($1)); } ; /* else and elsif blocks */ else : /* NULL */ { $$ = (OP*)NULL; } | ELSE mblock { ($2)->op_flags |= OPf_PARENS; $$ = scope($2); TOKEN_GETMAD($1,$$,'o'); } | ELSIF '(' mexpr ')' mblock else { PL_parser->copline = (line_t)IVAL($1); $$ = newCONDOP(0, newSTATEOP(OPf_SPECIAL,NULL,$3), scope($5), $6); PL_hints |= HINT_BLOCK_SCOPE; TOKEN_GETMAD($1,$$,'I'); TOKEN_GETMAD($2,$$,'('); TOKEN_GETMAD($4,$$,')'); } ; /* Real conditional expressions */ cond : IF '(' remember mexpr ')' mblock else { PL_parser->copline = (line_t)IVAL($1); $$ = block_end($3, newCONDOP(0, $4, scope($6), $7)); TOKEN_GETMAD($1,$$,'I'); TOKEN_GETMAD($2,$$,'('); TOKEN_GETMAD($5,$$,')'); } | UNLESS '(' remember miexpr ')' mblock else { PL_parser->copline = (line_t)IVAL($1); $$ = block_end($3, newCONDOP(0, $4, scope($6), $7)); TOKEN_GETMAD($1,$$,'I'); TOKEN_GETMAD($2,$$,'('); TOKEN_GETMAD($5,$$,')'); } ; /* Cases for a switch statement */ case : WHEN '(' remember mexpr ')' mblock { $$ = block_end($3, newWHENOP($4, scope($6))); } | DEFAULT block { $$ = newWHENOP(0, scope($2)); } ; /* Continue blocks */ cont : /* NULL */ { $$ = (OP*)NULL; } | CONTINUE block { $$ = scope($2); TOKEN_GETMAD($1,$$,'o'); } ; /* Loops: while, until, for, and a bare block */ loop : label WHILE '(' remember texpr ')' mintro mblock cont { OP *innerop; PL_parser->copline = (line_t)IVAL($2); $$ = block_end($4, newSTATEOP(0, PVAL($1), innerop = newWHILEOP(0, 1, (LOOP*)(OP*)NULL, IVAL($2), $5, $8, $9, $7))); TOKEN_GETMAD($1,innerop,'L'); TOKEN_GETMAD($2,innerop,'W'); TOKEN_GETMAD($3,innerop,'('); TOKEN_GETMAD($6,innerop,')'); } | label UNTIL '(' remember iexpr ')' mintro mblock cont { OP *innerop; PL_parser->copline = (line_t)IVAL($2); $$ = block_end($4, newSTATEOP(0, PVAL($1), innerop = newWHILEOP(0, 1, (LOOP*)(OP*)NULL, IVAL($2), $5, $8, $9, $7))); TOKEN_GETMAD($1,innerop,'L'); TOKEN_GETMAD($2,innerop,'W'); TOKEN_GETMAD($3,innerop,'('); TOKEN_GETMAD($6,innerop,')'); } | label FOR MY remember my_scalar '(' mexpr ')' mblock cont { OP *innerop; $$ = block_end($4, innerop = newFOROP(0, PVAL($1), (line_t)IVAL($2), $5, $7, $9, $10)); TOKEN_GETMAD($1,((LISTOP*)innerop)->op_first,'L'); TOKEN_GETMAD($2,((LISTOP*)innerop)->op_first->op_sibling,'W'); TOKEN_GETMAD($3,((LISTOP*)innerop)->op_first->op_sibling,'d'); TOKEN_GETMAD($6,((LISTOP*)innerop)->op_first->op_sibling,'('); TOKEN_GETMAD($8,((LISTOP*)innerop)->op_first->op_sibling,')'); } | label FOR scalar '(' remember mexpr ')' mblock cont { OP *innerop; $$ = block_end($5, innerop = newFOROP(0, PVAL($1), (line_t)IVAL($2), mod($3, OP_ENTERLOOP), $6, $8, $9)); TOKEN_GETMAD($1,((LISTOP*)innerop)->op_first,'L'); TOKEN_GETMAD($2,((LISTOP*)innerop)->op_first->op_sibling,'W'); TOKEN_GETMAD($4,((LISTOP*)innerop)->op_first->op_sibling,'('); TOKEN_GETMAD($7,((LISTOP*)innerop)->op_first->op_sibling,')'); } | label FOR '(' remember mexpr ')' mblock cont { OP *innerop; $$ = block_end($4, innerop = newFOROP(0, PVAL($1), (line_t)IVAL($2), (OP*)NULL, $5, $7, $8)); TOKEN_GETMAD($1,((LISTOP*)innerop)->op_first,'L'); TOKEN_GETMAD($2,((LISTOP*)innerop)->op_first->op_sibling,'W'); TOKEN_GETMAD($3,((LISTOP*)innerop)->op_first->op_sibling,'('); TOKEN_GETMAD($6,((LISTOP*)innerop)->op_first->op_sibling,')'); } | label FOR '(' remember mnexpr ';' texpr ';' mintro mnexpr ')' mblock /* basically fake up an initialize-while lineseq */ { OP *forop; PL_parser->copline = (line_t)IVAL($2); forop = newSTATEOP(0, PVAL($1), newWHILEOP(0, 1, (LOOP*)(OP*)NULL, IVAL($2), scalar($7), $12, $10, $9)); #ifdef MAD forop = newUNOP(OP_NULL, 0, append_elem(OP_LINESEQ, newSTATEOP(0, CopLABEL_alloc(($1)->tk_lval.pval), ($5 ? $5 : newOP(OP_NULL, 0)) ), forop)); token_getmad($2,forop,'3'); token_getmad($3,forop,'('); token_getmad($6,forop,'1'); token_getmad($8,forop,'2'); token_getmad($11,forop,')'); token_getmad($1,forop,'L'); #else if ($5) { forop = append_elem(OP_LINESEQ, newSTATEOP(0, CopLABEL_alloc($1), $5), forop); } #endif $$ = block_end($4, forop); } | label block cont /* a block is a loop that happens once */ { $$ = newSTATEOP(0, PVAL($1), newWHILEOP(0, 1, (LOOP*)(OP*)NULL, NOLINE, (OP*)NULL, $2, $3, 0)); TOKEN_GETMAD($1,((LISTOP*)$$)->op_first,'L'); } ; /* Switch blocks */ switch : label GIVEN '(' remember mydefsv mexpr ')' mblock { PL_parser->copline = (line_t) IVAL($2); $$ = block_end($4, newSTATEOP(0, PVAL($1), newGIVENOP($6, scope($8), (PADOFFSET) $5) )); } ; /* determine whether there are any new my declarations */ mintro : /* NULL */ { $$ = (PL_min_intro_pending && PL_max_intro_pending >= PL_min_intro_pending); intro_my(); } /* Normal expression */ nexpr : /* NULL */ { $$ = (OP*)NULL; } | sideff ; /* Boolean expression */ texpr : /* NULL means true */ { YYSTYPE tmplval; (void)scan_num("1", &tmplval); $$ = tmplval.opval; } | expr ; /* Inverted boolean expression */ iexpr : expr { $$ = invert(scalar($1)); } ; /* Expression with its own lexical scope */ mexpr : expr { $$ = $1; intro_my(); } ; mnexpr : nexpr { $$ = $1; intro_my(); } ; miexpr : iexpr { $$ = $1; intro_my(); } ; /* Optional "MAIN:"-style loop labels */ label : /* empty */ { #ifdef MAD YYSTYPE tmplval; tmplval.pval = NULL; $$ = newTOKEN(OP_NULL, tmplval, 0); #else $$ = NULL; #endif } | LABEL ; /* Some kind of declaration - just hang on peg in the parse tree */ decl : format { $$ = $1; } | subrout { $$ = $1; } | mysubrout { $$ = $1; } | package { $$ = $1; } | use { $$ = $1; } /* these two are only used by MAD */ | peg { $$ = $1; } ; peg : PEG { $$ = newOP(OP_NULL,0); TOKEN_GETMAD($1,$$,'p'); } ; format : FORMAT startformsub formname block { CV *fmtcv = PL_compcv; SvREFCNT_inc_simple_void(PL_compcv); #ifdef MAD $$ = newFORM($2, $3, $4); prepend_madprops($1->tk_mad, $$, 'F'); $1->tk_mad = 0; token_free($1); #else newFORM($2, $3, $4); $$ = (OP*)NULL; #endif if (CvOUTSIDE(fmtcv) && !CvUNIQUE(CvOUTSIDE(fmtcv))) { SvREFCNT_inc_simple_void(fmtcv); pad_add_anon((SV*)fmtcv, OP_NULL); } } ; formname: WORD { $$ = $1; } | /* NULL */ { $$ = (OP*)NULL; } ; /* Unimplemented "my sub foo { }" */ mysubrout: MYSUB startsub subname proto subattrlist subbody { SvREFCNT_inc_simple_void(PL_compcv); #ifdef MAD $$ = newMYSUB($2, $3, $4, $5, $6); token_getmad($1,$$,'d'); #else newMYSUB($2, $3, $4, $5, $6); $$ = (OP*)NULL; #endif } ; /* Subroutine definition */ subrout : SUB startsub subname proto subattrlist subbody { SvREFCNT_inc_simple_void(PL_compcv); #ifdef MAD { OP* o = newSVOP(OP_ANONCODE, 0, (SV*)newATTRSUB($2, $3, $4, $5, $6)); $$ = newOP(OP_NULL,0); op_getmad(o,$$,'&'); op_getmad($3,$$,'n'); op_getmad($4,$$,'s'); op_getmad($5,$$,'a'); token_getmad($1,$$,'d'); append_madprops($6->op_madprop, $$, 0); $6->op_madprop = 0; } #else newATTRSUB($2, $3, $4, $5, $6); $$ = (OP*)NULL; #endif } ; startsub: /* NULL */ /* start a regular subroutine scope */ { $$ = start_subparse(FALSE, 0); SAVEFREESV(PL_compcv); } ; startanonsub: /* NULL */ /* start an anonymous subroutine scope */ { $$ = start_subparse(FALSE, CVf_ANON); SAVEFREESV(PL_compcv); } ; startformsub: /* NULL */ /* start a format subroutine scope */ { $$ = start_subparse(TRUE, 0); SAVEFREESV(PL_compcv); } ; /* Name of a subroutine - must be a bareword, could be special */ subname : WORD { const char *const name = SvPV_nolen_const(((SVOP*)$1)->op_sv); if (strEQ(name, "BEGIN") || strEQ(name, "END") || strEQ(name, "INIT") || strEQ(name, "CHECK") || strEQ(name, "UNITCHECK")) CvSPECIAL_on(PL_compcv); $$ = $1; } ; /* Subroutine prototype */ proto : /* NULL */ { $$ = (OP*)NULL; } | THING ; /* Optional list of subroutine attributes */ subattrlist: /* NULL */ { $$ = (OP*)NULL; } | COLONATTR THING { $$ = $2; TOKEN_GETMAD($1,$$,':'); } | COLONATTR { $$ = IF_MAD( newOP(OP_NULL, 0), (OP*)NULL ); TOKEN_GETMAD($1,$$,':'); } ; /* List of attributes for a "my" variable declaration */ myattrlist: COLONATTR THING { $$ = $2; TOKEN_GETMAD($1,$$,':'); } | COLONATTR { $$ = IF_MAD( newOP(OP_NULL, 0), (OP*)NULL ); TOKEN_GETMAD($1,$$,':'); } ; /* Subroutine body - either null or a block */ subbody : block { $$ = $1; } | ';' { $$ = IF_MAD( newOP(OP_NULL,0), (OP*)NULL ); PL_parser->expect = XSTATE; TOKEN_GETMAD($1,$$,';'); } ; package : PACKAGE WORD WORD ';' { #ifdef MAD $$ = package($3); token_getmad($1,$$,'o'); if ($2) package_version($2); token_getmad($4,$$,';'); #else package($3); if ($2) package_version($2); $$ = (OP*)NULL; #endif } ; use : USE startsub { CvSPECIAL_on(PL_compcv); /* It's a BEGIN {} */ } WORD WORD listexpr ';' { SvREFCNT_inc_simple_void(PL_compcv); #ifdef MAD $$ = utilize(IVAL($1), $2, $4, $5, $6); token_getmad($1,$$,'o'); token_getmad($7,$$,';'); if (PL_parser->rsfp_filters && AvFILLp(PL_parser->rsfp_filters) >= 0) append_madprops(newMADPROP('!', MAD_NULL, NULL, 0), $$, 0); #else utilize(IVAL($1), $2, $4, $5, $6); $$ = (OP*)NULL; #endif } ; /* Ordinary expressions; logical combinations */ expr : expr ANDOP expr { $$ = newLOGOP(OP_AND, 0, $1, $3); TOKEN_GETMAD($2,$$,'o'); } | expr OROP expr { $$ = newLOGOP(IVAL($2), 0, $1, $3); TOKEN_GETMAD($2,$$,'o'); } | expr DOROP expr { $$ = newLOGOP(OP_DOR, 0, $1, $3); TOKEN_GETMAD($2,$$,'o'); } | argexpr %prec PREC_LOW ; /* Expressions are a list of terms joined by commas */ argexpr : argexpr ',' { #ifdef MAD OP* op = newNULLLIST(); token_getmad($2,op,','); $$ = append_elem(OP_LIST, $1, op); #else $$ = $1; #endif } | argexpr ',' term { OP* term = $3; DO_MAD( term = newUNOP(OP_NULL, 0, term); token_getmad($2,term,','); ) $$ = append_elem(OP_LIST, $1, term); } | term %prec PREC_LOW ; /* List operators */ listop : LSTOP indirob argexpr /* map {...} @args or print $fh @args */ { $$ = convert(IVAL($1), OPf_STACKED, prepend_elem(OP_LIST, newGVREF(IVAL($1),$2), $3) ); TOKEN_GETMAD($1,$$,'o'); } | FUNC '(' indirob expr ')' /* print ($fh @args */ { $$ = convert(IVAL($1), OPf_STACKED, prepend_elem(OP_LIST, newGVREF(IVAL($1),$3), $4) ); TOKEN_GETMAD($1,$$,'o'); TOKEN_GETMAD($2,$$,'('); TOKEN_GETMAD($5,$$,')'); } | term ARROW method '(' listexprcom ')' /* $foo->bar(list) */ { $$ = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, prepend_elem(OP_LIST, scalar($1), $5), newUNOP(OP_METHOD, 0, $3))); TOKEN_GETMAD($2,$$,'A'); TOKEN_GETMAD($4,$$,'('); TOKEN_GETMAD($6,$$,')'); } | term ARROW method /* $foo->bar */ { $$ = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, scalar($1), newUNOP(OP_METHOD, 0, $3))); TOKEN_GETMAD($2,$$,'A'); } | METHOD indirob listexpr /* new Class @args */ { $$ = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, prepend_elem(OP_LIST, $2, $3), newUNOP(OP_METHOD, 0, $1))); } | FUNCMETH indirob '(' listexprcom ')' /* method $object (@args) */ { $$ = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, prepend_elem(OP_LIST, $2, $4), newUNOP(OP_METHOD, 0, $1))); TOKEN_GETMAD($3,$$,'('); TOKEN_GETMAD($5,$$,')'); } | LSTOP listexpr /* print @args */ { $$ = convert(IVAL($1), 0, $2); TOKEN_GETMAD($1,$$,'o'); } | FUNC '(' listexprcom ')' /* print (@args) */ { $$ = convert(IVAL($1), 0, $3); TOKEN_GETMAD($1,$$,'o'); TOKEN_GETMAD($2,$$,'('); TOKEN_GETMAD($4,$$,')'); } | LSTOPSUB startanonsub block /* sub f(&@); f { foo } ... */ { SvREFCNT_inc_simple_void(PL_compcv); $$ = newANONATTRSUB($2, 0, (OP*)NULL, $3); } listexpr %prec LSTOP /* ... @bar */ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, prepend_elem(OP_LIST, $4, $5), $1)); } ; /* Names of methods. May use $object->$methodname */ method : METHOD | scalar ; /* Some kind of subscripted expression */ subscripted: star '{' expr ';' '}' /* *main::{something} */ /* In this and all the hash accessors, ';' is * provided by the tokeniser */ { $$ = newBINOP(OP_GELEM, 0, $1, scalar($3)); PL_parser->expect = XOPERATOR; TOKEN_GETMAD($2,$$,'{'); TOKEN_GETMAD($4,$$,';'); TOKEN_GETMAD($5,$$,'}'); } | scalar '[' expr ']' /* $array[$element] */ { $$ = newBINOP(OP_AELEM, 0, oopsAV($1), scalar($3)); TOKEN_GETMAD($2,$$,'['); TOKEN_GETMAD($4,$$,']'); } | term ARROW '[' expr ']' /* somearef->[$element] */ { $$ = newBINOP(OP_AELEM, 0, ref(newAVREF($1),OP_RV2AV), scalar($4)); TOKEN_GETMAD($2,$$,'a'); TOKEN_GETMAD($3,$$,'['); TOKEN_GETMAD($5,$$,']'); } | subscripted '[' expr ']' /* $foo->[$bar]->[$baz] */ { $$ = newBINOP(OP_AELEM, 0, ref(newAVREF($1),OP_RV2AV), scalar($3)); TOKEN_GETMAD($2,$$,'['); TOKEN_GETMAD($4,$$,']'); } | scalar '{' expr ';' '}' /* $foo->{bar();} */ { $$ = newBINOP(OP_HELEM, 0, oopsHV($1), jmaybe($3)); PL_parser->expect = XOPERATOR; TOKEN_GETMAD($2,$$,'{'); TOKEN_GETMAD($4,$$,';'); TOKEN_GETMAD($5,$$,'}'); } | term ARROW '{' expr ';' '}' /* somehref->{bar();} */ { $$ = newBINOP(OP_HELEM, 0, ref(newHVREF($1),OP_RV2HV), jmaybe($4)); PL_parser->expect = XOPERATOR; TOKEN_GETMAD($2,$$,'a'); TOKEN_GETMAD($3,$$,'{'); TOKEN_GETMAD($5,$$,';'); TOKEN_GETMAD($6,$$,'}'); } | subscripted '{' expr ';' '}' /* $foo->[bar]->{baz;} */ { $$ = newBINOP(OP_HELEM, 0, ref(newHVREF($1),OP_RV2HV), jmaybe($3)); PL_parser->expect = XOPERATOR; TOKEN_GETMAD($2,$$,'{'); TOKEN_GETMAD($4,$$,';'); TOKEN_GETMAD($5,$$,'}'); } | term ARROW '(' ')' /* $subref->() */ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, newCVREF(0, scalar($1))); TOKEN_GETMAD($2,$$,'a'); TOKEN_GETMAD($3,$$,'('); TOKEN_GETMAD($4,$$,')'); } | term ARROW '(' expr ')' /* $subref->(@args) */ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, $4, newCVREF(0, scalar($1)))); TOKEN_GETMAD($2,$$,'a'); TOKEN_GETMAD($3,$$,'('); TOKEN_GETMAD($5,$$,')'); } | subscripted '(' expr ')' /* $foo->{bar}->(@args) */ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, $3, newCVREF(0, scalar($1)))); TOKEN_GETMAD($2,$$,'('); TOKEN_GETMAD($4,$$,')'); } | subscripted '(' ')' /* $foo->{bar}->() */ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, newCVREF(0, scalar($1))); TOKEN_GETMAD($2,$$,'('); TOKEN_GETMAD($3,$$,')'); } | '(' expr ')' '[' expr ']' /* list slice */ { $$ = newSLICEOP(0, $5, $2); TOKEN_GETMAD($1,$$,'('); TOKEN_GETMAD($3,$$,')'); TOKEN_GETMAD($4,$$,'['); TOKEN_GETMAD($6,$$,']'); } | '(' ')' '[' expr ']' /* empty list slice! */ { $$ = newSLICEOP(0, $4, (OP*)NULL); TOKEN_GETMAD($1,$$,'('); TOKEN_GETMAD($2,$$,')'); TOKEN_GETMAD($3,$$,'['); TOKEN_GETMAD($5,$$,']'); } ; /* Binary operators between terms */ termbinop: term ASSIGNOP term /* $x = $y */ { $$ = newASSIGNOP(OPf_STACKED, $1, IVAL($2), $3); TOKEN_GETMAD($2,$$,'o'); } | term POWOP term /* $x ** $y */ { $$ = newBINOP(IVAL($2), 0, scalar($1), scalar($3)); TOKEN_GETMAD($2,$$,'o'); } | term MULOP term /* $x * $y, $x x $y */ { if (IVAL($2) != OP_REPEAT) scalar($1); $$ = newBINOP(IVAL($2), 0, $1, scalar($3)); TOKEN_GETMAD($2,$$,'o'); } | term ADDOP term /* $x + $y */ { $$ = newBINOP(IVAL($2), 0, scalar($1), scalar($3)); TOKEN_GETMAD($2,$$,'o'); } | term SHIFTOP term /* $x >> $y, $x << $y */ { $$ = newBINOP(IVAL($2), 0, scalar($1), scalar($3)); TOKEN_GETMAD($2,$$,'o'); } | term RELOP term /* $x > $y, etc. */ { $$ = newBINOP(IVAL($2), 0, scalar($1), scalar($3)); TOKEN_GETMAD($2,$$,'o'); } | term EQOP term /* $x == $y, $x eq $y */ { $$ = newBINOP(IVAL($2), 0, scalar($1), scalar($3)); TOKEN_GETMAD($2,$$,'o'); } | term BITANDOP term /* $x & $y */ { $$ = newBINOP(IVAL($2), 0, scalar($1), scalar($3)); TOKEN_GETMAD($2,$$,'o'); } | term BITOROP term /* $x | $y */ { $$ = newBINOP(IVAL($2), 0, scalar($1), scalar($3)); TOKEN_GETMAD($2,$$,'o'); } | term DOTDOT term /* $x..$y, $x...$y */ { $$ = newRANGE(IVAL($2), scalar($1), scalar($3)); DO_MAD({ UNOP *op; op = (UNOP*)$$; op = (UNOP*)op->op_first; /* get to flop */ op = (UNOP*)op->op_first; /* get to flip */ op = (UNOP*)op->op_first; /* get to range */ token_getmad($2,(OP*)op,'o'); }) } | term ANDAND term /* $x && $y */ { $$ = newLOGOP(OP_AND, 0, $1, $3); TOKEN_GETMAD($2,$$,'o'); } | term OROR term /* $x || $y */ { $$ = newLOGOP(OP_OR, 0, $1, $3); TOKEN_GETMAD($2,$$,'o'); } | term DORDOR term /* $x // $y */ { $$ = newLOGOP(OP_DOR, 0, $1, $3); TOKEN_GETMAD($2,$$,'o'); } | term MATCHOP term /* $x =~ /$y/ */ { $$ = bind_match(IVAL($2), $1, $3); TOKEN_GETMAD($2, ($$->op_type == OP_NOT ? ((UNOP*)$$)->op_first : $$), '~'); } ; /* Unary operators and terms */ termunop : '-' term %prec UMINUS /* -$x */ { $$ = newUNOP(OP_NEGATE, 0, scalar($2)); TOKEN_GETMAD($1,$$,'o'); } | '+' term %prec UMINUS /* +$x */ { $$ = IF_MAD( newUNOP(OP_NULL, 0, $2), $2 ); TOKEN_GETMAD($1,$$,'+'); } | '!' term /* !$x */ { $$ = newUNOP(OP_NOT, 0, scalar($2)); TOKEN_GETMAD($1,$$,'o'); } | '~' term /* ~$x */ { $$ = newUNOP(OP_COMPLEMENT, 0, scalar($2)); TOKEN_GETMAD($1,$$,'o'); } | term POSTINC /* $x++ */ { $$ = newUNOP(OP_POSTINC, 0, mod(scalar($1), OP_POSTINC)); TOKEN_GETMAD($2,$$,'o'); } | term POSTDEC /* $x-- */ { $$ = newUNOP(OP_POSTDEC, 0, mod(scalar($1), OP_POSTDEC)); TOKEN_GETMAD($2,$$,'o'); } | PREINC term /* ++$x */ { $$ = newUNOP(OP_PREINC, 0, mod(scalar($2), OP_PREINC)); TOKEN_GETMAD($1,$$,'o'); } | PREDEC term /* --$x */ { $$ = newUNOP(OP_PREDEC, 0, mod(scalar($2), OP_PREDEC)); TOKEN_GETMAD($1,$$,'o'); } ; /* Constructors for anonymous data */ anonymous: '[' expr ']' { $$ = newANONLIST($2); TOKEN_GETMAD($1,$$,'['); TOKEN_GETMAD($3,$$,']'); } | '[' ']' { $$ = newANONLIST((OP*)NULL); TOKEN_GETMAD($1,$$,'['); TOKEN_GETMAD($2,$$,']'); } | HASHBRACK expr ';' '}' %prec '(' /* { foo => "Bar" } */ { $$ = newANONHASH($2); TOKEN_GETMAD($1,$$,'{'); TOKEN_GETMAD($3,$$,';'); TOKEN_GETMAD($4,$$,'}'); } | HASHBRACK ';' '}' %prec '(' /* { } (';' by tokener) */ { $$ = newANONHASH((OP*)NULL); TOKEN_GETMAD($1,$$,'{'); TOKEN_GETMAD($2,$$,';'); TOKEN_GETMAD($3,$$,'}'); } | ANONSUB startanonsub proto subattrlist block %prec '(' { SvREFCNT_inc_simple_void(PL_compcv); $$ = newANONATTRSUB($2, $3, $4, $5); TOKEN_GETMAD($1,$$,'o'); OP_GETMAD($3,$$,'s'); OP_GETMAD($4,$$,'a'); } ; /* Things called with "do" */ termdo : DO term %prec UNIOP /* do $filename */ { $$ = dofile($2, IVAL($1)); TOKEN_GETMAD($1,$$,'o'); } | DO block %prec '(' /* do { code */ { $$ = newUNOP(OP_NULL, OPf_SPECIAL, scope($2)); TOKEN_GETMAD($1,$$,'D'); } | DO WORD '(' ')' /* do somesub() */ { $$ = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, scalar(newCVREF( (OPpENTERSUB_AMPER<<8), scalar($2) )),(OP*)NULL)); dep(); TOKEN_GETMAD($1,$$,'o'); TOKEN_GETMAD($3,$$,'('); TOKEN_GETMAD($4,$$,')'); } | DO WORD '(' expr ')' /* do somesub(@args) */ { $$ = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, append_elem(OP_LIST, $4, scalar(newCVREF( (OPpENTERSUB_AMPER<<8), scalar($2) )))); dep(); TOKEN_GETMAD($1,$$,'o'); TOKEN_GETMAD($3,$$,'('); TOKEN_GETMAD($5,$$,')'); } | DO scalar '(' ')' /* do $subref () */ { $$ = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, scalar(newCVREF(0,scalar($2))), (OP*)NULL)); dep(); TOKEN_GETMAD($1,$$,'o'); TOKEN_GETMAD($3,$$,'('); TOKEN_GETMAD($4,$$,')'); } | DO scalar '(' expr ')' /* do $subref (@args) */ { $$ = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, $4, scalar(newCVREF(0,scalar($2))))); dep(); TOKEN_GETMAD($1,$$,'o'); TOKEN_GETMAD($3,$$,'('); TOKEN_GETMAD($5,$$,')'); } ; term : termbinop | termunop | anonymous | termdo | term '?' term ':' term { $$ = newCONDOP(0, $1, $3, $5); TOKEN_GETMAD($2,$$,'?'); TOKEN_GETMAD($4,$$,':'); } | REFGEN term /* \$x, \@y, \%z */ { $$ = newUNOP(OP_REFGEN, 0, mod($2,OP_REFGEN)); TOKEN_GETMAD($1,$$,'o'); } | myattrterm %prec UNIOP { $$ = $1; } | LOCAL term %prec UNIOP { $$ = localize($2,IVAL($1)); TOKEN_GETMAD($1,$$,'k'); } | '(' expr ')' { $$ = sawparens(IF_MAD(newUNOP(OP_NULL,0,$2), $2)); TOKEN_GETMAD($1,$$,'('); TOKEN_GETMAD($3,$$,')'); } | '(' ')' { $$ = sawparens(newNULLLIST()); TOKEN_GETMAD($1,$$,'('); TOKEN_GETMAD($2,$$,')'); } | scalar %prec '(' { $$ = $1; } | star %prec '(' { $$ = $1; } | hsh %prec '(' { $$ = $1; } | ary %prec '(' { $$ = $1; } | arylen %prec '(' /* $#x, $#{ something } */ { $$ = newUNOP(OP_AV2ARYLEN, 0, ref($1, OP_AV2ARYLEN));} | subscripted { $$ = $1; } | ary '[' expr ']' /* array slice */ { $$ = prepend_elem(OP_ASLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_ASLICE, 0, list($3), ref($1, OP_ASLICE))); TOKEN_GETMAD($2,$$,'['); TOKEN_GETMAD($4,$$,']'); } | ary '{' expr ';' '}' /* @hash{@keys} */ { $$ = prepend_elem(OP_HSLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_HSLICE, 0, list($3), ref(oopsHV($1), OP_HSLICE))); PL_parser->expect = XOPERATOR; TOKEN_GETMAD($2,$$,'{'); TOKEN_GETMAD($4,$$,';'); TOKEN_GETMAD($5,$$,'}'); } | THING %prec '(' { $$ = $1; } | amper /* &foo; */ { $$ = newUNOP(OP_ENTERSUB, 0, scalar($1)); } | amper '(' ')' /* &foo() */ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar($1)); TOKEN_GETMAD($2,$$,'('); TOKEN_GETMAD($3,$$,')'); } | amper '(' expr ')' /* &foo(@args) */ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, $3, scalar($1))); DO_MAD({ OP* op = $$; if (op->op_type == OP_CONST) { /* defeat const fold */ op = (OP*)op->op_madprop->mad_val; } token_getmad($2,op,'('); token_getmad($4,op,')'); }) } | NOAMP WORD listexpr /* foo(@args) */ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, $3, scalar($2))); TOKEN_GETMAD($1,$$,'o'); } | LOOPEX /* loop exiting command (goto, last, dump, etc) */ { $$ = newOP(IVAL($1), OPf_SPECIAL); PL_hints |= HINT_BLOCK_SCOPE; TOKEN_GETMAD($1,$$,'o'); } | LOOPEX term { $$ = newLOOPEX(IVAL($1),$2); TOKEN_GETMAD($1,$$,'o'); } | NOTOP argexpr /* not $foo */ { $$ = newUNOP(OP_NOT, 0, scalar($2)); TOKEN_GETMAD($1,$$,'o'); } | UNIOP /* Unary op, $_ implied */ { $$ = newOP(IVAL($1), 0); TOKEN_GETMAD($1,$$,'o'); } | UNIOP block /* eval { foo }* */ { $$ = newUNOP(IVAL($1), 0, $2); TOKEN_GETMAD($1,$$,'o'); } | UNIOP term /* Unary op */ { $$ = newUNOP(IVAL($1), 0, $2); TOKEN_GETMAD($1,$$,'o'); } | REQUIRE /* require, $_ implied */ { $$ = newOP(OP_REQUIRE, $1 ? OPf_SPECIAL : 0); TOKEN_GETMAD($1,$$,'o'); } | REQUIRE term /* require Foo */ { $$ = newUNOP(OP_REQUIRE, $1 ? OPf_SPECIAL : 0, $2); TOKEN_GETMAD($1,$$,'o'); } | UNIOPSUB { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar($1)); } | UNIOPSUB term /* Sub treated as unop */ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, $2, scalar($1))); } | FUNC0 /* Nullary operator */ { $$ = newOP(IVAL($1), 0); TOKEN_GETMAD($1,$$,'o'); } | FUNC0 '(' ')' { $$ = newOP(IVAL($1), 0); TOKEN_GETMAD($1,$$,'o'); TOKEN_GETMAD($2,$$,'('); TOKEN_GETMAD($3,$$,')'); } | FUNC0SUB /* Sub treated as nullop */ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar($1)); } | FUNC1 '(' ')' /* not () */ { $$ = (IVAL($1) == OP_NOT) ? newUNOP(IVAL($1), 0, newSVOP(OP_CONST, 0, newSViv(0))) : newOP(IVAL($1), OPf_SPECIAL); TOKEN_GETMAD($1,$$,'o'); TOKEN_GETMAD($2,$$,'('); TOKEN_GETMAD($3,$$,')'); } | FUNC1 '(' expr ')' /* not($foo) */ { $$ = newUNOP(IVAL($1), 0, $3); TOKEN_GETMAD($1,$$,'o'); TOKEN_GETMAD($2,$$,'('); TOKEN_GETMAD($4,$$,')'); } | PMFUNC '(' argexpr ')' /* m//, s///, tr/// */ { $$ = pmruntime($1, $3, 1); TOKEN_GETMAD($2,$$,'('); TOKEN_GETMAD($4,$$,')'); } | WORD | listop | YADAYADA { $$ = newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0), newSVOP(OP_CONST, 0, newSVpvs("Unimplemented"))); TOKEN_GETMAD($1,$$,'X'); } | PLUGEXPR ; /* "my" declarations, with optional attributes */ myattrterm: MY myterm myattrlist { $$ = my_attrs($2,$3); DO_MAD( token_getmad($1,$$,'d'); append_madprops($3->op_madprop, $$, 'a'); $3->op_madprop = 0; ) } | MY myterm { $$ = localize($2,IVAL($1)); TOKEN_GETMAD($1,$$,'d'); } ; /* Things that can be "my"'d */ myterm : '(' expr ')' { $$ = sawparens($2); TOKEN_GETMAD($1,$$,'('); TOKEN_GETMAD($3,$$,')'); } | '(' ')' { $$ = sawparens(newNULLLIST()); TOKEN_GETMAD($1,$$,'('); TOKEN_GETMAD($2,$$,')'); } | scalar %prec '(' { $$ = $1; } | hsh %prec '(' { $$ = $1; } | ary %prec '(' { $$ = $1; } ; /* Basic list expressions */ listexpr: /* NULL */ %prec PREC_LOW { $$ = (OP*)NULL; } | argexpr %prec PREC_LOW { $$ = $1; } ; listexprcom: /* NULL */ { $$ = (OP*)NULL; } | expr { $$ = $1; } | expr ',' { #ifdef MAD OP* op = newNULLLIST(); token_getmad($2,op,','); $$ = append_elem(OP_LIST, $1, op); #else $$ = $1; #endif } ; /* A little bit of trickery to make "for my $foo (@bar)" actually be lexical */ my_scalar: scalar { PL_parser->in_my = 0; $$ = my($1); } ; amper : '&' indirob { $$ = newCVREF(IVAL($1),$2); TOKEN_GETMAD($1,$$,'&'); } ; scalar : '$' indirob { $$ = newSVREF($2); TOKEN_GETMAD($1,$$,'$'); } ; ary : '@' indirob { $$ = newAVREF($2); TOKEN_GETMAD($1,$$,'@'); } ; hsh : '%' indirob { $$ = newHVREF($2); TOKEN_GETMAD($1,$$,'%'); } ; arylen : DOLSHARP indirob { $$ = newAVREF($2); TOKEN_GETMAD($1,$$,'l'); } ; star : '*' indirob { $$ = newGVREF(0,$2); TOKEN_GETMAD($1,$$,'*'); } ; /* Indirect objects */ indirob : WORD { $$ = scalar($1); } | scalar %prec PREC_LOW { $$ = scalar($1); } | block { $$ = scope($1); } | PRIVATEREF { $$ = $1; } ; perl-5.12.0-RC0/make_patchnum.pl0000444000175000017500000001521011344764022015300 0ustar jessejesse#!/usr/bin/perl # These two should go upon release to make the script Perl 5.005 compatible use strict; use warnings; =head1 NAME make_patchnum.pl - make patchnum =head1 SYNOPSIS miniperl make_patchnum.pl perl make_patchnum.pl =head1 DESCRIPTION This program creates the files holding the information about locally applied patches to the source code. The created files are C and C. =head2 C Contains status information from git in a form meant to be processed by the tied hash logic of Config.pm. It is actually optional, although -V:git.\* will be uninformative without it. C contains similar information in a C header file format, designed to be used by patchlevel.h. This file is obtained from stock_git_version.h if miniperl is not available, and then later on replaced by the version created by this script. =head1 AUTHOR Yves Orton, Kenichi Ishigaki, Max Maischein =head1 COPYRIGHT Same terms as Perl itself. =cut # from a -Dmksymlink target dir, I need to cd to the git-src tree to # use git (like script does). Presuming that's not unique, one fix is # to follow Configure's symlink-path to run git. Maybe GIT_DIR or # path-args can solve it, if so we should advise here, I tried only # very briefly ('cd -' works too). my ($subcd, $srcdir); our $opt_v = scalar grep $_ eq '-v', @ARGV; BEGIN { my $root="."; # test 1st to see if we're a -Dmksymlinks target dir $subcd = ''; $srcdir = $root; if (-l "./Configure") { $srcdir = readlink("./Configure"); $srcdir =~ s/Configure//; $subcd = "cd $srcdir &&"; # activate backtick fragment } while (!-e "$root/perl.c" and length($root)<100) { if ($root eq '.') { $root=".."; } else { $root.="/.."; } } die "Can't find toplevel" if !-e "$root/perl.c"; sub path_to { "$root/$_[0]" } # use $_[0] if this'd be placed in toplevel. } sub read_file { my $file = path_to(@_); return "" unless -e $file; open my $fh, '<', $file or die "Failed to open for read '$file':$!"; return do { local $/; <$fh> }; } sub write_file { my ($file, $content) = @_; $file= path_to($file); open my $fh, '>', $file or die "Failed to open for write '$file':$!"; print $fh $content; close $fh; } sub backtick { # only for git. If we're in a -Dmksymlinks build-dir, we need to # cd to src so git will work . Probably a better way. my $command = shift; if (wantarray) { my @result= `$subcd $command`; #warn "$subcd $command: \$?=$?\n" if $?; print "#> $subcd $command ->\n @result\n" if !$? and $opt_v; chomp @result; return @result; } else { my $result= `$subcd $command`; $result="" if ! defined $result; warn "$subcd $command: \$?=$?\n" if $?; print "#> $subcd $command ->\n $result\n" if !$? and $opt_v; chomp $result; return $result; } } sub write_files { my %content= map { /WARNING: '([^']+)'/ || die "Bad mojo!"; $1 => $_ } @_; my @files= sort keys %content; my $files= join " and ", map { "'$_'" } @files; foreach my $file (@files) { if (read_file($file) ne $content{$file}) { print "Updating $files\n"; write_file($_,$content{$_}) for @files; return 1; } } print "Reusing $files\n"; return 0; } my $unpushed_commits = ' '; my ($read, $branch, $snapshot_created, $commit_id, $describe)= ("") x 5; my ($changed, $extra_info, $commit_title)= ("") x 3; if (my $patch_file= read_file(".patch")) { ($branch, $snapshot_created, $commit_id, $describe) = split /\s+/, $patch_file; $extra_info = "git_snapshot_date='$snapshot_created'"; $commit_title = "Snapshot of:"; } elsif (-d "$srcdir/.git") { # git branch | awk 'BEGIN{ORS=""} /\*/ { print $2 }' ($branch) = map { /\* ([^(]\S*)/ ? $1 : () } backtick("git branch"); my ($remote,$merge); if (length $branch) { $merge= backtick("git config branch.$branch.merge"); $merge = "" unless $? == 0; $merge =~ s!^refs/heads/!!; $remote= backtick("git config branch.$branch.remote"); $remote = "" unless $? == 0; } $commit_id = backtick("git rev-parse HEAD"); $describe = backtick("git describe"); my $commit_created = backtick(qq{git log -1 --pretty="format:%ci"}); $extra_info = "git_commit_date='$commit_created'"; backtick("git diff --no-ext-diff --quiet --exit-code"); $changed = $?; unless ($changed) { backtick("git diff-index --cached --quiet HEAD --"); $changed = $?; } if (length $branch && length $remote) { # git cherry $remote/$branch | awk 'BEGIN{ORS=","} /\+/ {print $2}' | sed -e 's/,$//' my $unpushed_commit_list = join ",", map { (split /\s/, $_)[1] } grep {/\+/} backtick("git cherry $remote/$merge"); # git cherry $remote/$branch | awk 'BEGIN{ORS="\t\\\\\n"} /\+/ {print ",\"" $2 "\""}' $unpushed_commits = join "", map { ',"'.(split /\s/, $_)[1]."\"\t\\\n" } grep {/\+/} backtick("git cherry $remote/$merge"); if (length $unpushed_commits) { $commit_title = "Local Commit:"; my $ancestor = backtick("git rev-parse $remote/$merge"); $extra_info = "$extra_info git_ancestor='$ancestor' git_remote_branch='$remote/$merge' git_unpushed='$unpushed_commit_list'"; } } if ($changed) { $commit_title = "Derived from:"; } $commit_title ||= "Commit id:"; } # we extract the filename out of the warning header, so dont mess with that write_files(<<"EOF_HEADER", <<"EOF_CONFIG"); /************************************************************************** * WARNING: 'git_version.h' is automatically generated by make_patchnum.pl * DO NOT EDIT DIRECTLY - edit make_patchnum.pl instead ***************************************************************************/ @{[$describe ? "#define PERL_PATCHNUM \"$describe\"" : ()]} #define PERL_GIT_UNPUSHED_COMMITS\t\t\\ $unpushed_commits/*leave-this-comment*/ @{[$changed ? "#define PERL_GIT_UNCOMMITTED_CHANGES" : ()]} EOF_HEADER ###################################################################### # WARNING: 'lib/Config_git.pl' is generated by make_patchnum.pl # DO NOT EDIT DIRECTLY - edit make_patchnum.pl instead ###################################################################### \$Config::Git_Data=<<'ENDOFGIT'; git_commit_id='$commit_id' git_describe='$describe' git_branch='$branch' git_uncommitted_changes='$changed' git_commit_id_title='$commit_title' $extra_info ENDOFGIT EOF_CONFIG # ex: set ts=8 sts=4 sw=4 et ft=perl: perl-5.12.0-RC0/README.linux0000444000175000017500000000272411325125741014151 0ustar jessejesseIf you read this file _as_is_, just ignore the funny characters you see. It is written in the POD format (see pod/perlpod.pod) which is specifically designed to be readable as is. =head1 NAME README.linux - Perl version 5 on Linux systems =head1 DESCRIPTION This document describes various features of Linux that will affect how Perl version 5 (hereafter just Perl) is compiled and/or runs. =head2 Experimental Support for Sun Studio Compilers for Linux OS Sun Microsystems has released a port of their Sun Studio compiliers for Linux. As of November 2005, only an alpha version has been released. Until a release of these compilers is made, support for compiling Perl with these compiler experimental. Also, some special instructions for building Perl with Sun Studio on Linux. Following the normal C, you have to run make as follows: LDLOADLIBS=-lc make C is an environment variable used by the linker to link modules C modules to glibc. Currently, that environment variable is not getting populated by a combination of C entries and C. While there may be a bug somewhere in Perl's configuration or C causing the problem, the most likely cause is an incomplete understanding of Sun Studio by this author. Further investigation is needed to get this working better. =head1 AUTHOR Steve Peters Please report any errors, updates, or suggestions to F. perl-5.12.0-RC0/configpm0000555000175000017500000007272111325127001013656 0ustar jessejesse#!./miniperl -w # # configpm # # Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, # 2002, 2003, 2004, 2005, 2006, 2007 Larry Wall and others. # # # Regenerate the files # # lib/Config.pm # lib/Config_heavy.pl # lib/Config.pod # lib/Cross.pm (optionally) # # # from the contents of the static files # # Porting/Glossary # myconfig.SH # # and from the contents of the Configure-generated file # # config.sh # # Note that output directory is xlib/[cross-name]/ for cross-compiling # # It will only update Config.pm and Config_heavy.pl if the contents of # either file would be different. Note that *both* files are updated in # this case, since for example an extension makefile that has a dependency # on Config.pm should trigger even if only Config_heavy.pl has changed. sub usage { die <; chomp; /^(\S+):\s*(\d+)$/ or die "Malformed line '$_'"; $Common{$1} = $1; } # names of things which may need to have slashes changed to double-colons my %Extensions = map {($_,$_)} qw(dynamic_ext static_ext extensions known_extensions); # allowed opts as well as specifies default and initial values my %Allowed_Opts = ( 'cross' => '', # --cross=PLATFORM - crosscompiling for PLATFORM 'glossary' => 1, # --no-glossary - no glossary file inclusion, # for compactness 'chdir' => '', # --chdir=dir - change directory before writing files ); sub opts { # user specified options my %given_opts = ( # --opt=smth (map {/^--([\-_\w]+)=(.*)$/} @ARGV), # --opt --no-opt --noopt (map {/^no-?(.*)$/i?($1=>0):($_=>1)} map {/^--([\-_\w]+)$/} @ARGV), ); my %opts = (%Allowed_Opts, %given_opts); for my $opt (grep {!exists $Allowed_Opts{$_}} keys %given_opts) { warn "option '$opt' is not recognized"; usage; } @ARGV = grep {!/^--/} @ARGV; return %opts; } my %Opts = opts(); if ($Opts{chdir}) { chdir $Opts{chdir} or die "$0: could not chdir $Opts{chdir}: $!" } my ($Config_SH, $Config_PM, $Config_heavy, $Config_POD); my $Glossary = 'Porting/Glossary'; if ($Opts{cross}) { # creating cross-platform config file mkdir "xlib"; mkdir "xlib/$Opts{cross}"; $Config_PM = "xlib/$Opts{cross}/Config.pm"; $Config_POD = "xlib/$Opts{cross}/Config.pod"; $Config_SH = "Cross/config-$Opts{cross}.sh"; } else { $Config_PM = "lib/Config.pm"; $Config_POD = "lib/Config.pod"; $Config_SH = "config.sh"; } ($Config_heavy = $Config_PM) =~ s/\.pm$/_heavy.pl/; die "Can't automatically determine name for Config_heavy.pl from '$Config_PM'" if $Config_heavy eq $Config_PM; my $config_txt; my $heavy_txt; $heavy_txt .= <<'ENDOFBEG'; # This file was created by configpm when Perl was built. Any changes # made to this file will be lost the next time perl is built. package Config; use strict; # use warnings; Pulls in Carp # use vars pulls in Carp sub _V { my ($bincompat, $non_bincompat, $date, @patches) = Internals::V(); my $opts = join ' ', sort split ' ', "$bincompat $non_bincompat"; # wrap at 76 columns. $opts =~ s/(?=.{53})(.{1,53}) /$1\n /mg; print Config::myconfig(); if ($^O eq 'VMS') { print "\nCharacteristics of this PERLSHR image: \n"; } else { print "\nCharacteristics of this binary (from libperl): \n"; } print " Compile-time options: $opts\n"; if (@patches) { print " Locally applied patches:\n"; print "\t$_\n" foreach @patches; } print " Built under $^O\n"; print " $date\n" if defined $date; my @env = map { "$_=\"$ENV{$_}\"" } sort grep {/^PERL/} keys %ENV; push @env, "CYGWIN=\"$ENV{CYGWIN}\"" if $^O eq 'cygwin'; if (@env) { print " \%ENV:\n"; print " $_\n" foreach @env; } print " \@INC:\n"; print " $_\n" foreach @INC; } ENDOFBEG my $myver = sprintf "%vd", $^V; $config_txt .= sprintf <<'ENDOFBEG', ($myver) x 3; # This file was created by configpm when Perl was built. Any changes # made to this file will be lost the next time perl is built. # for a description of the variables, please have a look at the # Glossary file, as written in the Porting folder, or use the url: # http://perl5.git.perl.org/perl.git/blob/HEAD:/Porting/Glossary package Config; use strict; # use warnings; Pulls in Carp # use vars pulls in Carp @Config::EXPORT = qw(%%Config); @Config::EXPORT_OK = qw(myconfig config_sh config_vars config_re); # Need to stub all the functions to make code such as print Config::config_sh # keep working sub myconfig; sub config_sh; sub config_vars; sub config_re; my %%Export_Cache = map {($_ => 1)} (@Config::EXPORT, @Config::EXPORT_OK); our %%Config; # Define our own import method to avoid pulling in the full Exporter: sub import { my $pkg = shift; @_ = @Config::EXPORT unless @_; my @funcs = grep $_ ne '%%Config', @_; my $export_Config = @funcs < @_ ? 1 : 0; no strict 'refs'; my $callpkg = caller(0); foreach my $func (@funcs) { die sprintf qq{"%%s" is not exported by the %%s module\n}, $func, __PACKAGE__ unless $Export_Cache{$func}; *{$callpkg.'::'.$func} = \&{$func}; } *{"$callpkg\::Config"} = \%%Config if $export_Config; return; } die "Perl lib version (%s) doesn't match executable version ($])" unless $^V; $^V eq %s or die "Perl lib version (%s) doesn't match executable version (" . sprintf("v%%vd",$^V) . ")"; ENDOFBEG my @non_v = (); my @v_others = (); my $in_v = 0; my %Data = (); my %seen_quotes; { my ($name, $val); open(CONFIG_SH, $Config_SH) || die "Can't open $Config_SH: $!"; while () { next if m:^#!/bin/sh:; # Catch PERL_CONFIG_SH=true and PERL_VERSION=n line from Configure. s/^(\w+)=(true|\d+)\s*$/$1='$2'\n/ or m/^(\w+)='(.*)'$/; my($k, $v) = ($1, $2); # grandfather PATCHLEVEL and SUBVERSION and CONFIG if ($k) { if ($k eq 'PERL_VERSION') { push @v_others, "PATCHLEVEL='$v'\n"; } elsif ($k eq 'PERL_SUBVERSION') { push @v_others, "SUBVERSION='$v'\n"; } elsif ($k eq 'PERL_CONFIG_SH') { push @v_others, "CONFIG='$v'\n"; } } # We can delimit things in config.sh with either ' or ". unless ($in_v or m/^(\w+)=(['"])(.*\n)/){ push(@non_v, "#$_"); # not a name='value' line next; } my $quote = $2; if ($in_v) { $val .= $_; } else { ($name,$val) = ($1,$3); } $in_v = $val !~ /$quote\n/; next if $in_v; s,/,::,g if $Extensions{$name}; $val =~ s/$quote\n?\z//; my $line = "$name=$quote$val$quote\n"; push(@v_others, $line); $seen_quotes{$quote}++; } close CONFIG_SH; } # This is somewhat grim, but I want the code for parsing config.sh here and # now so that I can expand $Config{ivsize} and $Config{ivtype} my $fetch_string = <<'EOT'; # Search for it in the big string sub fetch_string { my($self, $key) = @_; EOT if ($seen_quotes{'"'}) { # We need the full ' and " code $fetch_string .= <<'EOT'; my $quote_type = "'"; my $marker = "$key="; # Check for the common case, ' delimited my $start = index($Config_SH_expanded, "\n$marker$quote_type"); # If that failed, check for " delimited if ($start == -1) { $quote_type = '"'; $start = index($Config_SH_expanded, "\n$marker$quote_type"); } EOT } else { $fetch_string .= <<'EOT'; # We only have ' delimted. my $start = index($Config_SH_expanded, "\n$key=\'"); EOT } $fetch_string .= <<'EOT'; # Start can never be -1 now, as we've rigged the long string we're # searching with an initial dummy newline. return undef if $start == -1; $start += length($key) + 3; EOT if (!$seen_quotes{'"'}) { # Don't need the full ' and " code, or the eval expansion. $fetch_string .= <<'EOT'; my $value = substr($Config_SH_expanded, $start, index($Config_SH_expanded, "'\n", $start) - $start); EOT } else { $fetch_string .= <<'EOT'; my $value = substr($Config_SH_expanded, $start, index($Config_SH_expanded, "$quote_type\n", $start) - $start); # If we had a double-quote, we'd better eval it so escape # sequences and such can be interpolated. Since the incoming # value is supposed to follow shell rules and not perl rules, # we escape any perl variable markers if ($quote_type eq '"') { $value =~ s/\$/\\\$/g; $value =~ s/\@/\\\@/g; eval "\$value = \"$value\""; } EOT } $fetch_string .= <<'EOT'; # So we can say "if $Config{'foo'}". $value = undef if $value eq 'undef'; $self->{$key} = $value; # cache it } EOT eval $fetch_string; die if $@; # Calculation for the keys for byteorder # This is somewhat grim, but I need to run fetch_string here. our $Config_SH_expanded = join "\n", '', @v_others; my $t = fetch_string ({}, 'ivtype'); my $s = fetch_string ({}, 'ivsize'); # byteorder does exist on its own but we overlay a virtual # dynamically recomputed value. # However, ivtype and ivsize will not vary for sane fat binaries my $f = $t eq 'long' ? 'L!' : $s == 8 ? 'Q': 'I'; my $byteorder_code; if ($s == 4 || $s == 8) { my $list = join ',', reverse(2..$s); my $format = 'a'x$s; $byteorder_code = <<"EOT"; my \$i = 0; foreach my \$c ($list) { \$i |= ord(\$c); \$i <<= 8 } \$i |= ord(1); our \$byteorder = join('', unpack('$format', pack('$f', \$i))); EOT } else { $byteorder_code = "our \$byteorder = '?'x$s;\n"; } my @need_relocation; if (fetch_string({},'userelocatableinc')) { foreach my $what (qw(prefixexp archlibexp html1direxp html3direxp man1direxp man3direxp privlibexp scriptdirexp sitearchexp sitebinexp sitehtml1direxp sitehtml3direxp sitelibexp siteman1direxp siteman3direxp sitescriptexp vendorarchexp vendorbinexp vendorhtml1direxp vendorhtml3direxp vendorlibexp vendorman1direxp vendorman3direxp vendorscriptexp siteprefixexp sitelib_stem vendorlib_stem installarchlib installhtml1dir installhtml3dir installman1dir installman3dir installprefix installprefixexp installprivlib installscript installsitearch installsitebin installsitehtml1dir installsitehtml3dir installsitelib installsiteman1dir installsiteman3dir installsitescript installvendorarch installvendorbin installvendorhtml1dir installvendorhtml3dir installvendorlib installvendorman1dir installvendorman3dir installvendorscript )) { push @need_relocation, $what if fetch_string({}, $what) =~ m!^\.\.\./!; } } my %need_relocation; @need_relocation{@need_relocation} = @need_relocation; # This can have .../ anywhere: if (fetch_string({}, 'otherlibdirs') =~ m!\.\.\./!) { $need_relocation{otherlibdirs} = 'otherlibdirs'; } my $relocation_code = <<'EOT'; sub relocate_inc { my $libdir = shift; return $libdir unless $libdir =~ s!^\.\.\./!!; my $prefix = $^X; if ($prefix =~ s!/[^/]*$!!) { while ($libdir =~ m!^\.\./!) { # Loop while $libdir starts "../" and $prefix still has a trailing # directory last unless $prefix =~ s!/([^/]+)$!!; # but bail out if the directory we picked off the end of $prefix is . # or .. if ($1 eq '.' or $1 eq '..') { # Undo! This should be rare, hence code it this way rather than a # check each time before the s!!! above. $prefix = "$prefix/$1"; last; } # Remove that leading ../ and loop again substr ($libdir, 0, 3, ''); } $libdir = "$prefix/$libdir"; } $libdir; } EOT if (%need_relocation) { my $relocations_in_common; # otherlibdirs only features in the hash foreach (keys %need_relocation) { $relocations_in_common++ if $Common{$_}; } if ($relocations_in_common) { $config_txt .= $relocation_code; } else { $heavy_txt .= $relocation_code; } } $heavy_txt .= join('', @non_v) . "\n"; # copy config summary format from the myconfig.SH script $heavy_txt .= "our \$summary = <<'!END!';\n"; open(MYCONFIG,") && !/^Summary of/; do { $heavy_txt .= $_ } until !defined($_ = ) || /^\s*$/; close(MYCONFIG); $heavy_txt .= "\n!END!\n" . <<'EOT'; my $summary_expanded; sub myconfig { return $summary_expanded if $summary_expanded; ($summary_expanded = $summary) =~ s{\$(\w+)} { my $c; if ($1 eq 'git_ancestor_line') { if ($Config::Config{git_ancestor}) { $c= "\n Ancestor: $Config::Config{git_ancestor}"; } else { $c= ""; } } else { $c = $Config::Config{$1}; } defined($c) ? $c : 'undef' }ge; $summary_expanded; } local *_ = \my $a; $_ = <<'!END!'; EOT $heavy_txt .= join('', sort @v_others) . "!END!\n"; # Only need the dynamic byteorder code in Config.pm if 'byteorder' is one of # the precached keys if ($Common{byteorder}) { $config_txt .= $byteorder_code; } else { $heavy_txt .= $byteorder_code; } if (@need_relocation) { $heavy_txt .= 'foreach my $what (qw(' . join (' ', @need_relocation) . ")) {\n" . <<'EOT'; s/^($what=)(['"])(.*?)\2/$1 . $2 . relocate_inc($3) . $2/me; } EOT # Currently it only makes sense to do the ... relocation on Unix, so there's # no need to emulate the "which separator for this platform" logic in perl.c - # ':' will always be applicable if ($need_relocation{otherlibdirs}) { $heavy_txt .= << 'EOT'; s{^(otherlibdirs=)(['"])(.*?)\2} {$1 . $2 . join ':', map {relocate_inc($_)} split ':', $3 . $2}me; EOT } } $heavy_txt .= <<'EOT'; s/(byteorder=)(['"]).*?\2/$1$2$Config::byteorder$2/m; my $config_sh_len = length $_; our $Config_SH_expanded = "\n$_" . << 'EOVIRTUAL'; EOT foreach my $prefix (qw(ccflags ldflags)) { my $value = fetch_string ({}, $prefix); my $withlargefiles = fetch_string ({}, $prefix . "_uselargefiles"); if (defined $withlargefiles) { $value =~ s/\Q$withlargefiles\E\b//; $heavy_txt .= "${prefix}_nolargefiles='$value'\n"; } } foreach my $prefix (qw(libs libswanted)) { my $value = fetch_string ({}, $prefix); my $withlf = fetch_string ({}, 'libswanted_uselargefiles'); next unless defined $withlf; my @lflibswanted = split(' ', fetch_string ({}, 'libswanted_uselargefiles')); if (@lflibswanted) { my %lflibswanted; @lflibswanted{@lflibswanted} = (); if ($prefix eq 'libs') { my @libs = grep { /^-l(.+)/ && not exists $lflibswanted{$1} } split(' ', fetch_string ({}, 'libs')); $value = join(' ', @libs); } else { my @libswanted = grep { not exists $lflibswanted{$_} } split(' ', fetch_string ({}, 'libswanted')); $value = join(' ', @libswanted); } } $heavy_txt .= "${prefix}_nolargefiles='$value'\n"; } $heavy_txt .= "EOVIRTUAL\n"; $heavy_txt .= <<'ENDOFGIT'; eval { # do not have hairy conniptions if this isnt available require 'Config_git.pl'; $Config_SH_expanded .= $Config::Git_Data; 1; } or warn "Warning: failed to load Config_git.pl, something strange about this perl...\n"; ENDOFGIT $heavy_txt .= $fetch_string; $config_txt .= <<'ENDOFEND'; sub FETCH { my($self, $key) = @_; # check for cached value (which may be undef so we use exists not defined) return $self->{$key} if exists $self->{$key}; return $self->fetch_string($key); } ENDOFEND $heavy_txt .= <<'ENDOFEND'; my $prevpos = 0; sub FIRSTKEY { $prevpos = 0; substr($Config_SH_expanded, 1, index($Config_SH_expanded, '=') - 1 ); } sub NEXTKEY { ENDOFEND if ($seen_quotes{'"'}) { $heavy_txt .= <<'ENDOFEND'; # Find out how the current key's quoted so we can skip to its end. my $quote = substr($Config_SH_expanded, index($Config_SH_expanded, "=", $prevpos)+1, 1); my $pos = index($Config_SH_expanded, qq($quote\n), $prevpos) + 2; ENDOFEND } else { # Just ' quotes, so it's much easier. $heavy_txt .= <<'ENDOFEND'; my $pos = index($Config_SH_expanded, qq('\n), $prevpos) + 2; ENDOFEND } $heavy_txt .= <<'ENDOFEND'; my $len = index($Config_SH_expanded, "=", $pos) - $pos; $prevpos = $pos; $len > 0 ? substr($Config_SH_expanded, $pos, $len) : undef; } sub EXISTS { return 1 if exists($_[0]->{$_[1]}); return(index($Config_SH_expanded, "\n$_[1]='") != -1 ENDOFEND if ($seen_quotes{'"'}) { $heavy_txt .= <<'ENDOFEND'; or index($Config_SH_expanded, "\n$_[1]=\"") != -1 ENDOFEND } $heavy_txt .= <<'ENDOFEND'; ); } sub STORE { die "\%Config::Config is read-only\n" } *DELETE = \&STORE; *CLEAR = \&STORE; sub config_sh { substr $Config_SH_expanded, 1, $config_sh_len; } sub config_re { my $re = shift; return map { chomp; $_ } grep eval{ /^(?:$re)=/ }, split /^/, $Config_SH_expanded; } sub config_vars { # implements -V:cfgvar option (see perlrun -V:) foreach (@_) { # find optional leading, trailing colons; and query-spec my ($notag,$qry,$lncont) = m/^(:)?(.*?)(:)?$/; # flags fore and aft, # map colon-flags to print decorations my $prfx = $notag ? '': "$qry="; # tag-prefix for print my $lnend = $lncont ? ' ' : ";\n"; # line ending for print # all config-vars are by definition \w only, any \W means regex if ($qry =~ /\W/) { my @matches = config_re($qry); print map "$_$lnend", @matches ? @matches : "$qry: not found" if !$notag; print map { s/\w+=//; "$_$lnend" } @matches ? @matches : "$qry: not found" if $notag; } else { my $v = (exists $Config::Config{$qry}) ? $Config::Config{$qry} : 'UNKNOWN'; $v = 'undef' unless defined $v; print "${prfx}'${v}'$lnend"; } } } # Called by the real AUTOLOAD sub launcher { undef &AUTOLOAD; goto \&$Config::AUTOLOAD; } 1; ENDOFEND if ($^O eq 'os2') { $config_txt .= <<'ENDOFSET'; my %preconfig; if ($OS2::is_aout) { my ($value, $v) = $Config_SH_expanded =~ m/^used_aout='(.*)'\s*$/m; for (split ' ', $value) { ($v) = $Config_SH_expanded =~ m/^aout_$_='(.*)'\s*$/m; $preconfig{$_} = $v eq 'undef' ? undef : $v; } } $preconfig{d_fork} = undef unless $OS2::can_fork; # Some funny cases can't sub TIEHASH { bless {%preconfig} } ENDOFSET # Extract the name of the DLL from the makefile to avoid duplication my ($f) = grep -r, qw(GNUMakefile Makefile); my $dll; if (open my $fh, '<', $f) { while (<$fh>) { $dll = $1, last if /^PERL_DLL_BASE\s*=\s*(\S*)\s*$/; } } $config_txt .= < ? my $qkey = $key =~ /^[A-Za-z_][A-Za-z0-9_]*$/ ? $key : "'$key'"; if (defined $value) { # Quote things for a '' string $value =~ s!\\!\\\\!g; $value =~ s!'!\\'!g; $value = "'$value'"; if ($key eq 'otherlibdirs') { $value = "join (':', map {relocate_inc(\$_)} split (':', $value))"; } elsif ($need_relocation{$key}) { $value = "relocate_inc($value)"; } } else { $value = "undef"; } $Common{$key} = "$qkey => $value"; } if ($Common{byteorder}) { $Common{byteorder} = 'byteorder => $byteorder'; } my $fast_config = join '', map { " $_,\n" } sort values %Common; # Sanity check needed to stop an infite loop if Config_heavy.pl fails to define # &launcher for some reason (eg it got truncated) $config_txt .= sprintf <<'ENDOFTIE', $fast_config; sub DESTROY { } sub AUTOLOAD { require 'Config_heavy.pl'; goto \&launcher unless $Config::AUTOLOAD =~ /launcher$/; die "&Config::AUTOLOAD failed on $Config::AUTOLOAD"; } # tie returns the object, so the value returned to require will be true. tie %%Config, 'Config', { %s}; ENDOFTIE open(CONFIG_POD, ">$Config_POD") or die "Can't open $Config_POD: $!"; print CONFIG_POD <<'ENDOFTAIL'; =head1 NAME Config - access Perl configuration information =head1 SYNOPSIS use Config; if ($Config{usethreads}) { print "has thread support\n" } use Config qw(myconfig config_sh config_vars config_re); print myconfig(); print config_sh(); print config_re(); config_vars(qw(osname archname)); =head1 DESCRIPTION The Config module contains all the information that was available to the C program at Perl build time (over 900 values). Shell variables from the F file (written by Configure) are stored in the readonly-variable C<%Config>, indexed by their names. Values stored in config.sh as 'undef' are returned as undefined values. The perl C function can be used to check if a named variable exists. For a description of the variables, please have a look at the Glossary file, as written in the Porting folder, or use the url: http://perl5.git.perl.org/perl.git/blob/HEAD:/Porting/Glossary =over 4 =item myconfig() Returns a textual summary of the major perl configuration values. See also C<-V> in L. =item config_sh() Returns the entire perl configuration information in the form of the original config.sh shell variable assignment script. =item config_re($regex) Like config_sh() but returns, as a list, only the config entries who's names match the $regex. =item config_vars(@names) Prints to STDOUT the values of the named configuration variable. Each is printed on a separate line in the form: name='value'; Names which are unknown are output as C. See also C<-V:name> in L. =back =head1 EXAMPLE Here's a more sophisticated example of using %Config: use Config; use strict; my %sig_num; my @sig_name; unless($Config{sig_name} && $Config{sig_num}) { die "No sigs?"; } else { my @names = split ' ', $Config{sig_name}; @sig_num{@names} = split ' ', $Config{sig_num}; foreach (@names) { $sig_name[$sig_num{$_}] ||= $_; } } print "signal #17 = $sig_name[17]\n"; if ($sig_num{ALRM}) { print "SIGALRM is $sig_num{ALRM}\n"; } =head1 WARNING Because this information is not stored within the perl executable itself it is possible (but unlikely) that the information does not relate to the actual perl binary which is being used to access it. The Config module is installed into the architecture and version specific library directory ($Config{installarchlib}) and it checks the perl version number when loaded. The values stored in config.sh may be either single-quoted or double-quoted. Double-quoted strings are handy for those cases where you need to include escape sequences in the strings. To avoid runtime variable interpolation, any C<$> and C<@> characters are replaced by C<\$> and C<\@>, respectively. This isn't foolproof, of course, so don't embed C<\$> or C<\@> in double-quoted strings unless you're willing to deal with the consequences. (The slashes will end up escaped and the C<$> or C<@> will trigger variable interpolation) =head1 GLOSSARY Most C variables are determined by the C script on platforms supported by it (which is most UNIX platforms). Some platforms have custom-made C variables, and may thus not have some of the variables described below, or may have extraneous variables specific to that particular port. See the port specific documentation in such cases. =cut ENDOFTAIL if ($Opts{glossary}) { open(GLOS, "<$Glossary") or die "Can't open $Glossary: $!"; } my %seen = (); my $text = 0; $/ = ''; sub process { if (s/\A(\w*)\s+\(([\w.]+)\):\s*\n(\t?)/=item C<$1>\n\nFrom F<$2>:\n\n/m) { my $c = substr $1, 0, 1; unless ($seen{$c}++) { print CONFIG_POD < new paragraph s/^(? text s{([\'\"])(?=[^\'\"\s]*[./][^\'\"\s]*\1)([^\'\"\s]+)\1}(F<$2>)g; # '.o' s{([\'\"])([^\'\"\s]+)\1}(C<$2>)g; # "date" command s{\'([A-Za-z_\- *=/]+)\'}(C<$1>)g; # 'ln -s' s{ (?)xg; # /usr/local s/((?<=\s)~\w*)/F<$1>/g; # ~name s/(?/g; # UNISTD s/(? macro/g; # FILE_cnt macro s/n[\0]t/n't/g; # undo can't, won't damage } if ($Opts{glossary}) { ; # Skip the "DO NOT EDIT" ; # Skip the preamble while () { process; print CONFIG_POD; } } print CONFIG_POD <<'ENDOFTAIL'; =back =head1 GIT DATA Information on the git commit from which the current perl binary was compiled can be found in the variable C<$Config::Git_Data>. The variable is a structured string that looks something like this: git_commit_id='ea0c2dbd5f5ac6845ecc7ec6696415bf8e27bd52' git_describe='GitLive-blead-1076-gea0c2db' git_branch='smartmatch' git_uncommitted_changes='' git_commit_id_title='Commit id:' git_commit_date='2009-05-09 17:47:31 +0200' Its format is not guaranteed not to change over time. =head1 NOTE This module contains a good example of how to use tie to implement a cache and an example of how to make a tied variable readonly to those outside of it. =cut ENDOFTAIL close(GLOS) if $Opts{glossary}; close(CONFIG_POD); print "written $Config_POD\n"; my $orig_config_txt = ""; my $orig_heavy_txt = ""; { local $/; my $fh; $orig_config_txt = <$fh> if open $fh, "<", $Config_PM; $orig_heavy_txt = <$fh> if open $fh, "<", $Config_heavy; } if ($orig_config_txt ne $config_txt or $orig_heavy_txt ne $heavy_txt) { open CONFIG, ">", $Config_PM or die "Can't open $Config_PM: $!\n"; open CONFIG_HEAVY, ">", $Config_heavy or die "Can't open $Config_heavy: $!\n"; print CONFIG $config_txt; print CONFIG_HEAVY $heavy_txt; close(CONFIG_HEAVY); close(CONFIG); print "updated $Config_PM\n"; print "updated $Config_heavy\n"; } # Now create Cross.pm if needed if ($Opts{cross}) { open CROSS, ">lib/Cross.pm" or die "Can not open >lib/Cross.pm: $!"; my $cross = <<'EOS'; # typical invocation: # perl -MCross Makefile.PL # perl -MCross=wince -V:cc package Cross; sub import { my ($package,$platform) = @_; unless (defined $platform) { # if $platform is not specified, then use last one when # 'configpm; was invoked with --cross option $platform = '***replace-marker***'; } @INC = map {/\blib\b/?(do{local $_=$_;s/\blib\b/xlib\/$platform/;$_},$_):($_)} @INC; $::Cross::platform = $platform; } 1; EOS $cross =~ s/\*\*\*replace-marker\*\*\*/$Opts{cross}/g; print CROSS $cross; close CROSS; print "written lib/Cross.pm\n"; unshift(@INC,"xlib/$Opts{cross}"); } # Now do some simple tests on the Config.pm file we have created unshift(@INC,'lib'); unshift(@INC,'xlib/symbian') if $Opts{cross}; require $Config_PM; require $Config_heavy; import Config; die "$0: $Config_PM not valid" unless $Config{'PERL_CONFIG_SH'} eq 'true'; die "$0: error processing $Config_PM" if defined($Config{'an impossible name'}) or $Config{'PERL_CONFIG_SH'} ne 'true' # test cache ; die "$0: error processing $Config_PM" if eval '$Config{"cc"} = 1' or eval 'delete $Config{"cc"}' ; exit 0; # Popularity of various entries in %Config, based on a large build and test # run of code in the Fotango build system: __DATA__ path_sep: 8490 d_readlink: 7101 d_symlink: 7101 archlibexp: 4318 sitearchexp: 4305 sitelibexp: 4305 privlibexp: 4163 ldlibpthname: 4041 libpth: 2134 archname: 1591 exe_ext: 1256 scriptdir: 1155 version: 1116 useithreads: 1002 osvers: 982 osname: 851 inc_version_list: 783 dont_use_nlink: 779 intsize: 759 usevendorprefix: 642 dlsrc: 624 cc: 541 lib_ext: 520 so: 512 ld: 501 ccdlflags: 500 ldflags: 495 obj_ext: 495 cccdlflags: 493 lddlflags: 493 ar: 492 dlext: 492 libc: 492 ranlib: 492 full_ar: 491 vendorarchexp: 491 vendorlibexp: 491 installman1dir: 489 installman3dir: 489 installsitebin: 489 installsiteman1dir: 489 installsiteman3dir: 489 installvendorman1dir: 489 installvendorman3dir: 489 d_flexfnam: 474 eunicefix: 360 d_link: 347 installsitearch: 344 installscript: 341 installprivlib: 337 binexp: 336 installarchlib: 336 installprefixexp: 336 installsitelib: 336 installstyle: 336 installvendorarch: 336 installvendorbin: 336 installvendorlib: 336 man1ext: 336 man3ext: 336 sh: 336 siteprefixexp: 336 installbin: 335 usedl: 332 ccflags: 285 startperl: 232 optimize: 231 usemymalloc: 229 cpprun: 228 sharpbang: 228 perllibs: 225 usesfio: 224 usethreads: 220 perlpath: 218 extensions: 217 usesocks: 208 shellflags: 198 make: 191 d_pwage: 189 d_pwchange: 189 d_pwclass: 189 d_pwcomment: 189 d_pwexpire: 189 d_pwgecos: 189 d_pwpasswd: 189 d_pwquota: 189 gccversion: 189 libs: 186 useshrplib: 186 cppflags: 185 ptrsize: 185 shrpenv: 185 static_ext: 185 use5005threads: 185 uselargefiles: 185 alignbytes: 184 byteorder: 184 ccversion: 184 config_args: 184 cppminus: 184 perl-5.12.0-RC0/op.c0000444000175000017500000070512211340037012012705 0ustar jessejesse#line 2 "op.c" /* op.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was * our Mr. Bilbo's first cousin on the mother's side (her mother being the * youngest of the Old Took's daughters); and Mr. Drogo was his second * cousin. So Mr. Frodo is his first *and* second cousin, once removed * either way, as the saying is, if you follow me.' --the Gaffer * * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"] */ /* This file contains the functions that create, manipulate and optimize * the OP structures that hold a compiled perl program. * * A Perl program is compiled into a tree of OPs. Each op contains * structural pointers (eg to its siblings and the next op in the * execution sequence), a pointer to the function that would execute the * op, plus any data specific to that op. For example, an OP_CONST op * points to the pp_const() function and to an SV containing the constant * value. When pp_const() is executed, its job is to push that SV onto the * stack. * * OPs are mainly created by the newFOO() functions, which are mainly * called from the parser (in perly.y) as the code is parsed. For example * the Perl code $a + $b * $c would cause the equivalent of the following * to be called (oversimplifying a bit): * * newBINOP(OP_ADD, flags, * newSVREF($a), * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c)) * ) * * Note that during the build of miniperl, a temporary copy of this file * is made, called opmini.c. */ /* Perl's compiler is essentially a 3-pass compiler with interleaved phases: A bottom-up pass A top-down pass An execution-order pass The bottom-up pass is represented by all the "newOP" routines and the ck_ routines. The bottom-upness is actually driven by yacc. So at the point that a ck_ routine fires, we have no idea what the context is, either upward in the syntax tree, or either forward or backward in the execution order. (The bottom-up parser builds that part of the execution order it knows about, but if you follow the "next" links around, you'll find it's actually a closed loop through the top level node.) Whenever the bottom-up parser gets to a node that supplies context to its components, it invokes that portion of the top-down pass that applies to that part of the subtree (and marks the top node as processed, so if a node further up supplies context, it doesn't have to take the plunge again). As a particular subcase of this, as the new node is built, it takes all the closed execution loops of its subcomponents and links them into a new closed loop for the higher level node. But it's still not the real execution order. The actual execution order is not known till we get a grammar reduction to a top-level unit like a subroutine or file that will be called by "name" rather than via a "next" pointer. At that point, we can call into peep() to do that code's portion of the 3rd pass. It has to be recursive, but it's recursive on basic blocks, not on tree nodes. */ /* To implement user lexical pragmas, there needs to be a way at run time to get the compile time state of %^H for that block. Storing %^H in every block (or even COP) would be very expensive, so a different approach is taken. The (running) state of %^H is serialised into a tree of HE-like structs. Stores into %^H are chained onto the current leaf as a struct refcounted_he * with the key and the value. Deletes from %^H are saved with a value of PL_sv_placeholder. The state of %^H at any point can be turned back into a regular HV by walking back up the tree from that point's leaf, ignoring any key you've already seen (placeholder or not), storing the rest into the HV structure, then removing the placeholders. Hence memory is only used to store the %^H deltas from the enclosing COP, rather than the entire %^H on each COP. To cause actions on %^H to write out the serialisation records, it has magic type 'H'. This magic (itself) does nothing, but its presence causes the values to gain magic type 'h', which has entries for set and clear. C updates C with a store record, with deletes written by C. C saves the current C on the save stack, so that it will be correctly restored when any inner compiling scope is exited. */ #include "EXTERN.h" #define PERL_IN_OP_C #include "perl.h" #include "keywords.h" #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o) #define CALL_OPFREEHOOK(o) if (PL_opfreehook) CALL_FPTR(PL_opfreehook)(aTHX_ o) #if defined(PL_OP_SLAB_ALLOC) #ifdef PERL_DEBUG_READONLY_OPS # define PERL_SLAB_SIZE 4096 # include #endif #ifndef PERL_SLAB_SIZE #define PERL_SLAB_SIZE 2048 #endif void * Perl_Slab_Alloc(pTHX_ size_t sz) { dVAR; /* * To make incrementing use count easy PL_OpSlab is an I32 * * To make inserting the link to slab PL_OpPtr is I32 ** * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments * Add an overhead for pointer to slab and round up as a number of pointers */ sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *); if ((PL_OpSpace -= sz) < 0) { #ifdef PERL_DEBUG_READONLY_OPS /* We need to allocate chunk by chunk so that we can control the VM mapping */ PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE, MAP_ANON|MAP_PRIVATE, -1, 0); DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n", (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), PL_OpPtr)); if(PL_OpPtr == MAP_FAILED) { perror("mmap failed"); abort(); } #else PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*)); #endif if (!PL_OpPtr) { return NULL; } /* We reserve the 0'th I32 sized chunk as a use count */ PL_OpSlab = (I32 *) PL_OpPtr; /* Reduce size by the use count word, and by the size we need. * Latter is to mimic the '-=' in the if() above */ PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz; /* Allocation pointer starts at the top. Theory: because we build leaves before trunk allocating at end means that at run time access is cache friendly upward */ PL_OpPtr += PERL_SLAB_SIZE; #ifdef PERL_DEBUG_READONLY_OPS /* We remember this slab. */ /* This implementation isn't efficient, but it is simple. */ PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1)); PL_slabs[PL_slab_count++] = PL_OpSlab; DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab)); #endif } assert( PL_OpSpace >= 0 ); /* Move the allocation pointer down */ PL_OpPtr -= sz; assert( PL_OpPtr > (I32 **) PL_OpSlab ); *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */ (*PL_OpSlab)++; /* Increment use count of slab */ assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) ); assert( *PL_OpSlab > 0 ); return (void *)(PL_OpPtr + 1); } #ifdef PERL_DEBUG_READONLY_OPS void Perl_pending_Slabs_to_ro(pTHX) { /* Turn all the allocated op slabs read only. */ U32 count = PL_slab_count; I32 **const slabs = PL_slabs; /* Reset the array of pending OP slabs, as we're about to turn this lot read only. Also, do it ahead of the loop in case the warn triggers, and a warn handler has an eval */ PL_slabs = NULL; PL_slab_count = 0; /* Force a new slab for any further allocation. */ PL_OpSpace = 0; while (count--) { void *const start = slabs[count]; const size_t size = PERL_SLAB_SIZE* sizeof(I32*); if(mprotect(start, size, PROT_READ)) { Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", start, (unsigned long) size, errno); } } free(slabs); } STATIC void S_Slab_to_rw(pTHX_ void *op) { I32 * const * const ptr = (I32 **) op; I32 * const slab = ptr[-1]; PERL_ARGS_ASSERT_SLAB_TO_RW; assert( ptr-1 > (I32 **) slab ); assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) ); assert( *slab > 0 ); if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) { Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno); } } OP * Perl_op_refcnt_inc(pTHX_ OP *o) { if(o) { Slab_to_rw(o); ++o->op_targ; } return o; } PADOFFSET Perl_op_refcnt_dec(pTHX_ OP *o) { PERL_ARGS_ASSERT_OP_REFCNT_DEC; Slab_to_rw(o); return --o->op_targ; } #else # define Slab_to_rw(op) #endif void Perl_Slab_Free(pTHX_ void *op) { I32 * const * const ptr = (I32 **) op; I32 * const slab = ptr[-1]; PERL_ARGS_ASSERT_SLAB_FREE; assert( ptr-1 > (I32 **) slab ); assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) ); assert( *slab > 0 ); Slab_to_rw(op); if (--(*slab) == 0) { # ifdef NETWARE # define PerlMemShared PerlMem # endif #ifdef PERL_DEBUG_READONLY_OPS U32 count = PL_slab_count; /* Need to remove this slab from our list of slabs */ if (count) { while (count--) { if (PL_slabs[count] == slab) { dVAR; /* Found it. Move the entry at the end to overwrite it. */ DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate %p by moving %p from %lu to %lu\n", PL_OpSlab, PL_slabs[PL_slab_count - 1], PL_slab_count, count)); PL_slabs[count] = PL_slabs[--PL_slab_count]; /* Could realloc smaller at this point, but probably not worth it. */ if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) { perror("munmap failed"); abort(); } break; } } } #else PerlMemShared_free(slab); #endif if (slab == PL_OpSlab) { PL_OpSpace = 0; } } } #endif /* * In the following definition, the ", (OP*)0" is just to make the compiler * think the expression is of the right type: croak actually does a Siglongjmp. */ #define CHECKOP(type,o) \ ((PL_op_mask && PL_op_mask[type]) \ ? ( op_free((OP*)o), \ Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \ (OP*)0 ) \ : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o)) #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2) STATIC const char* S_gv_ename(pTHX_ GV *gv) { SV* const tmpsv = sv_newmortal(); PERL_ARGS_ASSERT_GV_ENAME; gv_efullname3(tmpsv, gv, NULL); return SvPV_nolen_const(tmpsv); } STATIC OP * S_no_fh_allowed(pTHX_ OP *o) { PERL_ARGS_ASSERT_NO_FH_ALLOWED; yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function", OP_DESC(o))); return o; } STATIC OP * S_too_few_arguments(pTHX_ OP *o, const char *name) { PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS; yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name)); return o; } STATIC OP * S_too_many_arguments(pTHX_ OP *o, const char *name) { PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS; yyerror(Perl_form(aTHX_ "Too many arguments for %s", name)); return o; } STATIC void S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid) { PERL_ARGS_ASSERT_BAD_TYPE; yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)", (int)n, name, t, OP_DESC(kid))); } STATIC void S_no_bareword_allowed(pTHX_ const OP *o) { PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED; if (PL_madskills) return; /* various ok barewords are hidden in extra OP_NULL */ qerror(Perl_mess(aTHX_ "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use", SVfARG(cSVOPo_sv))); } /* "register" allocation */ PADOFFSET Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) { dVAR; PADOFFSET off; const bool is_our = (PL_parser->in_my == KEY_our); PERL_ARGS_ASSERT_ALLOCMY; if (flags) Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf, (UV)flags); /* Until we're using the length for real, cross check that we're being told the truth. */ assert(strlen(name) == len); /* complain about "my $" etc etc */ if (len && !(is_our || isALPHA(name[1]) || (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) || (name[1] == '_' && (*name == '$' || len > 2)))) { /* name[2] is true if strlen(name) > 2 */ if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) { yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"", name[0], toCTRL(name[1]), (int)(len - 2), name + 2, PL_parser->in_my == KEY_state ? "state" : "my")); } else { yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name, PL_parser->in_my == KEY_state ? "state" : "my")); } } /* allocate a spare slot and store the name in that slot */ off = pad_add_name(name, len, is_our ? padadd_OUR : PL_parser->in_my == KEY_state ? padadd_STATE : 0, PL_parser->in_my_stash, (is_our /* $_ is always in main::, even with our */ ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash) : NULL ) ); /* anon sub prototypes contains state vars should always be cloned, * otherwise the state var would be shared between anon subs */ if (PL_parser->in_my == KEY_state && CvANON(PL_compcv)) CvCLONE_on(PL_compcv); return off; } /* free the body of an op without examining its contents. * Always use this rather than FreeOp directly */ static void S_op_destroy(pTHX_ OP *o) { if (o->op_latefree) { o->op_latefreed = 1; return; } FreeOp(o); } #ifdef USE_ITHREADS # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b) #else # define forget_pmop(a,b) S_forget_pmop(aTHX_ a) #endif /* Destructor */ void Perl_op_free(pTHX_ OP *o) { dVAR; OPCODE type; if (!o) return; if (o->op_latefreed) { if (o->op_latefree) return; goto do_free; } type = o->op_type; if (o->op_private & OPpREFCOUNTED) { switch (type) { case OP_LEAVESUB: case OP_LEAVESUBLV: case OP_LEAVEEVAL: case OP_LEAVE: case OP_SCOPE: case OP_LEAVEWRITE: { PADOFFSET refcnt; OP_REFCNT_LOCK; refcnt = OpREFCNT_dec(o); OP_REFCNT_UNLOCK; if (refcnt) { /* Need to find and remove any pattern match ops from the list we maintain for reset(). */ find_and_forget_pmops(o); return; } } break; default: break; } } /* Call the op_free hook if it has been set. Do it now so that it's called * at the right time for refcounted ops, but still before all of the kids * are freed. */ CALL_OPFREEHOOK(o); if (o->op_flags & OPf_KIDS) { register OP *kid, *nextkid; for (kid = cUNOPo->op_first; kid; kid = nextkid) { nextkid = kid->op_sibling; /* Get before next freeing kid */ op_free(kid); } } #ifdef PERL_DEBUG_READONLY_OPS Slab_to_rw(o); #endif /* COP* is not cleared by op_clear() so that we may track line * numbers etc even after null() */ if (type == OP_NEXTSTATE || type == OP_DBSTATE || (type == OP_NULL /* the COP might have been null'ed */ && ((OPCODE)o->op_targ == OP_NEXTSTATE || (OPCODE)o->op_targ == OP_DBSTATE))) { cop_free((COP*)o); } if (type == OP_NULL) type = (OPCODE)o->op_targ; op_clear(o); if (o->op_latefree) { o->op_latefreed = 1; return; } do_free: FreeOp(o); #ifdef DEBUG_LEAKING_SCALARS if (PL_op == o) PL_op = NULL; #endif } void Perl_op_clear(pTHX_ OP *o) { dVAR; PERL_ARGS_ASSERT_OP_CLEAR; #ifdef PERL_MAD /* if (o->op_madprop && o->op_madprop->mad_next) abort(); */ /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with "modification of a read only value" for a reason I can't fathom why. It's the "" stringification of $_, where $_ was set to '' in a foreach loop, but it defies simplification into a small test case. However, commenting them out has caused ext/List/Util/t/weak.t to fail the last test. */ /* mad_free(o->op_madprop); o->op_madprop = 0; */ #endif retry: switch (o->op_type) { case OP_NULL: /* Was holding old type, if any. */ if (PL_madskills && o->op_targ != OP_NULL) { o->op_type = (Optype)o->op_targ; o->op_targ = 0; goto retry; } case OP_ENTEREVAL: /* Was holding hints. */ o->op_targ = 0; break; default: if (!(o->op_flags & OPf_REF) || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst))) break; /* FALL THROUGH */ case OP_GVSV: case OP_GV: case OP_AELEMFAST: if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) { /* not an OP_PADAV replacement */ GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV) #ifdef USE_ITHREADS && PL_curpad #endif ? cGVOPo_gv : NULL; /* It's possible during global destruction that the GV is freed before the optree. Whilst the SvREFCNT_inc is happy to bump from 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0 will trigger an assertion failure, because the entry to sv_clear checks that the scalar is not already freed. A check of for !SvIS_FREED(gv) turns out to be invalid, because during global destruction the reference count can be forced down to zero (with SVf_BREAK set). In which case raising to 1 and then dropping to 0 triggers cleanup before it should happen. I *think* that this might actually be a general, systematic, weakness of the whole idea of SVf_BREAK, in that code *is* allowed to raise and lower references during global destruction, so any *valid* code that happens to do this during global destruction might well trigger premature cleanup. */ bool still_valid = gv && SvREFCNT(gv); if (still_valid) SvREFCNT_inc_simple_void(gv); #ifdef USE_ITHREADS if (cPADOPo->op_padix > 0) { /* No GvIN_PAD_off(cGVOPo_gv) here, because other references * may still exist on the pad */ pad_swipe(cPADOPo->op_padix, TRUE); cPADOPo->op_padix = 0; } #else SvREFCNT_dec(cSVOPo->op_sv); cSVOPo->op_sv = NULL; #endif if (still_valid) { int try_downgrade = SvREFCNT(gv) == 2; SvREFCNT_dec(gv); if (try_downgrade) gv_try_downgrade(gv); } } break; case OP_METHOD_NAMED: case OP_CONST: case OP_HINTSEVAL: SvREFCNT_dec(cSVOPo->op_sv); cSVOPo->op_sv = NULL; #ifdef USE_ITHREADS /** Bug #15654 Even if op_clear does a pad_free for the target of the op, pad_free doesn't actually remove the sv that exists in the pad; instead it lives on. This results in that it could be reused as a target later on when the pad was reallocated. **/ if(o->op_targ) { pad_swipe(o->op_targ,1); o->op_targ = 0; } #endif break; case OP_GOTO: case OP_NEXT: case OP_LAST: case OP_REDO: if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS)) break; /* FALL THROUGH */ case OP_TRANS: if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { #ifdef USE_ITHREADS if (cPADOPo->op_padix > 0) { pad_swipe(cPADOPo->op_padix, TRUE); cPADOPo->op_padix = 0; } #else SvREFCNT_dec(cSVOPo->op_sv); cSVOPo->op_sv = NULL; #endif } else { PerlMemShared_free(cPVOPo->op_pv); cPVOPo->op_pv = NULL; } break; case OP_SUBST: op_free(cPMOPo->op_pmreplrootu.op_pmreplroot); goto clear_pmop; case OP_PUSHRE: #ifdef USE_ITHREADS if (cPMOPo->op_pmreplrootu.op_pmtargetoff) { /* No GvIN_PAD_off here, because other references may still * exist on the pad */ pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE); } #else SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv)); #endif /* FALL THROUGH */ case OP_MATCH: case OP_QR: clear_pmop: forget_pmop(cPMOPo, 1); cPMOPo->op_pmreplrootu.op_pmreplroot = NULL; /* we use the same protection as the "SAFE" version of the PM_ macros * here since sv_clean_all might release some PMOPs * after PL_regex_padav has been cleared * and the clearing of PL_regex_padav needs to * happen before sv_clean_all */ #ifdef USE_ITHREADS if(PL_regex_pad) { /* We could be in destruction */ const IV offset = (cPMOPo)->op_pmoffset; ReREFCNT_dec(PM_GETRE(cPMOPo)); PL_regex_pad[offset] = &PL_sv_undef; sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset, sizeof(offset)); } #else ReREFCNT_dec(PM_GETRE(cPMOPo)); PM_SETRE(cPMOPo, NULL); #endif break; } if (o->op_targ > 0) { pad_free(o->op_targ); o->op_targ = 0; } } STATIC void S_cop_free(pTHX_ COP* cop) { PERL_ARGS_ASSERT_COP_FREE; CopFILE_free(cop); CopSTASH_free(cop); if (! specialWARN(cop->cop_warnings)) PerlMemShared_free(cop->cop_warnings); Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash); } STATIC void S_forget_pmop(pTHX_ PMOP *const o #ifdef USE_ITHREADS , U32 flags #endif ) { HV * const pmstash = PmopSTASH(o); PERL_ARGS_ASSERT_FORGET_PMOP; if (pmstash && !SvIS_FREED(pmstash)) { MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab); if (mg) { PMOP **const array = (PMOP**) mg->mg_ptr; U32 count = mg->mg_len / sizeof(PMOP**); U32 i = count; while (i--) { if (array[i] == o) { /* Found it. Move the entry at the end to overwrite it. */ array[i] = array[--count]; mg->mg_len = count * sizeof(PMOP**); /* Could realloc smaller at this point always, but probably not worth it. Probably worth free()ing if we're the last. */ if(!count) { Safefree(mg->mg_ptr); mg->mg_ptr = NULL; } break; } } } } if (PL_curpm == o) PL_curpm = NULL; #ifdef USE_ITHREADS if (flags) PmopSTASH_free(o); #endif } STATIC void S_find_and_forget_pmops(pTHX_ OP *o) { PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS; if (o->op_flags & OPf_KIDS) { OP *kid = cUNOPo->op_first; while (kid) { switch (kid->op_type) { case OP_SUBST: case OP_PUSHRE: case OP_MATCH: case OP_QR: forget_pmop((PMOP*)kid, 0); } find_and_forget_pmops(kid); kid = kid->op_sibling; } } } void Perl_op_null(pTHX_ OP *o) { dVAR; PERL_ARGS_ASSERT_OP_NULL; if (o->op_type == OP_NULL) return; if (!PL_madskills) op_clear(o); o->op_targ = o->op_type; o->op_type = OP_NULL; o->op_ppaddr = PL_ppaddr[OP_NULL]; } void Perl_op_refcnt_lock(pTHX) { dVAR; PERL_UNUSED_CONTEXT; OP_REFCNT_LOCK; } void Perl_op_refcnt_unlock(pTHX) { dVAR; PERL_UNUSED_CONTEXT; OP_REFCNT_UNLOCK; } /* Contextualizers */ #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o)) static OP * S_linklist(pTHX_ OP *o) { OP *first; PERL_ARGS_ASSERT_LINKLIST; if (o->op_next) return o->op_next; /* establish postfix order */ first = cUNOPo->op_first; if (first) { register OP *kid; o->op_next = LINKLIST(first); kid = first; for (;;) { if (kid->op_sibling) { kid->op_next = LINKLIST(kid->op_sibling); kid = kid->op_sibling; } else { kid->op_next = o; break; } } } else o->op_next = o; return o->op_next; } static OP * S_scalarkids(pTHX_ OP *o) { if (o && o->op_flags & OPf_KIDS) { OP *kid; for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) scalar(kid); } return o; } STATIC OP * S_scalarboolean(pTHX_ OP *o) { dVAR; PERL_ARGS_ASSERT_SCALARBOOLEAN; if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) { if (ckWARN(WARN_SYNTAX)) { const line_t oldline = CopLINE(PL_curcop); if (PL_parser && PL_parser->copline != NOLINE) CopLINE_set(PL_curcop, PL_parser->copline); Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be =="); CopLINE_set(PL_curcop, oldline); } } return scalar(o); } OP * Perl_scalar(pTHX_ OP *o) { dVAR; OP *kid; /* assumes no premature commitment */ if (!o || (PL_parser && PL_parser->error_count) || (o->op_flags & OPf_WANT) || o->op_type == OP_RETURN) { return o; } o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR; switch (o->op_type) { case OP_REPEAT: scalar(cBINOPo->op_first); break; case OP_OR: case OP_AND: case OP_COND_EXPR: for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) scalar(kid); break; /* FALL THROUGH */ case OP_SPLIT: case OP_MATCH: case OP_QR: case OP_SUBST: case OP_NULL: default: if (o->op_flags & OPf_KIDS) { for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) scalar(kid); } break; case OP_LEAVE: case OP_LEAVETRY: kid = cLISTOPo->op_first; scalar(kid); while ((kid = kid->op_sibling)) { if (kid->op_sibling) scalarvoid(kid); else scalar(kid); } PL_curcop = &PL_compiling; break; case OP_SCOPE: case OP_LINESEQ: case OP_LIST: for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { if (kid->op_sibling) scalarvoid(kid); else scalar(kid); } PL_curcop = &PL_compiling; break; case OP_SORT: Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context"); break; } return o; } OP * Perl_scalarvoid(pTHX_ OP *o) { dVAR; OP *kid; const char* useless = NULL; SV* sv; U8 want; PERL_ARGS_ASSERT_SCALARVOID; /* trailing mad null ops don't count as "there" for void processing */ if (PL_madskills && o->op_type != OP_NULL && o->op_sibling && o->op_sibling->op_type == OP_NULL) { OP *sib; for (sib = o->op_sibling; sib && sib->op_type == OP_NULL; sib = sib->op_sibling) ; if (!sib) return o; } if (o->op_type == OP_NEXTSTATE || o->op_type == OP_DBSTATE || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE))) PL_curcop = (COP*)o; /* for warning below */ /* assumes no premature commitment */ want = o->op_flags & OPf_WANT; if ((want && want != OPf_WANT_SCALAR) || (PL_parser && PL_parser->error_count) || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE) { return o; } if ((o->op_private & OPpTARGET_MY) && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ { return scalar(o); /* As if inside SASSIGN */ } o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID; switch (o->op_type) { default: if (!(PL_opargs[o->op_type] & OA_FOLDCONST)) break; /* FALL THROUGH */ case OP_REPEAT: if (o->op_flags & OPf_STACKED) break; goto func_ops; case OP_SUBSTR: if (o->op_private == 4) break; /* FALL THROUGH */ case OP_GVSV: case OP_WANTARRAY: case OP_GV: case OP_SMARTMATCH: case OP_PADSV: case OP_PADAV: case OP_PADHV: case OP_PADANY: case OP_AV2ARYLEN: case OP_REF: case OP_REFGEN: case OP_SREFGEN: case OP_DEFINED: case OP_HEX: case OP_OCT: case OP_LENGTH: case OP_VEC: case OP_INDEX: case OP_RINDEX: case OP_SPRINTF: case OP_AELEM: case OP_AELEMFAST: case OP_ASLICE: case OP_HELEM: case OP_HSLICE: case OP_UNPACK: case OP_PACK: case OP_JOIN: case OP_LSLICE: case OP_ANONLIST: case OP_ANONHASH: case OP_SORT: case OP_REVERSE: case OP_RANGE: case OP_FLIP: case OP_FLOP: case OP_CALLER: case OP_FILENO: case OP_EOF: case OP_TELL: case OP_GETSOCKNAME: case OP_GETPEERNAME: case OP_READLINK: case OP_TELLDIR: case OP_GETPPID: case OP_GETPGRP: case OP_GETPRIORITY: case OP_TIME: case OP_TMS: case OP_LOCALTIME: case OP_GMTIME: case OP_GHBYNAME: case OP_GHBYADDR: case OP_GHOSTENT: case OP_GNBYNAME: case OP_GNBYADDR: case OP_GNETENT: case OP_GPBYNAME: case OP_GPBYNUMBER: case OP_GPROTOENT: case OP_GSBYNAME: case OP_GSBYPORT: case OP_GSERVENT: case OP_GPWNAM: case OP_GPWUID: case OP_GGRNAM: case OP_GGRGID: case OP_GETLOGIN: case OP_PROTOTYPE: func_ops: if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))) /* Otherwise it's "Useless use of grep iterator" */ useless = OP_DESC(o); break; case OP_SPLIT: kid = cLISTOPo->op_first; if (kid && kid->op_type == OP_PUSHRE #ifdef USE_ITHREADS && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff) #else && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv) #endif useless = OP_DESC(o); break; case OP_NOT: kid = cUNOPo->op_first; if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST && kid->op_type != OP_TRANS) { goto func_ops; } useless = "negative pattern binding (!~)"; break; case OP_RV2GV: case OP_RV2SV: case OP_RV2AV: case OP_RV2HV: if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) && (!o->op_sibling || o->op_sibling->op_type != OP_READLINE)) useless = "a variable"; break; case OP_CONST: sv = cSVOPo_sv; if (cSVOPo->op_private & OPpCONST_STRICT) no_bareword_allowed(o); else { if (ckWARN(WARN_VOID)) { if (SvOK(sv)) { SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_ "a constant (%"SVf")", sv)); useless = SvPV_nolen(msv); } else useless = "a constant (undef)"; if (o->op_private & OPpCONST_ARYBASE) useless = NULL; /* don't warn on optimised away booleans, eg * use constant Foo, 5; Foo || print; */ if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT) useless = NULL; /* the constants 0 and 1 are permitted as they are conventionally used as dummies in constructs like 1 while some_condition_with_side_effects; */ else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) useless = NULL; else if (SvPOK(sv)) { /* perl4's way of mixing documentation and code (before the invention of POD) was based on a trick to mix nroff and perl code. The trick was built upon these three nroff macros being used in void context. The pink camel has the details in the script wrapman near page 319. */ const char * const maybe_macro = SvPVX_const(sv); if (strnEQ(maybe_macro, "di", 2) || strnEQ(maybe_macro, "ds", 2) || strnEQ(maybe_macro, "ig", 2)) useless = NULL; } } } op_null(o); /* don't execute or even remember it */ break; case OP_POSTINC: o->op_type = OP_PREINC; /* pre-increment is faster */ o->op_ppaddr = PL_ppaddr[OP_PREINC]; break; case OP_POSTDEC: o->op_type = OP_PREDEC; /* pre-decrement is faster */ o->op_ppaddr = PL_ppaddr[OP_PREDEC]; break; case OP_I_POSTINC: o->op_type = OP_I_PREINC; /* pre-increment is faster */ o->op_ppaddr = PL_ppaddr[OP_I_PREINC]; break; case OP_I_POSTDEC: o->op_type = OP_I_PREDEC; /* pre-decrement is faster */ o->op_ppaddr = PL_ppaddr[OP_I_PREDEC]; break; case OP_OR: case OP_AND: kid = cLOGOPo->op_first; if (kid->op_type == OP_NOT && (kid->op_flags & OPf_KIDS) && !PL_madskills) { if (o->op_type == OP_AND) { o->op_type = OP_OR; o->op_ppaddr = PL_ppaddr[OP_OR]; } else { o->op_type = OP_AND; o->op_ppaddr = PL_ppaddr[OP_AND]; } op_null(kid); } case OP_DOR: case OP_COND_EXPR: case OP_ENTERGIVEN: case OP_ENTERWHEN: for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) scalarvoid(kid); break; case OP_NULL: if (o->op_flags & OPf_STACKED) break; /* FALL THROUGH */ case OP_NEXTSTATE: case OP_DBSTATE: case OP_ENTERTRY: case OP_ENTER: if (!(o->op_flags & OPf_KIDS)) break; /* FALL THROUGH */ case OP_SCOPE: case OP_LEAVE: case OP_LEAVETRY: case OP_LEAVELOOP: case OP_LINESEQ: case OP_LIST: case OP_LEAVEGIVEN: case OP_LEAVEWHEN: for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) scalarvoid(kid); break; case OP_ENTEREVAL: scalarkids(o); break; case OP_SCALAR: return scalar(o); } if (useless) Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless); return o; } static OP * S_listkids(pTHX_ OP *o) { if (o && o->op_flags & OPf_KIDS) { OP *kid; for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) list(kid); } return o; } OP * Perl_list(pTHX_ OP *o) { dVAR; OP *kid; /* assumes no premature commitment */ if (!o || (o->op_flags & OPf_WANT) || (PL_parser && PL_parser->error_count) || o->op_type == OP_RETURN) { return o; } if ((o->op_private & OPpTARGET_MY) && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ { return o; /* As if inside SASSIGN */ } o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST; switch (o->op_type) { case OP_FLOP: case OP_REPEAT: list(cBINOPo->op_first); break; case OP_OR: case OP_AND: case OP_COND_EXPR: for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) list(kid); break; default: case OP_MATCH: case OP_QR: case OP_SUBST: case OP_NULL: if (!(o->op_flags & OPf_KIDS)) break; if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) { list(cBINOPo->op_first); return gen_constant_list(o); } case OP_LIST: listkids(o); break; case OP_LEAVE: case OP_LEAVETRY: kid = cLISTOPo->op_first; list(kid); while ((kid = kid->op_sibling)) { if (kid->op_sibling) scalarvoid(kid); else list(kid); } PL_curcop = &PL_compiling; break; case OP_SCOPE: case OP_LINESEQ: for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { if (kid->op_sibling) scalarvoid(kid); else list(kid); } PL_curcop = &PL_compiling; break; } return o; } static OP * S_scalarseq(pTHX_ OP *o) { dVAR; if (o) { const OPCODE type = o->op_type; if (type == OP_LINESEQ || type == OP_SCOPE || type == OP_LEAVE || type == OP_LEAVETRY) { OP *kid; for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { if (kid->op_sibling) { scalarvoid(kid); } } PL_curcop = &PL_compiling; } o->op_flags &= ~OPf_PARENS; if (PL_hints & HINT_BLOCK_SCOPE) o->op_flags |= OPf_PARENS; } else o = newOP(OP_STUB, 0); return o; } STATIC OP * S_modkids(pTHX_ OP *o, I32 type) { if (o && o->op_flags & OPf_KIDS) { OP *kid; for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) mod(kid, type); } return o; } /* Propagate lvalue ("modifiable") context to an op and its children. * 'type' represents the context type, roughly based on the type of op that * would do the modifying, although local() is represented by OP_NULL. * It's responsible for detecting things that can't be modified, flag * things that need to behave specially in an lvalue context (e.g., "$$x = 5" * might have to vivify a reference in $x), and so on. * * For example, "$a+1 = 2" would cause mod() to be called with o being * OP_ADD and type being OP_SASSIGN, and would output an error. */ OP * Perl_mod(pTHX_ OP *o, I32 type) { dVAR; OP *kid; /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */ int localize = -1; if (!o || (PL_parser && PL_parser->error_count)) return o; if ((o->op_private & OPpTARGET_MY) && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ { return o; } switch (o->op_type) { case OP_UNDEF: localize = 0; PL_modcount++; return o; case OP_CONST: if (!(o->op_private & OPpCONST_ARYBASE)) goto nomod; localize = 0; if (PL_eval_start && PL_eval_start->op_type == OP_CONST) { CopARYBASE_set(&PL_compiling, (I32)SvIV(cSVOPx(PL_eval_start)->op_sv)); PL_eval_start = 0; } else if (!type) { SAVECOPARYBASE(&PL_compiling); CopARYBASE_set(&PL_compiling, 0); } else if (type == OP_REFGEN) goto nomod; else Perl_croak(aTHX_ "That use of $[ is unsupported"); break; case OP_STUB: if ((o->op_flags & OPf_PARENS) || PL_madskills) break; goto nomod; case OP_ENTERSUB: if ((type == OP_UNDEF || type == OP_REFGEN) && !(o->op_flags & OPf_STACKED)) { o->op_type = OP_RV2CV; /* entersub => rv2cv */ /* The default is to set op_private to the number of children, which for a UNOP such as RV2CV is always 1. And w're using the bit for a flag in RV2CV, so we need it clear. */ o->op_private &= ~1; o->op_ppaddr = PL_ppaddr[OP_RV2CV]; assert(cUNOPo->op_first->op_type == OP_NULL); op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */ break; } else if (o->op_private & OPpENTERSUB_NOMOD) return o; else { /* lvalue subroutine call */ o->op_private |= OPpLVAL_INTRO; PL_modcount = RETURN_UNLIMITED_NUMBER; if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) { /* Backward compatibility mode: */ o->op_private |= OPpENTERSUB_INARGS; break; } else { /* Compile-time error message: */ OP *kid = cUNOPo->op_first; CV *cv; OP *okid; if (kid->op_type != OP_PUSHMARK) { if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST) Perl_croak(aTHX_ "panic: unexpected lvalue entersub " "args: type/targ %ld:%"UVuf, (long)kid->op_type, (UV)kid->op_targ); kid = kLISTOP->op_first; } while (kid->op_sibling) kid = kid->op_sibling; if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) { /* Indirect call */ if (kid->op_type == OP_METHOD_NAMED || kid->op_type == OP_METHOD) { UNOP *newop; NewOp(1101, newop, 1, UNOP); newop->op_type = OP_RV2CV; newop->op_ppaddr = PL_ppaddr[OP_RV2CV]; newop->op_first = NULL; newop->op_next = (OP*)newop; kid->op_sibling = (OP*)newop; newop->op_private |= OPpLVAL_INTRO; newop->op_private &= ~1; break; } if (kid->op_type != OP_RV2CV) Perl_croak(aTHX_ "panic: unexpected lvalue entersub " "entry via type/targ %ld:%"UVuf, (long)kid->op_type, (UV)kid->op_targ); kid->op_private |= OPpLVAL_INTRO; break; /* Postpone until runtime */ } okid = kid; kid = kUNOP->op_first; if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV) kid = kUNOP->op_first; if (kid->op_type == OP_NULL) Perl_croak(aTHX_ "Unexpected constant lvalue entersub " "entry via type/targ %ld:%"UVuf, (long)kid->op_type, (UV)kid->op_targ); if (kid->op_type != OP_GV) { /* Restore RV2CV to check lvalueness */ restore_2cv: if (kid->op_next && kid->op_next != kid) { /* Happens? */ okid->op_next = kid->op_next; kid->op_next = okid; } else okid->op_next = NULL; okid->op_type = OP_RV2CV; okid->op_targ = 0; okid->op_ppaddr = PL_ppaddr[OP_RV2CV]; okid->op_private |= OPpLVAL_INTRO; okid->op_private &= ~1; break; } cv = GvCV(kGVOP_gv); if (!cv) goto restore_2cv; if (CvLVALUE(cv)) break; } } /* FALL THROUGH */ default: nomod: /* grep, foreach, subcalls, refgen */ if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) break; yyerror(Perl_form(aTHX_ "Can't modify %s in %s", (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL) ? "do block" : (o->op_type == OP_ENTERSUB ? "non-lvalue subroutine call" : OP_DESC(o))), type ? PL_op_desc[type] : "local")); return o; case OP_PREINC: case OP_PREDEC: case OP_POW: case OP_MULTIPLY: case OP_DIVIDE: case OP_MODULO: case OP_REPEAT: case OP_ADD: case OP_SUBTRACT: case OP_CONCAT: case OP_LEFT_SHIFT: case OP_RIGHT_SHIFT: case OP_BIT_AND: case OP_BIT_XOR: case OP_BIT_OR: case OP_I_MULTIPLY: case OP_I_DIVIDE: case OP_I_MODULO: case OP_I_ADD: case OP_I_SUBTRACT: if (!(o->op_flags & OPf_STACKED)) goto nomod; PL_modcount++; break; case OP_COND_EXPR: localize = 1; for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) mod(kid, type); break; case OP_RV2AV: case OP_RV2HV: if (type == OP_REFGEN && o->op_flags & OPf_PARENS) { PL_modcount = RETURN_UNLIMITED_NUMBER; return o; /* Treat \(@foo) like ordinary list. */ } /* FALL THROUGH */ case OP_RV2GV: if (scalar_mod_type(o, type)) goto nomod; ref(cUNOPo->op_first, o->op_type); /* FALL THROUGH */ case OP_ASLICE: case OP_HSLICE: if (type == OP_LEAVESUBLV) o->op_private |= OPpMAYBE_LVSUB; localize = 1; /* FALL THROUGH */ case OP_AASSIGN: case OP_NEXTSTATE: case OP_DBSTATE: PL_modcount = RETURN_UNLIMITED_NUMBER; break; case OP_AV2ARYLEN: PL_hints |= HINT_BLOCK_SCOPE; if (type == OP_LEAVESUBLV) o->op_private |= OPpMAYBE_LVSUB; PL_modcount++; break; case OP_RV2SV: ref(cUNOPo->op_first, o->op_type); localize = 1; /* FALL THROUGH */ case OP_GV: PL_hints |= HINT_BLOCK_SCOPE; case OP_SASSIGN: case OP_ANDASSIGN: case OP_ORASSIGN: case OP_DORASSIGN: PL_modcount++; break; case OP_AELEMFAST: localize = -1; PL_modcount++; break; case OP_PADAV: case OP_PADHV: PL_modcount = RETURN_UNLIMITED_NUMBER; if (type == OP_REFGEN && o->op_flags & OPf_PARENS) return o; /* Treat \(@foo) like ordinary list. */ if (scalar_mod_type(o, type)) goto nomod; if (type == OP_LEAVESUBLV) o->op_private |= OPpMAYBE_LVSUB; /* FALL THROUGH */ case OP_PADSV: PL_modcount++; if (!type) /* local() */ Perl_croak(aTHX_ "Can't localize lexical variable %s", PAD_COMPNAME_PV(o->op_targ)); break; case OP_PUSHMARK: localize = 0; break; case OP_KEYS: if (type != OP_SASSIGN) goto nomod; goto lvalue_func; case OP_SUBSTR: if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */ goto nomod; /* FALL THROUGH */ case OP_POS: case OP_VEC: if (type == OP_LEAVESUBLV) o->op_private |= OPpMAYBE_LVSUB; lvalue_func: pad_free(o->op_targ); o->op_targ = pad_alloc(o->op_type, SVs_PADMY); assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL); if (o->op_flags & OPf_KIDS) mod(cBINOPo->op_first->op_sibling, type); break; case OP_AELEM: case OP_HELEM: ref(cBINOPo->op_first, o->op_type); if (type == OP_ENTERSUB && !(o->op_private & (OPpLVAL_INTRO | OPpDEREF))) o->op_private |= OPpLVAL_DEFER; if (type == OP_LEAVESUBLV) o->op_private |= OPpMAYBE_LVSUB; localize = 1; PL_modcount++; break; case OP_SCOPE: case OP_LEAVE: case OP_ENTER: case OP_LINESEQ: localize = 0; if (o->op_flags & OPf_KIDS) mod(cLISTOPo->op_last, type); break; case OP_NULL: localize = 0; if (o->op_flags & OPf_SPECIAL) /* do BLOCK */ goto nomod; else if (!(o->op_flags & OPf_KIDS)) break; if (o->op_targ != OP_LIST) { mod(cBINOPo->op_first, type); break; } /* FALL THROUGH */ case OP_LIST: localize = 0; for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) mod(kid, type); break; case OP_RETURN: if (type != OP_LEAVESUBLV) goto nomod; break; /* mod()ing was handled by ck_return() */ } /* [20011101.069] File test operators interpret OPf_REF to mean that their argument is a filehandle; thus \stat(".") should not set it. AMS 20011102 */ if (type == OP_REFGEN && PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)) return o; if (type != OP_LEAVESUBLV) o->op_flags |= OPf_MOD; if (type == OP_AASSIGN || type == OP_SASSIGN) o->op_flags |= OPf_SPECIAL|OPf_REF; else if (!type) { /* local() */ switch (localize) { case 1: o->op_private |= OPpLVAL_INTRO; o->op_flags &= ~OPf_SPECIAL; PL_hints |= HINT_BLOCK_SCOPE; break; case 0: break; case -1: Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Useless localization of %s", OP_DESC(o)); } } else if (type != OP_GREPSTART && type != OP_ENTERSUB && type != OP_LEAVESUBLV) o->op_flags |= OPf_REF; return o; } STATIC bool S_scalar_mod_type(const OP *o, I32 type) { PERL_ARGS_ASSERT_SCALAR_MOD_TYPE; switch (type) { case OP_SASSIGN: if (o->op_type == OP_RV2GV) return FALSE; /* FALL THROUGH */ case OP_PREINC: case OP_PREDEC: case OP_POSTINC: case OP_POSTDEC: case OP_I_PREINC: case OP_I_PREDEC: case OP_I_POSTINC: case OP_I_POSTDEC: case OP_POW: case OP_MULTIPLY: case OP_DIVIDE: case OP_MODULO: case OP_REPEAT: case OP_ADD: case OP_SUBTRACT: case OP_I_MULTIPLY: case OP_I_DIVIDE: case OP_I_MODULO: case OP_I_ADD: case OP_I_SUBTRACT: case OP_LEFT_SHIFT: case OP_RIGHT_SHIFT: case OP_BIT_AND: case OP_BIT_XOR: case OP_BIT_OR: case OP_CONCAT: case OP_SUBST: case OP_TRANS: case OP_READ: case OP_SYSREAD: case OP_RECV: case OP_ANDASSIGN: case OP_ORASSIGN: case OP_DORASSIGN: return TRUE; default: return FALSE; } } STATIC bool S_is_handle_constructor(const OP *o, I32 numargs) { PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR; switch (o->op_type) { case OP_PIPE_OP: case OP_SOCKPAIR: if (numargs == 2) return TRUE; /* FALL THROUGH */ case OP_SYSOPEN: case OP_OPEN: case OP_SELECT: /* XXX c.f. SelectSaver.pm */ case OP_SOCKET: case OP_OPEN_DIR: case OP_ACCEPT: if (numargs == 1) return TRUE; /* FALLTHROUGH */ default: return FALSE; } } static OP * S_refkids(pTHX_ OP *o, I32 type) { if (o && o->op_flags & OPf_KIDS) { OP *kid; for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) ref(kid, type); } return o; } OP * Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) { dVAR; OP *kid; PERL_ARGS_ASSERT_DOREF; if (!o || (PL_parser && PL_parser->error_count)) return o; switch (o->op_type) { case OP_ENTERSUB: if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) && !(o->op_flags & OPf_STACKED)) { o->op_type = OP_RV2CV; /* entersub => rv2cv */ o->op_ppaddr = PL_ppaddr[OP_RV2CV]; assert(cUNOPo->op_first->op_type == OP_NULL); op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */ o->op_flags |= OPf_SPECIAL; o->op_private &= ~1; } break; case OP_COND_EXPR: for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) doref(kid, type, set_op_ref); break; case OP_RV2SV: if (type == OP_DEFINED) o->op_flags |= OPf_SPECIAL; /* don't create GV */ doref(cUNOPo->op_first, o->op_type, set_op_ref); /* FALL THROUGH */ case OP_PADSV: if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV : type == OP_RV2HV ? OPpDEREF_HV : OPpDEREF_SV); o->op_flags |= OPf_MOD; } break; case OP_RV2AV: case OP_RV2HV: if (set_op_ref) o->op_flags |= OPf_REF; /* FALL THROUGH */ case OP_RV2GV: if (type == OP_DEFINED) o->op_flags |= OPf_SPECIAL; /* don't create GV */ doref(cUNOPo->op_first, o->op_type, set_op_ref); break; case OP_PADAV: case OP_PADHV: if (set_op_ref) o->op_flags |= OPf_REF; break; case OP_SCALAR: case OP_NULL: if (!(o->op_flags & OPf_KIDS)) break; doref(cBINOPo->op_first, type, set_op_ref); break; case OP_AELEM: case OP_HELEM: doref(cBINOPo->op_first, o->op_type, set_op_ref); if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV : type == OP_RV2HV ? OPpDEREF_HV : OPpDEREF_SV); o->op_flags |= OPf_MOD; } break; case OP_SCOPE: case OP_LEAVE: set_op_ref = FALSE; /* FALL THROUGH */ case OP_ENTER: case OP_LIST: if (!(o->op_flags & OPf_KIDS)) break; doref(cLISTOPo->op_last, type, set_op_ref); break; default: break; } return scalar(o); } STATIC OP * S_dup_attrlist(pTHX_ OP *o) { dVAR; OP *rop; PERL_ARGS_ASSERT_DUP_ATTRLIST; /* An attrlist is either a simple OP_CONST or an OP_LIST with kids, * where the first kid is OP_PUSHMARK and the remaining ones * are OP_CONST. We need to push the OP_CONST values. */ if (o->op_type == OP_CONST) rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv)); #ifdef PERL_MAD else if (o->op_type == OP_NULL) rop = NULL; #endif else { assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS)); rop = NULL; for (o = cLISTOPo->op_first; o; o=o->op_sibling) { if (o->op_type == OP_CONST) rop = append_elem(OP_LIST, rop, newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv))); } } return rop; } STATIC void S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my) { dVAR; SV *stashsv; PERL_ARGS_ASSERT_APPLY_ATTRS; /* fake up C */ ENTER; /* need to protect against side-effects of 'use' */ stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; #define ATTRSMODULE "attributes" #define ATTRSMODULE_PM "attributes.pm" if (for_my) { /* Don't force the C if we don't need it. */ SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE); if (svp && *svp != &PL_sv_undef) NOOP; /* already in %INC */ else Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvs(ATTRSMODULE), NULL); } else { Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, newSVpvs(ATTRSMODULE), NULL, prepend_elem(OP_LIST, newSVOP(OP_CONST, 0, stashsv), prepend_elem(OP_LIST, newSVOP(OP_CONST, 0, newRV(target)), dup_attrlist(attrs)))); } LEAVE; } STATIC void S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) { dVAR; OP *pack, *imop, *arg; SV *meth, *stashsv; PERL_ARGS_ASSERT_APPLY_ATTRS_MY; if (!attrs) return; assert(target->op_type == OP_PADSV || target->op_type == OP_PADHV || target->op_type == OP_PADAV); /* Ensure that attributes.pm is loaded. */ apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE); /* Need package name for method call. */ pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE)); /* Build up the real arg-list. */ stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; arg = newOP(OP_PADSV, 0); arg->op_targ = target->op_targ; arg = prepend_elem(OP_LIST, newSVOP(OP_CONST, 0, stashsv), prepend_elem(OP_LIST, newUNOP(OP_REFGEN, 0, mod(arg, OP_REFGEN)), dup_attrlist(attrs))); /* Fake up a method call to import */ meth = newSVpvs_share("import"); imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID, append_elem(OP_LIST, prepend_elem(OP_LIST, pack, list(arg)), newSVOP(OP_METHOD_NAMED, 0, meth))); imop->op_private |= OPpENTERSUB_NOMOD; /* Combine the ops. */ *imopsp = append_elem(OP_LIST, *imopsp, imop); } /* =notfor apidoc apply_attrs_string Attempts to apply a list of attributes specified by the C and C arguments to the subroutine identified by the C argument which is expected to be associated with the package identified by the C argument (see L). It gets this wrong, though, in that it does not correctly identify the boundaries of the individual attribute specifications within C. This is not really intended for the public API, but has to be listed here for systems such as AIX which need an explicit export list for symbols. (It's called from XS code in support of the C keyword from F.) Patches to fix it to respect attribute syntax properly would be welcome. =cut */ void Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv, const char *attrstr, STRLEN len) { OP *attrs = NULL; PERL_ARGS_ASSERT_APPLY_ATTRS_STRING; if (!len) { len = strlen(attrstr); } while (len) { for (; isSPACE(*attrstr) && len; --len, ++attrstr) ; if (len) { const char * const sstr = attrstr; for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ; attrs = append_elem(OP_LIST, attrs, newSVOP(OP_CONST, 0, newSVpvn(sstr, attrstr-sstr))); } } Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, newSVpvs(ATTRSMODULE), NULL, prepend_elem(OP_LIST, newSVOP(OP_CONST, 0, newSVpv(stashpv,0)), prepend_elem(OP_LIST, newSVOP(OP_CONST, 0, newRV(MUTABLE_SV(cv))), attrs))); } STATIC OP * S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) { dVAR; I32 type; PERL_ARGS_ASSERT_MY_KID; if (!o || (PL_parser && PL_parser->error_count)) return o; type = o->op_type; if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) { (void)my_kid(cUNOPo->op_first, attrs, imopsp); return o; } if (type == OP_LIST) { OP *kid; for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) my_kid(kid, attrs, imopsp); } else if (type == OP_UNDEF #ifdef PERL_MAD || type == OP_STUB #endif ) { return o; } else if (type == OP_RV2SV || /* "our" declaration */ type == OP_RV2AV || type == OP_RV2HV) { /* XXX does this let anything illegal in? */ if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */ yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"", OP_DESC(o), PL_parser->in_my == KEY_our ? "our" : PL_parser->in_my == KEY_state ? "state" : "my")); } else if (attrs) { GV * const gv = cGVOPx_gv(cUNOPo->op_first); PL_parser->in_my = FALSE; PL_parser->in_my_stash = NULL; apply_attrs(GvSTASH(gv), (type == OP_RV2SV ? GvSV(gv) : type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) : type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)), attrs, FALSE); } o->op_private |= OPpOUR_INTRO; return o; } else if (type != OP_PADSV && type != OP_PADAV && type != OP_PADHV && type != OP_PUSHMARK) { yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"", OP_DESC(o), PL_parser->in_my == KEY_our ? "our" : PL_parser->in_my == KEY_state ? "state" : "my")); return o; } else if (attrs && type != OP_PUSHMARK) { HV *stash; PL_parser->in_my = FALSE; PL_parser->in_my_stash = NULL; /* check for C when deciding package */ stash = PAD_COMPNAME_TYPE(o->op_targ); if (!stash) stash = PL_curstash; apply_attrs_my(stash, o, attrs, imopsp); } o->op_flags |= OPf_MOD; o->op_private |= OPpLVAL_INTRO; if (PL_parser->in_my == KEY_state) o->op_private |= OPpPAD_STATE; return o; } OP * Perl_my_attrs(pTHX_ OP *o, OP *attrs) { dVAR; OP *rops; int maybe_scalar = 0; PERL_ARGS_ASSERT_MY_ATTRS; /* [perl #17376]: this appears to be premature, and results in code such as C< our(%x); > executing in list mode rather than void mode */ #if 0 if (o->op_flags & OPf_PARENS) list(o); else maybe_scalar = 1; #else maybe_scalar = 1; #endif if (attrs) SAVEFREEOP(attrs); rops = NULL; o = my_kid(o, attrs, &rops); if (rops) { if (maybe_scalar && o->op_type == OP_PADSV) { o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o)); o->op_private |= OPpLVAL_INTRO; } else o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops); } PL_parser->in_my = FALSE; PL_parser->in_my_stash = NULL; return o; } OP * Perl_sawparens(pTHX_ OP *o) { PERL_UNUSED_CONTEXT; if (o) o->op_flags |= OPf_PARENS; return o; } OP * Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) { OP *o; bool ismatchop = 0; const OPCODE ltype = left->op_type; const OPCODE rtype = right->op_type; PERL_ARGS_ASSERT_BIND_MATCH; if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV || ltype == OP_PADHV) && ckWARN(WARN_MISC)) { const char * const desc = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS) ? (int)rtype : OP_MATCH]; const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV) ? "@array" : "%hash"); Perl_warner(aTHX_ packWARN(WARN_MISC), "Applying %s to %s will act on scalar(%s)", desc, sample, sample); } if (rtype == OP_CONST && cSVOPx(right)->op_private & OPpCONST_BARE && cSVOPx(right)->op_private & OPpCONST_STRICT) { no_bareword_allowed(right); } ismatchop = rtype == OP_MATCH || rtype == OP_SUBST || rtype == OP_TRANS; if (ismatchop && right->op_private & OPpTARGET_MY) { right->op_targ = 0; right->op_private &= ~OPpTARGET_MY; } if (!(right->op_flags & OPf_STACKED) && ismatchop) { OP *newleft; right->op_flags |= OPf_STACKED; if (rtype != OP_MATCH && ! (rtype == OP_TRANS && right->op_private & OPpTRANS_IDENTICAL)) newleft = mod(left, rtype); else newleft = left; if (right->op_type == OP_TRANS) o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right); else o = prepend_elem(rtype, scalar(newleft), right); if (type == OP_NOT) return newUNOP(OP_NOT, 0, scalar(o)); return o; } else return bind_match(type, left, pmruntime(newPMOP(OP_MATCH, 0), right, 0)); } OP * Perl_invert(pTHX_ OP *o) { if (!o) return NULL; return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o)); } OP * Perl_scope(pTHX_ OP *o) { dVAR; if (o) { if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) { o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o); o->op_type = OP_LEAVE; o->op_ppaddr = PL_ppaddr[OP_LEAVE]; } else if (o->op_type == OP_LINESEQ) { OP *kid; o->op_type = OP_SCOPE; o->op_ppaddr = PL_ppaddr[OP_SCOPE]; kid = ((LISTOP*)o)->op_first; if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { op_null(kid); /* The following deals with things like 'do {1 for 1}' */ kid = kid->op_sibling; if (kid && (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)) op_null(kid); } } else o = newLISTOP(OP_SCOPE, 0, o, NULL); } return o; } int Perl_block_start(pTHX_ int full) { dVAR; const int retval = PL_savestack_ix; pad_block_start(full); SAVEHINTS(); PL_hints &= ~HINT_BLOCK_SCOPE; SAVECOMPILEWARNINGS(); PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings); return retval; } OP* Perl_block_end(pTHX_ I32 floor, OP *seq) { dVAR; const int needblockscope = PL_hints & HINT_BLOCK_SCOPE; OP* const retval = scalarseq(seq); LEAVE_SCOPE(floor); CopHINTS_set(&PL_compiling, PL_hints); if (needblockscope) PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */ pad_leavemy(); return retval; } STATIC OP * S_newDEFSVOP(pTHX) { dVAR; const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0); if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { return newSVREF(newGVOP(OP_GV, 0, PL_defgv)); } else { OP * const o = newOP(OP_PADSV, 0); o->op_targ = offset; return o; } } void Perl_newPROG(pTHX_ OP *o) { dVAR; PERL_ARGS_ASSERT_NEWPROG; if (PL_in_eval) { if (PL_eval_root) return; PL_eval_root = newUNOP(OP_LEAVEEVAL, ((PL_in_eval & EVAL_KEEPERR) ? OPf_SPECIAL : 0), o); PL_eval_start = linklist(PL_eval_root); PL_eval_root->op_private |= OPpREFCOUNTED; OpREFCNT_set(PL_eval_root, 1); PL_eval_root->op_next = 0; CALL_PEEP(PL_eval_start); } else { if (o->op_type == OP_STUB) { PL_comppad_name = 0; PL_compcv = 0; S_op_destroy(aTHX_ o); return; } PL_main_root = scope(sawparens(scalarvoid(o))); PL_curcop = &PL_compiling; PL_main_start = LINKLIST(PL_main_root); PL_main_root->op_private |= OPpREFCOUNTED; OpREFCNT_set(PL_main_root, 1); PL_main_root->op_next = 0; CALL_PEEP(PL_main_start); PL_compcv = 0; /* Register with debugger */ if (PERLDB_INTER) { 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); } } } } OP * Perl_localize(pTHX_ OP *o, I32 lex) { dVAR; PERL_ARGS_ASSERT_LOCALIZE; if (o->op_flags & OPf_PARENS) /* [perl #17376]: this appears to be premature, and results in code such as C< our(%x); > executing in list mode rather than void mode */ #if 0 list(o); #else NOOP; #endif else { if ( PL_parser->bufptr > PL_parser->oldbufptr && PL_parser->bufptr[-1] == ',' && ckWARN(WARN_PARENTHESIS)) { char *s = PL_parser->bufptr; bool sigil = FALSE; /* some heuristics to detect a potential error */ while (*s && (strchr(", \t\n", *s))) s++; while (1) { if (*s && strchr("@$%*", *s) && *++s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) { s++; sigil = TRUE; while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) s++; while (*s && (strchr(", \t\n", *s))) s++; } else break; } if (sigil && (*s == ';' || *s == '=')) { Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS), "Parentheses missing around \"%s\" list", lex ? (PL_parser->in_my == KEY_our ? "our" : PL_parser->in_my == KEY_state ? "state" : "my") : "local"); } } } if (lex) o = my(o); else o = mod(o, OP_NULL); /* a bit kludgey */ PL_parser->in_my = FALSE; PL_parser->in_my_stash = NULL; return o; } OP * Perl_jmaybe(pTHX_ OP *o) { PERL_ARGS_ASSERT_JMAYBE; if (o->op_type == OP_LIST) { OP * const o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV))); o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o)); } return o; } static OP * S_fold_constants(pTHX_ register OP *o) { dVAR; register OP * VOL curop; OP *newop; VOL I32 type = o->op_type; SV * VOL sv = NULL; int ret = 0; I32 oldscope; OP *old_next; SV * const oldwarnhook = PL_warnhook; SV * const olddiehook = PL_diehook; COP not_compiling; dJMPENV; PERL_ARGS_ASSERT_FOLD_CONSTANTS; if (PL_opargs[type] & OA_RETSCALAR) scalar(o); if (PL_opargs[type] & OA_TARGET && !o->op_targ) o->op_targ = pad_alloc(type, SVs_PADTMP); /* integerize op, unless it happens to be C<-foo>. * XXX should pp_i_negate() do magic string negation instead? */ if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER) && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST && (cUNOPo->op_first->op_private & OPpCONST_BARE))) { o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)]; } if (!(PL_opargs[type] & OA_FOLDCONST)) goto nope; switch (type) { case OP_NEGATE: /* XXX might want a ck_negate() for this */ cUNOPo->op_first->op_private &= ~OPpCONST_STRICT; break; case OP_UCFIRST: case OP_LCFIRST: case OP_UC: case OP_LC: case OP_SLT: case OP_SGT: case OP_SLE: case OP_SGE: case OP_SCMP: /* XXX what about the numeric ops? */ if (PL_hints & HINT_LOCALE) goto nope; break; } if (PL_parser && PL_parser->error_count) goto nope; /* Don't try to run w/ errors */ for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { const OPCODE type = curop->op_type; if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) && type != OP_LIST && type != OP_SCALAR && type != OP_NULL && type != OP_PUSHMARK) { goto nope; } } curop = LINKLIST(o); old_next = o->op_next; o->op_next = 0; PL_op = curop; oldscope = PL_scopestack_ix; create_eval_scope(G_FAKINGEVAL); /* Verify that we don't need to save it: */ assert(PL_curcop == &PL_compiling); StructCopy(&PL_compiling, ¬_compiling, COP); PL_curcop = ¬_compiling; /* The above ensures that we run with all the correct hints of the currently compiling COP, but that IN_PERL_RUNTIME is not true. */ assert(IN_PERL_RUNTIME); PL_warnhook = PERL_WARNHOOK_FATAL; PL_diehook = NULL; JMPENV_PUSH(ret); switch (ret) { case 0: CALLRUNOPS(aTHX); sv = *(PL_stack_sp--); if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */ pad_swipe(o->op_targ, FALSE); else if (SvTEMP(sv)) { /* grab mortal temp? */ SvREFCNT_inc_simple_void(sv); SvTEMP_off(sv); } break; case 3: /* Something tried to die. Abandon constant folding. */ /* Pretend the error never happened. */ CLEAR_ERRSV(); o->op_next = old_next; break; default: JMPENV_POP; /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */ PL_warnhook = oldwarnhook; PL_diehook = olddiehook; /* XXX note that this croak may fail as we've already blown away * the stack - eg any nested evals */ Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret); } JMPENV_POP; PL_warnhook = oldwarnhook; PL_diehook = olddiehook; PL_curcop = &PL_compiling; if (PL_scopestack_ix > oldscope) delete_eval_scope(); if (ret) goto nope; #ifndef PERL_MAD op_free(o); #endif assert(sv); if (type == OP_RV2GV) newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv)); else newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv)); op_getmad(o,newop,'f'); return newop; nope: return o; } static OP * S_gen_constant_list(pTHX_ register OP *o) { dVAR; register OP *curop; const I32 oldtmps_floor = PL_tmps_floor; list(o); if (PL_parser && PL_parser->error_count) return o; /* Don't attempt to run with errors */ PL_op = curop = LINKLIST(o); o->op_next = 0; CALL_PEEP(curop); pp_pushmark(); CALLRUNOPS(aTHX); PL_op = curop; assert (!(curop->op_flags & OPf_SPECIAL)); assert(curop->op_type == OP_RANGE); pp_anonlist(); PL_tmps_floor = oldtmps_floor; o->op_type = OP_RV2AV; o->op_ppaddr = PL_ppaddr[OP_RV2AV]; o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */ o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */ o->op_opt = 0; /* needs to be revisited in peep() */ curop = ((UNOP*)o)->op_first; ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--)); #ifdef PERL_MAD op_getmad(curop,o,'O'); #else op_free(curop); #endif linklist(o); return list(o); } OP * Perl_convert(pTHX_ I32 type, I32 flags, OP *o) { dVAR; if (!o || o->op_type != OP_LIST) o = newLISTOP(OP_LIST, 0, o, NULL); else o->op_flags &= ~OPf_WANT; if (!(PL_opargs[type] & OA_MARK)) op_null(cLISTOPo->op_first); o->op_type = (OPCODE)type; o->op_ppaddr = PL_ppaddr[type]; o->op_flags |= flags; o = CHECKOP(type, o); if (o->op_type != (unsigned)type) return o; return fold_constants(o); } /* List constructors */ OP * Perl_append_elem(pTHX_ I32 type, OP *first, OP *last) { if (!first) return last; if (!last) return first; if (first->op_type != (unsigned)type || (type == OP_LIST && (first->op_flags & OPf_PARENS))) { return newLISTOP(type, 0, first, last); } if (first->op_flags & OPf_KIDS) ((LISTOP*)first)->op_last->op_sibling = last; else { first->op_flags |= OPf_KIDS; ((LISTOP*)first)->op_first = last; } ((LISTOP*)first)->op_last = last; return first; } OP * Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last) { if (!first) return (OP*)last; if (!last) return (OP*)first; if (first->op_type != (unsigned)type) return prepend_elem(type, (OP*)first, (OP*)last); if (last->op_type != (unsigned)type) return append_elem(type, (OP*)first, (OP*)last); first->op_last->op_sibling = last->op_first; first->op_last = last->op_last; first->op_flags |= (last->op_flags & OPf_KIDS); #ifdef PERL_MAD if (last->op_first && first->op_madprop) { MADPROP *mp = last->op_first->op_madprop; if (mp) { while (mp->mad_next) mp = mp->mad_next; mp->mad_next = first->op_madprop; } else { last->op_first->op_madprop = first->op_madprop; } } first->op_madprop = last->op_madprop; last->op_madprop = 0; #endif S_op_destroy(aTHX_ (OP*)last); return (OP*)first; } OP * Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last) { if (!first) return last; if (!last) return first; if (last->op_type == (unsigned)type) { if (type == OP_LIST) { /* already a PUSHMARK there */ first->op_sibling = ((LISTOP*)last)->op_first->op_sibling; ((LISTOP*)last)->op_first->op_sibling = first; if (!(first->op_flags & OPf_PARENS)) last->op_flags &= ~OPf_PARENS; } else { if (!(last->op_flags & OPf_KIDS)) { ((LISTOP*)last)->op_last = first; last->op_flags |= OPf_KIDS; } first->op_sibling = ((LISTOP*)last)->op_first; ((LISTOP*)last)->op_first = first; } last->op_flags |= OPf_KIDS; return last; } return newLISTOP(type, 0, first, last); } /* Constructors */ #ifdef PERL_MAD TOKEN * Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop) { TOKEN *tk; Newxz(tk, 1, TOKEN); tk->tk_type = (OPCODE)optype; tk->tk_type = 12345; tk->tk_lval = lval; tk->tk_mad = madprop; return tk; } void Perl_token_free(pTHX_ TOKEN* tk) { PERL_ARGS_ASSERT_TOKEN_FREE; if (tk->tk_type != 12345) return; mad_free(tk->tk_mad); Safefree(tk); } void Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot) { MADPROP* mp; MADPROP* tm; PERL_ARGS_ASSERT_TOKEN_GETMAD; if (tk->tk_type != 12345) { Perl_warner(aTHX_ packWARN(WARN_MISC), "Invalid TOKEN object ignored"); return; } tm = tk->tk_mad; if (!tm) return; /* faked up qw list? */ if (slot == '(' && tm->mad_type == MAD_SV && SvPVX((SV *)tm->mad_val)[0] == 'q') slot = 'x'; if (o) { mp = o->op_madprop; if (mp) { for (;;) { /* pretend constant fold didn't happen? */ if (mp->mad_key == 'f' && (o->op_type == OP_CONST || o->op_type == OP_GV) ) { token_getmad(tk,(OP*)mp->mad_val,slot); return; } if (!mp->mad_next) break; mp = mp->mad_next; } mp->mad_next = tm; mp = mp->mad_next; } else { o->op_madprop = tm; mp = o->op_madprop; } if (mp->mad_key == 'X') mp->mad_key = slot; /* just change the first one */ tk->tk_mad = 0; } else mad_free(tm); Safefree(tk); } void Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot) { MADPROP* mp; if (!from) return; if (o) { mp = o->op_madprop; if (mp) { for (;;) { /* pretend constant fold didn't happen? */ if (mp->mad_key == 'f' && (o->op_type == OP_CONST || o->op_type == OP_GV) ) { op_getmad(from,(OP*)mp->mad_val,slot); return; } if (!mp->mad_next) break; mp = mp->mad_next; } mp->mad_next = newMADPROP(slot,MAD_OP,from,0); } else { o->op_madprop = newMADPROP(slot,MAD_OP,from,0); } } } void Perl_op_getmad(pTHX_ OP* from, OP* o, char slot) { MADPROP* mp; if (!from) return; if (o) { mp = o->op_madprop; if (mp) { for (;;) { /* pretend constant fold didn't happen? */ if (mp->mad_key == 'f' && (o->op_type == OP_CONST || o->op_type == OP_GV) ) { op_getmad(from,(OP*)mp->mad_val,slot); return; } if (!mp->mad_next) break; mp = mp->mad_next; } mp->mad_next = newMADPROP(slot,MAD_OP,from,1); } else { o->op_madprop = newMADPROP(slot,MAD_OP,from,1); } } else { PerlIO_printf(PerlIO_stderr(), "DESTROYING op = %0"UVxf"\n", PTR2UV(from)); op_free(from); } } void Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot) { MADPROP* tm; if (!mp || !o) return; if (slot) mp->mad_key = slot; tm = o->op_madprop; o->op_madprop = mp; for (;;) { if (!mp->mad_next) break; mp = mp->mad_next; } mp->mad_next = tm; } void Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot) { if (!o) return; addmad(tm, &(o->op_madprop), slot); } void Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot) { MADPROP* mp; if (!tm || !root) return; if (slot) tm->mad_key = slot; mp = *root; if (!mp) { *root = tm; return; } for (;;) { if (!mp->mad_next) break; mp = mp->mad_next; } mp->mad_next = tm; } MADPROP * Perl_newMADsv(pTHX_ char key, SV* sv) { PERL_ARGS_ASSERT_NEWMADSV; return newMADPROP(key, MAD_SV, sv, 0); } MADPROP * Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen) { MADPROP *mp; Newxz(mp, 1, MADPROP); mp->mad_next = 0; mp->mad_key = key; mp->mad_vlen = vlen; mp->mad_type = type; mp->mad_val = val; /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */ return mp; } void Perl_mad_free(pTHX_ MADPROP* mp) { /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */ if (!mp) return; if (mp->mad_next) mad_free(mp->mad_next); /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen) PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */ switch (mp->mad_type) { case MAD_NULL: break; case MAD_PV: Safefree((char*)mp->mad_val); break; case MAD_OP: if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */ op_free((OP*)mp->mad_val); break; case MAD_SV: sv_free(MUTABLE_SV(mp->mad_val)); break; default: PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n"); break; } Safefree(mp); } #endif OP * Perl_newNULLLIST(pTHX) { return newOP(OP_STUB, 0); } static OP * S_force_list(pTHX_ OP *o) { if (!o || o->op_type != OP_LIST) o = newLISTOP(OP_LIST, 0, o, NULL); op_null(o); return o; } OP * Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) { dVAR; LISTOP *listop; assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP); NewOp(1101, listop, 1, LISTOP); listop->op_type = (OPCODE)type; listop->op_ppaddr = PL_ppaddr[type]; if (first || last) flags |= OPf_KIDS; listop->op_flags = (U8)flags; if (!last && first) last = first; else if (!first && last) first = last; else if (first) first->op_sibling = last; listop->op_first = first; listop->op_last = last; if (type == OP_LIST) { OP* const pushop = newOP(OP_PUSHMARK, 0); pushop->op_sibling = first; listop->op_first = pushop; listop->op_flags |= OPf_KIDS; if (!last) listop->op_last = pushop; } return CHECKOP(type, listop); } OP * Perl_newOP(pTHX_ I32 type, I32 flags) { dVAR; OP *o; assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); NewOp(1101, o, 1, OP); o->op_type = (OPCODE)type; o->op_ppaddr = PL_ppaddr[type]; o->op_flags = (U8)flags; o->op_latefree = 0; o->op_latefreed = 0; o->op_attached = 0; o->op_next = o; o->op_private = (U8)(0 | (flags >> 8)); if (PL_opargs[type] & OA_RETSCALAR) scalar(o); if (PL_opargs[type] & OA_TARGET) o->op_targ = pad_alloc(type, SVs_PADTMP); return CHECKOP(type, o); } OP * Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) { dVAR; UNOP *unop; assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP || type == OP_SASSIGN || type == OP_ENTERTRY || type == OP_NULL ); if (!first) first = newOP(OP_STUB, 0); if (PL_opargs[type] & OA_MARK) first = force_list(first); NewOp(1101, unop, 1, UNOP); unop->op_type = (OPCODE)type; unop->op_ppaddr = PL_ppaddr[type]; unop->op_first = first; unop->op_flags = (U8)(flags | OPf_KIDS); unop->op_private = (U8)(1 | (flags >> 8)); unop = (UNOP*) CHECKOP(type, unop); if (unop->op_next) return (OP*)unop; return fold_constants((OP *) unop); } OP * Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) { dVAR; BINOP *binop; assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP || type == OP_SASSIGN || type == OP_NULL ); NewOp(1101, binop, 1, BINOP); if (!first) first = newOP(OP_NULL, 0); binop->op_type = (OPCODE)type; binop->op_ppaddr = PL_ppaddr[type]; binop->op_first = first; binop->op_flags = (U8)(flags | OPf_KIDS); if (!last) { last = first; binop->op_private = (U8)(1 | (flags >> 8)); } else { binop->op_private = (U8)(2 | (flags >> 8)); first->op_sibling = last; } binop = (BINOP*)CHECKOP(type, binop); if (binop->op_next || binop->op_type != (OPCODE)type) return (OP*)binop; binop->op_last = binop->op_first->op_sibling; return fold_constants((OP *)binop); } static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__; static int uvcompare(const void *a, const void *b) { if (*((const UV *)a) < (*(const UV *)b)) return -1; if (*((const UV *)a) > (*(const UV *)b)) return 1; if (*((const UV *)a+1) < (*(const UV *)b+1)) return -1; if (*((const UV *)a+1) > (*(const UV *)b+1)) return 1; return 0; } static OP * S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) { dVAR; SV * const tstr = ((SVOP*)expr)->op_sv; SV * const rstr = #ifdef PERL_MAD (repl->op_type == OP_NULL) ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv : #endif ((SVOP*)repl)->op_sv; STRLEN tlen; STRLEN rlen; const U8 *t = (U8*)SvPV_const(tstr, tlen); const U8 *r = (U8*)SvPV_const(rstr, rlen); register I32 i; register I32 j; I32 grows = 0; register short *tbl; const I32 complement = o->op_private & OPpTRANS_COMPLEMENT; const I32 squash = o->op_private & OPpTRANS_SQUASH; I32 del = o->op_private & OPpTRANS_DELETE; SV* swash; PERL_ARGS_ASSERT_PMTRANS; PL_hints |= HINT_BLOCK_SCOPE; if (SvUTF8(tstr)) o->op_private |= OPpTRANS_FROM_UTF; if (SvUTF8(rstr)) o->op_private |= OPpTRANS_TO_UTF; if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { SV* const listsv = newSVpvs("# comment\n"); SV* transv = NULL; const U8* tend = t + tlen; const U8* rend = r + rlen; STRLEN ulen; UV tfirst = 1; UV tlast = 0; IV tdiff; UV rfirst = 1; UV rlast = 0; IV rdiff; IV diff; I32 none = 0; U32 max = 0; I32 bits; I32 havefinal = 0; U32 final = 0; const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF; const I32 to_utf = o->op_private & OPpTRANS_TO_UTF; U8* tsave = NULL; U8* rsave = NULL; const U32 flags = UTF8_ALLOW_DEFAULT; if (!from_utf) { STRLEN len = tlen; t = tsave = bytes_to_utf8(t, &len); tend = t + len; } if (!to_utf && rlen) { STRLEN len = rlen; r = rsave = bytes_to_utf8(r, &len); rend = r + len; } /* There are several snags with this code on EBCDIC: 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes). 2. scan_const() in toke.c has encoded chars in native encoding which makes ranges at least in EBCDIC 0..255 range the bottom odd. */ if (complement) { U8 tmpbuf[UTF8_MAXBYTES+1]; UV *cp; UV nextmin = 0; Newx(cp, 2*tlen, UV); i = 0; transv = newSVpvs(""); while (t < tend) { cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags); t += ulen; if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { t++; cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags); t += ulen; } else { cp[2*i+1] = cp[2*i]; } i++; } qsort(cp, i, 2*sizeof(UV), uvcompare); for (j = 0; j < i; j++) { UV val = cp[2*j]; diff = val - nextmin; if (diff > 0) { t = uvuni_to_utf8(tmpbuf,nextmin); sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); if (diff > 1) { U8 range_mark = UTF_TO_NATIVE(0xff); t = uvuni_to_utf8(tmpbuf, val - 1); sv_catpvn(transv, (char *)&range_mark, 1); sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); } } val = cp[2*j+1]; if (val >= nextmin) nextmin = val + 1; } t = uvuni_to_utf8(tmpbuf,nextmin); sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); { U8 range_mark = UTF_TO_NATIVE(0xff); sv_catpvn(transv, (char *)&range_mark, 1); } t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff, UNICODE_ALLOW_SUPER); sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); t = (const U8*)SvPVX_const(transv); tlen = SvCUR(transv); tend = t + tlen; Safefree(cp); } else if (!rlen && !del) { r = t; rlen = tlen; rend = tend; } if (!squash) { if ((!rlen && !del) || t == r || (tlen == rlen && memEQ((char *)t, (char *)r, tlen))) { o->op_private |= OPpTRANS_IDENTICAL; } } while (t < tend || tfirst <= tlast) { /* see if we need more "t" chars */ if (tfirst > tlast) { tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags); t += ulen; if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */ t++; tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags); t += ulen; } else tlast = tfirst; } /* now see if we need more "r" chars */ if (rfirst > rlast) { if (r < rend) { rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags); r += ulen; if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */ r++; rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags); r += ulen; } else rlast = rfirst; } else { if (!havefinal++) final = rlast; rfirst = rlast = 0xffffffff; } } /* now see which range will peter our first, if either. */ tdiff = tlast - tfirst; rdiff = rlast - rfirst; if (tdiff <= rdiff) diff = tdiff; else diff = rdiff; if (rfirst == 0xffffffff) { diff = tdiff; /* oops, pretend rdiff is infinite */ if (diff > 0) Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n", (long)tfirst, (long)tlast); else Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst); } else { if (diff > 0) Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n", (long)tfirst, (long)(tfirst + diff), (long)rfirst); else Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n", (long)tfirst, (long)rfirst); if (rfirst + diff > max) max = rfirst + diff; if (!grows) grows = (tfirst < rfirst && UNISKIP(tfirst) < UNISKIP(rfirst + diff)); rfirst += diff + 1; } tfirst += diff + 1; } none = ++max; if (del) del = ++max; if (max > 0xffff) bits = 32; else if (max > 0xff) bits = 16; else bits = 8; PerlMemShared_free(cPVOPo->op_pv); cPVOPo->op_pv = NULL; swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none)); #ifdef USE_ITHREADS cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP); SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix)); PAD_SETSV(cPADOPo->op_padix, swash); SvPADTMP_on(swash); SvREADONLY_on(swash); #else cSVOPo->op_sv = swash; #endif SvREFCNT_dec(listsv); SvREFCNT_dec(transv); if (!del && havefinal && rlen) (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5, newSVuv((UV)final), 0); if (grows) o->op_private |= OPpTRANS_GROWS; Safefree(tsave); Safefree(rsave); #ifdef PERL_MAD op_getmad(expr,o,'e'); op_getmad(repl,o,'r'); #else op_free(expr); op_free(repl); #endif return o; } tbl = (short*)cPVOPo->op_pv; if (complement) { Zero(tbl, 256, short); for (i = 0; i < (I32)tlen; i++) tbl[t[i]] = -1; for (i = 0, j = 0; i < 256; i++) { if (!tbl[i]) { if (j >= (I32)rlen) { if (del) tbl[i] = -2; else if (rlen) tbl[i] = r[j-1]; else tbl[i] = (short)i; } else { if (i < 128 && r[j] >= 128) grows = 1; tbl[i] = r[j++]; } } } if (!del) { if (!rlen) { j = rlen; if (!squash) o->op_private |= OPpTRANS_IDENTICAL; } else if (j >= (I32)rlen) j = rlen - 1; else { tbl = (short *) PerlMemShared_realloc(tbl, (0x101+rlen-j) * sizeof(short)); cPVOPo->op_pv = (char*)tbl; } tbl[0x100] = (short)(rlen - j); for (i=0; i < (I32)rlen - j; i++) tbl[0x101+i] = r[j+i]; } } else { if (!rlen && !del) { r = t; rlen = tlen; if (!squash) o->op_private |= OPpTRANS_IDENTICAL; } else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) { o->op_private |= OPpTRANS_IDENTICAL; } for (i = 0; i < 256; i++) tbl[i] = -1; for (i = 0, j = 0; i < (I32)tlen; i++,j++) { if (j >= (I32)rlen) { if (del) { if (tbl[t[i]] == -1) tbl[t[i]] = -2; continue; } --j; } if (tbl[t[i]] == -1) { if (t[i] < 128 && r[j] >= 128) grows = 1; tbl[t[i]] = r[j]; } } } if(del && rlen == tlen) { Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator"); } else if(rlen > tlen) { Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list"); } if (grows) o->op_private |= OPpTRANS_GROWS; #ifdef PERL_MAD op_getmad(expr,o,'e'); op_getmad(repl,o,'r'); #else op_free(expr); op_free(repl); #endif return o; } OP * Perl_newPMOP(pTHX_ I32 type, I32 flags) { dVAR; PMOP *pmop; assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP); NewOp(1101, pmop, 1, PMOP); pmop->op_type = (OPCODE)type; pmop->op_ppaddr = PL_ppaddr[type]; pmop->op_flags = (U8)flags; pmop->op_private = (U8)(0 | (flags >> 8)); if (PL_hints & HINT_RE_TAINT) pmop->op_pmflags |= PMf_RETAINT; if (PL_hints & HINT_LOCALE) pmop->op_pmflags |= PMf_LOCALE; #ifdef USE_ITHREADS assert(SvPOK(PL_regex_pad[0])); if (SvCUR(PL_regex_pad[0])) { /* Pop off the "packed" IV from the end. */ SV *const repointer_list = PL_regex_pad[0]; const char *p = SvEND(repointer_list) - sizeof(IV); const IV offset = *((IV*)p); assert(SvCUR(repointer_list) % sizeof(IV) == 0); SvEND_set(repointer_list, p); pmop->op_pmoffset = offset; /* This slot should be free, so assert this: */ assert(PL_regex_pad[offset] == &PL_sv_undef); } else { SV * const repointer = &PL_sv_undef; av_push(PL_regex_padav, repointer); pmop->op_pmoffset = av_len(PL_regex_padav); PL_regex_pad = AvARRAY(PL_regex_padav); } #endif return CHECKOP(type, pmop); } /* Given some sort of match op o, and an expression expr containing a * pattern, either compile expr into a regex and attach it to o (if it's * constant), or convert expr into a runtime regcomp op sequence (if it's * not) * * isreg indicates that the pattern is part of a regex construct, eg * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or * split "pattern", which aren't. In the former case, expr will be a list * if the pattern contains more than one term (eg /a$b/) or if it contains * a replacement, ie s/// or tr///. */ OP * Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) { dVAR; PMOP *pm; LOGOP *rcop; I32 repl_has_vars = 0; OP* repl = NULL; bool reglist; PERL_ARGS_ASSERT_PMRUNTIME; if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) { /* last element in list is the replacement; pop it */ OP* kid; repl = cLISTOPx(expr)->op_last; kid = cLISTOPx(expr)->op_first; while (kid->op_sibling != repl) kid = kid->op_sibling; kid->op_sibling = NULL; cLISTOPx(expr)->op_last = kid; } if (isreg && expr->op_type == OP_LIST && cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last) { /* convert single element list to element */ OP* const oe = expr; expr = cLISTOPx(oe)->op_first->op_sibling; cLISTOPx(oe)->op_first->op_sibling = NULL; cLISTOPx(oe)->op_last = NULL; op_free(oe); } if (o->op_type == OP_TRANS) { return pmtrans(o, expr, repl); } reglist = isreg && expr->op_type == OP_LIST; if (reglist) op_null(expr); PL_hints |= HINT_BLOCK_SCOPE; pm = (PMOP*)o; if (expr->op_type == OP_CONST) { SV *pat = ((SVOP*)expr)->op_sv; U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME; if (o->op_flags & OPf_SPECIAL) pm_flags |= RXf_SPLIT; if (DO_UTF8(pat)) { assert (SvUTF8(pat)); } else if (SvUTF8(pat)) { /* Not doing UTF-8, despite what the SV says. Is this only if we're trapped in use 'bytes'? */ /* Make a copy of the octet sequence, but without the flag on, as the compiler now honours the SvUTF8 flag on pat. */ STRLEN len; const char *const p = SvPV(pat, len); pat = newSVpvn_flags(p, len, SVs_TEMP); } PM_SETRE(pm, CALLREGCOMP(pat, pm_flags)); #ifdef PERL_MAD op_getmad(expr,(OP*)pm,'e'); #else op_free(expr); #endif } else { if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) expr = newUNOP((!(PL_hints & HINT_RE_EVAL) ? OP_REGCRESET : OP_REGCMAYBE),0,expr); NewOp(1101, rcop, 1, LOGOP); rcop->op_type = OP_REGCOMP; rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP]; rcop->op_first = scalar(expr); rcop->op_flags |= OPf_KIDS | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0) | (reglist ? OPf_STACKED : 0); rcop->op_private = 1; rcop->op_other = o; if (reglist) rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP); /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */ PL_cv_has_eval = 1; /* establish postfix order */ if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) { LINKLIST(expr); rcop->op_next = expr; ((UNOP*)expr)->op_first->op_next = (OP*)rcop; } else { rcop->op_next = LINKLIST(expr); expr->op_next = (OP*)rcop; } prepend_elem(o->op_type, scalar((OP*)rcop), o); } if (repl) { OP *curop; if (pm->op_pmflags & PMf_EVAL) { curop = NULL; if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end) CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end); } else if (repl->op_type == OP_CONST) curop = repl; else { OP *lastop = NULL; for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) { if (curop->op_type == OP_SCOPE || curop->op_type == OP_LEAVE || (PL_opargs[curop->op_type] & OA_DANGEROUS)) { if (curop->op_type == OP_GV) { GV * const gv = cGVOPx_gv(curop); repl_has_vars = 1; if (strchr("&`'123456789+-\016\022", *GvENAME(gv))) break; } else if (curop->op_type == OP_RV2CV) break; else if (curop->op_type == OP_RV2SV || curop->op_type == OP_RV2AV || curop->op_type == OP_RV2HV || curop->op_type == OP_RV2GV) { if (lastop && lastop->op_type != OP_GV) /*funny deref?*/ break; } else if (curop->op_type == OP_PADSV || curop->op_type == OP_PADAV || curop->op_type == OP_PADHV || curop->op_type == OP_PADANY) { repl_has_vars = 1; } else if (curop->op_type == OP_PUSHRE) NOOP; /* Okay here, dangerous in newASSIGNOP */ else break; } lastop = curop; } } if (curop == repl && !(repl_has_vars && (!PM_GETRE(pm) || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN))) { pm->op_pmflags |= PMf_CONST; /* const for long enough */ prepend_elem(o->op_type, scalar(repl), o); } else { if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */ pm->op_pmflags |= PMf_MAYBE_CONST; } NewOp(1101, rcop, 1, LOGOP); rcop->op_type = OP_SUBSTCONT; rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT]; rcop->op_first = scalar(repl); rcop->op_flags |= OPf_KIDS; rcop->op_private = 1; rcop->op_other = o; /* establish postfix order */ rcop->op_next = LINKLIST(repl); repl->op_next = (OP*)rcop; pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop); assert(!(pm->op_pmflags & PMf_ONCE)); pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop); rcop->op_next = 0; } } return (OP*)pm; } OP * Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) { dVAR; SVOP *svop; PERL_ARGS_ASSERT_NEWSVOP; assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP); NewOp(1101, svop, 1, SVOP); svop->op_type = (OPCODE)type; svop->op_ppaddr = PL_ppaddr[type]; svop->op_sv = sv; svop->op_next = (OP*)svop; svop->op_flags = (U8)flags; if (PL_opargs[type] & OA_RETSCALAR) scalar((OP*)svop); if (PL_opargs[type] & OA_TARGET) svop->op_targ = pad_alloc(type, SVs_PADTMP); return CHECKOP(type, svop); } #ifdef USE_ITHREADS OP * Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) { dVAR; PADOP *padop; PERL_ARGS_ASSERT_NEWPADOP; assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP); NewOp(1101, padop, 1, PADOP); padop->op_type = (OPCODE)type; padop->op_ppaddr = PL_ppaddr[type]; padop->op_padix = pad_alloc(type, SVs_PADTMP); SvREFCNT_dec(PAD_SVl(padop->op_padix)); PAD_SETSV(padop->op_padix, sv); assert(sv); SvPADTMP_on(sv); padop->op_next = (OP*)padop; padop->op_flags = (U8)flags; if (PL_opargs[type] & OA_RETSCALAR) scalar((OP*)padop); if (PL_opargs[type] & OA_TARGET) padop->op_targ = pad_alloc(type, SVs_PADTMP); return CHECKOP(type, padop); } #endif OP * Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) { dVAR; PERL_ARGS_ASSERT_NEWGVOP; #ifdef USE_ITHREADS GvIN_PAD_on(gv); return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv)); #else return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv)); #endif } OP * Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) { dVAR; PVOP *pvop; assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); NewOp(1101, pvop, 1, PVOP); pvop->op_type = (OPCODE)type; pvop->op_ppaddr = PL_ppaddr[type]; pvop->op_pv = pv; pvop->op_next = (OP*)pvop; pvop->op_flags = (U8)flags; if (PL_opargs[type] & OA_RETSCALAR) scalar((OP*)pvop); if (PL_opargs[type] & OA_TARGET) pvop->op_targ = pad_alloc(type, SVs_PADTMP); return CHECKOP(type, pvop); } #ifdef PERL_MAD OP* #else void #endif Perl_package(pTHX_ OP *o) { dVAR; SV *const sv = cSVOPo->op_sv; #ifdef PERL_MAD OP *pegop; #endif PERL_ARGS_ASSERT_PACKAGE; save_hptr(&PL_curstash); save_item(PL_curstname); PL_curstash = gv_stashsv(sv, GV_ADD); sv_setsv(PL_curstname, sv); PL_hints |= HINT_BLOCK_SCOPE; PL_parser->copline = NOLINE; PL_parser->expect = XSTATE; #ifndef PERL_MAD op_free(o); #else if (!PL_madskills) { op_free(o); return NULL; } pegop = newOP(OP_NULL,0); op_getmad(o,pegop,'P'); return pegop; #endif } void Perl_package_version( pTHX_ OP *v ) { dVAR; U32 savehints = PL_hints; PERL_ARGS_ASSERT_PACKAGE_VERSION; PL_hints &= ~HINT_STRICT_VARS; sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv ); PL_hints = savehints; op_free(v); } #ifdef PERL_MAD OP* #else void #endif Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) { dVAR; OP *pack; OP *imop; OP *veop; #ifdef PERL_MAD OP *pegop = newOP(OP_NULL,0); #endif PERL_ARGS_ASSERT_UTILIZE; if (idop->op_type != OP_CONST) Perl_croak(aTHX_ "Module name must be constant"); if (PL_madskills) op_getmad(idop,pegop,'U'); veop = NULL; if (version) { SV * const vesv = ((SVOP*)version)->op_sv; if (PL_madskills) op_getmad(version,pegop,'V'); if (!arg && !SvNIOKp(vesv)) { arg = version; } else { OP *pack; SV *meth; if (version->op_type != OP_CONST || !SvNIOKp(vesv)) Perl_croak(aTHX_ "Version number must be a constant number"); /* Make copy of idop so we don't free it twice */ pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); /* Fake up a method call to VERSION */ meth = newSVpvs_share("VERSION"); veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, append_elem(OP_LIST, prepend_elem(OP_LIST, pack, list(version)), newSVOP(OP_METHOD_NAMED, 0, meth))); } } /* Fake up an import/unimport */ if (arg && arg->op_type == OP_STUB) { if (PL_madskills) op_getmad(arg,pegop,'S'); imop = arg; /* no import on explicit () */ } else if (SvNIOKp(((SVOP*)idop)->op_sv)) { imop = NULL; /* use 5.0; */ if (!aver) idop->op_private |= OPpCONST_NOVER; } else { SV *meth; if (PL_madskills) op_getmad(arg,pegop,'A'); /* Make copy of idop so we don't free it twice */ pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); /* Fake up a method call to import/unimport */ meth = aver ? newSVpvs_share("import") : newSVpvs_share("unimport"); imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, append_elem(OP_LIST, prepend_elem(OP_LIST, pack, list(arg)), newSVOP(OP_METHOD_NAMED, 0, meth))); } /* Fake up the BEGIN {}, which does its thing immediately. */ newATTRSUB(floor, newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")), NULL, NULL, append_elem(OP_LINESEQ, append_elem(OP_LINESEQ, newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)), newSTATEOP(0, NULL, veop)), newSTATEOP(0, NULL, imop) )); /* The "did you use incorrect case?" warning used to be here. * The problem is that on case-insensitive filesystems one * might get false positives for "use" (and "require"): * "use Strict" or "require CARP" will work. This causes * portability problems for the script: in case-strict * filesystems the script will stop working. * * The "incorrect case" warning checked whether "use Foo" * imported "Foo" to your namespace, but that is wrong, too: * there is no requirement nor promise in the language that * a Foo.pm should or would contain anything in package "Foo". * * There is very little Configure-wise that can be done, either: * the case-sensitivity of the build filesystem of Perl does not * help in guessing the case-sensitivity of the runtime environment. */ PL_hints |= HINT_BLOCK_SCOPE; PL_parser->copline = NOLINE; PL_parser->expect = XSTATE; PL_cop_seqmax++; /* Purely for B::*'s benefit */ #ifdef PERL_MAD if (!PL_madskills) { /* FIXME - don't allocate pegop if !PL_madskills */ op_free(pegop); return NULL; } return pegop; #endif } /* =head1 Embedding Functions =for apidoc load_module Loads the module whose name is pointed to by the string part of name. Note that the actual module name, not its filename, should be given. Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS (or 0 for no flags). ver, if specified, provides version semantics similar to C. The optional trailing SV* arguments can be used to specify arguments to the module's import() method, similar to C. They must be terminated with a final NULL pointer. Note that this list can only be omitted when the PERL_LOADMOD_NOIMPORT flag has been used. Otherwise at least a single NULL pointer to designate the default import list is required. =cut */ void Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...) { va_list args; PERL_ARGS_ASSERT_LOAD_MODULE; va_start(args, ver); vload_module(flags, name, ver, &args); va_end(args); } #ifdef PERL_IMPLICIT_CONTEXT void Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...) { dTHX; va_list args; PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT; va_start(args, ver); vload_module(flags, name, ver, &args); va_end(args); } #endif void Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) { dVAR; OP *veop, *imop; OP * const modname = newSVOP(OP_CONST, 0, name); PERL_ARGS_ASSERT_VLOAD_MODULE; modname->op_private |= OPpCONST_BARE; if (ver) { veop = newSVOP(OP_CONST, 0, ver); } else veop = NULL; if (flags & PERL_LOADMOD_NOIMPORT) { imop = sawparens(newNULLLIST()); } else if (flags & PERL_LOADMOD_IMPORT_OPS) { imop = va_arg(*args, OP*); } else { SV *sv; imop = NULL; sv = va_arg(*args, SV*); while (sv) { imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); sv = va_arg(*args, SV*); } } /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure * that it has a PL_parser to play with while doing that, and also * that it doesn't mess with any existing parser, by creating a tmp * new parser with lex_start(). This won't actually be used for much, * since pp_require() will create another parser for the real work. */ ENTER; SAVEVPTR(PL_curcop); lex_start(NULL, NULL, FALSE); utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), veop, modname, imop); LEAVE; } OP * Perl_dofile(pTHX_ OP *term, I32 force_builtin) { dVAR; OP *doop; GV *gv = NULL; PERL_ARGS_ASSERT_DOFILE; if (!force_builtin) { gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV); if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) { GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE); gv = gvp ? *gvp : NULL; } } if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, term, scalar(newUNOP(OP_RV2CV, 0, newGVOP(OP_GV, 0, gv)))))); } else { doop = newUNOP(OP_DOFILE, 0, scalar(term)); } return doop; } OP * Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval) { return newBINOP(OP_LSLICE, flags, list(force_list(subscript)), list(force_list(listval)) ); } STATIC I32 S_is_list_assignment(pTHX_ register const OP *o) { unsigned type; U8 flags; if (!o) return TRUE; if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS)) o = cUNOPo->op_first; flags = o->op_flags; type = o->op_type; if (type == OP_COND_EXPR) { const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling); const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling); if (t && f) return TRUE; if (t || f) yyerror("Assignment to both a list and a scalar"); return FALSE; } if (type == OP_LIST && (flags & OPf_WANT) == OPf_WANT_SCALAR && o->op_private & OPpLVAL_INTRO) return FALSE; if (type == OP_LIST || flags & OPf_PARENS || type == OP_RV2AV || type == OP_RV2HV || type == OP_ASLICE || type == OP_HSLICE) return TRUE; if (type == OP_PADAV || type == OP_PADHV) return TRUE; if (type == OP_RV2SV) return FALSE; return FALSE; } OP * Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) { dVAR; OP *o; if (optype) { if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) { return newLOGOP(optype, 0, mod(scalar(left), optype), newUNOP(OP_SASSIGN, 0, scalar(right))); } else { return newBINOP(optype, OPf_STACKED, mod(scalar(left), optype), scalar(right)); } } if (is_list_assignment(left)) { static const char no_list_state[] = "Initialization of state variables" " in list context currently forbidden"; OP *curop; bool maybe_common_vars = TRUE; PL_modcount = 0; /* Grandfathering $[ assignment here. Bletch.*/ /* Only simple assignments like C<< ($[) = 1 >> are allowed */ PL_eval_start = (left->op_type == OP_CONST) ? right : NULL; left = mod(left, OP_AASSIGN); if (PL_eval_start) PL_eval_start = 0; else if (left->op_type == OP_CONST) { /* FIXME for MAD */ /* Result of assignment is always 1 (or we'd be dead already) */ return newSVOP(OP_CONST, 0, newSViv(1)); } curop = list(force_list(left)); o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop); o->op_private = (U8)(0 | (flags >> 8)); if ((left->op_type == OP_LIST || (left->op_type == OP_NULL && left->op_targ == OP_LIST))) { OP* lop = ((LISTOP*)left)->op_first; maybe_common_vars = FALSE; while (lop) { if (lop->op_type == OP_PADSV || lop->op_type == OP_PADAV || lop->op_type == OP_PADHV || lop->op_type == OP_PADANY) { if (!(lop->op_private & OPpLVAL_INTRO)) maybe_common_vars = TRUE; if (lop->op_private & OPpPAD_STATE) { if (left->op_private & OPpLVAL_INTRO) { /* Each variable in state($a, $b, $c) = ... */ } else { /* Each state variable in (state $a, my $b, our $c, $d, undef) = ... */ } yyerror(no_list_state); } else { /* Each my variable in (state $a, my $b, our $c, $d, undef) = ... */ } } else if (lop->op_type == OP_UNDEF || lop->op_type == OP_PUSHMARK) { /* undef may be interesting in (state $a, undef, state $c) */ } else { /* Other ops in the list. */ maybe_common_vars = TRUE; } lop = lop->op_sibling; } } else if ((left->op_private & OPpLVAL_INTRO) && ( left->op_type == OP_PADSV || left->op_type == OP_PADAV || left->op_type == OP_PADHV || left->op_type == OP_PADANY)) { if (left->op_type == OP_PADSV) maybe_common_vars = FALSE; if (left->op_private & OPpPAD_STATE) { /* All single variable list context state assignments, hence state ($a) = ... (state $a) = ... state @a = ... state (@a) = ... (state @a) = ... state %a = ... state (%a) = ... (state %a) = ... */ yyerror(no_list_state); } } /* PL_generation sorcery: * an assignment like ($a,$b) = ($c,$d) is easier than * ($a,$b) = ($c,$a), since there is no need for temporary vars. * To detect whether there are common vars, the global var * PL_generation is incremented for each assign op we compile. * Then, while compiling the assign op, we run through all the * variables on both sides of the assignment, setting a spare slot * in each of them to PL_generation. If any of them already have * that value, we know we've got commonality. We could use a * single bit marker, but then we'd have to make 2 passes, first * to clear the flag, then to test and set it. To find somewhere * to store these values, evil chicanery is done with SvUVX(). */ if (maybe_common_vars) { OP *lastop = o; PL_generation++; for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { if (PL_opargs[curop->op_type] & OA_DANGEROUS) { if (curop->op_type == OP_GV) { GV *gv = cGVOPx_gv(curop); if (gv == PL_defgv || (int)GvASSIGN_GENERATION(gv) == PL_generation) break; GvASSIGN_GENERATION_set(gv, PL_generation); } else if (curop->op_type == OP_PADSV || curop->op_type == OP_PADAV || curop->op_type == OP_PADHV || curop->op_type == OP_PADANY) { if (PAD_COMPNAME_GEN(curop->op_targ) == (STRLEN)PL_generation) break; PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation); } else if (curop->op_type == OP_RV2CV) break; else if (curop->op_type == OP_RV2SV || curop->op_type == OP_RV2AV || curop->op_type == OP_RV2HV || curop->op_type == OP_RV2GV) { if (lastop->op_type != OP_GV) /* funny deref? */ break; } else if (curop->op_type == OP_PUSHRE) { #ifdef USE_ITHREADS if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) { GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff)); if (gv == PL_defgv || (int)GvASSIGN_GENERATION(gv) == PL_generation) break; GvASSIGN_GENERATION_set(gv, PL_generation); } #else GV *const gv = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv; if (gv) { if (gv == PL_defgv || (int)GvASSIGN_GENERATION(gv) == PL_generation) break; GvASSIGN_GENERATION_set(gv, PL_generation); } #endif } else break; } lastop = curop; } if (curop != o) o->op_private |= OPpASSIGN_COMMON; } if (right && right->op_type == OP_SPLIT && !PL_madskills) { OP* tmpop = ((LISTOP*)right)->op_first; if (tmpop && (tmpop->op_type == OP_PUSHRE)) { PMOP * const pm = (PMOP*)tmpop; if (left->op_type == OP_RV2AV && !(left->op_private & OPpLVAL_INTRO) && !(o->op_private & OPpASSIGN_COMMON) ) { tmpop = ((UNOP*)left)->op_first; if (tmpop->op_type == OP_GV #ifdef USE_ITHREADS && !pm->op_pmreplrootu.op_pmtargetoff #else && !pm->op_pmreplrootu.op_pmtargetgv #endif ) { #ifdef USE_ITHREADS pm->op_pmreplrootu.op_pmtargetoff = cPADOPx(tmpop)->op_padix; cPADOPx(tmpop)->op_padix = 0; /* steal it */ #else pm->op_pmreplrootu.op_pmtargetgv = MUTABLE_GV(cSVOPx(tmpop)->op_sv); cSVOPx(tmpop)->op_sv = NULL; /* steal it */ #endif pm->op_pmflags |= PMf_ONCE; tmpop = cUNOPo->op_first; /* to list (nulled) */ tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */ tmpop->op_sibling = NULL; /* don't free split */ right->op_next = tmpop->op_next; /* fix starting loc */ op_free(o); /* blow off assign */ right->op_flags &= ~OPf_WANT; /* "I don't know and I don't care." */ return right; } } else { if (PL_modcount < RETURN_UNLIMITED_NUMBER && ((LISTOP*)right)->op_last->op_type == OP_CONST) { SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv; if (SvIOK(sv) && SvIVX(sv) == 0) sv_setiv(sv, PL_modcount+1); } } } } return o; } if (!right) right = newOP(OP_UNDEF, 0); if (right->op_type == OP_READLINE) { right->op_flags |= OPf_STACKED; return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right)); } else { PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/ o = newBINOP(OP_SASSIGN, flags, scalar(right), mod(scalar(left), OP_SASSIGN) ); if (PL_eval_start) PL_eval_start = 0; else { if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */ deprecate("assignment to $["); op_free(o); o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling))); o->op_private |= OPpCONST_ARYBASE; } } } return o; } OP * Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) { dVAR; const U32 seq = intro_my(); register COP *cop; NewOp(1101, cop, 1, COP); if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) { cop->op_type = OP_DBSTATE; cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ]; } else { cop->op_type = OP_NEXTSTATE; cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ]; } cop->op_flags = (U8)flags; CopHINTS_set(cop, PL_hints); #ifdef NATIVE_HINTS cop->op_private |= NATIVE_HINTS; #endif CopHINTS_set(&PL_compiling, CopHINTS_get(cop)); cop->op_next = (OP*)cop; cop->cop_seq = seq; /* CopARYBASE is now "virtual", in that it's stored as a flag bit in CopHINTS and a possible value in cop_hints_hash, so no need to copy it. */ cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings); cop->cop_hints_hash = PL_curcop->cop_hints_hash; if (cop->cop_hints_hash) { HINTS_REFCNT_LOCK; cop->cop_hints_hash->refcounted_he_refcnt++; HINTS_REFCNT_UNLOCK; } if (label) { cop->cop_hints_hash = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label); PL_hints |= HINT_BLOCK_SCOPE; /* It seems that we need to defer freeing this pointer, as other parts of the grammar end up wanting to copy it after this op has been created. */ SAVEFREEPV(label); } if (PL_parser && PL_parser->copline == NOLINE) CopLINE_set(cop, CopLINE(PL_curcop)); else { CopLINE_set(cop, PL_parser->copline); if (PL_parser) PL_parser->copline = NOLINE; } #ifdef USE_ITHREADS CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */ #else CopFILEGV_set(cop, CopFILEGV(PL_curcop)); #endif CopSTASH_set(cop, PL_curstash); if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) { /* this line can have a breakpoint - store the cop in IV */ AV *av = CopFILEAVx(PL_curcop); if (av) { SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE); if (svp && *svp != &PL_sv_undef ) { (void)SvIOK_on(*svp); SvIV_set(*svp, PTR2IV(cop)); } } } if (flags & OPf_SPECIAL) op_null((OP*)cop); return prepend_elem(OP_LINESEQ, (OP*)cop, o); } OP * Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other) { dVAR; PERL_ARGS_ASSERT_NEWLOGOP; return new_logop(type, flags, &first, &other); } STATIC OP * S_search_const(pTHX_ OP *o) { PERL_ARGS_ASSERT_SEARCH_CONST; switch (o->op_type) { case OP_CONST: return o; case OP_NULL: if (o->op_flags & OPf_KIDS) return search_const(cUNOPo->op_first); break; case OP_LEAVE: case OP_SCOPE: case OP_LINESEQ: { OP *kid; if (!(o->op_flags & OPf_KIDS)) return NULL; kid = cLISTOPo->op_first; do { switch (kid->op_type) { case OP_ENTER: case OP_NULL: case OP_NEXTSTATE: kid = kid->op_sibling; break; default: if (kid != cLISTOPo->op_last) return NULL; goto last; } } while (kid); if (!kid) kid = cLISTOPo->op_last; last: return search_const(kid); } } return NULL; } STATIC OP * S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) { dVAR; LOGOP *logop; OP *o; OP *first; OP *other; OP *cstop = NULL; int prepend_not = 0; PERL_ARGS_ASSERT_NEW_LOGOP; first = *firstp; other = *otherp; if (type == OP_XOR) /* Not short circuit, but here by precedence. */ return newBINOP(type, flags, scalar(first), scalar(other)); assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP); scalarboolean(first); /* optimize AND and OR ops that have NOTs as children */ if (first->op_type == OP_NOT && (first->op_flags & OPf_KIDS) && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */ || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */ && !PL_madskills) { if (type == OP_AND || type == OP_OR) { if (type == OP_AND) type = OP_OR; else type = OP_AND; op_null(first); if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */ op_null(other); prepend_not = 1; /* prepend a NOT op later */ } } } /* search for a constant op that could let us fold the test */ if ((cstop = search_const(first))) { if (cstop->op_private & OPpCONST_STRICT) no_bareword_allowed(cstop); else if ((cstop->op_private & OPpCONST_BARE)) Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional"); if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) || (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) || (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) { *firstp = NULL; if (other->op_type == OP_CONST) other->op_private |= OPpCONST_SHORTCIRCUIT; if (PL_madskills) { OP *newop = newUNOP(OP_NULL, 0, other); op_getmad(first, newop, '1'); newop->op_targ = type; /* set "was" field */ return newop; } op_free(first); if (other->op_type == OP_LEAVE) other = newUNOP(OP_NULL, OPf_SPECIAL, other); return other; } else { /* check for C, or C */ const OP *o2 = other; if ( ! (o2->op_type == OP_LIST && (( o2 = cUNOPx(o2)->op_first)) && o2->op_type == OP_PUSHMARK && (( o2 = o2->op_sibling)) ) ) o2 = other; if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV || o2->op_type == OP_PADHV) && o2->op_private & OPpLVAL_INTRO && !(o2->op_private & OPpPAD_STATE)) { Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), "Deprecated use of my() in false conditional"); } *otherp = NULL; if (first->op_type == OP_CONST) first->op_private |= OPpCONST_SHORTCIRCUIT; if (PL_madskills) { first = newUNOP(OP_NULL, 0, first); op_getmad(other, first, '2'); first->op_targ = type; /* set "was" field */ } else op_free(other); return first; } } else if ((first->op_flags & OPf_KIDS) && type != OP_DOR && ckWARN(WARN_MISC)) /* [#24076] Don't warn for err FOO. */ { const OP * const k1 = ((UNOP*)first)->op_first; const OP * const k2 = k1->op_sibling; OPCODE warnop = 0; switch (first->op_type) { case OP_NULL: if (k2 && k2->op_type == OP_READLINE && (k2->op_flags & OPf_STACKED) && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) { warnop = k2->op_type; } break; case OP_SASSIGN: if (k1->op_type == OP_READDIR || k1->op_type == OP_GLOB || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) || k1->op_type == OP_EACH) { warnop = ((k1->op_type == OP_NULL) ? (OPCODE)k1->op_targ : k1->op_type); } break; } if (warnop) { const line_t oldline = CopLINE(PL_curcop); CopLINE_set(PL_curcop, PL_parser->copline); Perl_warner(aTHX_ packWARN(WARN_MISC), "Value of %s%s can be \"0\"; test with defined()", PL_op_desc[warnop], ((warnop == OP_READLINE || warnop == OP_GLOB) ? " construct" : "() operator")); CopLINE_set(PL_curcop, oldline); } } if (!other) return first; if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN) other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */ NewOp(1101, logop, 1, LOGOP); logop->op_type = (OPCODE)type; logop->op_ppaddr = PL_ppaddr[type]; logop->op_first = first; logop->op_flags = (U8)(flags | OPf_KIDS); logop->op_other = LINKLIST(other); logop->op_private = (U8)(1 | (flags >> 8)); /* establish postfix order */ logop->op_next = LINKLIST(first); first->op_next = (OP*)logop; first->op_sibling = other; CHECKOP(type,logop); o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop); other->op_next = o; return o; } OP * Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) { dVAR; LOGOP *logop; OP *start; OP *o; OP *cstop; PERL_ARGS_ASSERT_NEWCONDOP; if (!falseop) return newLOGOP(OP_AND, 0, first, trueop); if (!trueop) return newLOGOP(OP_OR, 0, first, falseop); scalarboolean(first); if ((cstop = search_const(first))) { /* Left or right arm of the conditional? */ const bool left = SvTRUE(((SVOP*)cstop)->op_sv); OP *live = left ? trueop : falseop; OP *const dead = left ? falseop : trueop; if (cstop->op_private & OPpCONST_BARE && cstop->op_private & OPpCONST_STRICT) { no_bareword_allowed(cstop); } if (PL_madskills) { /* This is all dead code when PERL_MAD is not defined. */ live = newUNOP(OP_NULL, 0, live); op_getmad(first, live, 'C'); op_getmad(dead, live, left ? 'e' : 't'); } else { op_free(first); op_free(dead); } if (live->op_type == OP_LEAVE) live = newUNOP(OP_NULL, OPf_SPECIAL, live); return live; } NewOp(1101, logop, 1, LOGOP); logop->op_type = OP_COND_EXPR; logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR]; logop->op_first = first; logop->op_flags = (U8)(flags | OPf_KIDS); logop->op_private = (U8)(1 | (flags >> 8)); logop->op_other = LINKLIST(trueop); logop->op_next = LINKLIST(falseop); CHECKOP(OP_COND_EXPR, /* that's logop->op_type */ logop); /* establish postfix order */ start = LINKLIST(first); first->op_next = (OP*)logop; first->op_sibling = trueop; trueop->op_sibling = falseop; o = newUNOP(OP_NULL, 0, (OP*)logop); trueop->op_next = falseop->op_next = o; o->op_next = start; return o; } OP * Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) { dVAR; LOGOP *range; OP *flip; OP *flop; OP *leftstart; OP *o; PERL_ARGS_ASSERT_NEWRANGE; NewOp(1101, range, 1, LOGOP); range->op_type = OP_RANGE; range->op_ppaddr = PL_ppaddr[OP_RANGE]; range->op_first = left; range->op_flags = OPf_KIDS; leftstart = LINKLIST(left); range->op_other = LINKLIST(right); range->op_private = (U8)(1 | (flags >> 8)); left->op_sibling = right; range->op_next = (OP*)range; flip = newUNOP(OP_FLIP, flags, (OP*)range); flop = newUNOP(OP_FLOP, 0, flip); o = newUNOP(OP_NULL, 0, flop); linklist(flop); range->op_next = leftstart; left->op_next = flip; right->op_next = flop; range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY); sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV); flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY); sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV); flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0; flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0; flip->op_next = o; if (!flip->op_private || !flop->op_private) linklist(o); /* blow off optimizer unless constant */ return o; } OP * Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) { dVAR; OP* listop; OP* o; const bool once = block && block->op_flags & OPf_SPECIAL && (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL); PERL_UNUSED_ARG(debuggable); if (expr) { if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv)) return block; /* do {} while 0 does once */ if (expr->op_type == OP_READLINE || expr->op_type == OP_READDIR || expr->op_type == OP_GLOB || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) { expr = newUNOP(OP_DEFINED, 0, newASSIGNOP(0, newDEFSVOP(), 0, expr) ); } else if (expr->op_flags & OPf_KIDS) { const OP * const k1 = ((UNOP*)expr)->op_first; const OP * const k2 = k1 ? k1->op_sibling : NULL; switch (expr->op_type) { case OP_NULL: if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR) && (k2->op_flags & OPf_STACKED) && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) expr = newUNOP(OP_DEFINED, 0, expr); break; case OP_SASSIGN: if (k1 && (k1->op_type == OP_READDIR || k1->op_type == OP_GLOB || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) || k1->op_type == OP_EACH)) expr = newUNOP(OP_DEFINED, 0, expr); break; } } } /* if block is null, the next append_elem() would put UNSTACK, a scalar * op, in listop. This is wrong. [perl #27024] */ if (!block) block = newOP(OP_NULL, 0); listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0)); o = new_logop(OP_AND, 0, &expr, &listop); if (listop) ((LISTOP*)listop)->op_last->op_next = LINKLIST(o); if (once && o != listop) o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other; if (o == listop) o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */ o->op_flags |= flags; o = scope(o); o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/ return o; } OP * Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont, I32 has_my) { dVAR; OP *redo; OP *next = NULL; OP *listop; OP *o; U8 loopflags = 0; PERL_UNUSED_ARG(debuggable); if (expr) { if (expr->op_type == OP_READLINE || expr->op_type == OP_READDIR || expr->op_type == OP_GLOB || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) { expr = newUNOP(OP_DEFINED, 0, newASSIGNOP(0, newDEFSVOP(), 0, expr) ); } else if (expr->op_flags & OPf_KIDS) { const OP * const k1 = ((UNOP*)expr)->op_first; const OP * const k2 = (k1) ? k1->op_sibling : NULL; switch (expr->op_type) { case OP_NULL: if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR) && (k2->op_flags & OPf_STACKED) && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) expr = newUNOP(OP_DEFINED, 0, expr); break; case OP_SASSIGN: if (k1 && (k1->op_type == OP_READDIR || k1->op_type == OP_GLOB || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) || k1->op_type == OP_EACH)) expr = newUNOP(OP_DEFINED, 0, expr); break; } } } if (!block) block = newOP(OP_NULL, 0); else if (cont || has_my) { block = scope(block); } if (cont) { next = LINKLIST(cont); } if (expr) { OP * const unstack = newOP(OP_UNSTACK, 0); if (!next) next = unstack; cont = append_elem(OP_LINESEQ, cont, unstack); } assert(block); listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont); assert(listop); redo = LINKLIST(listop); if (expr) { PL_parser->copline = (line_t)whileline; scalar(listop); o = new_logop(OP_AND, 0, &expr, &listop); if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) { op_free(expr); /* oops, it's a while (0) */ op_free((OP*)loop); return NULL; /* listop already freed by new_logop */ } if (listop) ((LISTOP*)listop)->op_last->op_next = (o == listop ? redo : LINKLIST(o)); } else o = listop; if (!loop) { NewOp(1101,loop,1,LOOP); loop->op_type = OP_ENTERLOOP; loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP]; loop->op_private = 0; loop->op_next = (OP*)loop; } o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o); loop->op_redoop = redo; loop->op_lastop = o; o->op_private |= loopflags; if (next) loop->op_nextop = next; else loop->op_nextop = o; o->op_flags |= flags; o->op_private |= (flags >> 8); return o; } OP * Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont) { dVAR; LOOP *loop; OP *wop; PADOFFSET padoff = 0; I32 iterflags = 0; I32 iterpflags = 0; OP *madsv = NULL; PERL_ARGS_ASSERT_NEWFOROP; if (sv) { if (sv->op_type == OP_RV2SV) { /* symbol table variable */ iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */ sv->op_type = OP_RV2GV; sv->op_ppaddr = PL_ppaddr[OP_RV2GV]; /* The op_type check is needed to prevent a possible segfault * if the loop variable is undeclared and 'strict vars' is in * effect. This is illegal but is nonetheless parsed, so we * may reach this point with an OP_CONST where we're expecting * an OP_GV. */ if (cUNOPx(sv)->op_first->op_type == OP_GV && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv) iterpflags |= OPpITER_DEF; } else if (sv->op_type == OP_PADSV) { /* private variable */ iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */ padoff = sv->op_targ; if (PL_madskills) madsv = sv; else { sv->op_targ = 0; op_free(sv); } sv = NULL; } else Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]); if (padoff) { SV *const namesv = PAD_COMPNAME_SV(padoff); STRLEN len; const char *const name = SvPV_const(namesv, len); if (len == 2 && name[0] == '$' && name[1] == '_') iterpflags |= OPpITER_DEF; } } else { const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0); if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { sv = newGVOP(OP_GV, 0, PL_defgv); } else { padoff = offset; } iterpflags |= OPpITER_DEF; } if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) { expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART); iterflags |= OPf_STACKED; } else if (expr->op_type == OP_NULL && (expr->op_flags & OPf_KIDS) && ((BINOP*)expr)->op_first->op_type == OP_FLOP) { /* Basically turn for($x..$y) into the same as for($x,$y), but we * set the STACKED flag to indicate that these values are to be * treated as min/max values by 'pp_iterinit'. */ const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first; LOGOP* const range = (LOGOP*) flip->op_first; OP* const left = range->op_first; OP* const right = left->op_sibling; LISTOP* listop; range->op_flags &= ~OPf_KIDS; range->op_first = NULL; listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right); listop->op_first->op_next = range->op_next; left->op_next = range->op_other; right->op_next = (OP*)listop; listop->op_next = listop->op_first; #ifdef PERL_MAD op_getmad(expr,(OP*)listop,'O'); #else op_free(expr); #endif expr = (OP*)(listop); op_null(expr); iterflags |= OPf_STACKED; } else { expr = mod(force_list(expr), OP_GREPSTART); } loop = (LOOP*)list(convert(OP_ENTERITER, iterflags, append_elem(OP_LIST, expr, scalar(sv)))); assert(!loop->op_next); /* for my $x () sets OPpLVAL_INTRO; * for our $x () sets OPpOUR_INTRO */ loop->op_private = (U8)iterpflags; #ifdef PL_OP_SLAB_ALLOC { LOOP *tmp; NewOp(1234,tmp,1,LOOP); Copy(loop,tmp,1,LISTOP); S_op_destroy(aTHX_ (OP*)loop); loop = tmp; } #else loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP)); #endif loop->op_targ = padoff; wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0); if (madsv) op_getmad(madsv, (OP*)loop, 'v'); PL_parser->copline = forline; return newSTATEOP(0, label, wop); } OP* Perl_newLOOPEX(pTHX_ I32 type, OP *label) { dVAR; OP *o; PERL_ARGS_ASSERT_NEWLOOPEX; assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); if (type != OP_GOTO || label->op_type == OP_CONST) { /* "last()" means "last" */ if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) o = newOP(type, OPf_SPECIAL); else { o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST ? SvPV_nolen_const(((SVOP*)label)->op_sv) : "")); } #ifdef PERL_MAD op_getmad(label,o,'L'); #else op_free(label); #endif } else { /* Check whether it's going to be a goto &function */ if (label->op_type == OP_ENTERSUB && !(label->op_flags & OPf_STACKED)) label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN)); o = newUNOP(type, OPf_STACKED, label); } PL_hints |= HINT_BLOCK_SCOPE; return o; } /* if the condition is a literal array or hash (or @{ ... } etc), make a reference to it. */ STATIC OP * S_ref_array_or_hash(pTHX_ OP *cond) { if (cond && (cond->op_type == OP_RV2AV || cond->op_type == OP_PADAV || cond->op_type == OP_RV2HV || cond->op_type == OP_PADHV)) return newUNOP(OP_REFGEN, 0, mod(cond, OP_REFGEN)); else return cond; } /* These construct the optree fragments representing given() and when() blocks. entergiven and enterwhen are LOGOPs; the op_other pointer points up to the associated leave op. We need this so we can put it in the context and make break/continue work. (Also, of course, pp_enterwhen will jump straight to op_other if the match fails.) */ STATIC OP * S_newGIVWHENOP(pTHX_ OP *cond, OP *block, I32 enter_opcode, I32 leave_opcode, PADOFFSET entertarg) { dVAR; LOGOP *enterop; OP *o; PERL_ARGS_ASSERT_NEWGIVWHENOP; NewOp(1101, enterop, 1, LOGOP); enterop->op_type = (Optype)enter_opcode; enterop->op_ppaddr = PL_ppaddr[enter_opcode]; enterop->op_flags = (U8) OPf_KIDS; enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg); enterop->op_private = 0; o = newUNOP(leave_opcode, 0, (OP *) enterop); if (cond) { enterop->op_first = scalar(cond); cond->op_sibling = block; o->op_next = LINKLIST(cond); cond->op_next = (OP *) enterop; } else { /* This is a default {} block */ enterop->op_first = block; enterop->op_flags |= OPf_SPECIAL; o->op_next = (OP *) enterop; } CHECKOP(enter_opcode, enterop); /* Currently does nothing, since entergiven and enterwhen both use ck_null() */ enterop->op_next = LINKLIST(block); block->op_next = enterop->op_other = o; return o; } /* Does this look like a boolean operation? For these purposes a boolean operation is: - a subroutine call [*] - a logical connective - a comparison operator - a filetest operator, with the exception of -s -M -A -C - defined(), exists() or eof() - /$re/ or $foo =~ /$re/ [*] possibly surprising */ STATIC bool S_looks_like_bool(pTHX_ const OP *o) { dVAR; PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL; switch(o->op_type) { case OP_OR: case OP_DOR: return looks_like_bool(cLOGOPo->op_first); case OP_AND: return ( looks_like_bool(cLOGOPo->op_first) && looks_like_bool(cLOGOPo->op_first->op_sibling)); case OP_NULL: return ( o->op_flags & OPf_KIDS && looks_like_bool(cUNOPo->op_first)); case OP_SCALAR: return looks_like_bool(cUNOPo->op_first); case OP_ENTERSUB: case OP_NOT: case OP_XOR: case OP_EQ: case OP_NE: case OP_LT: case OP_GT: case OP_LE: case OP_GE: case OP_I_EQ: case OP_I_NE: case OP_I_LT: case OP_I_GT: case OP_I_LE: case OP_I_GE: case OP_SEQ: case OP_SNE: case OP_SLT: case OP_SGT: case OP_SLE: case OP_SGE: case OP_SMARTMATCH: case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC: case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC: case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED: case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR: case OP_FTBLK: case OP_FTFILE: case OP_FTDIR: case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID: case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY: case OP_FTTEXT: case OP_FTBINARY: case OP_DEFINED: case OP_EXISTS: case OP_MATCH: case OP_EOF: case OP_FLOP: return TRUE; case OP_CONST: /* Detect comparisons that have been optimized away */ if (cSVOPo->op_sv == &PL_sv_yes || cSVOPo->op_sv == &PL_sv_no) return TRUE; else return FALSE; /* FALL THROUGH */ default: return FALSE; } } OP * Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off) { dVAR; PERL_ARGS_ASSERT_NEWGIVENOP; return newGIVWHENOP( ref_array_or_hash(cond), block, OP_ENTERGIVEN, OP_LEAVEGIVEN, defsv_off); } /* If cond is null, this is a default {} block */ OP * Perl_newWHENOP(pTHX_ OP *cond, OP *block) { const bool cond_llb = (!cond || looks_like_bool(cond)); OP *cond_op; PERL_ARGS_ASSERT_NEWWHENOP; if (cond_llb) cond_op = cond; else { cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL, newDEFSVOP(), scalar(ref_array_or_hash(cond))); } return newGIVWHENOP( cond_op, append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)), OP_ENTERWHEN, OP_LEAVEWHEN, 0); } /* =for apidoc cv_undef Clear out all the active components of a CV. This can happen either by an explicit C, or by the reference count going to zero. In the former case, we keep the CvOUTSIDE pointer, so that any anonymous children can still follow the full lexical scope chain. =cut */ void Perl_cv_undef(pTHX_ CV *cv) { dVAR; PERL_ARGS_ASSERT_CV_UNDEF; DEBUG_X(PerlIO_printf(Perl_debug_log, "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n", PTR2UV(cv), PTR2UV(PL_comppad)) ); #ifdef USE_ITHREADS if (CvFILE(cv) && !CvISXSUB(cv)) { /* for XSUBs CvFILE point directly to static memory; __FILE__ */ Safefree(CvFILE(cv)); } CvFILE(cv) = NULL; #endif if (!CvISXSUB(cv) && CvROOT(cv)) { if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv)) Perl_croak(aTHX_ "Can't undef active subroutine"); ENTER; PAD_SAVE_SETNULLPAD(); op_free(CvROOT(cv)); CvROOT(cv) = NULL; CvSTART(cv) = NULL; LEAVE; } SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */ CvGV(cv) = NULL; pad_undef(cv); /* remove CvOUTSIDE unless this is an undef rather than a free */ if (!SvREFCNT(cv) && CvOUTSIDE(cv)) { if (!CvWEAKOUTSIDE(cv)) SvREFCNT_dec(CvOUTSIDE(cv)); CvOUTSIDE(cv) = NULL; } if (CvCONST(cv)) { SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr)); CvCONST_off(cv); } if (CvISXSUB(cv) && CvXSUB(cv)) { CvXSUB(cv) = NULL; } /* delete all flags except WEAKOUTSIDE */ CvFLAGS(cv) &= CVf_WEAKOUTSIDE; } void Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p, const STRLEN len) { PERL_ARGS_ASSERT_CV_CKPROTO_LEN; /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by relying on SvCUR, and doubling up the buffer to hold CvFILE(). */ if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */ || (p && (len != SvCUR(cv) /* Not the same length. */ || memNE(p, SvPVX_const(cv), len)))) && ckWARN_d(WARN_PROTOTYPE)) { SV* const msg = sv_newmortal(); SV* name = NULL; if (gv) gv_efullname3(name = sv_newmortal(), gv, NULL); sv_setpvs(msg, "Prototype mismatch:"); if (name) Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name)); if (SvPOK(cv)) Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv)); else sv_catpvs(msg, ": none"); sv_catpvs(msg, " vs "); if (p) Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p); else sv_catpvs(msg, "none"); Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg)); } } static void const_sv_xsub(pTHX_ CV* cv); /* =head1 Optree Manipulation Functions =for apidoc cv_const_sv If C is a constant sub eligible for inlining. returns the constant value returned by the sub. Otherwise, returns NULL. Constant subs can be created with C or as described in L. =cut */ SV * Perl_cv_const_sv(pTHX_ const CV *const cv) { PERL_UNUSED_CONTEXT; if (!cv) return NULL; if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM)) return NULL; return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL; } /* op_const_sv: examine an optree to determine whether it's in-lineable. * Can be called in 3 ways: * * !cv * look for a single OP_CONST with attached value: return the value * * cv && CvCLONE(cv) && !CvCONST(cv) * * examine the clone prototype, and if contains only a single * OP_CONST referencing a pad const, or a single PADSV referencing * an outer lexical, return a non-zero value to indicate the CV is * a candidate for "constizing" at clone time * * cv && CvCONST(cv) * * We have just cloned an anon prototype that was marked as a const * candidiate. Try to grab the current value, and in the case of * PADSV, ignore it if it has multiple references. Return the value. */ SV * Perl_op_const_sv(pTHX_ const OP *o, CV *cv) { dVAR; SV *sv = NULL; if (PL_madskills) return NULL; if (!o) return NULL; if (o->op_type == OP_LINESEQ && cLISTOPo->op_first) o = cLISTOPo->op_first->op_sibling; for (; o; o = o->op_next) { const OPCODE type = o->op_type; if (sv && o->op_next == o) return sv; if (o->op_next != o) { if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK) continue; if (type == OP_DBSTATE) continue; } if (type == OP_LEAVESUB || type == OP_RETURN) break; if (sv) return NULL; if (type == OP_CONST && cSVOPo->op_sv) sv = cSVOPo->op_sv; else if (cv && type == OP_CONST) { sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ); if (!sv) return NULL; } else if (cv && type == OP_PADSV) { if (CvCONST(cv)) { /* newly cloned anon */ 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 (!sv || SvREFCNT(sv) != 2) return NULL; sv = newSVsv(sv); SvREADONLY_on(sv); return sv; } else { if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE) sv = &PL_sv_undef; /* an arbitrary non-null value */ } } else { return NULL; } } return sv; } #ifdef PERL_MAD OP * #else void #endif Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) { #if 0 /* This would be the return value, but the return cannot be reached. */ OP* pegop = newOP(OP_NULL, 0); #endif PERL_UNUSED_ARG(floor); if (o) SAVEFREEOP(o); if (proto) SAVEFREEOP(proto); if (attrs) SAVEFREEOP(attrs); if (block) SAVEFREEOP(block); Perl_croak(aTHX_ "\"my sub\" not yet implemented"); #ifdef PERL_MAD NORETURN_FUNCTION_END; #endif } CV * Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block) { return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block); } CV * Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) { dVAR; GV *gv; const char *ps; STRLEN ps_len; register CV *cv = NULL; SV *const_sv; /* If the subroutine has no body, no attributes, and no builtin attributes then it's just a sub declaration, and we may be able to get away with storing with a placeholder scalar in the symbol table, rather than a full GV and CV. If anything is present then it will take a full CV to store it. */ const I32 gv_fetch_flags = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS) || PL_madskills) ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT; const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL; bool has_name; if (proto) { assert(proto->op_type == OP_CONST); ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len); } else ps = NULL; if (name) { gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV); has_name = TRUE; } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) { SV * const sv = sv_newmortal(); Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]", PL_curstash ? "__ANON__" : "__ANON__::__ANON__", CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV); has_name = TRUE; } else if (PL_curstash) { gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV); has_name = FALSE; } else { gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV); has_name = FALSE; } if (!PL_madskills) { if (o) SAVEFREEOP(o); if (proto) SAVEFREEOP(proto); if (attrs) SAVEFREEOP(attrs); } if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at maximum a prototype before. */ if (SvTYPE(gv) > SVt_NULL) { if (!SvPOK((const SV *)gv) && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1)) { Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype"); } cv_ckproto_len((const CV *)gv, NULL, ps, ps_len); } if (ps) sv_setpvn(MUTABLE_SV(gv), ps, ps_len); else sv_setiv(MUTABLE_SV(gv), -1); SvREFCNT_dec(PL_compcv); cv = PL_compcv = NULL; goto done; } cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv); if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS) #ifdef PERL_MAD || block->op_type == OP_NULL #endif ) const_sv = NULL; else const_sv = op_const_sv(block, NULL); if (cv) { const bool exists = CvROOT(cv) || CvXSUB(cv); /* if the subroutine doesn't exist and wasn't pre-declared * with a prototype, assume it will be AUTOLOADed, * skipping the prototype check */ if (exists || SvPOK(cv)) cv_ckproto_len(cv, gv, ps, ps_len); /* already defined (or promised)? */ if (exists || GvASSUMECV(gv)) { if ((!block #ifdef PERL_MAD || block->op_type == OP_NULL #endif )&& !attrs) { if (CvFLAGS(PL_compcv)) { /* might have had built-in attrs applied */ if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && ckWARN(WARN_MISC)) Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined"); CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS & ~CVf_LVALUE); } /* just a "sub foo;" when &foo is already defined */ SAVEFREESV(PL_compcv); goto done; } if (block #ifdef PERL_MAD && block->op_type != OP_NULL #endif ) { if (ckWARN(WARN_REDEFINE) || (CvCONST(cv) && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv)))) { const line_t oldline = CopLINE(PL_curcop); if (PL_parser && PL_parser->copline != NOLINE) CopLINE_set(PL_curcop, PL_parser->copline); Perl_warner(aTHX_ packWARN(WARN_REDEFINE), CvCONST(cv) ? "Constant subroutine %s redefined" : "Subroutine %s redefined", name); CopLINE_set(PL_curcop, oldline); } #ifdef PERL_MAD if (!PL_minus_c) /* keep old one around for madskills */ #endif { /* (PL_madskills unset in used file.) */ SvREFCNT_dec(cv); } cv = NULL; } } } if (const_sv) { SvREFCNT_inc_simple_void_NN(const_sv); if (cv) { assert(!CvROOT(cv) && !CvCONST(cv)); sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */ CvXSUBANY(cv).any_ptr = const_sv; CvXSUB(cv) = const_sv_xsub; CvCONST_on(cv); CvISXSUB_on(cv); } else { GvCV(gv) = NULL; cv = newCONSTSUB(NULL, name, const_sv); } mro_method_changed_in( /* sub Foo::Bar () { 123 } */ (CvGV(cv) && GvSTASH(CvGV(cv))) ? GvSTASH(CvGV(cv)) : CvSTASH(cv) ? CvSTASH(cv) : PL_curstash ); if (PL_madskills) goto install_block; op_free(block); SvREFCNT_dec(PL_compcv); PL_compcv = NULL; goto done; } if (cv) { /* must reuse cv if autoloaded */ /* transfer PL_compcv to cv */ if (block #ifdef PERL_MAD && block->op_type != OP_NULL #endif ) { cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS; cv_undef(cv); CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs; if (!CvWEAKOUTSIDE(cv)) SvREFCNT_dec(CvOUTSIDE(cv)); CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv); CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv); CvOUTSIDE(PL_compcv) = 0; CvPADLIST(cv) = CvPADLIST(PL_compcv); CvPADLIST(PL_compcv) = 0; /* inner references to PL_compcv must be fixed up ... */ pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv); if (PERLDB_INTER)/* Advice debugger on the new sub. */ ++PL_sub_generation; } else { /* Might have had built-in attributes applied -- propagate them. */ CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS); } /* ... before we throw it away */ SvREFCNT_dec(PL_compcv); PL_compcv = cv; } else { cv = PL_compcv; if (name) { GvCV(gv) = cv; if (PL_madskills) { if (strEQ(name, "import")) { PL_formfeed = MUTABLE_SV(cv); /* diag_listed_as: SKIPME */ Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv)); } } GvCVGEN(gv) = 0; mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */ } } if (!CvGV(cv)) { CvGV(cv) = gv; CvFILE_set_from_cop(cv, PL_curcop); CvSTASH(cv) = PL_curstash; } if (attrs) { /* Need to do a C. */ HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash; apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE); } if (ps) sv_setpvn(MUTABLE_SV(cv), ps, ps_len); if (PL_parser && PL_parser->error_count) { op_free(block); block = NULL; if (name) { const char *s = strrchr(name, ':'); s = s ? s+1 : name; if (strEQ(s, "BEGIN")) { const char not_safe[] = "BEGIN not safe after errors--compilation aborted"; if (PL_in_eval & EVAL_KEEPERR) Perl_croak(aTHX_ not_safe); else { /* force display of errors found but not reported */ sv_catpv(ERRSV, not_safe); Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV)); } } } } install_block: if (!block) goto done; /* If we assign an optree to a PVCV, then we've defined a subroutine that the debugger could be able to set a breakpoint in, so signal to pp_entereval that it should not throw away any saved lines at scope exit. */ PL_breakable_sub_gen++; if (CvLVALUE(cv)) { CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, mod(scalarseq(block), OP_LEAVESUBLV)); block->op_attached = 1; } else { /* This makes sub {}; work as expected. */ if (block->op_type == OP_STUB) { OP* const newblock = newSTATEOP(0, NULL, 0); #ifdef PERL_MAD op_getmad(block,newblock,'B'); #else op_free(block); #endif block = newblock; } else block->op_attached = 1; CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block)); } CvROOT(cv)->op_private |= OPpREFCOUNTED; OpREFCNT_set(CvROOT(cv), 1); CvSTART(cv) = LINKLIST(CvROOT(cv)); CvROOT(cv)->op_next = 0; CALL_PEEP(CvSTART(cv)); /* now that optimizer has done its work, adjust pad values */ pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB); if (CvCLONE(cv)) { assert(!CvCONST(cv)); if (ps && !*ps && op_const_sv(block, cv)) CvCONST_on(cv); } if (has_name) { if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { SV * const sv = newSV(0); SV * const tmpstr = sv_newmortal(); GV * const db_postponed = gv_fetchpvs("DB::postponed", GV_ADDMULTI, SVt_PVHV); HV *hv; Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld", CopFILE(PL_curcop), (long)PL_subline, (long)CopLINE(PL_curcop)); gv_efullname3(tmpstr, gv, NULL); (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0); hv = GvHVn(db_postponed); if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) { CV * const pcv = GvCV(db_postponed); if (pcv) { dSP; PUSHMARK(SP); XPUSHs(tmpstr); PUTBACK; call_sv(MUTABLE_SV(pcv), G_DISCARD); } } } if (name && ! (PL_parser && PL_parser->error_count)) process_special_blocks(name, gv, cv); } done: if (PL_parser) PL_parser->copline = NOLINE; LEAVE_SCOPE(floor); return cv; } STATIC void S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv, CV *const cv) { const char *const colon = strrchr(fullname,':'); const char *const name = colon ? colon + 1 : fullname; PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS; if (*name == 'B') { if (strEQ(name, "BEGIN")) { const I32 oldscope = PL_scopestack_ix; ENTER; SAVECOPFILE(&PL_compiling); SAVECOPLINE(&PL_compiling); DEBUG_x( dump_sub(gv) ); Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv)); GvCV(gv) = 0; /* cv has been hijacked */ call_list(oldscope, PL_beginav); PL_curcop = &PL_compiling; CopHINTS_set(&PL_compiling, PL_hints); LEAVE; } else return; } else { if (*name == 'E') { if strEQ(name, "END") { DEBUG_x( dump_sub(gv) ); Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv)); } else return; } else if (*name == 'U') { if (strEQ(name, "UNITCHECK")) { /* It's never too late to run a unitcheck block */ Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv)); } else return; } else if (*name == 'C') { if (strEQ(name, "CHECK")) { if (PL_main_start) Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block"); Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv)); } else return; } else if (*name == 'I') { if (strEQ(name, "INIT")) { if (PL_main_start) Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block"); Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv)); } else return; } else return; DEBUG_x( dump_sub(gv) ); GvCV(gv) = 0; /* cv has been hijacked */ } } /* =for apidoc newCONSTSUB Creates a constant sub equivalent to Perl C which is eligible for inlining at compile-time. Passing NULL for SV creates a constant sub equivalent to C, which won't be called if used as a destructor, but will suppress the overhead of a call to C. (This form, however, isn't eligible for inlining at compile time.) =cut */ CV * Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv) { dVAR; CV* cv; #ifdef USE_ITHREADS const char *const file = CopFILE(PL_curcop); #else SV *const temp_sv = CopFILESV(PL_curcop); const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL; #endif ENTER; if (IN_PERL_RUNTIME) { /* at runtime, it's not safe to manipulate PL_curcop: it may be * an op shared between threads. Use a non-shared COP for our * dirty work */ SAVEVPTR(PL_curcop); PL_curcop = &PL_compiling; } SAVECOPLINE(PL_curcop); CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE); SAVEHINTS(); PL_hints &= ~HINT_BLOCK_SCOPE; if (stash) { SAVESPTR(PL_curstash); SAVECOPSTASH(PL_curcop); PL_curstash = stash; CopSTASH_set(PL_curcop,stash); } /* file becomes the CvFILE. For an XS, it's supposed to be static storage, and so doesn't get free()d. (It's expected to be from the C pre- processor __FILE__ directive). But we need a dynamically allocated one, and we need it to get freed. */ cv = newXS_flags(name, const_sv_xsub, file ? file : "", "", XS_DYNAMIC_FILENAME); CvXSUBANY(cv).any_ptr = sv; CvCONST_on(cv); #ifdef USE_ITHREADS if (stash) CopSTASH_free(PL_curcop); #endif LEAVE; return cv; } CV * Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr, const char *const filename, const char *const proto, U32 flags) { CV *cv = newXS(name, subaddr, filename); PERL_ARGS_ASSERT_NEWXS_FLAGS; if (flags & XS_DYNAMIC_FILENAME) { /* We need to "make arrangements" (ie cheat) to ensure that the filename lasts as long as the PVCV we just created, but also doesn't leak */ STRLEN filename_len = strlen(filename); STRLEN proto_and_file_len = filename_len; char *proto_and_file; STRLEN proto_len; if (proto) { proto_len = strlen(proto); proto_and_file_len += proto_len; Newx(proto_and_file, proto_and_file_len + 1, char); Copy(proto, proto_and_file, proto_len, char); Copy(filename, proto_and_file + proto_len, filename_len + 1, char); } else { proto_len = 0; proto_and_file = savepvn(filename, filename_len); } /* This gets free()d. :-) */ sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len, SV_HAS_TRAILING_NUL); if (proto) { /* This gives us the correct prototype, rather than one with the file name appended. */ SvCUR_set(cv, proto_len); } else { SvPOK_off(cv); } CvFILE(cv) = proto_and_file + proto_len; } else { sv_setpv(MUTABLE_SV(cv), proto); } return cv; } /* =for apidoc U||newXS Used by C to hook up XSUBs as Perl subs. I needs to be static storage, as it is used directly as CvFILE(), without a copy being made. =cut */ CV * Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename) { dVAR; GV * const gv = gv_fetchpv(name ? name : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"), GV_ADDMULTI, SVt_PVCV); register CV *cv; PERL_ARGS_ASSERT_NEWXS; if (!subaddr) Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename); if ((cv = (name ? GvCV(gv) : NULL))) { if (GvCVGEN(gv)) { /* just a cached method */ SvREFCNT_dec(cv); cv = NULL; } else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) { /* already defined (or promised) */ /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */ if (ckWARN(WARN_REDEFINE)) { GV * const gvcv = CvGV(cv); if (gvcv) { HV * const stash = GvSTASH(gvcv); if (stash) { const char *redefined_name = HvNAME_get(stash); if ( strEQ(redefined_name,"autouse") ) { const line_t oldline = CopLINE(PL_curcop); if (PL_parser && PL_parser->copline != NOLINE) CopLINE_set(PL_curcop, PL_parser->copline); Perl_warner(aTHX_ packWARN(WARN_REDEFINE), CvCONST(cv) ? "Constant subroutine %s redefined" : "Subroutine %s redefined" ,name); CopLINE_set(PL_curcop, oldline); } } } } SvREFCNT_dec(cv); cv = NULL; } } if (cv) /* must reuse cv if autoloaded */ cv_undef(cv); else { cv = MUTABLE_CV(newSV_type(SVt_PVCV)); if (name) { GvCV(gv) = cv; GvCVGEN(gv) = 0; mro_method_changed_in(GvSTASH(gv)); /* newXS */ } } CvGV(cv) = gv; (void)gv_fetchfile(filename); CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be an external constant string */ CvISXSUB_on(cv); CvXSUB(cv) = subaddr; if (name) process_special_blocks(name, gv, cv); else CvANON_on(cv); return cv; } #ifdef PERL_MAD OP * #else void #endif Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) { dVAR; register CV *cv; #ifdef PERL_MAD OP* pegop = newOP(OP_NULL, 0); #endif GV * const gv = o ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM) : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM); GvMULTI_on(gv); if ((cv = GvFORM(gv))) { if (ckWARN(WARN_REDEFINE)) { const line_t oldline = CopLINE(PL_curcop); if (PL_parser && PL_parser->copline != NOLINE) CopLINE_set(PL_curcop, PL_parser->copline); if (o) { Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv)); } else { Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format STDOUT redefined"); } CopLINE_set(PL_curcop, oldline); } SvREFCNT_dec(cv); } cv = PL_compcv; GvFORM(gv) = cv; CvGV(cv) = gv; CvFILE_set_from_cop(cv, PL_curcop); pad_tidy(padtidy_FORMAT); CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block)); CvROOT(cv)->op_private |= OPpREFCOUNTED; OpREFCNT_set(CvROOT(cv), 1); CvSTART(cv) = LINKLIST(CvROOT(cv)); CvROOT(cv)->op_next = 0; CALL_PEEP(CvSTART(cv)); #ifdef PERL_MAD op_getmad(o,pegop,'n'); op_getmad_weak(block, pegop, 'b'); #else op_free(o); #endif if (PL_parser) PL_parser->copline = NOLINE; LEAVE_SCOPE(floor); #ifdef PERL_MAD return pegop; #endif } OP * Perl_newANONLIST(pTHX_ OP *o) { return convert(OP_ANONLIST, OPf_SPECIAL, o); } OP * Perl_newANONHASH(pTHX_ OP *o) { return convert(OP_ANONHASH, OPf_SPECIAL, o); } OP * Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block) { return newANONATTRSUB(floor, proto, NULL, block); } OP * Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block) { return newUNOP(OP_REFGEN, 0, newSVOP(OP_ANONCODE, 0, MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block)))); } OP * Perl_oopsAV(pTHX_ OP *o) { dVAR; PERL_ARGS_ASSERT_OOPSAV; switch (o->op_type) { case OP_PADSV: o->op_type = OP_PADAV; o->op_ppaddr = PL_ppaddr[OP_PADAV]; return ref(o, OP_RV2AV); case OP_RV2SV: o->op_type = OP_RV2AV; o->op_ppaddr = PL_ppaddr[OP_RV2AV]; ref(o, OP_RV2AV); break; default: Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV"); break; } return o; } OP * Perl_oopsHV(pTHX_ OP *o) { dVAR; PERL_ARGS_ASSERT_OOPSHV; switch (o->op_type) { case OP_PADSV: case OP_PADAV: o->op_type = OP_PADHV; o->op_ppaddr = PL_ppaddr[OP_PADHV]; return ref(o, OP_RV2HV); case OP_RV2SV: case OP_RV2AV: o->op_type = OP_RV2HV; o->op_ppaddr = PL_ppaddr[OP_RV2HV]; ref(o, OP_RV2HV); break; default: Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV"); break; } return o; } OP * Perl_newAVREF(pTHX_ OP *o) { dVAR; PERL_ARGS_ASSERT_NEWAVREF; if (o->op_type == OP_PADANY) { o->op_type = OP_PADAV; o->op_ppaddr = PL_ppaddr[OP_PADAV]; return o; } else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) { Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), "Using an array as a reference is deprecated"); } return newUNOP(OP_RV2AV, 0, scalar(o)); } OP * Perl_newGVREF(pTHX_ I32 type, OP *o) { if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT) return newUNOP(OP_NULL, 0, o); return ref(newUNOP(OP_RV2GV, OPf_REF, o), type); } OP * Perl_newHVREF(pTHX_ OP *o) { dVAR; PERL_ARGS_ASSERT_NEWHVREF; if (o->op_type == OP_PADANY) { o->op_type = OP_PADHV; o->op_ppaddr = PL_ppaddr[OP_PADHV]; return o; } else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) { Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), "Using a hash as a reference is deprecated"); } return newUNOP(OP_RV2HV, 0, scalar(o)); } OP * Perl_newCVREF(pTHX_ I32 flags, OP *o) { return newUNOP(OP_RV2CV, flags, scalar(o)); } OP * Perl_newSVREF(pTHX_ OP *o) { dVAR; PERL_ARGS_ASSERT_NEWSVREF; if (o->op_type == OP_PADANY) { o->op_type = OP_PADSV; o->op_ppaddr = PL_ppaddr[OP_PADSV]; return o; } return newUNOP(OP_RV2SV, 0, scalar(o)); } /* Check routines. See the comments at the top of this file for details * on when these are called */ OP * Perl_ck_anoncode(pTHX_ OP *o) { PERL_ARGS_ASSERT_CK_ANONCODE; cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type); if (!PL_madskills) cSVOPo->op_sv = NULL; return o; } OP * Perl_ck_bitop(pTHX_ OP *o) { dVAR; PERL_ARGS_ASSERT_CK_BITOP; #define OP_IS_NUMCOMPARE(op) \ ((op) == OP_LT || (op) == OP_I_LT || \ (op) == OP_GT || (op) == OP_I_GT || \ (op) == OP_LE || (op) == OP_I_LE || \ (op) == OP_GE || (op) == OP_I_GE || \ (op) == OP_EQ || (op) == OP_I_EQ || \ (op) == OP_NE || (op) == OP_I_NE || \ (op) == OP_NCMP || (op) == OP_I_NCMP) o->op_private = (U8)(PL_hints & HINT_INTEGER); if (!(o->op_flags & OPf_STACKED) /* Not an assignment */ && (o->op_type == OP_BIT_OR || o->op_type == OP_BIT_AND || o->op_type == OP_BIT_XOR)) { const OP * const left = cBINOPo->op_first; const OP * const right = left->op_sibling; if ((OP_IS_NUMCOMPARE(left->op_type) && (left->op_flags & OPf_PARENS) == 0) || (OP_IS_NUMCOMPARE(right->op_type) && (right->op_flags & OPf_PARENS) == 0)) Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE), "Possible precedence problem on bitwise %c operator", o->op_type == OP_BIT_OR ? '|' : o->op_type == OP_BIT_AND ? '&' : '^' ); } return o; } OP * Perl_ck_concat(pTHX_ OP *o) { const OP * const kid = cUNOPo->op_first; PERL_ARGS_ASSERT_CK_CONCAT; PERL_UNUSED_CONTEXT; if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) && !(kUNOP->op_first->op_flags & OPf_MOD)) o->op_flags |= OPf_STACKED; return o; } OP * Perl_ck_spair(pTHX_ OP *o) { dVAR; PERL_ARGS_ASSERT_CK_SPAIR; if (o->op_flags & OPf_KIDS) { OP* newop; OP* kid; const OPCODE type = o->op_type; o = modkids(ck_fun(o), type); kid = cUNOPo->op_first; newop = kUNOP->op_first->op_sibling; if (newop) { const OPCODE type = newop->op_type; if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) || type == OP_PADAV || type == OP_PADHV || type == OP_RV2AV || type == OP_RV2HV) return o; } #ifdef PERL_MAD op_getmad(kUNOP->op_first,newop,'K'); #else op_free(kUNOP->op_first); #endif kUNOP->op_first = newop; } o->op_ppaddr = PL_ppaddr[++o->op_type]; return ck_fun(o); } OP * Perl_ck_delete(pTHX_ OP *o) { PERL_ARGS_ASSERT_CK_DELETE; o = ck_fun(o); o->op_private = 0; if (o->op_flags & OPf_KIDS) { OP * const kid = cUNOPo->op_first; switch (kid->op_type) { case OP_ASLICE: o->op_flags |= OPf_SPECIAL; /* FALL THROUGH */ case OP_HSLICE: o->op_private |= OPpSLICE; break; case OP_AELEM: o->op_flags |= OPf_SPECIAL; /* FALL THROUGH */ case OP_HELEM: break; default: Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice", OP_DESC(o)); } if (kid->op_private & OPpLVAL_INTRO) o->op_private |= OPpLVAL_INTRO; op_null(kid); } return o; } OP * Perl_ck_die(pTHX_ OP *o) { PERL_ARGS_ASSERT_CK_DIE; #ifdef VMS if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH; #endif return ck_fun(o); } OP * Perl_ck_eof(pTHX_ OP *o) { dVAR; PERL_ARGS_ASSERT_CK_EOF; if (o->op_flags & OPf_KIDS) { if (cLISTOPo->op_first->op_type == OP_STUB) { OP * const newop = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv)); #ifdef PERL_MAD op_getmad(o,newop,'O'); #else op_free(o); #endif o = newop; } return ck_fun(o); } return o; } OP * Perl_ck_eval(pTHX_ OP *o) { dVAR; PERL_ARGS_ASSERT_CK_EVAL; PL_hints |= HINT_BLOCK_SCOPE; if (o->op_flags & OPf_KIDS) { SVOP * const kid = (SVOP*)cUNOPo->op_first; if (!kid) { o->op_flags &= ~OPf_KIDS; op_null(o); } else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) { LOGOP *enter; #ifdef PERL_MAD OP* const oldo = o; #endif cUNOPo->op_first = 0; #ifndef PERL_MAD op_free(o); #endif NewOp(1101, enter, 1, LOGOP); enter->op_type = OP_ENTERTRY; enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY]; enter->op_private = 0; /* establish postfix order */ enter->op_next = (OP*)enter; o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid); o->op_type = OP_LEAVETRY; o->op_ppaddr = PL_ppaddr[OP_LEAVETRY]; enter->op_other = o; op_getmad(oldo,o,'O'); return o; } else { scalar((OP*)kid); PL_cv_has_eval = 1; } } else { #ifdef PERL_MAD OP* const oldo = o; #else op_free(o); #endif o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP()); op_getmad(oldo,o,'O'); } o->op_targ = (PADOFFSET)PL_hints; if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) { /* Store a copy of %^H that pp_entereval can pick up. */ OP *hhop = newSVOP(OP_HINTSEVAL, 0, MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)))); cUNOPo->op_first->op_sibling = hhop; o->op_private |= OPpEVAL_HAS_HH; } return o; } OP * Perl_ck_exit(pTHX_ OP *o) { PERL_ARGS_ASSERT_CK_EXIT; #ifdef VMS HV * const table = GvHV(PL_hintgv); if (table) { SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE); if (svp && *svp && SvTRUE(*svp)) o->op_private |= OPpEXIT_VMSISH; } if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH; #endif return ck_fun(o); } OP * Perl_ck_exec(pTHX_ OP *o) { PERL_ARGS_ASSERT_CK_EXEC; if (o->op_flags & OPf_STACKED) { OP *kid; o = ck_fun(o); kid = cUNOPo->op_first->op_sibling; if (kid->op_type == OP_RV2GV) op_null(kid); } else o = listkids(o); return o; } OP * Perl_ck_exists(pTHX_ OP *o) { dVAR; PERL_ARGS_ASSERT_CK_EXISTS; o = ck_fun(o); if (o->op_flags & OPf_KIDS) { OP * const kid = cUNOPo->op_first; if (kid->op_type == OP_ENTERSUB) { (void) ref(kid, o->op_type); if (kid->op_type != OP_RV2CV && !(PL_parser && PL_parser->error_count)) Perl_croak(aTHX_ "%s argument is not a subroutine name", OP_DESC(o)); o->op_private |= OPpEXISTS_SUB; } else if (kid->op_type == OP_AELEM) o->op_flags |= OPf_SPECIAL; else if (kid->op_type != OP_HELEM) Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine", OP_DESC(o)); op_null(kid); } return o; } OP * Perl_ck_rvconst(pTHX_ register OP *o) { dVAR; SVOP * const kid = (SVOP*)cUNOPo->op_first; PERL_ARGS_ASSERT_CK_RVCONST; o->op_private |= (PL_hints & HINT_STRICT_REFS); if (o->op_type == OP_RV2CV) o->op_private &= ~1; if (kid->op_type == OP_CONST) { int iscv; GV *gv; SV * const kidsv = kid->op_sv; /* Is it a constant from cv_const_sv()? */ if (SvROK(kidsv) && SvREADONLY(kidsv)) { SV * const rsv = SvRV(kidsv); const svtype type = SvTYPE(rsv); const char *badtype = NULL; switch (o->op_type) { case OP_RV2SV: if (type > SVt_PVMG) badtype = "a SCALAR"; break; case OP_RV2AV: if (type != SVt_PVAV) badtype = "an ARRAY"; break; case OP_RV2HV: if (type != SVt_PVHV) badtype = "a HASH"; break; case OP_RV2CV: if (type != SVt_PVCV) badtype = "a CODE"; break; } if (badtype) Perl_croak(aTHX_ "Constant is not %s reference", badtype); return o; } else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) && (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) { /* If this is an access to a stash, disable "strict refs", because * stashes aren't auto-vivified at compile-time (unless we store * symbols in them), and we don't want to produce a run-time * stricture error when auto-vivifying the stash. */ const char *s = SvPV_nolen(kidsv); const STRLEN l = SvCUR(kidsv); if (l > 1 && s[l-1] == ':' && s[l-2] == ':') o->op_private &= ~HINT_STRICT_REFS; } if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) { const char *badthing; switch (o->op_type) { case OP_RV2SV: badthing = "a SCALAR"; break; case OP_RV2AV: badthing = "an ARRAY"; break; case OP_RV2HV: badthing = "a HASH"; break; default: badthing = NULL; break; } if (badthing) Perl_croak(aTHX_ "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use", SVfARG(kidsv), badthing); } /* * This is a little tricky. We only want to add the symbol if we * didn't add it in the lexer. Otherwise we get duplicate strict * warnings. But if we didn't add it in the lexer, we must at * least pretend like we wanted to add it even if it existed before, * or we get possible typo warnings. OPpCONST_ENTERED says * whether the lexer already added THIS instance of this symbol. */ iscv = (o->op_type == OP_RV2CV) * 2; do { gv = gv_fetchsv(kidsv, iscv | !(kid->op_private & OPpCONST_ENTERED), iscv ? SVt_PVCV : o->op_type == OP_RV2SV ? SVt_PV : o->op_type == OP_RV2AV ? SVt_PVAV : o->op_type == OP_RV2HV ? SVt_PVHV : SVt_PVGV); } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++); if (gv) { kid->op_type = OP_GV; SvREFCNT_dec(kid->op_sv); #ifdef USE_ITHREADS /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */ kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP); SvREFCNT_dec(PAD_SVl(kPADOP->op_padix)); GvIN_PAD_on(gv); PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv))); #else kid->op_sv = SvREFCNT_inc_simple_NN(gv); #endif kid->op_private = 0; kid->op_ppaddr = PL_ppaddr[OP_GV]; } } return o; } OP * Perl_ck_ftst(pTHX_ OP *o) { dVAR; const I32 type = o->op_type; PERL_ARGS_ASSERT_CK_FTST; if (o->op_flags & OPf_REF) { NOOP; } else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) { SVOP * const kid = (SVOP*)cUNOPo->op_first; const OPCODE kidtype = kid->op_type; if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) { OP * const newop = newGVOP(type, OPf_REF, gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO)); #ifdef PERL_MAD op_getmad(o,newop,'O'); #else op_free(o); #endif return newop; } if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type)) o->op_private |= OPpFT_ACCESS; if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst) && kidtype != OP_STAT && kidtype != OP_LSTAT) o->op_private |= OPpFT_STACKED; } else { #ifdef PERL_MAD OP* const oldo = o; #else op_free(o); #endif if (type == OP_FTTTY) o = newGVOP(type, OPf_REF, PL_stdingv); else o = newUNOP(type, 0, newDEFSVOP()); op_getmad(oldo,o,'O'); } return o; } OP * Perl_ck_fun(pTHX_ OP *o) { dVAR; const int type = o->op_type; register I32 oa = PL_opargs[type] >> OASHIFT; PERL_ARGS_ASSERT_CK_FUN; if (o->op_flags & OPf_STACKED) { if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL)) oa &= ~OA_OPTIONAL; else return no_fh_allowed(o); } if (o->op_flags & OPf_KIDS) { OP **tokid = &cLISTOPo->op_first; register OP *kid = cLISTOPo->op_first; OP *sibl; I32 numargs = 0; if (kid->op_type == OP_PUSHMARK || (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK)) { tokid = &kid->op_sibling; kid = kid->op_sibling; } if (!kid && PL_opargs[type] & OA_DEFGV) *tokid = kid = newDEFSVOP(); while (oa && kid) { numargs++; sibl = kid->op_sibling; #ifdef PERL_MAD if (!sibl && kid->op_type == OP_STUB) { numargs--; break; } #endif switch (oa & 7) { case OA_SCALAR: /* list seen where single (scalar) arg expected? */ if (numargs == 1 && !(oa >> 4) && kid->op_type == OP_LIST && type != OP_SCALAR) { return too_many_arguments(o,PL_op_desc[type]); } scalar(kid); break; case OA_LIST: if (oa < 16) { kid = 0; continue; } else list(kid); break; case OA_AVREF: if ((type == OP_PUSH || type == OP_UNSHIFT) && !kid->op_sibling) Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Useless use of %s with no values", PL_op_desc[type]); if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { OP * const newop = newAVREF(newGVOP(OP_GV, 0, gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) )); Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), "Array @%"SVf" missing the @ in argument %"IVdf" of %s()", SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]); #ifdef PERL_MAD op_getmad(kid,newop,'K'); #else op_free(kid); #endif kid = newop; kid->op_sibling = sibl; *tokid = kid; } else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) bad_type(numargs, "array", PL_op_desc[type], kid); mod(kid, type); break; case OA_HVREF: if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { OP * const newop = newHVREF(newGVOP(OP_GV, 0, gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) )); Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()", SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]); #ifdef PERL_MAD op_getmad(kid,newop,'K'); #else op_free(kid); #endif kid = newop; kid->op_sibling = sibl; *tokid = kid; } else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV) bad_type(numargs, "hash", PL_op_desc[type], kid); mod(kid, type); break; case OA_CVREF: { OP * const newop = newUNOP(OP_NULL, 0, kid); kid->op_sibling = 0; linklist(kid); newop->op_next = newop; kid = newop; kid->op_sibling = sibl; *tokid = kid; } break; case OA_FILEREF: if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) { if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { OP * const newop = newGVOP(OP_GV, 0, gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO)); if (!(o->op_private & 1) && /* if not unop */ kid == cLISTOPo->op_last) cLISTOPo->op_last = newop; #ifdef PERL_MAD op_getmad(kid,newop,'K'); #else op_free(kid); #endif kid = newop; } else if (kid->op_type == OP_READLINE) { /* neophyte patrol: open(), close() etc. */ bad_type(numargs, "HANDLE", OP_DESC(o), kid); } else { I32 flags = OPf_SPECIAL; I32 priv = 0; PADOFFSET targ = 0; /* is this op a FH constructor? */ if (is_handle_constructor(o,numargs)) { const char *name = NULL; STRLEN len = 0; flags = 0; /* Set a flag to tell rv2gv to vivify * need to "prove" flag does not mean something * else already - NI-S 1999/05/07 */ priv = OPpDEREF; if (kid->op_type == OP_PADSV) { SV *const namesv = PAD_COMPNAME_SV(kid->op_targ); name = SvPV_const(namesv, len); } else if (kid->op_type == OP_RV2SV && kUNOP->op_first->op_type == OP_GV) { GV * const gv = cGVOPx_gv(kUNOP->op_first); name = GvNAME(gv); len = GvNAMELEN(gv); } else if (kid->op_type == OP_AELEM || kid->op_type == OP_HELEM) { OP *firstop; OP *op = ((BINOP*)kid)->op_first; name = NULL; if (op) { SV *tmpstr = NULL; const char * const a = kid->op_type == OP_AELEM ? "[]" : "{}"; if (((op->op_type == OP_RV2AV) || (op->op_type == OP_RV2HV)) && (firstop = ((UNOP*)op)->op_first) && (firstop->op_type == OP_GV)) { /* packagevar $a[] or $h{} */ GV * const gv = cGVOPx_gv(firstop); if (gv) tmpstr = Perl_newSVpvf(aTHX_ "%s%c...%c", GvNAME(gv), a[0], a[1]); } else if (op->op_type == OP_PADAV || op->op_type == OP_PADHV) { /* lexicalvar $a[] or $h{} */ const char * const padname = PAD_COMPNAME_PV(op->op_targ); if (padname) tmpstr = Perl_newSVpvf(aTHX_ "%s%c...%c", padname + 1, a[0], a[1]); } if (tmpstr) { name = SvPV_const(tmpstr, len); sv_2mortal(tmpstr); } } if (!name) { name = "__ANONIO__"; len = 10; } mod(kid, type); } if (name) { SV *namesv; targ = pad_alloc(OP_RV2GV, SVs_PADTMP); namesv = PAD_SVl(targ); SvUPGRADE(namesv, SVt_PV); if (*name != '$') sv_setpvs(namesv, "$"); sv_catpvn(namesv, name, len); } } kid->op_sibling = 0; kid = newUNOP(OP_RV2GV, flags, scalar(kid)); kid->op_targ = targ; kid->op_private |= priv; } kid->op_sibling = sibl; *tokid = kid; } scalar(kid); break; case OA_SCALARREF: mod(scalar(kid), type); break; } oa >>= 4; tokid = &kid->op_sibling; kid = kid->op_sibling; } #ifdef PERL_MAD if (kid && kid->op_type != OP_STUB) return too_many_arguments(o,OP_DESC(o)); o->op_private |= numargs; #else /* FIXME - should the numargs move as for the PERL_MAD case? */ o->op_private |= numargs; if (kid) return too_many_arguments(o,OP_DESC(o)); #endif listkids(o); } else if (PL_opargs[type] & OA_DEFGV) { #ifdef PERL_MAD OP *newop = newUNOP(type, 0, newDEFSVOP()); op_getmad(o,newop,'O'); return newop; #else /* Ordering of these two is important to keep f_map.t passing. */ op_free(o); return newUNOP(type, 0, newDEFSVOP()); #endif } if (oa) { while (oa & OA_OPTIONAL) oa >>= 4; if (oa && oa != OA_LIST) return too_few_arguments(o,OP_DESC(o)); } return o; } OP * Perl_ck_glob(pTHX_ OP *o) { dVAR; GV *gv; PERL_ARGS_ASSERT_CK_GLOB; o = ck_fun(o); if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling) append_elem(OP_GLOB, o, newDEFSVOP()); if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV)) && GvCVu(gv) && GvIMPORTED_CV(gv))) { gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV); } #if !defined(PERL_EXTERNAL_GLOB) /* XXX this can be tightened up and made more failsafe. */ if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) { GV *glob_gv; ENTER; Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvs("File::Glob"), NULL, NULL, NULL); gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV); glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV); GvCV(gv) = GvCV(glob_gv); SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv))); GvIMPORTED_CV_on(gv); LEAVE; } #endif /* PERL_EXTERNAL_GLOB */ if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { append_elem(OP_GLOB, o, newSVOP(OP_CONST, 0, newSViv(PL_glob_index++))); o->op_type = OP_LIST; o->op_ppaddr = PL_ppaddr[OP_LIST]; cLISTOPo->op_first->op_type = OP_PUSHMARK; cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK]; cLISTOPo->op_first->op_targ = 0; o = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, o, scalar(newUNOP(OP_RV2CV, 0, newGVOP(OP_GV, 0, gv))))); o = newUNOP(OP_NULL, 0, ck_subr(o)); o->op_targ = OP_GLOB; /* hint at what it used to be */ return o; } gv = newGVgen("main"); gv_IOadd(gv); append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv)); scalarkids(o); return o; } OP * Perl_ck_grep(pTHX_ OP *o) { dVAR; LOGOP *gwop = NULL; OP *kid; const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE; PADOFFSET offset; PERL_ARGS_ASSERT_CK_GREP; o->op_ppaddr = PL_ppaddr[OP_GREPSTART]; /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */ if (o->op_flags & OPf_STACKED) { OP* k; o = ck_sort(o); kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first; if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE) return no_fh_allowed(o); for (k = kid; k; k = k->op_next) { kid = k; } NewOp(1101, gwop, 1, LOGOP); kid->op_next = (OP*)gwop; o->op_flags &= ~OPf_STACKED; } kid = cLISTOPo->op_first->op_sibling; if (type == OP_MAPWHILE) list(kid); else scalar(kid); o = ck_fun(o); if (PL_parser && PL_parser->error_count) return o; kid = cLISTOPo->op_first->op_sibling; if (kid->op_type != OP_NULL) Perl_croak(aTHX_ "panic: ck_grep"); kid = kUNOP->op_first; if (!gwop) NewOp(1101, gwop, 1, LOGOP); gwop->op_type = type; gwop->op_ppaddr = PL_ppaddr[type]; gwop->op_first = listkids(o); gwop->op_flags |= OPf_KIDS; gwop->op_other = LINKLIST(kid); kid->op_next = (OP*)gwop; offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0); if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { o->op_private = gwop->op_private = 0; gwop->op_targ = pad_alloc(type, SVs_PADTMP); } else { o->op_private = gwop->op_private = OPpGREP_LEX; gwop->op_targ = o->op_targ = offset; } kid = cLISTOPo->op_first->op_sibling; if (!kid || !kid->op_sibling) return too_few_arguments(o,OP_DESC(o)); for (kid = kid->op_sibling; kid; kid = kid->op_sibling) mod(kid, OP_GREPSTART); return (OP*)gwop; } OP * Perl_ck_index(pTHX_ OP *o) { PERL_ARGS_ASSERT_CK_INDEX; if (o->op_flags & OPf_KIDS) { OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ if (kid) kid = kid->op_sibling; /* get past "big" */ if (kid && kid->op_type == OP_CONST) fbm_compile(((SVOP*)kid)->op_sv, 0); } return ck_fun(o); } OP * Perl_ck_lfun(pTHX_ OP *o) { const OPCODE type = o->op_type; PERL_ARGS_ASSERT_CK_LFUN; return modkids(ck_fun(o), type); } OP * Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ { PERL_ARGS_ASSERT_CK_DEFINED; if ((o->op_flags & OPf_KIDS)) { switch (cUNOPo->op_first->op_type) { case OP_RV2AV: /* This is needed for if (defined %stash::) to work. Do not break Tk. */ break; /* Globals via GV can be undef */ case OP_PADAV: case OP_AASSIGN: /* Is this a good idea? */ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), "defined(@array) is deprecated"); Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), "\t(Maybe you should just omit the defined()?)\n"); break; case OP_RV2HV: case OP_PADHV: Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), "defined(%%hash) is deprecated"); Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), "\t(Maybe you should just omit the defined()?)\n"); break; default: /* no warning */ break; } } return ck_rfun(o); } OP * Perl_ck_readline(pTHX_ OP *o) { PERL_ARGS_ASSERT_CK_READLINE; if (!(o->op_flags & OPf_KIDS)) { OP * const newop = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv)); #ifdef PERL_MAD op_getmad(o,newop,'O'); #else op_free(o); #endif return newop; } return o; } OP * Perl_ck_rfun(pTHX_ OP *o) { const OPCODE type = o->op_type; PERL_ARGS_ASSERT_CK_RFUN; return refkids(ck_fun(o), type); } OP * Perl_ck_listiob(pTHX_ OP *o) { register OP *kid; PERL_ARGS_ASSERT_CK_LISTIOB; kid = cLISTOPo->op_first; if (!kid) { o = force_list(o); kid = cLISTOPo->op_first; } if (kid->op_type == OP_PUSHMARK) kid = kid->op_sibling; if (kid && o->op_flags & OPf_STACKED) kid = kid->op_sibling; else if (kid && !kid->op_sibling) { /* print HANDLE; */ if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) { o->op_flags |= OPf_STACKED; /* make it a filehandle */ kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid)); cLISTOPo->op_first->op_sibling = kid; cLISTOPo->op_last = kid; kid = kid->op_sibling; } } if (!kid) append_elem(o->op_type, o, newDEFSVOP()); return listkids(o); } OP * Perl_ck_smartmatch(pTHX_ OP *o) { dVAR; if (0 == (o->op_flags & OPf_SPECIAL)) { OP *first = cBINOPo->op_first; OP *second = first->op_sibling; /* Implicitly take a reference to an array or hash */ first->op_sibling = NULL; first = cBINOPo->op_first = ref_array_or_hash(first); second = first->op_sibling = ref_array_or_hash(second); /* Implicitly take a reference to a regular expression */ if (first->op_type == OP_MATCH) { first->op_type = OP_QR; first->op_ppaddr = PL_ppaddr[OP_QR]; } if (second->op_type == OP_MATCH) { second->op_type = OP_QR; second->op_ppaddr = PL_ppaddr[OP_QR]; } } return o; } OP * Perl_ck_sassign(pTHX_ OP *o) { dVAR; OP * const kid = cLISTOPo->op_first; PERL_ARGS_ASSERT_CK_SASSIGN; /* has a disposable target? */ if ((PL_opargs[kid->op_type] & OA_TARGLEX) && !(kid->op_flags & OPf_STACKED) /* Cannot steal the second time! */ && !(kid->op_private & OPpTARGET_MY) /* Keep the full thing for madskills */ && !PL_madskills ) { OP * const kkid = kid->op_sibling; /* Can just relocate the target. */ if (kkid && kkid->op_type == OP_PADSV && !(kkid->op_private & OPpLVAL_INTRO)) { kid->op_targ = kkid->op_targ; kkid->op_targ = 0; /* Now we do not need PADSV and SASSIGN. */ kid->op_sibling = o->op_sibling; /* NULL */ cLISTOPo->op_first = NULL; op_free(o); op_free(kkid); kid->op_private |= OPpTARGET_MY; /* Used for context settings */ return kid; } } if (kid->op_sibling) { OP *kkid = kid->op_sibling; if (kkid->op_type == OP_PADSV && (kkid->op_private & OPpLVAL_INTRO) && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) { const PADOFFSET target = kkid->op_targ; OP *const other = newOP(OP_PADSV, kkid->op_flags | ((kkid->op_private & ~OPpLVAL_INTRO) << 8)); OP *const first = newOP(OP_NULL, 0); OP *const nullop = newCONDOP(0, first, o, other); OP *const condop = first->op_next; /* hijacking PADSTALE for uninitialized state variables */ SvPADSTALE_on(PAD_SVl(target)); condop->op_type = OP_ONCE; condop->op_ppaddr = PL_ppaddr[OP_ONCE]; condop->op_targ = target; other->op_targ = target; /* Because we change the type of the op here, we will skip the assinment binop->op_last = binop->op_first->op_sibling; at the end of Perl_newBINOP(). So need to do it here. */ cBINOPo->op_last = cBINOPo->op_first->op_sibling; return nullop; } } return o; } OP * Perl_ck_match(pTHX_ OP *o) { dVAR; PERL_ARGS_ASSERT_CK_MATCH; if (o->op_type != OP_QR && PL_compcv) { const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0); if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) { o->op_targ = offset; o->op_private |= OPpTARGET_MY; } } if (o->op_type == OP_MATCH || o->op_type == OP_QR) o->op_private |= OPpRUNTIME; return o; } OP * Perl_ck_method(pTHX_ OP *o) { OP * const kid = cUNOPo->op_first; PERL_ARGS_ASSERT_CK_METHOD; if (kid->op_type == OP_CONST) { SV* sv = kSVOP->op_sv; const char * const method = SvPVX_const(sv); if (!(strchr(method, ':') || strchr(method, '\''))) { OP *cmop; if (!SvREADONLY(sv) || !SvFAKE(sv)) { sv = newSVpvn_share(method, SvCUR(sv), 0); } else { kSVOP->op_sv = NULL; } cmop = newSVOP(OP_METHOD_NAMED, 0, sv); #ifdef PERL_MAD op_getmad(o,cmop,'O'); #else op_free(o); #endif return cmop; } } return o; } OP * Perl_ck_null(pTHX_ OP *o) { PERL_ARGS_ASSERT_CK_NULL; PERL_UNUSED_CONTEXT; return o; } OP * Perl_ck_open(pTHX_ OP *o) { dVAR; HV * const table = GvHV(PL_hintgv); PERL_ARGS_ASSERT_CK_OPEN; if (table) { SV **svp = hv_fetchs(table, "open_IN", FALSE); if (svp && *svp) { STRLEN len = 0; const char *d = SvPV_const(*svp, len); const I32 mode = mode_from_discipline(d, len); if (mode & O_BINARY) o->op_private |= OPpOPEN_IN_RAW; else if (mode & O_TEXT) o->op_private |= OPpOPEN_IN_CRLF; } svp = hv_fetchs(table, "open_OUT", FALSE); if (svp && *svp) { STRLEN len = 0; const char *d = SvPV_const(*svp, len); const I32 mode = mode_from_discipline(d, len); if (mode & O_BINARY) o->op_private |= OPpOPEN_OUT_RAW; else if (mode & O_TEXT) o->op_private |= OPpOPEN_OUT_CRLF; } } if (o->op_type == OP_BACKTICK) { if (!(o->op_flags & OPf_KIDS)) { OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP()); #ifdef PERL_MAD op_getmad(o,newop,'O'); #else op_free(o); #endif return newop; } return o; } { /* In case of three-arg dup open remove strictness * from the last arg if it is a bareword. */ OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */ OP * const last = cLISTOPx(o)->op_last; /* The bareword. */ OP *oa; const char *mode; if ((last->op_type == OP_CONST) && /* The bareword. */ (last->op_private & OPpCONST_BARE) && (last->op_private & OPpCONST_STRICT) && (oa = first->op_sibling) && /* The fh. */ (oa = oa->op_sibling) && /* The mode. */ (oa->op_type == OP_CONST) && SvPOK(((SVOP*)oa)->op_sv) && (mode = SvPVX_const(((SVOP*)oa)->op_sv)) && mode[0] == '>' && mode[1] == '&' && /* A dup open. */ (last == oa->op_sibling)) /* The bareword. */ last->op_private &= ~OPpCONST_STRICT; } return ck_fun(o); } OP * Perl_ck_repeat(pTHX_ OP *o) { PERL_ARGS_ASSERT_CK_REPEAT; if (cBINOPo->op_first->op_flags & OPf_PARENS) { o->op_private |= OPpREPEAT_DOLIST; cBINOPo->op_first = force_list(cBINOPo->op_first); } else scalar(o); return o; } OP * Perl_ck_require(pTHX_ OP *o) { dVAR; GV* gv = NULL; PERL_ARGS_ASSERT_CK_REQUIRE; if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */ SVOP * const kid = (SVOP*)cUNOPo->op_first; if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { SV * const sv = kid->op_sv; U32 was_readonly = SvREADONLY(sv); char *s; STRLEN len; const char *end; if (was_readonly) { if (SvFAKE(sv)) { sv_force_normal_flags(sv, 0); assert(!SvREADONLY(sv)); was_readonly = 0; } else { SvREADONLY_off(sv); } } s = SvPVX(sv); len = SvCUR(sv); end = s + len; for (; s < end; s++) { if (*s == ':' && s[1] == ':') { *s = '/'; Move(s+2, s+1, end - s - 1, char); --end; } } SvEND_set(sv, end); sv_catpvs(sv, ".pm"); SvFLAGS(sv) |= was_readonly; } } if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */ /* handle override, if any */ gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV); if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) { GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE); gv = gvp ? *gvp : NULL; } } if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { OP * const kid = cUNOPo->op_first; OP * newop; cUNOPo->op_first = 0; #ifndef PERL_MAD op_free(o); #endif newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, kid, scalar(newUNOP(OP_RV2CV, 0, newGVOP(OP_GV, 0, gv)))))); op_getmad(o,newop,'O'); return newop; } return scalar(ck_fun(o)); } OP * Perl_ck_return(pTHX_ OP *o) { dVAR; OP *kid; PERL_ARGS_ASSERT_CK_RETURN; kid = cLISTOPo->op_first->op_sibling; if (CvLVALUE(PL_compcv)) { for (; kid; kid = kid->op_sibling) mod(kid, OP_LEAVESUBLV); } else { for (; kid; kid = kid->op_sibling) if ((kid->op_type == OP_NULL) && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) { /* This is a do block */ OP *op = kUNOP->op_first; if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) { op = cUNOPx(op)->op_first; assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL)); /* Force the use of the caller's context */ op->op_flags |= OPf_SPECIAL; } } } return o; } OP * Perl_ck_select(pTHX_ OP *o) { dVAR; OP* kid; PERL_ARGS_ASSERT_CK_SELECT; if (o->op_flags & OPf_KIDS) { kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ if (kid && kid->op_sibling) { o->op_type = OP_SSELECT; o->op_ppaddr = PL_ppaddr[OP_SSELECT]; o = ck_fun(o); return fold_constants(o); } } o = ck_fun(o); kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ if (kid && kid->op_type == OP_RV2GV) kid->op_private &= ~HINT_STRICT_REFS; return o; } OP * Perl_ck_shift(pTHX_ OP *o) { dVAR; const I32 type = o->op_type; PERL_ARGS_ASSERT_CK_SHIFT; if (!(o->op_flags & OPf_KIDS)) { OP *argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv))); #ifdef PERL_MAD OP * const oldo = o; o = newUNOP(type, 0, scalar(argop)); op_getmad(oldo,o,'O'); return o; #else op_free(o); return newUNOP(type, 0, scalar(argop)); #endif } return scalar(modkids(ck_fun(o), type)); } OP * Perl_ck_sort(pTHX_ OP *o) { dVAR; OP *firstkid; PERL_ARGS_ASSERT_CK_SORT; if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) { HV * const hinthv = GvHV(PL_hintgv); if (hinthv) { SV ** const svp = hv_fetchs(hinthv, "sort", FALSE); if (svp) { const I32 sorthints = (I32)SvIV(*svp); if ((sorthints & HINT_SORT_QUICKSORT) != 0) o->op_private |= OPpSORT_QSORT; if ((sorthints & HINT_SORT_STABLE) != 0) o->op_private |= OPpSORT_STABLE; } } } if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED) simplify_sort(o); firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ if (o->op_flags & OPf_STACKED) { /* may have been cleared */ OP *k = NULL; OP *kid = cUNOPx(firstkid)->op_first; /* get past null */ if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) { linklist(kid); if (kid->op_type == OP_SCOPE) { k = kid->op_next; kid->op_next = 0; } else if (kid->op_type == OP_LEAVE) { if (o->op_type == OP_SORT) { op_null(kid); /* wipe out leave */ kid->op_next = kid; for (k = kLISTOP->op_first->op_next; k; k = k->op_next) { if (k->op_next == kid) k->op_next = 0; /* don't descend into loops */ else if (k->op_type == OP_ENTERLOOP || k->op_type == OP_ENTERITER) { k = cLOOPx(k)->op_lastop; } } } else kid->op_next = 0; /* just disconnect the leave */ k = kLISTOP->op_first; } CALL_PEEP(k); kid = firstkid; if (o->op_type == OP_SORT) { /* provide scalar context for comparison function/block */ kid = scalar(kid); kid->op_next = kid; } else kid->op_next = k; o->op_flags |= OPf_SPECIAL; } else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV) op_null(firstkid); firstkid = firstkid->op_sibling; } /* provide list context for arguments */ if (o->op_type == OP_SORT) list(firstkid); return o; } STATIC void S_simplify_sort(pTHX_ OP *o) { dVAR; register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ OP *k; int descending; GV *gv; const char *gvname; PERL_ARGS_ASSERT_SIMPLIFY_SORT; if (!(o->op_flags & OPf_STACKED)) return; GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV)); GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV)); kid = kUNOP->op_first; /* get past null */ if (kid->op_type != OP_SCOPE) return; kid = kLISTOP->op_last; /* get past scope */ switch(kid->op_type) { case OP_NCMP: case OP_I_NCMP: case OP_SCMP: break; default: return; } k = kid; /* remember this node*/ if (kBINOP->op_first->op_type != OP_RV2SV) return; kid = kBINOP->op_first; /* get past cmp */ if (kUNOP->op_first->op_type != OP_GV) return; kid = kUNOP->op_first; /* get past rv2sv */ gv = kGVOP_gv; if (GvSTASH(gv) != PL_curstash) return; gvname = GvNAME(gv); if (*gvname == 'a' && gvname[1] == '\0') descending = 0; else if (*gvname == 'b' && gvname[1] == '\0') descending = 1; else return; kid = k; /* back to cmp */ if (kBINOP->op_last->op_type != OP_RV2SV) return; kid = kBINOP->op_last; /* down to 2nd arg */ if (kUNOP->op_first->op_type != OP_GV) return; kid = kUNOP->op_first; /* get past rv2sv */ gv = kGVOP_gv; if (GvSTASH(gv) != PL_curstash) return; gvname = GvNAME(gv); if ( descending ? !(*gvname == 'a' && gvname[1] == '\0') : !(*gvname == 'b' && gvname[1] == '\0')) return; o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL); if (descending) o->op_private |= OPpSORT_DESCEND; if (k->op_type == OP_NCMP) o->op_private |= OPpSORT_NUMERIC; if (k->op_type == OP_I_NCMP) o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER; kid = cLISTOPo->op_first->op_sibling; cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */ #ifdef PERL_MAD op_getmad(kid,o,'S'); /* then delete it */ #else op_free(kid); /* then delete it */ #endif } OP * Perl_ck_split(pTHX_ OP *o) { dVAR; register OP *kid; PERL_ARGS_ASSERT_CK_SPLIT; if (o->op_flags & OPf_STACKED) return no_fh_allowed(o); kid = cLISTOPo->op_first; if (kid->op_type != OP_NULL) Perl_croak(aTHX_ "panic: ck_split"); kid = kid->op_sibling; op_free(cLISTOPo->op_first); cLISTOPo->op_first = kid; if (!kid) { cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" ")); cLISTOPo->op_last = kid; /* There was only one element previously */ } if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) { OP * const sibl = kid->op_sibling; kid->op_sibling = 0; kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0); if (cLISTOPo->op_first == cLISTOPo->op_last) cLISTOPo->op_last = kid; cLISTOPo->op_first = kid; kid->op_sibling = sibl; } kid->op_type = OP_PUSHRE; kid->op_ppaddr = PL_ppaddr[OP_PUSHRE]; scalar(kid); if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) { Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /g modifier is meaningless in split"); } if (!kid->op_sibling) append_elem(OP_SPLIT, o, newDEFSVOP()); kid = kid->op_sibling; scalar(kid); if (!kid->op_sibling) append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0))); assert(kid->op_sibling); kid = kid->op_sibling; scalar(kid); if (kid->op_sibling) return too_many_arguments(o,OP_DESC(o)); return o; } OP * Perl_ck_join(pTHX_ OP *o) { const OP * const kid = cLISTOPo->op_first->op_sibling; PERL_ARGS_ASSERT_CK_JOIN; if (kid && kid->op_type == OP_MATCH) { if (ckWARN(WARN_SYNTAX)) { const REGEXP *re = PM_GETRE(kPMOP); const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING"; const STRLEN len = re ? RX_PRELEN(re) : 6; Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "/%.*s/ should probably be written as \"%.*s\"", (int)len, pmstr, (int)len, pmstr); } } return ck_fun(o); } OP * Perl_ck_subr(pTHX_ OP *o) { dVAR; OP *prev = ((cUNOPo->op_first->op_sibling) ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first; OP *o2 = prev->op_sibling; OP *cvop; const char *proto = NULL; const char *proto_end = NULL; CV *cv = NULL; GV *namegv = NULL; int optional = 0; I32 arg = 0; I32 contextclass = 0; const char *e = NULL; bool delete_op = 0; PERL_ARGS_ASSERT_CK_SUBR; o->op_private |= OPpENTERSUB_HASTARG; for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ; if (cvop->op_type == OP_RV2CV) { o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER); op_null(cvop); /* disable rv2cv */ if (!(o->op_private & OPpENTERSUB_AMPER)) { SVOP *tmpop = (SVOP*)((UNOP*)cvop)->op_first; GV *gv = NULL; switch (tmpop->op_type) { case OP_GV: { gv = cGVOPx_gv(tmpop); cv = GvCVu(gv); if (!cv) tmpop->op_private |= OPpEARLY_CV; } break; case OP_CONST: { SV *sv = cSVOPx_sv(tmpop); if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) cv = (CV*)SvRV(sv); } break; } if (cv && SvPOK(cv)) { STRLEN len; namegv = gv && CvANON(cv) ? gv : CvGV(cv); proto = SvPV(MUTABLE_SV(cv), len); proto_end = proto + len; } } } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) { if (o2->op_type == OP_CONST) o2->op_private &= ~OPpCONST_STRICT; else if (o2->op_type == OP_LIST) { OP * const sib = ((UNOP*)o2)->op_first->op_sibling; if (sib && sib->op_type == OP_CONST) sib->op_private &= ~OPpCONST_STRICT; } } o->op_private |= (PL_hints & HINT_STRICT_REFS); if (PERLDB_SUB && PL_curstash != PL_debstash) o->op_private |= OPpENTERSUB_DB; while (o2 != cvop) { OP* o3; if (PL_madskills && o2->op_type == OP_STUB) { o2 = o2->op_sibling; continue; } if (PL_madskills && o2->op_type == OP_NULL) o3 = ((UNOP*)o2)->op_first; else o3 = o2; if (proto) { if (proto >= proto_end) return too_many_arguments(o, gv_ename(namegv)); switch (*proto) { case ';': optional = 1; proto++; continue; case '_': /* _ must be at the end */ if (proto[1] && proto[1] != ';') goto oops; case '$': proto++; arg++; scalar(o2); break; case '%': case '@': list(o2); arg++; break; case '&': proto++; arg++; if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF) bad_type(arg, arg == 1 ? "block or sub {}" : "sub {}", gv_ename(namegv), o3); break; case '*': /* '*' allows any scalar type, including bareword */ proto++; arg++; if (o3->op_type == OP_RV2GV) goto wrapref; /* autoconvert GLOB -> GLOBref */ else if (o3->op_type == OP_CONST) o3->op_private &= ~OPpCONST_STRICT; else if (o3->op_type == OP_ENTERSUB) { /* accidental subroutine, revert to bareword */ OP *gvop = ((UNOP*)o3)->op_first; if (gvop && gvop->op_type == OP_NULL) { gvop = ((UNOP*)gvop)->op_first; if (gvop) { for (; gvop->op_sibling; gvop = gvop->op_sibling) ; if (gvop && (gvop->op_private & OPpENTERSUB_NOPAREN) && (gvop = ((UNOP*)gvop)->op_first) && gvop->op_type == OP_GV) { GV * const gv = cGVOPx_gv(gvop); OP * const sibling = o2->op_sibling; SV * const n = newSVpvs(""); #ifdef PERL_MAD OP * const oldo2 = o2; #else op_free(o2); #endif gv_fullname4(n, gv, "", FALSE); o2 = newSVOP(OP_CONST, 0, n); op_getmad(oldo2,o2,'O'); prev->op_sibling = o2; o2->op_sibling = sibling; } } } } scalar(o2); break; case '[': case ']': goto oops; break; case '\\': proto++; arg++; again: switch (*proto++) { case '[': if (contextclass++ == 0) { e = strchr(proto, ']'); if (!e || e == proto) goto oops; } else goto oops; goto again; break; case ']': if (contextclass) { const char *p = proto; const char *const end = proto; contextclass = 0; while (*--p != '[') {} bad_type(arg, Perl_form(aTHX_ "one of %.*s", (int)(end - p), p), gv_ename(namegv), o3); } else goto oops; break; case '*': if (o3->op_type == OP_RV2GV) goto wrapref; if (!contextclass) bad_type(arg, "symbol", gv_ename(namegv), o3); break; case '&': if (o3->op_type == OP_ENTERSUB) goto wrapref; if (!contextclass) bad_type(arg, "subroutine entry", gv_ename(namegv), o3); break; case '$': if (o3->op_type == OP_RV2SV || o3->op_type == OP_PADSV || o3->op_type == OP_HELEM || o3->op_type == OP_AELEM) goto wrapref; if (!contextclass) bad_type(arg, "scalar", gv_ename(namegv), o3); break; case '@': if (o3->op_type == OP_RV2AV || o3->op_type == OP_PADAV) goto wrapref; if (!contextclass) bad_type(arg, "array", gv_ename(namegv), o3); break; case '%': if (o3->op_type == OP_RV2HV || o3->op_type == OP_PADHV) goto wrapref; if (!contextclass) bad_type(arg, "hash", gv_ename(namegv), o3); break; wrapref: { OP* const kid = o2; OP* const sib = kid->op_sibling; kid->op_sibling = 0; o2 = newUNOP(OP_REFGEN, 0, kid); o2->op_sibling = sib; prev->op_sibling = o2; } if (contextclass && e) { proto = e + 1; contextclass = 0; } break; default: goto oops; } if (contextclass) goto again; break; case ' ': proto++; continue; default: oops: Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf, gv_ename(namegv), SVfARG(cv)); } } else list(o2); mod(o2, OP_ENTERSUB); prev = o2; o2 = o2->op_sibling; } /* while */ if (o2 == cvop && proto && *proto == '_') { /* generate an access to $_ */ o2 = newDEFSVOP(); o2->op_sibling = prev->op_sibling; prev->op_sibling = o2; /* instead of cvop */ } if (proto && !optional && proto_end > proto && (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_')) return too_few_arguments(o, gv_ename(namegv)); if(delete_op) { #ifdef PERL_MAD OP * const oldo = o; #else op_free(o); #endif o=newSVOP(OP_CONST, 0, newSViv(0)); op_getmad(oldo,o,'O'); } return o; } OP * Perl_ck_svconst(pTHX_ OP *o) { PERL_ARGS_ASSERT_CK_SVCONST; PERL_UNUSED_CONTEXT; SvREADONLY_on(cSVOPo->op_sv); return o; } OP * Perl_ck_chdir(pTHX_ OP *o) { if (o->op_flags & OPf_KIDS) { SVOP * const kid = (SVOP*)cUNOPo->op_first; if (kid && kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { o->op_flags |= OPf_SPECIAL; kid->op_private &= ~OPpCONST_STRICT; } } return ck_fun(o); } OP * Perl_ck_trunc(pTHX_ OP *o) { PERL_ARGS_ASSERT_CK_TRUNC; if (o->op_flags & OPf_KIDS) { SVOP *kid = (SVOP*)cUNOPo->op_first; if (kid->op_type == OP_NULL) kid = (SVOP*)kid->op_sibling; if (kid && kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { o->op_flags |= OPf_SPECIAL; kid->op_private &= ~OPpCONST_STRICT; } } return ck_fun(o); } OP * Perl_ck_unpack(pTHX_ OP *o) { OP *kid = cLISTOPo->op_first; PERL_ARGS_ASSERT_CK_UNPACK; if (kid->op_sibling) { kid = kid->op_sibling; if (!kid->op_sibling) kid->op_sibling = newDEFSVOP(); } return ck_fun(o); } OP * Perl_ck_substr(pTHX_ OP *o) { PERL_ARGS_ASSERT_CK_SUBSTR; o = ck_fun(o); if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) { OP *kid = cLISTOPo->op_first; if (kid->op_type == OP_NULL) kid = kid->op_sibling; if (kid) kid->op_flags |= OPf_MOD; } return o; } OP * Perl_ck_each(pTHX_ OP *o) { dVAR; OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL; PERL_ARGS_ASSERT_CK_EACH; if (kid) { if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) { const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES; o->op_type = new_type; o->op_ppaddr = PL_ppaddr[new_type]; } else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) )) { bad_type(1, "hash or array", PL_op_desc[o->op_type], kid); return o; } } return ck_fun(o); } /* caller is supposed to assign the return to the container of the rep_op var */ STATIC OP * S_opt_scalarhv(pTHX_ OP *rep_op) { dVAR; UNOP *unop; PERL_ARGS_ASSERT_OPT_SCALARHV; NewOp(1101, unop, 1, UNOP); unop->op_type = (OPCODE)OP_BOOLKEYS; unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS]; unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS ); unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8)); unop->op_first = rep_op; unop->op_next = rep_op->op_next; rep_op->op_next = (OP*)unop; rep_op->op_flags|=(OPf_REF | OPf_MOD); unop->op_sibling = rep_op->op_sibling; rep_op->op_sibling = NULL; /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */ if (rep_op->op_type == OP_PADHV) { rep_op->op_flags &= ~OPf_WANT_SCALAR; rep_op->op_flags |= OPf_WANT_LIST; } return (OP*)unop; } /* Checks if o acts as an in-place operator on an array. oright points to the * beginning of the right-hand side. Returns the left-hand side of the * assignment if o acts in-place, or NULL otherwise. */ STATIC OP * S_is_inplace_av(pTHX_ OP *o, OP *oright) { OP *o2; OP *oleft = NULL; PERL_ARGS_ASSERT_IS_INPLACE_AV; if (!oright || (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV) || oright->op_next != o || (oright->op_private & OPpLVAL_INTRO) ) return NULL; /* o2 follows the chain of op_nexts through the LHS of the * assign (if any) to the aassign op itself */ o2 = o->op_next; if (!o2 || o2->op_type != OP_NULL) return NULL; o2 = o2->op_next; if (!o2 || o2->op_type != OP_PUSHMARK) return NULL; o2 = o2->op_next; if (o2 && o2->op_type == OP_GV) o2 = o2->op_next; if (!o2 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV) || (o2->op_private & OPpLVAL_INTRO) ) return NULL; oleft = o2; o2 = o2->op_next; if (!o2 || o2->op_type != OP_NULL) return NULL; o2 = o2->op_next; if (!o2 || o2->op_type != OP_AASSIGN || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID) return NULL; /* check that the sort is the first arg on RHS of assign */ o2 = cUNOPx(o2)->op_first; if (!o2 || o2->op_type != OP_NULL) return NULL; o2 = cUNOPx(o2)->op_first; if (!o2 || o2->op_type != OP_PUSHMARK) return NULL; if (o2->op_sibling != o) return NULL; /* check the array is the same on both sides */ if (oleft->op_type == OP_RV2AV) { if (oright->op_type != OP_RV2AV || !cUNOPx(oright)->op_first || cUNOPx(oright)->op_first->op_type != OP_GV || cGVOPx_gv(cUNOPx(oleft)->op_first) != cGVOPx_gv(cUNOPx(oright)->op_first) ) return NULL; } else if (oright->op_type != OP_PADAV || oright->op_targ != oleft->op_targ ) return NULL; return oleft; } /* A peephole optimizer. We visit the ops in the order they're to execute. * See the comments at the top of this file for more details about when * peep() is called */ void Perl_peep(pTHX_ register OP *o) { dVAR; register OP* oldop = NULL; if (!o || o->op_opt) return; ENTER; SAVEOP(); SAVEVPTR(PL_curcop); for (; o; o = o->op_next) { if (o->op_opt) break; /* By default, this op has now been optimised. A couple of cases below clear this again. */ o->op_opt = 1; PL_op = o; switch (o->op_type) { case OP_NEXTSTATE: case OP_DBSTATE: PL_curcop = ((COP*)o); /* for warnings */ break; case OP_CONST: if (cSVOPo->op_private & OPpCONST_STRICT) no_bareword_allowed(o); #ifdef USE_ITHREADS case OP_HINTSEVAL: case OP_METHOD_NAMED: /* Relocate sv to the pad for thread safety. * Despite being a "constant", the SV is written to, * for reference counts, sv_upgrade() etc. */ if (cSVOP->op_sv) { const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP); if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) { /* If op_sv is already a PADTMP then it is being used by * some pad, so make a copy. */ sv_setsv(PAD_SVl(ix),cSVOPo->op_sv); SvREADONLY_on(PAD_SVl(ix)); SvREFCNT_dec(cSVOPo->op_sv); } else if (o->op_type != OP_METHOD_NAMED && cSVOPo->op_sv == &PL_sv_undef) { /* PL_sv_undef is hack - it's unsafe to store it in the AV that is the pad, because av_fetch treats values of PL_sv_undef as a "free" AV entry and will merrily replace them with a new SV, causing pad_alloc to think that this pad slot is free. (When, clearly, it is not) */ SvOK_off(PAD_SVl(ix)); SvPADTMP_on(PAD_SVl(ix)); SvREADONLY_on(PAD_SVl(ix)); } else { SvREFCNT_dec(PAD_SVl(ix)); SvPADTMP_on(cSVOPo->op_sv); PAD_SETSV(ix, cSVOPo->op_sv); /* XXX I don't know how this isn't readonly already. */ SvREADONLY_on(PAD_SVl(ix)); } cSVOPo->op_sv = NULL; o->op_targ = ix; } #endif break; case OP_CONCAT: if (o->op_next && o->op_next->op_type == OP_STRINGIFY) { if (o->op_next->op_private & OPpTARGET_MY) { if (o->op_flags & OPf_STACKED) /* chained concats */ break; /* ignore_optimization */ else { /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */ o->op_targ = o->op_next->op_targ; o->op_next->op_targ = 0; o->op_private |= OPpTARGET_MY; } } op_null(o->op_next); } break; case OP_STUB: if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) { break; /* Scalar stub must produce undef. List stub is noop */ } goto nothin; case OP_NULL: if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE) { PL_curcop = ((COP*)o); } /* XXX: We avoid setting op_seq here to prevent later calls to peep() from mistakenly concluding that optimisation has already occurred. This doesn't fix the real problem, though (See 20010220.007). AMS 20010719 */ /* op_seq functionality is now replaced by op_opt */ o->op_opt = 0; /* FALL THROUGH */ case OP_SCALAR: case OP_LINESEQ: case OP_SCOPE: nothin: if (oldop && o->op_next) { oldop->op_next = o->op_next; o->op_opt = 0; continue; } break; case OP_PADAV: case OP_GV: if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) { OP* const pop = (o->op_type == OP_PADAV) ? o->op_next : o->op_next->op_next; IV i; if (pop && pop->op_type == OP_CONST && ((PL_op = pop->op_next)) && pop->op_next->op_type == OP_AELEM && !(pop->op_next->op_private & (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) && (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop)) <= 255 && i >= 0) { GV *gv; if (cSVOPx(pop)->op_private & OPpCONST_STRICT) no_bareword_allowed(pop); if (o->op_type == OP_GV) op_null(o->op_next); op_null(pop->op_next); op_null(pop); o->op_flags |= pop->op_next->op_flags & OPf_MOD; o->op_next = pop->op_next->op_next; o->op_ppaddr = PL_ppaddr[OP_AELEMFAST]; o->op_private = (U8)i; if (o->op_type == OP_GV) { gv = cGVOPo_gv; GvAVn(gv); } else o->op_flags |= OPf_SPECIAL; o->op_type = OP_AELEMFAST; } break; } if (o->op_next->op_type == OP_RV2SV) { if (!(o->op_next->op_private & OPpDEREF)) { op_null(o->op_next); o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO | OPpOUR_INTRO); o->op_next = o->op_next->op_next; o->op_type = OP_GVSV; o->op_ppaddr = PL_ppaddr[OP_GVSV]; } } else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) { GV * const gv = cGVOPo_gv; if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) { /* XXX could check prototype here instead of just carping */ SV * const sv = sv_newmortal(); gv_efullname3(sv, gv, NULL); Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf"() called too early to check prototype", SVfARG(sv)); } } else if (o->op_next->op_type == OP_READLINE && o->op_next->op_next->op_type == OP_CONCAT && (o->op_next->op_next->op_flags & OPf_STACKED)) { /* Turn "$a .= " into an OP_RCATLINE. AMS 20010917 */ o->op_type = OP_RCATLINE; o->op_flags |= OPf_STACKED; o->op_ppaddr = PL_ppaddr[OP_RCATLINE]; op_null(o->op_next->op_next); op_null(o->op_next); } break; { OP *fop; OP *sop; case OP_NOT: fop = cUNOP->op_first; sop = NULL; goto stitch_keys; break; case OP_AND: case OP_OR: case OP_DOR: fop = cLOGOP->op_first; sop = fop->op_sibling; while (cLOGOP->op_other->op_type == OP_NULL) cLOGOP->op_other = cLOGOP->op_other->op_next; peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */ stitch_keys: o->op_opt = 1; if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV) || ( sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV) ) ){ OP * nop = o; OP * lop = o; if (!(nop->op_flags && OPf_WANT_VOID)) { while (nop && nop->op_next) { switch (nop->op_next->op_type) { case OP_NOT: case OP_AND: case OP_OR: case OP_DOR: lop = nop = nop->op_next; break; case OP_NULL: nop = nop->op_next; break; default: nop = NULL; break; } } } if (lop->op_flags && OPf_WANT_VOID) { if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV) cLOGOP->op_first = opt_scalarhv(fop); if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)) cLOGOP->op_first->op_sibling = opt_scalarhv(sop); } } break; } case OP_MAPWHILE: case OP_GREPWHILE: case OP_ANDASSIGN: case OP_ORASSIGN: case OP_DORASSIGN: case OP_COND_EXPR: case OP_RANGE: case OP_ONCE: while (cLOGOP->op_other->op_type == OP_NULL) cLOGOP->op_other = cLOGOP->op_other->op_next; peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */ break; case OP_ENTERLOOP: case OP_ENTERITER: while (cLOOP->op_redoop->op_type == OP_NULL) cLOOP->op_redoop = cLOOP->op_redoop->op_next; peep(cLOOP->op_redoop); while (cLOOP->op_nextop->op_type == OP_NULL) cLOOP->op_nextop = cLOOP->op_nextop->op_next; peep(cLOOP->op_nextop); while (cLOOP->op_lastop->op_type == OP_NULL) cLOOP->op_lastop = cLOOP->op_lastop->op_next; peep(cLOOP->op_lastop); break; case OP_SUBST: assert(!(cPMOP->op_pmflags & PMf_ONCE)); while (cPMOP->op_pmstashstartu.op_pmreplstart && cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL) cPMOP->op_pmstashstartu.op_pmreplstart = cPMOP->op_pmstashstartu.op_pmreplstart->op_next; peep(cPMOP->op_pmstashstartu.op_pmreplstart); break; case OP_EXEC: if (o->op_next && o->op_next->op_type == OP_NEXTSTATE && ckWARN(WARN_SYNTAX)) { if (o->op_next->op_sibling) { const OPCODE type = o->op_next->op_sibling->op_type; if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) { const line_t oldline = CopLINE(PL_curcop); CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next)); Perl_warner(aTHX_ packWARN(WARN_EXEC), "Statement unlikely to be reached"); Perl_warner(aTHX_ packWARN(WARN_EXEC), "\t(Maybe you meant system() when you said exec()?)\n"); CopLINE_set(PL_curcop, oldline); } } } break; case OP_HELEM: { UNOP *rop; SV *lexname; GV **fields; SV **svp, *sv; const char *key = NULL; STRLEN keylen; if (((BINOP*)o)->op_last->op_type != OP_CONST) break; /* Make the CONST have a shared SV */ svp = cSVOPx_svp(((BINOP*)o)->op_last); if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) { key = SvPV_const(sv, keylen); lexname = newSVpvn_share(key, SvUTF8(sv) ? -(I32)keylen : (I32)keylen, 0); SvREFCNT_dec(sv); *svp = lexname; } if ((o->op_private & (OPpLVAL_INTRO))) break; rop = (UNOP*)((BINOP*)o)->op_first; if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV) break; lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE); if (!SvPAD_TYPED(lexname)) break; fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE); if (!fields || !GvHV(*fields)) break; key = SvPV_const(*svp, keylen); if (!hv_fetch(GvHV(*fields), key, SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) { Perl_croak(aTHX_ "No such class field \"%s\" " "in variable %s of type %s", key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname))); } break; } case OP_HSLICE: { UNOP *rop; SV *lexname; GV **fields; SV **svp; const char *key; STRLEN keylen; SVOP *first_key_op, *key_op; if ((o->op_private & (OPpLVAL_INTRO)) /* I bet there's always a pushmark... */ || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST) /* hmmm, no optimization if list contains only one key. */ break; rop = (UNOP*)((LISTOP*)o)->op_last; if (rop->op_type != OP_RV2HV) break; if (rop->op_first->op_type == OP_PADSV) /* @$hash{qw(keys here)} */ rop = (UNOP*)rop->op_first; else { /* @{$hash}{qw(keys here)} */ if (rop->op_first->op_type == OP_SCOPE && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV) { rop = (UNOP*)cLISTOPx(rop->op_first)->op_last; } else break; } lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE); if (!SvPAD_TYPED(lexname)) break; fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE); if (!fields || !GvHV(*fields)) break; /* Again guessing that the pushmark can be jumped over.... */ first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling) ->op_first->op_sibling; for (key_op = first_key_op; key_op; key_op = (SVOP*)key_op->op_sibling) { if (key_op->op_type != OP_CONST) continue; svp = cSVOPx_svp(key_op); key = SvPV_const(*svp, keylen); if (!hv_fetch(GvHV(*fields), key, SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) { Perl_croak(aTHX_ "No such class field \"%s\" " "in variable %s of type %s", key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname))); } } break; } case OP_SORT: { /* will point to RV2AV or PADAV op on LHS/RHS of assign */ OP *oleft; OP *o2; /* check that RHS of sort is a single plain array */ OP *oright = cUNOPo->op_first; if (!oright || oright->op_type != OP_PUSHMARK) break; /* reverse sort ... can be optimised. */ if (!cUNOPo->op_sibling) { /* Nothing follows us on the list. */ OP * const reverse = o->op_next; if (reverse->op_type == OP_REVERSE && (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) { OP * const pushmark = cUNOPx(reverse)->op_first; if (pushmark && (pushmark->op_type == OP_PUSHMARK) && (cUNOPx(pushmark)->op_sibling == o)) { /* reverse -> pushmark -> sort */ o->op_private |= OPpSORT_REVERSE; op_null(reverse); pushmark->op_next = oright->op_next; op_null(oright); } } } /* make @a = sort @a act in-place */ oright = cUNOPx(oright)->op_sibling; if (!oright) break; if (oright->op_type == OP_NULL) { /* skip sort block/sub */ oright = cUNOPx(oright)->op_sibling; } oleft = is_inplace_av(o, oright); if (!oleft) break; /* transfer MODishness etc from LHS arg to RHS arg */ oright->op_flags = oleft->op_flags; o->op_private |= OPpSORT_INPLACE; /* excise push->gv->rv2av->null->aassign */ o2 = o->op_next->op_next; op_null(o2); /* PUSHMARK */ o2 = o2->op_next; if (o2->op_type == OP_GV) { op_null(o2); /* GV */ o2 = o2->op_next; } op_null(o2); /* RV2AV or PADAV */ o2 = o2->op_next->op_next; op_null(o2); /* AASSIGN */ o->op_next = o2->op_next; break; } case OP_REVERSE: { OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av; OP *gvop = NULL; OP *oleft, *oright; LISTOP *enter, *exlist; /* @a = reverse @a */ if ((oright = cLISTOPo->op_first) && (oright->op_type == OP_PUSHMARK) && (oright = oright->op_sibling) && (oleft = is_inplace_av(o, oright))) { OP *o2; /* transfer MODishness etc from LHS arg to RHS arg */ oright->op_flags = oleft->op_flags; o->op_private |= OPpREVERSE_INPLACE; /* excise push->gv->rv2av->null->aassign */ o2 = o->op_next->op_next; op_null(o2); /* PUSHMARK */ o2 = o2->op_next; if (o2->op_type == OP_GV) { op_null(o2); /* GV */ o2 = o2->op_next; } op_null(o2); /* RV2AV or PADAV */ o2 = o2->op_next->op_next; op_null(o2); /* AASSIGN */ o->op_next = o2->op_next; break; } enter = (LISTOP *) o->op_next; if (!enter) break; if (enter->op_type == OP_NULL) { enter = (LISTOP *) enter->op_next; if (!enter) break; } /* for $a (...) will have OP_GV then OP_RV2GV here. for (...) just has an OP_GV. */ if (enter->op_type == OP_GV) { gvop = (OP *) enter; enter = (LISTOP *) enter->op_next; if (!enter) break; if (enter->op_type == OP_RV2GV) { enter = (LISTOP *) enter->op_next; if (!enter) break; } } if (enter->op_type != OP_ENTERITER) break; iter = enter->op_next; if (!iter || iter->op_type != OP_ITER) break; expushmark = enter->op_first; if (!expushmark || expushmark->op_type != OP_NULL || expushmark->op_targ != OP_PUSHMARK) break; exlist = (LISTOP *) expushmark->op_sibling; if (!exlist || exlist->op_type != OP_NULL || exlist->op_targ != OP_LIST) break; if (exlist->op_last != o) { /* Mmm. Was expecting to point back to this op. */ break; } theirmark = exlist->op_first; if (!theirmark || theirmark->op_type != OP_PUSHMARK) break; if (theirmark->op_sibling != o) { /* There's something between the mark and the reverse, eg for (1, reverse (...)) so no go. */ break; } ourmark = ((LISTOP *)o)->op_first; if (!ourmark || ourmark->op_type != OP_PUSHMARK) break; ourlast = ((LISTOP *)o)->op_last; if (!ourlast || ourlast->op_next != o) break; rv2av = ourmark->op_sibling; if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS) && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) { /* We're just reversing a single array. */ rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF; enter->op_flags |= OPf_STACKED; } /* We don't have control over who points to theirmark, so sacrifice ours. */ theirmark->op_next = ourmark->op_next; theirmark->op_flags = ourmark->op_flags; ourlast->op_next = gvop ? gvop : (OP *) enter; op_null(ourmark); op_null(o); enter->op_private |= OPpITER_REVERSED; iter->op_private |= OPpITER_REVERSED; break; } case OP_SASSIGN: { OP *rv2gv; UNOP *refgen, *rv2cv; LISTOP *exlist; if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID) break; if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2) break; rv2gv = ((BINOP *)o)->op_last; if (!rv2gv || rv2gv->op_type != OP_RV2GV) break; refgen = (UNOP *)((BINOP *)o)->op_first; if (!refgen || refgen->op_type != OP_REFGEN) break; exlist = (LISTOP *)refgen->op_first; if (!exlist || exlist->op_type != OP_NULL || exlist->op_targ != OP_LIST) break; if (exlist->op_first->op_type != OP_PUSHMARK) break; rv2cv = (UNOP*)exlist->op_last; if (rv2cv->op_type != OP_RV2CV) break; assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0); assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0); assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0); o->op_private |= OPpASSIGN_CV_TO_GV; rv2gv->op_private |= OPpDONT_INIT_GV; rv2cv->op_private |= OPpMAY_RETURN_CONSTANT; break; } case OP_QR: case OP_MATCH: if (!(cPMOP->op_pmflags & PMf_ONCE)) { assert (!cPMOP->op_pmstashstartu.op_pmreplstart); } break; } oldop = o; } LEAVE; } const char* Perl_custom_op_name(pTHX_ const OP* o) { dVAR; const IV index = PTR2IV(o->op_ppaddr); SV* keysv; HE* he; PERL_ARGS_ASSERT_CUSTOM_OP_NAME; if (!PL_custom_op_names) /* This probably shouldn't happen */ return (char *)PL_op_name[OP_CUSTOM]; keysv = sv_2mortal(newSViv(index)); he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0); if (!he) return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */ return SvPV_nolen(HeVAL(he)); } const char* Perl_custom_op_desc(pTHX_ const OP* o) { dVAR; const IV index = PTR2IV(o->op_ppaddr); SV* keysv; HE* he; PERL_ARGS_ASSERT_CUSTOM_OP_DESC; if (!PL_custom_op_descs) return (char *)PL_op_desc[OP_CUSTOM]; keysv = sv_2mortal(newSViv(index)); he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0); if (!he) return (char *)PL_op_desc[OP_CUSTOM]; return SvPV_nolen(HeVAL(he)); } #include "XSUB.h" /* Efficient sub that returns a constant scalar value. */ static void const_sv_xsub(pTHX_ CV* cv) { dVAR; dXSARGS; SV *const sv = MUTABLE_SV(XSANY.any_ptr); if (items != 0) { NOOP; #if 0 /* diag_listed_as: SKIPME */ Perl_croak(aTHX_ "usage: %s::%s()", HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv))); #endif } if (!sv) { XSRETURN(0); } EXTEND(sp, 1); ST(0) = sv; XSRETURN(1); } /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */ perl-5.12.0-RC0/pp_sort.c0000444000175000017500000017700011325127001013754 0ustar jessejesse/* pp_sort.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * ...they shuffled back towards the rear of the line. 'No, not at the * rear!' the slave-driver shouted. 'Three files up. And stay there... * * [p.931 of _The Lord of the Rings_, VI/ii: "The Land of Shadow"] */ /* This file contains pp ("push/pop") functions that * execute the opcodes that make up a perl program. A typical pp function * expects to find its arguments on the stack, and usually pushes its * results onto the stack, hence the 'pp' terminology. Each OP structure * contains a pointer to the relevant pp_foo() function. * * This particular file just contains pp_sort(), which is complex * enough to merit its own file! See the other pp*.c files for the rest of * the pp_ functions. */ #include "EXTERN.h" #define PERL_IN_PP_SORT_C #include "perl.h" #if defined(UNDER_CE) /* looks like 'small' is reserved word for WINCE (or somesuch)*/ #define small xsmall #endif #define sv_cmp_static Perl_sv_cmp #define sv_cmp_locale_static Perl_sv_cmp_locale #ifndef SMALLSORT #define SMALLSORT (200) #endif /* Flags for qsortsv and mergesortsv */ #define SORTf_DESC 1 #define SORTf_STABLE 2 #define SORTf_QSORT 4 /* * The mergesort implementation is by Peter M. Mcilroy . * * The original code was written in conjunction with BSD Computer Software * Research Group at University of California, Berkeley. * * See also: "Optimistic Merge Sort" (SODA '92) * * The integration to Perl is by John P. Linderman . * * The code can be distributed under the same terms as Perl itself. * */ typedef char * aptr; /* pointer for arithmetic on sizes */ typedef SV * gptr; /* pointers in our lists */ /* Binary merge internal sort, with a few special mods ** for the special perl environment it now finds itself in. ** ** Things that were once options have been hotwired ** to values suitable for this use. In particular, we'll always ** initialize looking for natural runs, we'll always produce stable ** output, and we'll always do Peter McIlroy's binary merge. */ /* Pointer types for arithmetic and storage and convenience casts */ #define APTR(P) ((aptr)(P)) #define GPTP(P) ((gptr *)(P)) #define GPPP(P) ((gptr **)(P)) /* byte offset from pointer P to (larger) pointer Q */ #define BYTEOFF(P, Q) (APTR(Q) - APTR(P)) #define PSIZE sizeof(gptr) /* If PSIZE is power of 2, make PSHIFT that power, if that helps */ #ifdef PSHIFT #define PNELEM(P, Q) (BYTEOFF(P,Q) >> (PSHIFT)) #define PNBYTE(N) ((N) << (PSHIFT)) #define PINDEX(P, N) (GPTP(APTR(P) + PNBYTE(N))) #else /* Leave optimization to compiler */ #define PNELEM(P, Q) (GPTP(Q) - GPTP(P)) #define PNBYTE(N) ((N) * (PSIZE)) #define PINDEX(P, N) (GPTP(P) + (N)) #endif /* Pointer into other corresponding to pointer into this */ #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P)) #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src= 2 * PTHRESH. We only try to form long runs when ** PTHRESH adjacent pairs compare in the same way, suggesting overall order. ** ** Unless otherwise specified, pair pointers address the first of two elements. ** ** b and b+1 are a pair that compare with sense "sense". ** b is the "bottom" of adjacent pairs that might form a longer run. ** ** p2 parallels b in the list2 array, where runs are defined by ** a pointer chain. ** ** t represents the "top" of the adjacent pairs that might extend ** the run beginning at b. Usually, t addresses a pair ** that compares with opposite sense from (b,b+1). ** However, it may also address a singleton element at the end of list1, ** or it may be equal to "last", the first element beyond list1. ** ** r addresses the Nth pair following b. If this would be beyond t, ** we back it off to t. Only when r is less than t do we consider the ** run long enough to consider checking. ** ** q addresses a pair such that the pairs at b through q already form a run. ** Often, q will equal b, indicating we only are sure of the pair itself. ** However, a search on the previous cycle may have revealed a longer run, ** so q may be greater than b. ** ** p is used to work back from a candidate r, trying to reach q, ** which would mean b through r would be a run. If we discover such a run, ** we start q at r and try to push it further towards t. ** If b through r is NOT a run, we detect the wrong order at (p-1,p). ** In any event, after the check (if any), we have two main cases. ** ** 1) Short run. b <= q < p <= r <= t. ** b through q is a run (perhaps trivial) ** q through p are uninteresting pairs ** p through r is a run ** ** 2) Long run. b < r <= q < t. ** b through q is a run (of length >= 2 * PTHRESH) ** ** Note that degenerate cases are not only possible, but likely. ** For example, if the pair following b compares with opposite sense, ** then b == q < p == r == t. */ static IV dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, const SVCOMPARE_t cmp) { I32 sense; register gptr *b, *p, *q, *t, *p2; register gptr *last, *r; IV runs = 0; b = list1; last = PINDEX(b, nmemb); sense = (cmp(aTHX_ *b, *(b+1)) > 0); for (p2 = list2; b < last; ) { /* We just started, or just reversed sense. ** Set t at end of pairs with the prevailing sense. */ for (p = b+2, t = p; ++p < last; t = ++p) { if ((cmp(aTHX_ *t, *p) > 0) != sense) break; } q = b; /* Having laid out the playing field, look for long runs */ do { p = r = b + (2 * PTHRESH); if (r >= t) p = r = t; /* too short to care about */ else { while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) && ((p -= 2) > q)) {} if (p <= q) { /* b through r is a (long) run. ** Extend it as far as possible. */ p = q = r; while (((p += 2) < t) && ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p; r = p = q + 2; /* no simple pairs, no after-run */ } } if (q > b) { /* run of greater than 2 at b */ gptr *savep = p; p = q += 2; /* pick up singleton, if possible */ if ((p == t) && ((t + 1) == last) && ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) savep = r = p = q = last; p2 = NEXT(p2) = p2 + (p - b); ++runs; if (sense) while (b < --p) { const gptr c = *b; *b++ = *p; *p = c; } p = savep; } while (q < p) { /* simple pairs */ p2 = NEXT(p2) = p2 + 2; ++runs; if (sense) { const gptr c = *q++; *(q-1) = *q; *q++ = c; } else q += 2; } if (((b = p) == t) && ((t+1) == last)) { NEXT(p2) = p2 + 1; ++runs; b++; } q = r; } while (b < t); sense = !sense; } return runs; } /* The original merge sort, in use since 5.7, was as fast as, or faster than, * qsort on many platforms, but slower than qsort, conspicuously so, * on others. The most likely explanation was platform-specific * differences in cache sizes and relative speeds. * * The quicksort divide-and-conquer algorithm guarantees that, as the * problem is subdivided into smaller and smaller parts, the parts * fit into smaller (and faster) caches. So it doesn't matter how * many levels of cache exist, quicksort will "find" them, and, * as long as smaller is faster, take advantage of them. * * By contrast, consider how the original mergesort algorithm worked. * Suppose we have five runs (each typically of length 2 after dynprep). * * pass base aux * 0 1 2 3 4 5 * 1 12 34 5 * 2 1234 5 * 3 12345 * 4 12345 * * Adjacent pairs are merged in "grand sweeps" through the input. * This means, on pass 1, the records in runs 1 and 2 aren't revisited until * runs 3 and 4 are merged and the runs from run 5 have been copied. * The only cache that matters is one large enough to hold *all* the input. * On some platforms, this may be many times slower than smaller caches. * * The following pseudo-code uses the same basic merge algorithm, * but in a divide-and-conquer way. * * # merge $runs runs at offset $offset of list $list1 into $list2. * # all unmerged runs ($runs == 1) originate in list $base. * sub mgsort2 { * my ($offset, $runs, $base, $list1, $list2) = @_; * * if ($runs == 1) { * if ($list1 is $base) copy run to $list2 * return offset of end of list (or copy) * } else { * $off2 = mgsort2($offset, $runs-($runs/2), $base, $list2, $list1) * mgsort2($off2, $runs/2, $base, $list2, $list1) * merge the adjacent runs at $offset of $list1 into $list2 * return the offset of the end of the merged runs * } * } * mgsort2(0, $runs, $base, $aux, $base); * * For our 5 runs, the tree of calls looks like * * 5 * 3 2 * 2 1 1 1 * 1 1 * * 1 2 3 4 5 * * and the corresponding activity looks like * * copy runs 1 and 2 from base to aux * merge runs 1 and 2 from aux to base * (run 3 is where it belongs, no copy needed) * merge runs 12 and 3 from base to aux * (runs 4 and 5 are where they belong, no copy needed) * merge runs 4 and 5 from base to aux * merge runs 123 and 45 from aux to base * * Note that we merge runs 1 and 2 immediately after copying them, * while they are still likely to be in fast cache. Similarly, * run 3 is merged with run 12 while it still may be lingering in cache. * This implementation should therefore enjoy much of the cache-friendly * behavior that quicksort does. In addition, it does less copying * than the original mergesort implementation (only runs 1 and 2 are copied) * and the "balancing" of merges is better (merged runs comprise more nearly * equal numbers of original runs). * * The actual cache-friendly implementation will use a pseudo-stack * to avoid recursion, and will unroll processing of runs of length 2, * but it is otherwise similar to the recursive implementation. */ typedef struct { IV offset; /* offset of 1st of 2 runs at this level */ IV runs; /* how many runs must be combined into 1 */ } off_runs; /* pseudo-stack element */ static I32 cmp_desc(pTHX_ gptr const a, gptr const b) { dVAR; return -PL_sort_RealCmp(aTHX_ a, b); } STATIC void S_mergesortsv(pTHX_ gptr *base, size_t nmemb, SVCOMPARE_t cmp, U32 flags) { dVAR; IV i, run, offset; I32 sense, level; register gptr *f1, *f2, *t, *b, *p; int iwhich; gptr *aux; gptr *p1; gptr small[SMALLSORT]; gptr *which[3]; off_runs stack[60], *stackp; SVCOMPARE_t savecmp = NULL; if (nmemb <= 1) return; /* sorted trivially */ if ((flags & SORTf_DESC) != 0) { savecmp = PL_sort_RealCmp; /* Save current comparison routine, if any */ PL_sort_RealCmp = cmp; /* Put comparison routine where cmp_desc can find it */ cmp = cmp_desc; } if (nmemb <= SMALLSORT) aux = small; /* use stack for aux array */ else { Newx(aux,nmemb,gptr); } /* allocate auxilliary array */ level = 0; stackp = stack; stackp->runs = dynprep(aTHX_ base, aux, nmemb, cmp); stackp->offset = offset = 0; which[0] = which[2] = base; which[1] = aux; for (;;) { /* On levels where both runs have be constructed (stackp->runs == 0), * merge them, and note the offset of their end, in case the offset * is needed at the next level up. Hop up a level, and, * as long as stackp->runs is 0, keep merging. */ IV runs = stackp->runs; if (runs == 0) { gptr *list1, *list2; iwhich = level & 1; list1 = which[iwhich]; /* area where runs are now */ list2 = which[++iwhich]; /* area for merged runs */ do { register gptr *l1, *l2, *tp2; offset = stackp->offset; f1 = p1 = list1 + offset; /* start of first run */ p = tp2 = list2 + offset; /* where merged run will go */ t = NEXT(p); /* where first run ends */ f2 = l1 = POTHER(t, list2, list1); /* ... on the other side */ t = NEXT(t); /* where second runs ends */ l2 = POTHER(t, list2, list1); /* ... on the other side */ offset = PNELEM(list2, t); while (f1 < l1 && f2 < l2) { /* If head 1 is larger than head 2, find ALL the elements ** in list 2 strictly less than head1, write them all, ** then head 1. Then compare the new heads, and repeat, ** until one or both lists are exhausted. ** ** In all comparisons (after establishing ** which head to merge) the item to merge ** (at pointer q) is the first operand of ** the comparison. When we want to know ** if "q is strictly less than the other", ** we can't just do ** cmp(q, other) < 0 ** because stability demands that we treat equality ** as high when q comes from l2, and as low when ** q was from l1. So we ask the question by doing ** cmp(q, other) <= sense ** and make sense == 0 when equality should look low, ** and -1 when equality should look high. */ register gptr *q; if (cmp(aTHX_ *f1, *f2) <= 0) { q = f2; b = f1; t = l1; sense = -1; } else { q = f1; b = f2; t = l2; sense = 0; } /* ramp up ** ** Leave t at something strictly ** greater than q (or at the end of the list), ** and b at something strictly less than q. */ for (i = 1, run = 0 ;;) { if ((p = PINDEX(b, i)) >= t) { /* off the end */ if (((p = PINDEX(t, -1)) > b) && (cmp(aTHX_ *q, *p) <= sense)) t = p; else b = p; break; } else if (cmp(aTHX_ *q, *p) <= sense) { t = p; break; } else b = p; if (++run >= RTHRESH) i += i; } /* q is known to follow b and must be inserted before t. ** Increment b, so the range of possibilities is [b,t). ** Round binary split down, to favor early appearance. ** Adjust b and t until q belongs just before t. */ b++; while (b < t) { p = PINDEX(b, (PNELEM(b, t) - 1) / 2); if (cmp(aTHX_ *q, *p) <= sense) { t = p; } else b = p + 1; } /* Copy all the strictly low elements */ if (q == f1) { FROMTOUPTO(f2, tp2, t); *tp2++ = *f1++; } else { FROMTOUPTO(f1, tp2, t); *tp2++ = *f2++; } } /* Run out remaining list */ if (f1 == l1) { if (f2 < l2) FROMTOUPTO(f2, tp2, l2); } else FROMTOUPTO(f1, tp2, l1); p1 = NEXT(p1) = POTHER(tp2, list2, list1); if (--level == 0) goto done; --stackp; t = list1; list1 = list2; list2 = t; /* swap lists */ } while ((runs = stackp->runs) == 0); } stackp->runs = 0; /* current run will finish level */ /* While there are more than 2 runs remaining, * turn them into exactly 2 runs (at the "other" level), * each made up of approximately half the runs. * Stack the second half for later processing, * and set about producing the first half now. */ while (runs > 2) { ++level; ++stackp; stackp->offset = offset; runs -= stackp->runs = runs / 2; } /* We must construct a single run from 1 or 2 runs. * All the original runs are in which[0] == base. * The run we construct must end up in which[level&1]. */ iwhich = level & 1; if (runs == 1) { /* Constructing a single run from a single run. * If it's where it belongs already, there's nothing to do. * Otherwise, copy it to where it belongs. * A run of 1 is either a singleton at level 0, * or the second half of a split 3. In neither event * is it necessary to set offset. It will be set by the merge * that immediately follows. */ if (iwhich) { /* Belongs in aux, currently in base */ f1 = b = PINDEX(base, offset); /* where list starts */ f2 = PINDEX(aux, offset); /* where list goes */ t = NEXT(f2); /* where list will end */ offset = PNELEM(aux, t); /* offset thereof */ t = PINDEX(base, offset); /* where it currently ends */ FROMTOUPTO(f1, f2, t); /* copy */ NEXT(b) = t; /* set up parallel pointer */ } else if (level == 0) goto done; /* single run at level 0 */ } else { /* Constructing a single run from two runs. * The merge code at the top will do that. * We need only make sure the two runs are in the "other" array, * so they'll end up in the correct array after the merge. */ ++level; ++stackp; stackp->offset = offset; stackp->runs = 0; /* take care of both runs, trigger merge */ if (!iwhich) { /* Merged runs belong in aux, copy 1st */ f1 = b = PINDEX(base, offset); /* where first run starts */ f2 = PINDEX(aux, offset); /* where it will be copied */ t = NEXT(f2); /* where first run will end */ offset = PNELEM(aux, t); /* offset thereof */ p = PINDEX(base, offset); /* end of first run */ t = NEXT(t); /* where second run will end */ t = PINDEX(base, PNELEM(aux, t)); /* where it now ends */ FROMTOUPTO(f1, f2, t); /* copy both runs */ NEXT(b) = p; /* paralled pointer for 1st */ NEXT(p) = t; /* ... and for second */ } } } done: if (aux != small) Safefree(aux); /* free iff allocated */ if (flags) { PL_sort_RealCmp = savecmp; /* Restore current comparison routine, if any */ } return; } /* * The quicksort implementation was derived from source code contributed * by Tom Horsley. * * NOTE: this code was derived from Tom Horsley's qsort replacement * and should not be confused with the original code. */ /* Copyright (C) Tom Horsley, 1997. All rights reserved. Permission granted to distribute under the same terms as perl which are (briefly): This program is free software; you can redistribute it and/or modify it under the terms of either: a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" which comes with this Kit. Details on the perl license can be found in the perl source code which may be located via the www.perl.com web page. This is the most wonderfulest possible qsort I can come up with (and still be mostly portable) My (limited) tests indicate it consistently does about 20% fewer calls to compare than does the qsort in the Visual C++ library, other vendors may vary. Some of the ideas in here can be found in "Algorithms" by Sedgewick, others I invented myself (or more likely re-invented since they seemed pretty obvious once I watched the algorithm operate for a while). Most of this code was written while watching the Marlins sweep the Giants in the 1997 National League Playoffs - no Braves fans allowed to use this code (just kidding :-). I realize that if I wanted to be true to the perl tradition, the only comment in this file would be something like: ...they shuffled back towards the rear of the line. 'No, not at the rear!' the slave-driver shouted. 'Three files up. And stay there... However, I really needed to violate that tradition just so I could keep track of what happens myself, not to mention some poor fool trying to understand this years from now :-). */ /* ********************************************************** Configuration */ #ifndef QSORT_ORDER_GUESS #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */ #endif /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for future processing - a good max upper bound is log base 2 of memory size (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can safely be smaller than that since the program is taking up some space and most operating systems only let you grab some subset of contiguous memory (not to mention that you are normally sorting data larger than 1 byte element size :-). */ #ifndef QSORT_MAX_STACK #define QSORT_MAX_STACK 32 #endif /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort. Anything bigger and we use qsort. If you make this too small, the qsort will probably break (or become less efficient), because it doesn't expect the middle element of a partition to be the same as the right or left - you have been warned). */ #ifndef QSORT_BREAK_EVEN #define QSORT_BREAK_EVEN 6 #endif /* QSORT_PLAY_SAFE is the size of the largest partition we're willing to go quadratic on. We innoculate larger partitions against quadratic behavior by shuffling them before sorting. This is not an absolute guarantee of non-quadratic behavior, but it would take staggeringly bad luck to pick extreme elements as the pivot from randomized data. */ #ifndef QSORT_PLAY_SAFE #define QSORT_PLAY_SAFE 255 #endif /* ************************************************************* Data Types */ /* hold left and right index values of a partition waiting to be sorted (the partition includes both left and right - right is NOT one past the end or anything like that). */ struct partition_stack_entry { int left; int right; #ifdef QSORT_ORDER_GUESS int qsort_break_even; #endif }; /* ******************************************************* Shorthand Macros */ /* Note that these macros will be used from inside the qsort function where we happen to know that the variable 'elt_size' contains the size of an array element and the variable 'temp' points to enough space to hold a temp element and the variable 'array' points to the array being sorted and 'compare' is the pointer to the compare routine. Also note that there are very many highly architecture specific ways these might be sped up, but this is simply the most generally portable code I could think of. */ /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2 */ #define qsort_cmp(elt1, elt2) \ ((*compare)(aTHX_ array[elt1], array[elt2])) #ifdef QSORT_ORDER_GUESS #define QSORT_NOTICE_SWAP swapped++; #else #define QSORT_NOTICE_SWAP #endif /* swaps contents of array elements elt1, elt2. */ #define qsort_swap(elt1, elt2) \ STMT_START { \ QSORT_NOTICE_SWAP \ temp = array[elt1]; \ array[elt1] = array[elt2]; \ array[elt2] = temp; \ } STMT_END /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets elt3 and elt3 gets elt1. */ #define qsort_rotate(elt1, elt2, elt3) \ STMT_START { \ QSORT_NOTICE_SWAP \ temp = array[elt1]; \ array[elt1] = array[elt2]; \ array[elt2] = array[elt3]; \ array[elt3] = temp; \ } STMT_END /* ************************************************************ Debug stuff */ #ifdef QSORT_DEBUG static void break_here() { return; /* good place to set a breakpoint */ } #define qsort_assert(t) (void)( (t) || (break_here(), 0) ) static void doqsort_all_asserts( void * array, size_t num_elts, size_t elt_size, int (*compare)(const void * elt1, const void * elt2), int pc_left, int pc_right, int u_left, int u_right) { int i; qsort_assert(pc_left <= pc_right); qsort_assert(u_right < pc_left); qsort_assert(pc_right < u_left); for (i = u_right + 1; i < pc_left; ++i) { qsort_assert(qsort_cmp(i, pc_left) < 0); } for (i = pc_left; i < pc_right; ++i) { qsort_assert(qsort_cmp(i, pc_right) == 0); } for (i = pc_right + 1; i < u_left; ++i) { qsort_assert(qsort_cmp(pc_right, i) < 0); } } #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \ doqsort_all_asserts(array, num_elts, elt_size, compare, \ PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) #else #define qsort_assert(t) ((void)0) #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0) #endif /* ****************************************************************** qsort */ STATIC void /* the standard unstable (u) quicksort (qsort) */ S_qsortsvu(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare) { register SV * temp; struct partition_stack_entry partition_stack[QSORT_MAX_STACK]; int next_stack_entry = 0; int part_left; int part_right; #ifdef QSORT_ORDER_GUESS int qsort_break_even; int swapped; #endif PERL_ARGS_ASSERT_QSORTSVU; /* Make sure we actually have work to do. */ if (num_elts <= 1) { return; } /* Innoculate large partitions against quadratic behavior */ if (num_elts > QSORT_PLAY_SAFE) { register size_t n; register SV ** const q = array; for (n = num_elts; n > 1; ) { register const size_t j = (size_t)(n-- * Drand01()); temp = q[j]; q[j] = q[n]; q[n] = temp; } } /* Setup the initial partition definition and fall into the sorting loop */ part_left = 0; part_right = (int)(num_elts - 1); #ifdef QSORT_ORDER_GUESS qsort_break_even = QSORT_BREAK_EVEN; #else #define qsort_break_even QSORT_BREAK_EVEN #endif for ( ; ; ) { if ((part_right - part_left) >= qsort_break_even) { /* OK, this is gonna get hairy, so lets try to document all the concepts and abbreviations and variables and what they keep track of: pc: pivot chunk - the set of array elements we accumulate in the middle of the partition, all equal in value to the original pivot element selected. The pc is defined by: pc_left - the leftmost array index of the pc pc_right - the rightmost array index of the pc we start with pc_left == pc_right and only one element in the pivot chunk (but it can grow during the scan). u: uncompared elements - the set of elements in the partition we have not yet compared to the pivot value. There are two uncompared sets during the scan - one to the left of the pc and one to the right. u_right - the rightmost index of the left side's uncompared set u_left - the leftmost index of the right side's uncompared set The leftmost index of the left sides's uncompared set doesn't need its own variable because it is always defined by the leftmost edge of the whole partition (part_left). The same goes for the rightmost edge of the right partition (part_right). We know there are no uncompared elements on the left once we get u_right < part_left and no uncompared elements on the right once u_left > part_right. When both these conditions are met, we have completed the scan of the partition. Any elements which are between the pivot chunk and the uncompared elements should be less than the pivot value on the left side and greater than the pivot value on the right side (in fact, the goal of the whole algorithm is to arrange for that to be true and make the groups of less-than and greater-then elements into new partitions to sort again). As you marvel at the complexity of the code and wonder why it has to be so confusing. Consider some of the things this level of confusion brings: Once I do a compare, I squeeze every ounce of juice out of it. I never do compare calls I don't have to do, and I certainly never do redundant calls. I also never swap any elements unless I can prove there is a good reason. Many sort algorithms will swap a known value with an uncompared value just to get things in the right place (or avoid complexity :-), but that uncompared value, once it gets compared, may then have to be swapped again. A lot of the complexity of this code is due to the fact that it never swaps anything except compared values, and it only swaps them when the compare shows they are out of position. */ int pc_left, pc_right; int u_right, u_left; int s; pc_left = ((part_left + part_right) / 2); pc_right = pc_left; u_right = pc_left - 1; u_left = pc_right + 1; /* Qsort works best when the pivot value is also the median value in the partition (unfortunately you can't find the median value without first sorting :-), so to give the algorithm a helping hand, we pick 3 elements and sort them and use the median value of that tiny set as the pivot value. Some versions of qsort like to use the left middle and right as the 3 elements to sort so they can insure the ends of the partition will contain values which will stop the scan in the compare loop, but when you have to call an arbitrarily complex routine to do a compare, its really better to just keep track of array index values to know when you hit the edge of the partition and avoid the extra compare. An even better reason to avoid using a compare call is the fact that you can drop off the edge of the array if someone foolishly provides you with an unstable compare function that doesn't always provide consistent results. So, since it is simpler for us to compare the three adjacent elements in the middle of the partition, those are the ones we pick here (conveniently pointed at by u_right, pc_left, and u_left). The values of the left, center, and right elements are refered to as l c and r in the following comments. */ #ifdef QSORT_ORDER_GUESS swapped = 0; #endif s = qsort_cmp(u_right, pc_left); if (s < 0) { /* l < c */ s = qsort_cmp(pc_left, u_left); /* if l < c, c < r - already in order - nothing to do */ if (s == 0) { /* l < c, c == r - already in order, pc grows */ ++pc_right; qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); } else if (s > 0) { /* l < c, c > r - need to know more */ s = qsort_cmp(u_right, u_left); if (s < 0) { /* l < c, c > r, l < r - swap c & r to get ordered */ qsort_swap(pc_left, u_left); qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); } else if (s == 0) { /* l < c, c > r, l == r - swap c&r, grow pc */ qsort_swap(pc_left, u_left); --pc_left; qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); } else { /* l < c, c > r, l > r - make lcr into rlc to get ordered */ qsort_rotate(pc_left, u_right, u_left); qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); } } } else if (s == 0) { /* l == c */ s = qsort_cmp(pc_left, u_left); if (s < 0) { /* l == c, c < r - already in order, grow pc */ --pc_left; qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); } else if (s == 0) { /* l == c, c == r - already in order, grow pc both ways */ --pc_left; ++pc_right; qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); } else { /* l == c, c > r - swap l & r, grow pc */ qsort_swap(u_right, u_left); ++pc_right; qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); } } else { /* l > c */ s = qsort_cmp(pc_left, u_left); if (s < 0) { /* l > c, c < r - need to know more */ s = qsort_cmp(u_right, u_left); if (s < 0) { /* l > c, c < r, l < r - swap l & c to get ordered */ qsort_swap(u_right, pc_left); qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); } else if (s == 0) { /* l > c, c < r, l == r - swap l & c, grow pc */ qsort_swap(u_right, pc_left); ++pc_right; qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); } else { /* l > c, c < r, l > r - rotate lcr into crl to order */ qsort_rotate(u_right, pc_left, u_left); qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); } } else if (s == 0) { /* l > c, c == r - swap ends, grow pc */ qsort_swap(u_right, u_left); --pc_left; qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); } else { /* l > c, c > r - swap ends to get in order */ qsort_swap(u_right, u_left); qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); } } /* We now know the 3 middle elements have been compared and arranged in the desired order, so we can shrink the uncompared sets on both sides */ --u_right; ++u_left; qsort_all_asserts(pc_left, pc_right, u_left, u_right); /* The above massive nested if was the simple part :-). We now have the middle 3 elements ordered and we need to scan through the uncompared sets on either side, swapping elements that are on the wrong side or simply shuffling equal elements around to get all equal elements into the pivot chunk. */ for ( ; ; ) { int still_work_on_left; int still_work_on_right; /* Scan the uncompared values on the left. If I find a value equal to the pivot value, move it over so it is adjacent to the pivot chunk and expand the pivot chunk. If I find a value less than the pivot value, then just leave it - its already on the correct side of the partition. If I find a greater value, then stop the scan. */ while ((still_work_on_left = (u_right >= part_left))) { s = qsort_cmp(u_right, pc_left); if (s < 0) { --u_right; } else if (s == 0) { --pc_left; if (pc_left != u_right) { qsort_swap(u_right, pc_left); } --u_right; } else { break; } qsort_assert(u_right < pc_left); qsort_assert(pc_left <= pc_right); qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0); qsort_assert(qsort_cmp(pc_left, pc_right) == 0); } /* Do a mirror image scan of uncompared values on the right */ while ((still_work_on_right = (u_left <= part_right))) { s = qsort_cmp(pc_right, u_left); if (s < 0) { ++u_left; } else if (s == 0) { ++pc_right; if (pc_right != u_left) { qsort_swap(pc_right, u_left); } ++u_left; } else { break; } qsort_assert(u_left > pc_right); qsort_assert(pc_left <= pc_right); qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0); qsort_assert(qsort_cmp(pc_left, pc_right) == 0); } if (still_work_on_left) { /* I know I have a value on the left side which needs to be on the right side, but I need to know more to decide exactly the best thing to do with it. */ if (still_work_on_right) { /* I know I have values on both side which are out of position. This is a big win because I kill two birds with one swap (so to speak). I can advance the uncompared pointers on both sides after swapping both of them into the right place. */ qsort_swap(u_right, u_left); --u_right; ++u_left; qsort_all_asserts(pc_left, pc_right, u_left, u_right); } else { /* I have an out of position value on the left, but the right is fully scanned, so I "slide" the pivot chunk and any less-than values left one to make room for the greater value over on the right. If the out of position value is immediately adjacent to the pivot chunk (there are no less-than values), I can do that with a swap, otherwise, I have to rotate one of the less than values into the former position of the out of position value and the right end of the pivot chunk into the left end (got all that?). */ --pc_left; if (pc_left == u_right) { qsort_swap(u_right, pc_right); qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1); } else { qsort_rotate(u_right, pc_left, pc_right); qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1); } --pc_right; --u_right; } } else if (still_work_on_right) { /* Mirror image of complex case above: I have an out of position value on the right, but the left is fully scanned, so I need to shuffle things around to make room for the right value on the left. */ ++pc_right; if (pc_right == u_left) { qsort_swap(u_left, pc_left); qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right); } else { qsort_rotate(pc_right, pc_left, u_left); qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right); } ++pc_left; ++u_left; } else { /* No more scanning required on either side of partition, break out of loop and figure out next set of partitions */ break; } } /* The elements in the pivot chunk are now in the right place. They will never move or be compared again. All I have to do is decide what to do with the stuff to the left and right of the pivot chunk. Notes on the QSORT_ORDER_GUESS ifdef code: 1. If I just built these partitions without swapping any (or very many) elements, there is a chance that the elements are already ordered properly (being properly ordered will certainly result in no swapping, but the converse can't be proved :-). 2. A (properly written) insertion sort will run faster on already ordered data than qsort will. 3. Perhaps there is some way to make a good guess about switching to an insertion sort earlier than partition size 6 (for instance - we could save the partition size on the stack and increase the size each time we find we didn't swap, thus switching to insertion sort earlier for partitions with a history of not swapping). 4. Naturally, if I just switch right away, it will make artificial benchmarks with pure ascending (or descending) data look really good, but is that a good reason in general? Hard to say... */ #ifdef QSORT_ORDER_GUESS if (swapped < 3) { #if QSORT_ORDER_GUESS == 1 qsort_break_even = (part_right - part_left) + 1; #endif #if QSORT_ORDER_GUESS == 2 qsort_break_even *= 2; #endif #if QSORT_ORDER_GUESS == 3 const int prev_break = qsort_break_even; qsort_break_even *= qsort_break_even; if (qsort_break_even < prev_break) { qsort_break_even = (part_right - part_left) + 1; } #endif } else { qsort_break_even = QSORT_BREAK_EVEN; } #endif if (part_left < pc_left) { /* There are elements on the left which need more processing. Check the right as well before deciding what to do. */ if (pc_right < part_right) { /* We have two partitions to be sorted. Stack the biggest one and process the smallest one on the next iteration. This minimizes the stack height by insuring that any additional stack entries must come from the smallest partition which (because it is smallest) will have the fewest opportunities to generate additional stack entries. */ if ((part_right - pc_right) > (pc_left - part_left)) { /* stack the right partition, process the left */ partition_stack[next_stack_entry].left = pc_right + 1; partition_stack[next_stack_entry].right = part_right; #ifdef QSORT_ORDER_GUESS partition_stack[next_stack_entry].qsort_break_even = qsort_break_even; #endif part_right = pc_left - 1; } else { /* stack the left partition, process the right */ partition_stack[next_stack_entry].left = part_left; partition_stack[next_stack_entry].right = pc_left - 1; #ifdef QSORT_ORDER_GUESS partition_stack[next_stack_entry].qsort_break_even = qsort_break_even; #endif part_left = pc_right + 1; } qsort_assert(next_stack_entry < QSORT_MAX_STACK); ++next_stack_entry; } else { /* The elements on the left are the only remaining elements that need sorting, arrange for them to be processed as the next partition. */ part_right = pc_left - 1; } } else if (pc_right < part_right) { /* There is only one chunk on the right to be sorted, make it the new partition and loop back around. */ part_left = pc_right + 1; } else { /* This whole partition wound up in the pivot chunk, so we need to get a new partition off the stack. */ if (next_stack_entry == 0) { /* the stack is empty - we are done */ break; } --next_stack_entry; part_left = partition_stack[next_stack_entry].left; part_right = partition_stack[next_stack_entry].right; #ifdef QSORT_ORDER_GUESS qsort_break_even = partition_stack[next_stack_entry].qsort_break_even; #endif } } else { /* This partition is too small to fool with qsort complexity, just do an ordinary insertion sort to minimize overhead. */ int i; /* Assume 1st element is in right place already, and start checking at 2nd element to see where it should be inserted. */ for (i = part_left + 1; i <= part_right; ++i) { int j; /* Scan (backwards - just in case 'i' is already in right place) through the elements already sorted to see if the ith element belongs ahead of one of them. */ for (j = i - 1; j >= part_left; --j) { if (qsort_cmp(i, j) >= 0) { /* i belongs right after j */ break; } } ++j; if (j != i) { /* Looks like we really need to move some things */ int k; temp = array[i]; for (k = i - 1; k >= j; --k) array[k + 1] = array[k]; array[j] = temp; } } /* That partition is now sorted, grab the next one, or get out of the loop if there aren't any more. */ if (next_stack_entry == 0) { /* the stack is empty - we are done */ break; } --next_stack_entry; part_left = partition_stack[next_stack_entry].left; part_right = partition_stack[next_stack_entry].right; #ifdef QSORT_ORDER_GUESS qsort_break_even = partition_stack[next_stack_entry].qsort_break_even; #endif } } /* Believe it or not, the array is sorted at this point! */ } /* Stabilize what is, presumably, an otherwise unstable sort method. * We do that by allocating (or having on hand) an array of pointers * that is the same size as the original array of elements to be sorted. * We initialize this parallel array with the addresses of the original * array elements. This indirection can make you crazy. * Some pictures can help. After initializing, we have * * indir list1 * +----+ +----+ * | | --------------> | | ------> first element to be sorted * +----+ +----+ * | | --------------> | | ------> second element to be sorted * +----+ +----+ * | | --------------> | | ------> third element to be sorted * +----+ +----+ * ... * +----+ +----+ * | | --------------> | | ------> n-1st element to be sorted * +----+ +----+ * | | --------------> | | ------> n-th element to be sorted * +----+ +----+ * * During the sort phase, we leave the elements of list1 where they are, * and sort the pointers in the indirect array in the same order determined * by the original comparison routine on the elements pointed to. * Because we don't move the elements of list1 around through * this phase, we can break ties on elements that compare equal * using their address in the list1 array, ensuring stability. * This leaves us with something looking like * * indir list1 * +----+ +----+ * | | --+ +---> | | ------> first element to be sorted * +----+ | | +----+ * | | --|-------|---> | | ------> second element to be sorted * +----+ | | +----+ * | | --|-------+ +-> | | ------> third element to be sorted * +----+ | | +----+ * ... * +----+ | | | | +----+ * | | ---|-+ | +--> | | ------> n-1st element to be sorted * +----+ | | +----+ * | | ---+ +----> | | ------> n-th element to be sorted * +----+ +----+ * * where the i-th element of the indirect array points to the element * that should be i-th in the sorted array. After the sort phase, * we have to put the elements of list1 into the places * dictated by the indirect array. */ static I32 cmpindir(pTHX_ gptr const a, gptr const b) { dVAR; gptr * const ap = (gptr *)a; gptr * const bp = (gptr *)b; const I32 sense = PL_sort_RealCmp(aTHX_ *ap, *bp); if (sense) return sense; return (ap > bp) ? 1 : ((ap < bp) ? -1 : 0); } static I32 cmpindir_desc(pTHX_ gptr const a, gptr const b) { dVAR; gptr * const ap = (gptr *)a; gptr * const bp = (gptr *)b; const I32 sense = PL_sort_RealCmp(aTHX_ *ap, *bp); /* Reverse the default */ if (sense) return -sense; /* But don't reverse the stability test. */ return (ap > bp) ? 1 : ((ap < bp) ? -1 : 0); } STATIC void S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp, U32 flags) { dVAR; if ((flags & SORTf_STABLE) != 0) { register gptr **pp, *q; register size_t n, j, i; gptr *small[SMALLSORT], **indir, tmp; SVCOMPARE_t savecmp; if (nmemb <= 1) return; /* sorted trivially */ /* Small arrays can use the stack, big ones must be allocated */ if (nmemb <= SMALLSORT) indir = small; else { Newx(indir, nmemb, gptr *); } /* Copy pointers to original array elements into indirect array */ for (n = nmemb, pp = indir, q = list1; n--; ) *pp++ = q++; savecmp = PL_sort_RealCmp; /* Save current comparison routine, if any */ PL_sort_RealCmp = cmp; /* Put comparison routine where cmpindir can find it */ /* sort, with indirection */ if (flags & SORTf_DESC) qsortsvu((gptr *)indir, nmemb, cmpindir_desc); else qsortsvu((gptr *)indir, nmemb, cmpindir); pp = indir; q = list1; for (n = nmemb; n--; ) { /* Assert A: all elements of q with index > n are already * in place. This is vacuosly true at the start, and we * put element n where it belongs below (if it wasn't * already where it belonged). Assert B: we only move * elements that aren't where they belong, * so, by A, we never tamper with elements above n. */ j = pp[n] - q; /* This sets j so that q[j] is * at pp[n]. *pp[j] belongs in * q[j], by construction. */ if (n != j) { /* all's well if n == j */ tmp = q[j]; /* save what's in q[j] */ do { q[j] = *pp[j]; /* put *pp[j] where it belongs */ i = pp[j] - q; /* the index in q of the element * just moved */ pp[j] = q + j; /* this is ok now */ } while ((j = i) != n); /* There are only finitely many (nmemb) addresses * in the pp array. * So we must eventually revisit an index we saw before. * Suppose the first revisited index is k != n. * An index is visited because something else belongs there. * If we visit k twice, then two different elements must * belong in the same place, which cannot be. * So j must get back to n, the loop terminates, * and we put the saved element where it belongs. */ q[n] = tmp; /* put what belongs into * the n-th element */ } } /* free iff allocated */ if (indir != small) { Safefree(indir); } /* restore prevailing comparison routine */ PL_sort_RealCmp = savecmp; } else if ((flags & SORTf_DESC) != 0) { const SVCOMPARE_t savecmp = PL_sort_RealCmp; /* Save current comparison routine, if any */ PL_sort_RealCmp = cmp; /* Put comparison routine where cmp_desc can find it */ cmp = cmp_desc; qsortsvu(list1, nmemb, cmp); /* restore prevailing comparison routine */ PL_sort_RealCmp = savecmp; } else { qsortsvu(list1, nmemb, cmp); } } /* =head1 Array Manipulation Functions =for apidoc sortsv Sort an array. Here is an example: sortsv(AvARRAY(av), av_len(av)+1, Perl_sv_cmp_locale); Currently this always uses mergesort. See sortsv_flags for a more flexible routine. =cut */ void Perl_sortsv(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp) { PERL_ARGS_ASSERT_SORTSV; sortsv_flags(array, nmemb, cmp, 0); } /* =for apidoc sortsv_flags Sort an array, with various options. =cut */ void Perl_sortsv_flags(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp, U32 flags) { PERL_ARGS_ASSERT_SORTSV_FLAGS; if (flags & SORTf_QSORT) S_qsortsv(aTHX_ array, nmemb, cmp, flags); else S_mergesortsv(aTHX_ array, nmemb, cmp, flags); } #define SvNSIOK(sv) ((SvFLAGS(sv) & SVf_NOK) || ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV)) == SVf_IOK)) #define SvSIOK(sv) ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV)) == SVf_IOK) #define SvNSIV(sv) ( SvNOK(sv) ? SvNVX(sv) : ( SvSIOK(sv) ? SvIVX(sv) : sv_2nv(sv) ) ) PP(pp_sort) { dVAR; dSP; dMARK; dORIGMARK; register SV **p1 = ORIGMARK+1, **p2; register I32 max, i; AV* av = NULL; HV *stash; GV *gv; CV *cv = NULL; I32 gimme = GIMME; OP* const nextop = PL_op->op_next; I32 overloading = 0; bool hasargs = FALSE; I32 is_xsub = 0; I32 sorting_av = 0; const U8 priv = PL_op->op_private; const U8 flags = PL_op->op_flags; U32 sort_flags = 0; void (*sortsvp)(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp, U32 flags) = Perl_sortsv_flags; I32 all_SIVs = 1; if ((priv & OPpSORT_DESCEND) != 0) sort_flags |= SORTf_DESC; if ((priv & OPpSORT_QSORT) != 0) sort_flags |= SORTf_QSORT; if ((priv & OPpSORT_STABLE) != 0) sort_flags |= SORTf_STABLE; if (gimme != G_ARRAY) { SP = MARK; EXTEND(SP,1); RETPUSHUNDEF; } ENTER; SAVEVPTR(PL_sortcop); if (flags & OPf_STACKED) { if (flags & OPf_SPECIAL) { OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */ kid = kUNOP->op_first; /* pass rv2gv */ kid = kUNOP->op_first; /* pass leave */ PL_sortcop = kid->op_next; stash = CopSTASH(PL_curcop); } else { cv = sv_2cv(*++MARK, &stash, &gv, 0); if (cv && SvPOK(cv)) { const char * const proto = SvPV_nolen_const(MUTABLE_SV(cv)); if (proto && strEQ(proto, "$$")) { hasargs = TRUE; } } if (!(cv && CvROOT(cv))) { if (cv && CvISXSUB(cv)) { is_xsub = 1; } else if (gv) { SV *tmpstr = sv_newmortal(); gv_efullname3(tmpstr, gv, NULL); DIE(aTHX_ "Undefined sort subroutine \"%"SVf"\" called", SVfARG(tmpstr)); } else { DIE(aTHX_ "Undefined subroutine in sort"); } } if (is_xsub) PL_sortcop = (OP*)cv; else PL_sortcop = CvSTART(cv); } } else { PL_sortcop = NULL; stash = CopSTASH(PL_curcop); } /* optimiser converts "@a = sort @a" to "sort \@a"; * in case of tied @a, pessimise: push (@a) onto stack, then assign * result back to @a at the end of this function */ if (priv & OPpSORT_INPLACE) { assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV); (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */ av = MUTABLE_AV((*SP)); max = AvFILL(av) + 1; if (SvMAGICAL(av)) { MEXTEND(SP, max); for (i=0; i < max; i++) { SV **svp = av_fetch(av, i, FALSE); *SP++ = (svp) ? *svp : NULL; } SP--; p1 = p2 = SP - (max-1); } else { if (SvREADONLY(av)) Perl_croak(aTHX_ "%s", PL_no_modify); else SvREADONLY_on(av); p1 = p2 = AvARRAY(av); sorting_av = 1; } } else { p2 = MARK+1; max = SP - MARK; } /* shuffle stack down, removing optional initial cv (p1!=p2), plus * any nulls; also stringify or converting to integer or number as * required any args */ for (i=max; i > 0 ; i--) { if ((*p1 = *p2++)) { /* Weed out nulls. */ SvTEMP_off(*p1); if (!PL_sortcop) { if (priv & OPpSORT_NUMERIC) { if (priv & OPpSORT_INTEGER) { if (!SvIOK(*p1)) { if (SvAMAGIC(*p1)) overloading = 1; else (void)sv_2iv(*p1); } } else { if (!SvNSIOK(*p1)) { if (SvAMAGIC(*p1)) overloading = 1; else (void)sv_2nv(*p1); } if (all_SIVs && !SvSIOK(*p1)) all_SIVs = 0; } } else { if (!SvPOK(*p1)) { if (SvAMAGIC(*p1)) overloading = 1; else (void)sv_2pv_flags(*p1, 0, SV_GMAGIC|SV_CONST_RETURN); } } } p1++; } else max--; } if (sorting_av) AvFILLp(av) = max-1; if (max > 1) { SV **start; if (PL_sortcop) { PERL_CONTEXT *cx; SV** newsp; const bool oldcatch = CATCH_GET; SAVETMPS; SAVEOP(); CATCH_SET(TRUE); PUSHSTACKi(PERLSI_SORT); if (!hasargs && !is_xsub) { SAVESPTR(PL_firstgv); SAVESPTR(PL_secondgv); SAVESPTR(PL_sortstash); PL_firstgv = gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV); PL_secondgv = gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV); PL_sortstash = stash; SAVESPTR(GvSV(PL_firstgv)); SAVESPTR(GvSV(PL_secondgv)); } PUSHBLOCK(cx, CXt_NULL, PL_stack_base); if (!(flags & OPf_SPECIAL)) { cx->cx_type = CXt_SUB; cx->blk_gimme = G_SCALAR; /* If our comparison routine is already active (CvDEPTH is * is not 0), then PUSHSUB does not increase the refcount, * so we have to do it ourselves, because the LEAVESUB fur- * ther down lowers it. */ if (CvDEPTH(cv)) SvREFCNT_inc_simple_void_NN(cv); PUSHSUB(cx); if (!is_xsub) { AV* const padlist = CvPADLIST(cv); if (++CvDEPTH(cv) >= 2) { PERL_STACK_OVERFLOW_CHECK(); pad_push(padlist, CvDEPTH(cv)); } SAVECOMPPAD(); PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); if (hasargs) { /* This is mostly copied from pp_entersub */ AV * const av = MUTABLE_AV(PAD_SVl(0)); cx->blk_sub.savearray = GvAV(PL_defgv); GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av)); CX_CURPAD_SAVE(cx->blk_sub); cx->blk_sub.argarray = av; } } } cx->cx_type |= CXp_MULTICALL; start = p1 - max; sortsvp(aTHX_ start, max, (is_xsub ? S_sortcv_xsub : hasargs ? S_sortcv_stacked : S_sortcv), sort_flags); if (!(flags & OPf_SPECIAL)) { LEAVESUB(cv); if (!is_xsub) CvDEPTH(cv)--; } POPBLOCK(cx,PL_curpm); PL_stack_sp = newsp; POPSTACK; CATCH_SET(oldcatch); } else { MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */ start = sorting_av ? AvARRAY(av) : ORIGMARK+1; sortsvp(aTHX_ start, max, (priv & OPpSORT_NUMERIC) ? ( ( ( priv & OPpSORT_INTEGER) || all_SIVs) ? ( overloading ? S_amagic_i_ncmp : S_sv_i_ncmp) : ( overloading ? S_amagic_ncmp : S_sv_ncmp ) ) : ( IN_LOCALE_RUNTIME ? ( overloading ? (SVCOMPARE_t)S_amagic_cmp_locale : (SVCOMPARE_t)sv_cmp_locale_static) : ( overloading ? (SVCOMPARE_t)S_amagic_cmp : (SVCOMPARE_t)sv_cmp_static)), sort_flags); } if ((priv & OPpSORT_REVERSE) != 0) { SV **q = start+max-1; while (start < q) { SV * const tmp = *start; *start++ = *q; *q-- = tmp; } } } if (sorting_av) SvREADONLY_off(av); else if (av && !sorting_av) { /* simulate pp_aassign of tied AV */ SV** const base = MARK+1; for (i=0; i < max; i++) { base[i] = newSVsv(base[i]); } av_clear(av); av_extend(av, max); for (i=0; i < max; i++) { SV * const sv = base[i]; SV ** const didstore = av_store(av, i, sv); if (SvSMAGICAL(sv)) mg_set(sv); if (!didstore) sv_2mortal(sv); } } LEAVE; PL_stack_sp = ORIGMARK + (sorting_av ? 0 : max); return nextop; } static I32 S_sortcv(pTHX_ SV *const a, SV *const b) { dVAR; const I32 oldsaveix = PL_savestack_ix; const I32 oldscopeix = PL_scopestack_ix; I32 result; PERL_ARGS_ASSERT_SORTCV; GvSV(PL_firstgv) = a; GvSV(PL_secondgv) = b; PL_stack_sp = PL_stack_base; PL_op = PL_sortcop; CALLRUNOPS(aTHX); if (PL_stack_sp != PL_stack_base + 1) Perl_croak(aTHX_ "Sort subroutine didn't return single value"); result = SvIV(*PL_stack_sp); while (PL_scopestack_ix > oldscopeix) { LEAVE; } leave_scope(oldsaveix); return result; } static I32 S_sortcv_stacked(pTHX_ SV *const a, SV *const b) { dVAR; const I32 oldsaveix = PL_savestack_ix; const I32 oldscopeix = PL_scopestack_ix; I32 result; AV * const av = GvAV(PL_defgv); PERL_ARGS_ASSERT_SORTCV_STACKED; if (AvMAX(av) < 1) { SV** ary = AvALLOC(av); if (AvARRAY(av) != ary) { AvMAX(av) += AvARRAY(av) - AvALLOC(av); AvARRAY(av) = ary; } if (AvMAX(av) < 1) { AvMAX(av) = 1; Renew(ary,2,SV*); AvARRAY(av) = ary; } } AvFILLp(av) = 1; AvARRAY(av)[0] = a; AvARRAY(av)[1] = b; PL_stack_sp = PL_stack_base; PL_op = PL_sortcop; CALLRUNOPS(aTHX); if (PL_stack_sp != PL_stack_base + 1) Perl_croak(aTHX_ "Sort subroutine didn't return single value"); result = SvIV(*PL_stack_sp); while (PL_scopestack_ix > oldscopeix) { LEAVE; } leave_scope(oldsaveix); return result; } static I32 S_sortcv_xsub(pTHX_ SV *const a, SV *const b) { dVAR; dSP; const I32 oldsaveix = PL_savestack_ix; const I32 oldscopeix = PL_scopestack_ix; CV * const cv=MUTABLE_CV(PL_sortcop); I32 result; PERL_ARGS_ASSERT_SORTCV_XSUB; SP = PL_stack_base; PUSHMARK(SP); EXTEND(SP, 2); *++SP = a; *++SP = b; PUTBACK; (void)(*CvXSUB(cv))(aTHX_ cv); if (PL_stack_sp != PL_stack_base + 1) Perl_croak(aTHX_ "Sort subroutine didn't return single value"); result = SvIV(*PL_stack_sp); while (PL_scopestack_ix > oldscopeix) { LEAVE; } leave_scope(oldsaveix); return result; } static I32 S_sv_ncmp(pTHX_ SV *const a, SV *const b) { const NV nv1 = SvNSIV(a); const NV nv2 = SvNSIV(b); PERL_ARGS_ASSERT_SV_NCMP; return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0; } static I32 S_sv_i_ncmp(pTHX_ SV *const a, SV *const b) { const IV iv1 = SvIV(a); const IV iv2 = SvIV(b); PERL_ARGS_ASSERT_SV_I_NCMP; return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0; } #define tryCALL_AMAGICbin(left,right,meth) \ (PL_amagic_generation && (SvAMAGIC(left)||SvAMAGIC(right))) \ ? amagic_call(left, right, CAT2(meth,_amg), 0) \ : NULL; #define SORT_NORMAL_RETURN_VALUE(val) (((val) > 0) ? 1 : ((val) ? -1 : 0)) static I32 S_amagic_ncmp(pTHX_ register SV *const a, register SV *const b) { dVAR; SV * const tmpsv = tryCALL_AMAGICbin(a,b,ncmp); PERL_ARGS_ASSERT_AMAGIC_NCMP; if (tmpsv) { if (SvIOK(tmpsv)) { const I32 i = SvIVX(tmpsv); return SORT_NORMAL_RETURN_VALUE(i); } else { const NV d = SvNV(tmpsv); return SORT_NORMAL_RETURN_VALUE(d); } } return S_sv_ncmp(aTHX_ a, b); } static I32 S_amagic_i_ncmp(pTHX_ register SV *const a, register SV *const b) { dVAR; SV * const tmpsv = tryCALL_AMAGICbin(a,b,ncmp); PERL_ARGS_ASSERT_AMAGIC_I_NCMP; if (tmpsv) { if (SvIOK(tmpsv)) { const I32 i = SvIVX(tmpsv); return SORT_NORMAL_RETURN_VALUE(i); } else { const NV d = SvNV(tmpsv); return SORT_NORMAL_RETURN_VALUE(d); } } return S_sv_i_ncmp(aTHX_ a, b); } static I32 S_amagic_cmp(pTHX_ register SV *const str1, register SV *const str2) { dVAR; SV * const tmpsv = tryCALL_AMAGICbin(str1,str2,scmp); PERL_ARGS_ASSERT_AMAGIC_CMP; if (tmpsv) { if (SvIOK(tmpsv)) { const I32 i = SvIVX(tmpsv); return SORT_NORMAL_RETURN_VALUE(i); } else { const NV d = SvNV(tmpsv); return SORT_NORMAL_RETURN_VALUE(d); } } return sv_cmp(str1, str2); } static I32 S_amagic_cmp_locale(pTHX_ register SV *const str1, register SV *const str2) { dVAR; SV * const tmpsv = tryCALL_AMAGICbin(str1,str2,scmp); PERL_ARGS_ASSERT_AMAGIC_CMP_LOCALE; if (tmpsv) { if (SvIOK(tmpsv)) { const I32 i = SvIVX(tmpsv); return SORT_NORMAL_RETURN_VALUE(i); } else { const NV d = SvNV(tmpsv); return SORT_NORMAL_RETURN_VALUE(d); } } return sv_cmp_locale(str1, str2); } /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */ perl-5.12.0-RC0/iperlsys.h0000444000175000017500000013722011325125741014156 0ustar jessejesse/* * iperlsys.h - Perl's interface to the system * * This file defines the system level functionality that perl needs. * * When using C, this definition is in the form of a set of macros * that can be #defined to the system-level function (or a wrapper * provided elsewhere). * * GSAR 21-JUN-98 */ #ifndef __Inc__IPerl___ #define __Inc__IPerl___ /* * PerlXXX_YYY explained - DickH and DougL @ ActiveState.com * * XXX := functional group * YYY := stdlib/OS function name * * Continuing with the theme of PerlIO, all OS functionality was * encapsulated into one of several interfaces. * * PerlIO - stdio * PerlLIO - low level I/O * PerlMem - malloc, realloc, free * PerlDir - directory related * PerlEnv - process environment handling * PerlProc - process control * PerlSock - socket functions * * * The features of this are: * 1. All OS dependant code is in the Perl Host and not the Perl Core. * (At least this is the holy grail goal of this work) * 2. The Perl Host (see perl.h for description) can provide a new and * improved interface to OS functionality if required. * 3. Developers can easily hook into the OS calls for instrumentation * or diagnostic purposes. * * What was changed to do this: * 1. All calls to OS functions were replaced with PerlXXX_YYY * */ /* Interface for perl stdio functions, or whatever we are Configure-d to use. */ #include "perlio.h" #ifndef Sighandler_t # if defined(HAS_SIGACTION) && defined(SA_SIGINFO) typedef Signal_t (*Sighandler_t) (int, siginfo_t*, void*); # else typedef Signal_t (*Sighandler_t) (int); # endif #endif #if defined(PERL_IMPLICIT_SYS) /* IPerlStdIO */ struct IPerlStdIO; struct IPerlStdIOInfo; typedef FILE* (*LPStdin)(struct IPerlStdIO*); typedef FILE* (*LPStdout)(struct IPerlStdIO*); typedef FILE* (*LPStderr)(struct IPerlStdIO*); typedef FILE* (*LPOpen)(struct IPerlStdIO*, const char*, const char*); typedef int (*LPClose)(struct IPerlStdIO*, FILE*); typedef int (*LPEof)(struct IPerlStdIO*, FILE*); typedef int (*LPError)(struct IPerlStdIO*, FILE*); typedef void (*LPClearerr)(struct IPerlStdIO*, FILE*); typedef int (*LPGetc)(struct IPerlStdIO*, FILE*); typedef STDCHAR* (*LPGetBase)(struct IPerlStdIO*, FILE*); typedef int (*LPGetBufsiz)(struct IPerlStdIO*, FILE*); typedef int (*LPGetCnt)(struct IPerlStdIO*, FILE*); typedef STDCHAR* (*LPGetPtr)(struct IPerlStdIO*, FILE*); typedef char* (*LPGets)(struct IPerlStdIO*, FILE*, char*, int); typedef int (*LPPutc)(struct IPerlStdIO*, FILE*, int); typedef int (*LPPuts)(struct IPerlStdIO*, FILE*, const char*); typedef int (*LPFlush)(struct IPerlStdIO*, FILE*); 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*); 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); typedef void (*LPSetCnt)(struct IPerlStdIO*, FILE*, int); #ifndef NETWARE typedef void (*LPSetPtr)(struct IPerlStdIO*, FILE*, STDCHAR*); #elif defined(NETWARE) typedef void (*LPSetPtr)(struct IPerlStdIO*, FILE*, STDCHAR*, int); #endif typedef void (*LPSetlinebuf)(struct IPerlStdIO*, FILE*); typedef int (*LPPrintf)(struct IPerlStdIO*, FILE*, const char*, ...); typedef int (*LPVprintf)(struct IPerlStdIO*, FILE*, const char*, 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*); typedef void (*LPInit)(struct IPerlStdIO*); typedef void (*LPInitOSExtras)(struct IPerlStdIO*); typedef FILE* (*LPFdupopen)(struct IPerlStdIO*, FILE*); struct IPerlStdIO { LPStdin pStdin; LPStdout pStdout; LPStderr pStderr; LPOpen pOpen; LPClose pClose; LPEof pEof; LPError pError; LPClearerr pClearerr; LPGetc pGetc; LPGetBase pGetBase; LPGetBufsiz pGetBufsiz; LPGetCnt pGetCnt; LPGetPtr pGetPtr; LPGets pGets; LPPutc pPutc; LPPuts pPuts; LPFlush pFlush; LPUngetc pUngetc; LPFileno pFileno; LPFdopen pFdopen; LPReopen pReopen; LPRead pRead; LPWrite pWrite; LPSetBuf pSetBuf; LPSetVBuf pSetVBuf; LPSetCnt pSetCnt; LPSetPtr pSetPtr; LPSetlinebuf pSetlinebuf; LPPrintf pPrintf; LPVprintf pVprintf; LPTell pTell; LPSeek pSeek; LPRewind pRewind; LPTmpfile pTmpfile; LPGetpos pGetpos; LPSetpos pSetpos; LPInit pInit; LPInitOSExtras pInitOSExtras; LPFdupopen pFdupopen; }; struct IPerlStdIOInfo { unsigned long nCount; /* number of entries expected */ struct IPerlStdIO perlStdIOList; }; /* These do not belong here ... NI-S, 14 Nov 2000 */ #ifdef USE_STDIO_PTR # define PerlSIO_has_cntptr(f) 1 # ifdef STDIO_PTR_LVALUE # ifdef STDIO_CNT_LVALUE # define PerlSIO_canset_cnt(f) 1 # ifdef STDIO_PTR_LVAL_NOCHANGE_CNT # define PerlSIO_fast_gets(f) 1 # endif # else /* STDIO_CNT_LVALUE */ # define PerlSIO_canset_cnt(f) 0 # endif # else /* STDIO_PTR_LVALUE */ # ifdef STDIO_PTR_LVAL_SETS_CNT # define PerlSIO_fast_gets(f) 1 # endif # endif #else /* USE_STDIO_PTR */ # define PerlSIO_has_cntptr(f) 0 # define PerlSIO_canset_cnt(f) 0 #endif /* USE_STDIO_PTR */ #ifndef PerlSIO_fast_gets #define PerlSIO_fast_gets(f) 0 #endif #ifdef FILE_base #define PerlSIO_has_base(f) 1 #else #define PerlSIO_has_base(f) 0 #endif /* Now take FILE * via function table */ #define PerlSIO_stdin \ (*PL_StdIO->pStdin)(PL_StdIO) #define PerlSIO_stdout \ (*PL_StdIO->pStdout)(PL_StdIO) #define PerlSIO_stderr \ (*PL_StdIO->pStderr)(PL_StdIO) #define PerlSIO_fopen(x,y) \ (*PL_StdIO->pOpen)(PL_StdIO, (x),(y)) #define PerlSIO_fclose(f) \ (*PL_StdIO->pClose)(PL_StdIO, (f)) #define PerlSIO_feof(f) \ (*PL_StdIO->pEof)(PL_StdIO, (f)) #define PerlSIO_ferror(f) \ (*PL_StdIO->pError)(PL_StdIO, (f)) #define PerlSIO_clearerr(f) \ (*PL_StdIO->pClearerr)(PL_StdIO, (f)) #define PerlSIO_fgetc(f) \ (*PL_StdIO->pGetc)(PL_StdIO, (f)) #define PerlSIO_get_base(f) \ (*PL_StdIO->pGetBase)(PL_StdIO, (f)) #define PerlSIO_get_bufsiz(f) \ (*PL_StdIO->pGetBufsiz)(PL_StdIO, (f)) #define PerlSIO_get_cnt(f) \ (*PL_StdIO->pGetCnt)(PL_StdIO, (f)) #define PerlSIO_get_ptr(f) \ (*PL_StdIO->pGetPtr)(PL_StdIO, (f)) #define PerlSIO_fputc(f,c) \ (*PL_StdIO->pPutc)(PL_StdIO, (f),(c)) #define PerlSIO_fputs(f,s) \ (*PL_StdIO->pPuts)(PL_StdIO, (f),(s)) #define PerlSIO_fflush(f) \ (*PL_StdIO->pFlush)(PL_StdIO, (f)) #define PerlSIO_fgets(s, n, fp) \ (*PL_StdIO->pGets)(PL_StdIO, (fp), s, n) #define PerlSIO_ungetc(c,f) \ (*PL_StdIO->pUngetc)(PL_StdIO, (c),(f)) #define PerlSIO_fileno(f) \ (*PL_StdIO->pFileno)(PL_StdIO, (f)) #define PerlSIO_fdopen(f, s) \ (*PL_StdIO->pFdopen)(PL_StdIO, (f),(s)) #define PerlSIO_freopen(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)) #define PerlSIO_fwrite(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)) #define PerlSIO_setvbuf(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)) #define PerlSIO_set_ptr(f,p) \ (*PL_StdIO->pSetPtr)(PL_StdIO, (f), (p)) #define PerlSIO_setlinebuf(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) #define PerlSIO_ftell(f) \ (*PL_StdIO->pTell)(PL_StdIO, (f)) #define PerlSIO_fseek(f,o,w) \ (*PL_StdIO->pSeek)(PL_StdIO, (f),(o),(w)) #define PerlSIO_fgetpos(f,p) \ (*PL_StdIO->pGetpos)(PL_StdIO, (f),(p)) #define PerlSIO_fsetpos(f,p) \ (*PL_StdIO->pSetpos)(PL_StdIO, (f),(p)) #define PerlSIO_rewind(f) \ (*PL_StdIO->pRewind)(PL_StdIO, (f)) #define PerlSIO_tmpfile() \ (*PL_StdIO->pTmpfile)(PL_StdIO) #define PerlSIO_init() \ (*PL_StdIO->pInit)(PL_StdIO) #undef init_os_extras #define init_os_extras() \ (*PL_StdIO->pInitOSExtras)(PL_StdIO) #define PerlSIO_fdupopen(f) \ (*PL_StdIO->pFdupopen)(PL_StdIO, (f)) #else /* PERL_IMPLICIT_SYS */ #define PerlSIO_stdin stdin #define PerlSIO_stdout stdout #define PerlSIO_stderr stderr #define PerlSIO_fopen(x,y) fopen(x,y) #ifdef __VOS__ /* Work around VOS bug posix-979, wrongly setting errno when at end of file. */ #define PerlSIO_fclose(f) (((errno==1025)?errno=0:0),fclose(f)) #define PerlSIO_feof(f) (((errno==1025)?errno=0:0),feof(f)) #define PerlSIO_ferror(f) (((errno==1025)?errno=0:0),ferror(f)) #else #define PerlSIO_fclose(f) fclose(f) #define PerlSIO_feof(f) feof(f) #define PerlSIO_ferror(f) ferror(f) #endif #define PerlSIO_clearerr(f) clearerr(f) #define PerlSIO_fgetc(f) fgetc(f) #ifdef FILE_base #define PerlSIO_get_base(f) FILE_base(f) #define PerlSIO_get_bufsiz(f) FILE_bufsiz(f) #else #define PerlSIO_get_base(f) NULL #define PerlSIO_get_bufsiz(f) 0 #endif #ifdef USE_STDIO_PTR #define PerlSIO_get_cnt(f) FILE_cnt(f) #define PerlSIO_get_ptr(f) FILE_ptr(f) #else #define PerlSIO_get_cnt(f) 0 #define PerlSIO_get_ptr(f) NULL #endif #define PerlSIO_fputc(f,c) fputc(c,f) #define PerlSIO_fputs(f,s) fputs(s,f) #define PerlSIO_fflush(f) Fflush(f) #define PerlSIO_fgets(s, n, fp) fgets(s,n,fp) #if defined(VMS) && defined(__DECC) /* Unusual definition of ungetc() here to accomodate fast_sv_gets()' * belief that it can mix getc/ungetc with reads from stdio buffer */ int decc$ungetc(int __c, FILE *__stream); # define PerlSIO_ungetc(c,f) ((c) == EOF ? EOF : \ ((*(f) && !((*(f))->_flag & _IONBF) && \ ((*(f))->_ptr > (*(f))->_base)) ? \ ((*(f))->_cnt++, *(--(*(f))->_ptr) = (c)) : decc$ungetc(c,f))) #else # define PerlSIO_ungetc(c,f) ungetc(c,f) #endif #define PerlSIO_fileno(f) fileno(f) #define PerlSIO_fdopen(f, s) fdopen(f,s) #define PerlSIO_freopen(p, m, f) freopen(p,m,f) #define PerlSIO_fread(buf,sz,count,f) fread(buf,sz,count,f) #define PerlSIO_fwrite(buf,sz,count,f) fwrite(buf,sz,count,f) #define PerlSIO_setbuf(f,b) setbuf(f,b) #define PerlSIO_setvbuf(f,b,t,s) setvbuf(f,b,t,s) #if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE) #define PerlSIO_set_cnt(f,c) FILE_cnt(f) = (c) #else #define PerlSIO_set_cnt(f,c) PerlIOProc_abort() #endif #if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) #define PerlSIO_set_ptr(f,p) (FILE_ptr(f) = (p)) #else #define PerlSIO_set_ptr(f,p) PerlIOProc_abort() #endif #define PerlSIO_setlinebuf(f) setlinebuf(f) #define PerlSIO_printf fprintf #define PerlSIO_stdoutf printf #define PerlSIO_vprintf(f,fmt,a) vfprintf(f,fmt,a) #define PerlSIO_ftell(f) ftell(f) #define PerlSIO_fseek(f,o,w) fseek(f,o,w) #define PerlSIO_fgetpos(f,p) fgetpos(f,p) #define PerlSIO_fsetpos(f,p) fsetpos(f,p) #define PerlSIO_rewind(f) rewind(f) #define PerlSIO_tmpfile() tmpfile() #define PerlSIO_fdupopen(f) (f) #endif /* PERL_IMPLICIT_SYS */ /* * Interface for directory functions */ #if defined(PERL_IMPLICIT_SYS) /* IPerlDir */ struct IPerlDir; struct IPerlDirInfo; typedef int (*LPMakedir)(struct IPerlDir*, const char*, int); typedef int (*LPChdir)(struct IPerlDir*, const char*); typedef int (*LPRmdir)(struct IPerlDir*, const char*); typedef int (*LPDirClose)(struct IPerlDir*, DIR*); typedef DIR* (*LPDirOpen)(struct IPerlDir*, const char*); typedef struct direct* (*LPDirRead)(struct IPerlDir*, DIR*); typedef void (*LPDirRewind)(struct IPerlDir*, DIR*); typedef void (*LPDirSeek)(struct IPerlDir*, DIR*, long); typedef long (*LPDirTell)(struct IPerlDir*, DIR*); #ifdef WIN32 typedef char* (*LPDirMapPathA)(struct IPerlDir*, const char*); typedef WCHAR* (*LPDirMapPathW)(struct IPerlDir*, const WCHAR*); #endif struct IPerlDir { LPMakedir pMakedir; LPChdir pChdir; LPRmdir pRmdir; LPDirClose pClose; LPDirOpen pOpen; LPDirRead pRead; LPDirRewind pRewind; LPDirSeek pSeek; LPDirTell pTell; #ifdef WIN32 LPDirMapPathA pMapPathA; LPDirMapPathW pMapPathW; #endif }; struct IPerlDirInfo { unsigned long nCount; /* number of entries expected */ struct IPerlDir perlDirList; }; #define PerlDir_mkdir(name, mode) \ (*PL_Dir->pMakedir)(PL_Dir, (name), (mode)) #define PerlDir_chdir(name) \ (*PL_Dir->pChdir)(PL_Dir, (name)) #define PerlDir_rmdir(name) \ (*PL_Dir->pRmdir)(PL_Dir, (name)) #define PerlDir_close(dir) \ (*PL_Dir->pClose)(PL_Dir, (dir)) #define PerlDir_open(name) \ (*PL_Dir->pOpen)(PL_Dir, (name)) #define PerlDir_read(dir) \ (*PL_Dir->pRead)(PL_Dir, (dir)) #define PerlDir_rewind(dir) \ (*PL_Dir->pRewind)(PL_Dir, (dir)) #define PerlDir_seek(dir, loc) \ (*PL_Dir->pSeek)(PL_Dir, (dir), (loc)) #define PerlDir_tell(dir) \ (*PL_Dir->pTell)(PL_Dir, (dir)) #ifdef WIN32 #define PerlDir_mapA(dir) \ (*PL_Dir->pMapPathA)(PL_Dir, (dir)) #define PerlDir_mapW(dir) \ (*PL_Dir->pMapPathW)(PL_Dir, (dir)) #endif #else /* PERL_IMPLICIT_SYS */ #define PerlDir_mkdir(name, mode) Mkdir((name), (mode)) #ifdef VMS # define PerlDir_chdir(n) Chdir((n)) #else # define PerlDir_chdir(name) chdir((name)) #endif #define PerlDir_rmdir(name) rmdir((name)) #define PerlDir_close(dir) closedir((dir)) #define PerlDir_open(name) opendir((name)) #define PerlDir_read(dir) readdir((dir)) #define PerlDir_rewind(dir) rewinddir((dir)) #define PerlDir_seek(dir, loc) seekdir((dir), (loc)) #define PerlDir_tell(dir) telldir((dir)) #ifdef WIN32 #define PerlDir_mapA(dir) dir #define PerlDir_mapW(dir) dir #endif #endif /* PERL_IMPLICIT_SYS */ /* Interface for perl environment functions */ #if defined(PERL_IMPLICIT_SYS) /* IPerlEnv */ struct IPerlEnv; 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); typedef int (*LPEnvUname)(struct IPerlEnv*, struct utsname *name); typedef void (*LPEnvClearenv)(struct IPerlEnv*); typedef void* (*LPEnvGetChildenv)(struct IPerlEnv*); typedef void (*LPEnvFreeChildenv)(struct IPerlEnv*, void* env); typedef char* (*LPEnvGetChilddir)(struct IPerlEnv*); 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); #endif #ifdef WIN32 typedef unsigned long (*LPEnvOsID)(struct IPerlEnv*); typedef char* (*LPEnvLibPath)(struct IPerlEnv*, const char*, STRLEN *const len); typedef char* (*LPEnvSiteLibPath)(struct IPerlEnv*, const char*, STRLEN *const len); typedef char* (*LPEnvVendorLibPath)(struct IPerlEnv*, const char*, STRLEN *const len); typedef void (*LPEnvGetChildIO)(struct IPerlEnv*, child_IO_table*); #endif struct IPerlEnv { LPEnvGetenv pGetenv; LPEnvPutenv pPutenv; LPEnvGetenv_len pGetenv_len; LPEnvUname pEnvUname; LPEnvClearenv pClearenv; LPEnvGetChildenv pGetChildenv; LPEnvFreeChildenv pFreeChildenv; LPEnvGetChilddir pGetChilddir; LPEnvFreeChilddir pFreeChilddir; #ifdef HAS_ENVGETENV LPENVGetenv pENVGetenv; LPENVGetenv_len pENVGetenv_len; #endif #ifdef WIN32 LPEnvOsID pEnvOsID; LPEnvLibPath pLibPath; LPEnvSiteLibPath pSiteLibPath; LPEnvVendorLibPath pVendorLibPath; LPEnvGetChildIO pGetChildIO; #endif }; struct IPerlEnvInfo { unsigned long nCount; /* number of entries expected */ struct IPerlEnv perlEnvList; }; #define PerlEnv_putenv(str) \ (*PL_Env->pPutenv)(PL_Env,(str)) #define PerlEnv_getenv(str) \ (*PL_Env->pGetenv)(PL_Env,(str)) #define PerlEnv_getenv_len(str,l) \ (*PL_Env->pGetenv_len)(PL_Env,(str), (l)) #define PerlEnv_clearenv() \ (*PL_Env->pClearenv)(PL_Env) #define PerlEnv_get_childenv() \ (*PL_Env->pGetChildenv)(PL_Env) #define PerlEnv_free_childenv(e) \ (*PL_Env->pFreeChildenv)(PL_Env, (e)) #define PerlEnv_get_childdir() \ (*PL_Env->pGetChilddir)(PL_Env) #define PerlEnv_free_childdir(d) \ (*PL_Env->pFreeChilddir)(PL_Env, (d)) #ifdef HAS_ENVGETENV # define PerlEnv_ENVgetenv(str) \ (*PL_Env->pENVGetenv)(PL_Env,(str)) # define PerlEnv_ENVgetenv_len(str,l) \ (*PL_Env->pENVGetenv_len)(PL_Env,(str), (l)) #else # define PerlEnv_ENVgetenv(str) \ PerlEnv_getenv((str)) # define PerlEnv_ENVgetenv_len(str,l) \ PerlEnv_getenv_len((str),(l)) #endif #define PerlEnv_uname(name) \ (*PL_Env->pEnvUname)(PL_Env,(name)) #ifdef WIN32 #define PerlEnv_os_id() \ (*PL_Env->pEnvOsID)(PL_Env) #define PerlEnv_lib_path(str, lenp) \ (*PL_Env->pLibPath)(PL_Env,(str),(lenp)) #define PerlEnv_sitelib_path(str, lenp) \ (*PL_Env->pSiteLibPath)(PL_Env,(str),(lenp)) #define PerlEnv_vendorlib_path(str, lenp) \ (*PL_Env->pVendorLibPath)(PL_Env,(str),(lenp)) #define PerlEnv_get_child_IO(ptr) \ (*PL_Env->pGetChildIO)(PL_Env, ptr) #endif #else /* PERL_IMPLICIT_SYS */ #define PerlEnv_putenv(str) putenv((str)) #define PerlEnv_getenv(str) getenv((str)) #define PerlEnv_getenv_len(str,l) getenv_len((str), (l)) #ifdef HAS_ENVGETENV # define PerlEnv_ENVgetenv(str) ENVgetenv((str)) # define PerlEnv_ENVgetenv_len(str,l) ENVgetenv_len((str), (l)) #else # define PerlEnv_ENVgetenv(str) PerlEnv_getenv((str)) # define PerlEnv_ENVgetenv_len(str,l) PerlEnv_getenv_len((str), (l)) #endif #define PerlEnv_uname(name) uname((name)) #ifdef WIN32 #define PerlEnv_os_id() win32_os_id() #define PerlEnv_lib_path(str, lenp) win32_get_privlib(str, lenp) #define PerlEnv_sitelib_path(str, lenp) win32_get_sitelib(str, lenp) #define PerlEnv_vendorlib_path(str, lenp) win32_get_vendorlib(str, lenp) #define PerlEnv_get_child_IO(ptr) win32_get_child_IO(ptr) #define PerlEnv_clearenv() win32_clearenv() #define PerlEnv_get_childenv() win32_get_childenv() #define PerlEnv_free_childenv(e) win32_free_childenv((e)) #define PerlEnv_get_childdir() win32_get_childdir() #define PerlEnv_free_childdir(d) win32_free_childdir((d)) #else #define PerlEnv_clearenv() clearenv() #define PerlEnv_get_childenv() get_childenv() #define PerlEnv_free_childenv(e) free_childenv((e)) #define PerlEnv_get_childdir() get_childdir() #define PerlEnv_free_childdir(d) free_childdir((d)) #endif #endif /* PERL_IMPLICIT_SYS */ /* Interface for perl low-level IO functions */ #if defined(PERL_IMPLICIT_SYS) /* IPerlLIO */ struct IPerlLIO; 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); typedef int (*LPLIOChsize)(struct IPerlLIO*, int, Off_t); typedef int (*LPLIOClose)(struct IPerlLIO*, int); typedef int (*LPLIODup)(struct IPerlLIO*, int); 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*); typedef int (*LPLIOIsatty)(struct IPerlLIO*, int); typedef int (*LPLIOLink)(struct IPerlLIO*, const char*, const char *); typedef Off_t (*LPLIOLseek)(struct IPerlLIO*, int, Off_t, int); typedef int (*LPLIOLstat)(struct IPerlLIO*, const char*, 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*); #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*); 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); struct IPerlLIO { LPLIOAccess pAccess; LPLIOChmod pChmod; LPLIOChown pChown; LPLIOChsize pChsize; LPLIOClose pClose; LPLIODup pDup; LPLIODup2 pDup2; LPLIOFlock pFlock; LPLIOFileStat pFileStat; LPLIOIOCtl pIOCtl; LPLIOIsatty pIsatty; LPLIOLink pLink; LPLIOLseek pLseek; LPLIOLstat pLstat; LPLIOMktemp pMktemp; LPLIOOpen pOpen; LPLIOOpen3 pOpen3; LPLIORead pRead; LPLIORename pRename; LPLIOSetmode pSetmode; LPLIONameStat pNameStat; LPLIOTmpnam pTmpnam; LPLIOUmask pUmask; LPLIOUnlink pUnlink; LPLIOUtime pUtime; LPLIOWrite pWrite; }; struct IPerlLIOInfo { unsigned long nCount; /* number of entries expected */ struct IPerlLIO perlLIOList; }; #define PerlLIO_access(file, mode) \ (*PL_LIO->pAccess)(PL_LIO, (file), (mode)) #define PerlLIO_chmod(file, mode) \ (*PL_LIO->pChmod)(PL_LIO, (file), (mode)) #define PerlLIO_chown(file, owner, group) \ (*PL_LIO->pChown)(PL_LIO, (file), (owner), (group)) #define PerlLIO_chsize(fd, size) \ (*PL_LIO->pChsize)(PL_LIO, (fd), (size)) #define PerlLIO_close(fd) \ (*PL_LIO->pClose)(PL_LIO, (fd)) #define PerlLIO_dup(fd) \ (*PL_LIO->pDup)(PL_LIO, (fd)) #define PerlLIO_dup2(fd1, fd2) \ (*PL_LIO->pDup2)(PL_LIO, (fd1), (fd2)) #define PerlLIO_flock(fd, op) \ (*PL_LIO->pFlock)(PL_LIO, (fd), (op)) #define PerlLIO_fstat(fd, buf) \ (*PL_LIO->pFileStat)(PL_LIO, (fd), (buf)) #define PerlLIO_ioctl(fd, u, buf) \ (*PL_LIO->pIOCtl)(PL_LIO, (fd), (u), (buf)) #define PerlLIO_isatty(fd) \ (*PL_LIO->pIsatty)(PL_LIO, (fd)) #define PerlLIO_link(oldname, newname) \ (*PL_LIO->pLink)(PL_LIO, (oldname), (newname)) #define PerlLIO_lseek(fd, offset, mode) \ (*PL_LIO->pLseek)(PL_LIO, (fd), (offset), (mode)) #define PerlLIO_lstat(name, buf) \ (*PL_LIO->pLstat)(PL_LIO, (name), (buf)) #define PerlLIO_mktemp(file) \ (*PL_LIO->pMktemp)(PL_LIO, (file)) #define PerlLIO_open(file, flag) \ (*PL_LIO->pOpen)(PL_LIO, (file), (flag)) #define PerlLIO_open3(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)) #define PerlLIO_rename(oname, newname) \ (*PL_LIO->pRename)(PL_LIO, (oname), (newname)) #define PerlLIO_setmode(fd, mode) \ (*PL_LIO->pSetmode)(PL_LIO, (fd), (mode)) #define PerlLIO_stat(name, buf) \ (*PL_LIO->pNameStat)(PL_LIO, (name), (buf)) #define PerlLIO_tmpnam(str) \ (*PL_LIO->pTmpnam)(PL_LIO, (str)) #define PerlLIO_umask(mode) \ (*PL_LIO->pUmask)(PL_LIO, (mode)) #define PerlLIO_unlink(file) \ (*PL_LIO->pUnlink)(PL_LIO, (file)) #define PerlLIO_utime(file, time) \ (*PL_LIO->pUtime)(PL_LIO, (file), (time)) #define PerlLIO_write(fd, buf, count) \ (*PL_LIO->pWrite)(PL_LIO, (fd), (buf), (count)) #else /* PERL_IMPLICIT_SYS */ #define PerlLIO_access(file, mode) access((file), (mode)) #define PerlLIO_chmod(file, mode) chmod((file), (mode)) #define PerlLIO_chown(file, owner, grp) chown((file), (owner), (grp)) #if defined(HAS_TRUNCATE) # define PerlLIO_chsize(fd, size) ftruncate((fd), (size)) #elif defined(HAS_CHSIZE) # define PerlLIO_chsize(fd, size) chsize((fd), (size)) #else # define PerlLIO_chsize(fd, size) my_chsize((fd), (size)) #endif #define PerlLIO_close(fd) close((fd)) #define PerlLIO_dup(fd) dup((fd)) #define PerlLIO_dup2(fd1, fd2) dup2((fd1), (fd2)) #define PerlLIO_flock(fd, op) FLOCK((fd), (op)) #define PerlLIO_fstat(fd, buf) Fstat((fd), (buf)) #define PerlLIO_ioctl(fd, u, buf) ioctl((fd), (u), (buf)) #define PerlLIO_isatty(fd) isatty((fd)) #define PerlLIO_link(oldname, newname) link((oldname), (newname)) #define PerlLIO_lseek(fd, offset, mode) lseek((fd), (offset), (mode)) #define PerlLIO_stat(name, buf) Stat((name), (buf)) #ifdef HAS_LSTAT # define PerlLIO_lstat(name, buf) lstat((name), (buf)) #else # define PerlLIO_lstat(name, buf) PerlLIO_stat((name), (buf)) #endif #define PerlLIO_mktemp(file) mktemp((file)) #define PerlLIO_mkstemp(file) mkstemp((file)) #define PerlLIO_open(file, flag) open((file), (flag)) #define PerlLIO_open3(file, flag, perm) open((file), (flag), (perm)) #define PerlLIO_read(fd, buf, count) read((fd), (buf), (count)) #define PerlLIO_rename(old, new) rename((old), (new)) #define PerlLIO_setmode(fd, mode) setmode((fd), (mode)) #define PerlLIO_tmpnam(str) tmpnam((str)) #define PerlLIO_umask(mode) umask((mode)) #define PerlLIO_unlink(file) unlink((file)) #define PerlLIO_utime(file, time) utime((file), (time)) #define PerlLIO_write(fd, buf, count) write((fd), (buf), (count)) #endif /* PERL_IMPLICIT_SYS */ /* Interface for perl memory allocation */ #if defined(PERL_IMPLICIT_SYS) /* IPerlMem */ struct IPerlMem; struct IPerlMemInfo; typedef void* (*LPMemMalloc)(struct IPerlMem*, size_t); typedef void* (*LPMemRealloc)(struct IPerlMem*, void*, size_t); typedef void (*LPMemFree)(struct IPerlMem*, void*); typedef void* (*LPMemCalloc)(struct IPerlMem*, size_t, size_t); typedef void (*LPMemGetLock)(struct IPerlMem*); typedef void (*LPMemFreeLock)(struct IPerlMem*); typedef int (*LPMemIsLocked)(struct IPerlMem*); struct IPerlMem { LPMemMalloc pMalloc; LPMemRealloc pRealloc; LPMemFree pFree; LPMemCalloc pCalloc; LPMemGetLock pGetLock; LPMemFreeLock pFreeLock; LPMemIsLocked pIsLocked; }; struct IPerlMemInfo { unsigned long nCount; /* number of entries expected */ struct IPerlMem perlMemList; }; /* Interpreter specific memory macros */ #define PerlMem_malloc(size) \ (*PL_Mem->pMalloc)(PL_Mem, (size)) #define PerlMem_realloc(buf, size) \ (*PL_Mem->pRealloc)(PL_Mem, (buf), (size)) #define PerlMem_free(buf) \ (*PL_Mem->pFree)(PL_Mem, (buf)) #define PerlMem_calloc(num, size) \ (*PL_Mem->pCalloc)(PL_Mem, (num), (size)) #define PerlMem_get_lock() \ (*PL_Mem->pGetLock)(PL_Mem) #define PerlMem_free_lock() \ (*PL_Mem->pFreeLock)(PL_Mem) #define PerlMem_is_locked() \ (*PL_Mem->pIsLocked)(PL_Mem) /* Shared memory macros */ #ifdef NETWARE #define PerlMemShared_malloc(size) \ (*PL_Mem->pMalloc)(PL_Mem, (size)) #define PerlMemShared_realloc(buf, size) \ (*PL_Mem->pRealloc)(PL_Mem, (buf), (size)) #define PerlMemShared_free(buf) \ (*PL_Mem->pFree)(PL_Mem, (buf)) #define PerlMemShared_calloc(num, size) \ (*PL_Mem->pCalloc)(PL_Mem, (num), (size)) #define PerlMemShared_get_lock() \ (*PL_Mem->pGetLock)(PL_Mem) #define PerlMemShared_free_lock() \ (*PL_Mem->pFreeLock)(PL_Mem) #define PerlMemShared_is_locked() \ (*PL_Mem->pIsLocked)(PL_Mem) #else #define PerlMemShared_malloc(size) \ (*PL_MemShared->pMalloc)(PL_MemShared, (size)) #define PerlMemShared_realloc(buf, size) \ (*PL_MemShared->pRealloc)(PL_MemShared, (buf), (size)) #define PerlMemShared_free(buf) \ (*PL_MemShared->pFree)(PL_MemShared, (buf)) #define PerlMemShared_calloc(num, size) \ (*PL_MemShared->pCalloc)(PL_MemShared, (num), (size)) #define PerlMemShared_get_lock() \ (*PL_MemShared->pGetLock)(PL_MemShared) #define PerlMemShared_free_lock() \ (*PL_MemShared->pFreeLock)(PL_MemShared) #define PerlMemShared_is_locked() \ (*PL_MemShared->pIsLocked)(PL_MemShared) #endif /* Parse tree memory macros */ #define PerlMemParse_malloc(size) \ (*PL_MemParse->pMalloc)(PL_MemParse, (size)) #define PerlMemParse_realloc(buf, size) \ (*PL_MemParse->pRealloc)(PL_MemParse, (buf), (size)) #define PerlMemParse_free(buf) \ (*PL_MemParse->pFree)(PL_MemParse, (buf)) #define PerlMemParse_calloc(num, size) \ (*PL_MemParse->pCalloc)(PL_MemParse, (num), (size)) #define PerlMemParse_get_lock() \ (*PL_MemParse->pGetLock)(PL_MemParse) #define PerlMemParse_free_lock() \ (*PL_MemParse->pFreeLock)(PL_MemParse) #define PerlMemParse_is_locked() \ (*PL_MemParse->pIsLocked)(PL_MemParse) #else /* PERL_IMPLICIT_SYS */ /* Interpreter specific memory macros */ #define PerlMem_malloc(size) malloc((size)) #define PerlMem_realloc(buf, size) realloc((buf), (size)) #define PerlMem_free(buf) free((buf)) #define PerlMem_calloc(num, size) calloc((num), (size)) #define PerlMem_get_lock() #define PerlMem_free_lock() #define PerlMem_is_locked() 0 /* Shared memory macros */ #define PerlMemShared_malloc(size) malloc((size)) #define PerlMemShared_realloc(buf, size) realloc((buf), (size)) #define PerlMemShared_free(buf) free((buf)) #define PerlMemShared_calloc(num, size) calloc((num), (size)) #define PerlMemShared_get_lock() #define PerlMemShared_free_lock() #define PerlMemShared_is_locked() 0 /* Parse tree memory macros */ #define PerlMemParse_malloc(size) malloc((size)) #define PerlMemParse_realloc(buf, size) realloc((buf), (size)) #define PerlMemParse_free(buf) free((buf)) #define PerlMemParse_calloc(num, size) calloc((num), (size)) #define PerlMemParse_get_lock() #define PerlMemParse_free_lock() #define PerlMemParse_is_locked() 0 #endif /* PERL_IMPLICIT_SYS */ /* Interface for perl process functions */ #if defined(PERL_IMPLICIT_SYS) #ifndef jmp_buf #include #endif /* IPerlProc */ struct IPerlProc; struct IPerlProcInfo; typedef void (*LPProcAbort)(struct IPerlProc*); typedef char* (*LPProcCrypt)(struct IPerlProc*, const char*, const char*); typedef void (*LPProcExit)(struct IPerlProc*, int) __attribute__noreturn__; typedef void (*LPProc_Exit)(struct IPerlProc*, int) __attribute__noreturn__; typedef int (*LPProcExecl)(struct IPerlProc*, const char*, const char*, const char*, const char*, const char*); typedef int (*LPProcExecv)(struct IPerlProc*, const char*, const char*const*); typedef int (*LPProcExecvp)(struct IPerlProc*, const char*, const char*const*); typedef uid_t (*LPProcGetuid)(struct IPerlProc*); typedef uid_t (*LPProcGeteuid)(struct IPerlProc*); typedef gid_t (*LPProcGetgid)(struct IPerlProc*); typedef gid_t (*LPProcGetegid)(struct IPerlProc*); typedef char* (*LPProcGetlogin)(struct IPerlProc*); 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*); typedef PerlIO* (*LPProcPopenList)(struct IPerlProc*, const char*, IV narg, SV **args); typedef int (*LPProcPclose)(struct IPerlProc*, PerlIO*); typedef int (*LPProcPipe)(struct IPerlProc*, int*); typedef int (*LPProcSetuid)(struct IPerlProc*, uid_t); typedef int (*LPProcSetgid)(struct IPerlProc*, gid_t); typedef int (*LPProcSleep)(struct IPerlProc*, unsigned int); typedef int (*LPProcTimes)(struct IPerlProc*, struct tms*); typedef int (*LPProcWait)(struct IPerlProc*, int*); typedef int (*LPProcWaitpid)(struct IPerlProc*, int, int*, int); typedef Sighandler_t (*LPProcSignal)(struct IPerlProc*, int, Sighandler_t); typedef int (*LPProcFork)(struct IPerlProc*); typedef int (*LPProcGetpid)(struct IPerlProc*); #ifdef WIN32 typedef void* (*LPProcDynaLoader)(struct IPerlProc*, const char*); typedef void (*LPProcGetOSError)(struct IPerlProc*, SV* sv, DWORD dwErr); typedef int (*LPProcSpawnvp)(struct IPerlProc*, int, const char*, const char*const*); #endif typedef int (*LPProcLastHost)(struct IPerlProc*); typedef int (*LPProcGetTimeOfDay)(struct IPerlProc*, struct timeval*, void*); struct IPerlProc { LPProcAbort pAbort; LPProcCrypt pCrypt; LPProcExit pExit; LPProc_Exit p_Exit; LPProcExecl pExecl; LPProcExecv pExecv; LPProcExecvp pExecvp; LPProcGetuid pGetuid; LPProcGeteuid pGeteuid; LPProcGetgid pGetgid; LPProcGetegid pGetegid; LPProcGetlogin pGetlogin; LPProcKill pKill; LPProcKillpg pKillpg; LPProcPauseProc pPauseProc; LPProcPopen pPopen; LPProcPclose pPclose; LPProcPipe pPipe; LPProcSetuid pSetuid; LPProcSetgid pSetgid; LPProcSleep pSleep; LPProcTimes pTimes; LPProcWait pWait; LPProcWaitpid pWaitpid; LPProcSignal pSignal; LPProcFork pFork; LPProcGetpid pGetpid; #ifdef WIN32 LPProcDynaLoader pDynaLoader; LPProcGetOSError pGetOSError; LPProcSpawnvp pSpawnvp; #endif LPProcLastHost pLastHost; LPProcPopenList pPopenList; LPProcGetTimeOfDay pGetTimeOfDay; }; struct IPerlProcInfo { unsigned long nCount; /* number of entries expected */ struct IPerlProc perlProcList; }; #define PerlProc_abort() \ (*PL_Proc->pAbort)(PL_Proc) #define PerlProc_crypt(c,s) \ (*PL_Proc->pCrypt)(PL_Proc, (c), (s)) #define PerlProc_exit(s) \ (*PL_Proc->pExit)(PL_Proc, (s)) #define PerlProc__exit(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)) #define PerlProc_execv(c, a) \ (*PL_Proc->pExecv)(PL_Proc, (c), (a)) #define PerlProc_execvp(c, a) \ (*PL_Proc->pExecvp)(PL_Proc, (c), (a)) #define PerlProc_getuid() \ (*PL_Proc->pGetuid)(PL_Proc) #define PerlProc_geteuid() \ (*PL_Proc->pGeteuid)(PL_Proc) #define PerlProc_getgid() \ (*PL_Proc->pGetgid)(PL_Proc) #define PerlProc_getegid() \ (*PL_Proc->pGetegid)(PL_Proc) #define PerlProc_getlogin() \ (*PL_Proc->pGetlogin)(PL_Proc) #define PerlProc_kill(i, a) \ (*PL_Proc->pKill)(PL_Proc, (i), (a)) #define PerlProc_killpg(i, a) \ (*PL_Proc->pKillpg)(PL_Proc, (i), (a)) #define PerlProc_pause() \ (*PL_Proc->pPauseProc)(PL_Proc) #define PerlProc_popen(c, m) \ (*PL_Proc->pPopen)(PL_Proc, (c), (m)) #define PerlProc_popen_list(m, n, a) \ (*PL_Proc->pPopenList)(PL_Proc, (m), (n), (a)) #define PerlProc_pclose(f) \ (*PL_Proc->pPclose)(PL_Proc, (f)) #define PerlProc_pipe(fd) \ (*PL_Proc->pPipe)(PL_Proc, (fd)) #define PerlProc_setuid(u) \ (*PL_Proc->pSetuid)(PL_Proc, (u)) #define PerlProc_setgid(g) \ (*PL_Proc->pSetgid)(PL_Proc, (g)) #define PerlProc_sleep(t) \ (*PL_Proc->pSleep)(PL_Proc, (t)) #define PerlProc_times(t) \ (*PL_Proc->pTimes)(PL_Proc, (t)) #define PerlProc_wait(t) \ (*PL_Proc->pWait)(PL_Proc, (t)) #define PerlProc_waitpid(p,s,f) \ (*PL_Proc->pWaitpid)(PL_Proc, (p), (s), (f)) #define PerlProc_signal(n, h) \ (*PL_Proc->pSignal)(PL_Proc, (n), (h)) #define PerlProc_fork() \ (*PL_Proc->pFork)(PL_Proc) #define PerlProc_getpid() \ (*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)) #define PerlProc_GetOSError(s,e) \ (*PL_Proc->pGetOSError)(PL_Proc, (s), (e)) #define PerlProc_spawnvp(m, c, a) \ (*PL_Proc->pSpawnvp)(PL_Proc, (m), (c), (a)) #endif #define PerlProc_lasthost() \ (*PL_Proc->pLastHost)(PL_Proc) #define PerlProc_gettimeofday(t,z) \ (*PL_Proc->pGetTimeOfDay)(PL_Proc,(t),(z)) #else /* PERL_IMPLICIT_SYS */ #define PerlProc_abort() abort() #define PerlProc_crypt(c,s) crypt((c), (s)) #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)) #define PerlProc_execv(c, a) execv((c), (a)) #define PerlProc_execvp(c, a) execvp((c), (a)) #define PerlProc_getuid() getuid() #define PerlProc_geteuid() geteuid() #define PerlProc_getgid() getgid() #define PerlProc_getegid() getegid() #define PerlProc_getlogin() getlogin() #define PerlProc_kill(i, a) kill((i), (a)) #define PerlProc_killpg(i, a) killpg((i), (a)) #define PerlProc_pause() Pause() #define PerlProc_popen(c, m) my_popen((c), (m)) #define PerlProc_popen_list(m,n,a) my_popen_list((m),(n),(a)) #define PerlProc_pclose(f) my_pclose((f)) #define PerlProc_pipe(fd) pipe((fd)) #define PerlProc_setuid(u) setuid((u)) #define PerlProc_setgid(g) setgid((g)) #define PerlProc_sleep(t) sleep((t)) #define PerlProc_times(t) times((t)) #define PerlProc_wait(t) wait((t)) #define PerlProc_waitpid(p,s,f) waitpid((p), (s), (f)) #define PerlProc_setjmp(b, n) Sigsetjmp((b), (n)) #define PerlProc_longjmp(b, n) Siglongjmp((b), (n)) #define PerlProc_signal(n, h) signal((n), (h)) #define PerlProc_fork() my_fork() #define PerlProc_getpid() getpid() #define PerlProc_gettimeofday(t,z) gettimeofday((t),(z)) #ifdef WIN32 #define PerlProc_DynaLoad(f) \ win32_dynaload((f)) #define PerlProc_GetOSError(s,e) \ win32_str_os_error((s), (e)) #define PerlProc_spawnvp(m, c, a) \ win32_spawnvp((m), (c), (a)) #undef PerlProc_signal #define PerlProc_signal(n, h) win32_signal((n), (h)) #endif #endif /* PERL_IMPLICIT_SYS */ /* Interface for perl socket functions */ #if defined(PERL_IMPLICIT_SYS) /* PerlSock */ struct IPerlSock; struct IPerlSockInfo; typedef u_long (*LPHtonl)(struct IPerlSock*, u_long); 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*); typedef int (*LPBind)(struct IPerlSock*, SOCKET, const struct sockaddr*, int); typedef int (*LPConnect)(struct IPerlSock*, SOCKET, 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*); typedef struct hostent* (*LPGethostbyaddr)(struct IPerlSock*, const char*, int, int); typedef struct hostent* (*LPGethostbyname)(struct IPerlSock*, const char*); typedef struct hostent* (*LPGethostent)(struct IPerlSock*); typedef struct netent* (*LPGetnetbyaddr)(struct IPerlSock*, long, int); typedef struct netent* (*LPGetnetbyname)(struct IPerlSock*, const char*); typedef struct netent* (*LPGetnetent)(struct IPerlSock*); 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*); typedef struct servent* (*LPGetservbyport)(struct IPerlSock*, int, const char*); typedef struct servent* (*LPGetservent)(struct IPerlSock*); typedef int (*LPGetsockname)(struct IPerlSock*, SOCKET, struct sockaddr*, int*); typedef int (*LPGetsockopt)(struct IPerlSock*, SOCKET, int, 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*); typedef int (*LPSelect)(struct IPerlSock*, int, char*, char*, char*, const struct timeval*); typedef int (*LPSend)(struct IPerlSock*, SOCKET, const char*, int, int); typedef int (*LPSendto)(struct IPerlSock*, SOCKET, const char*, 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); typedef int (*LPShutdown)(struct IPerlSock*, SOCKET, int); typedef SOCKET (*LPSocket)(struct IPerlSock*, int, int, int); typedef int (*LPSocketpair)(struct IPerlSock*, int, int, int, int*); #ifdef WIN32 typedef int (*LPClosesocket)(struct IPerlSock*, SOCKET s); #endif struct IPerlSock { LPHtonl pHtonl; LPHtons pHtons; LPNtohl pNtohl; LPNtohs pNtohs; LPAccept pAccept; LPBind pBind; LPConnect pConnect; LPEndhostent pEndhostent; LPEndnetent pEndnetent; LPEndprotoent pEndprotoent; LPEndservent pEndservent; LPGethostname pGethostname; LPGetpeername pGetpeername; LPGethostbyaddr pGethostbyaddr; LPGethostbyname pGethostbyname; LPGethostent pGethostent; LPGetnetbyaddr pGetnetbyaddr; LPGetnetbyname pGetnetbyname; LPGetnetent pGetnetent; LPGetprotobyname pGetprotobyname; LPGetprotobynumber pGetprotobynumber; LPGetprotoent pGetprotoent; LPGetservbyname pGetservbyname; LPGetservbyport pGetservbyport; LPGetservent pGetservent; LPGetsockname pGetsockname; LPGetsockopt pGetsockopt; LPInetAddr pInetAddr; LPInetNtoa pInetNtoa; LPListen pListen; LPRecv pRecv; LPRecvfrom pRecvfrom; LPSelect pSelect; LPSend pSend; LPSendto pSendto; LPSethostent pSethostent; LPSetnetent pSetnetent; LPSetprotoent pSetprotoent; LPSetservent pSetservent; LPSetsockopt pSetsockopt; LPShutdown pShutdown; LPSocket pSocket; LPSocketpair pSocketpair; #ifdef WIN32 LPClosesocket pClosesocket; #endif }; struct IPerlSockInfo { unsigned long nCount; /* number of entries expected */ struct IPerlSock perlSockList; }; #define PerlSock_htonl(x) \ (*PL_Sock->pHtonl)(PL_Sock, x) #define PerlSock_htons(x) \ (*PL_Sock->pHtons)(PL_Sock, x) #define PerlSock_ntohl(x) \ (*PL_Sock->pNtohl)(PL_Sock, x) #define PerlSock_ntohs(x) \ (*PL_Sock->pNtohs)(PL_Sock, x) #define PerlSock_accept(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) #define PerlSock_connect(s, n, l) \ (*PL_Sock->pConnect)(PL_Sock, s, n, l) #define PerlSock_endhostent() \ (*PL_Sock->pEndhostent)(PL_Sock) #define PerlSock_endnetent() \ (*PL_Sock->pEndnetent)(PL_Sock) #define PerlSock_endprotoent() \ (*PL_Sock->pEndprotoent)(PL_Sock) #define PerlSock_endservent() \ (*PL_Sock->pEndservent)(PL_Sock) #define PerlSock_gethostbyaddr(a, l, t) \ (*PL_Sock->pGethostbyaddr)(PL_Sock, a, l, t) #define PerlSock_gethostbyname(n) \ (*PL_Sock->pGethostbyname)(PL_Sock, n) #define PerlSock_gethostent() \ (*PL_Sock->pGethostent)(PL_Sock) #define PerlSock_gethostname(n, l) \ (*PL_Sock->pGethostname)(PL_Sock, n, l) #define PerlSock_getnetbyaddr(n, t) \ (*PL_Sock->pGetnetbyaddr)(PL_Sock, n, t) #define PerlSock_getnetbyname(c) \ (*PL_Sock->pGetnetbyname)(PL_Sock, c) #define PerlSock_getnetent() \ (*PL_Sock->pGetnetent)(PL_Sock) #define PerlSock_getpeername(s, n, l) \ (*PL_Sock->pGetpeername)(PL_Sock, s, n, l) #define PerlSock_getprotobyname(n) \ (*PL_Sock->pGetprotobyname)(PL_Sock, n) #define PerlSock_getprotobynumber(n) \ (*PL_Sock->pGetprotobynumber)(PL_Sock, n) #define PerlSock_getprotoent() \ (*PL_Sock->pGetprotoent)(PL_Sock) #define PerlSock_getservbyname(n, p) \ (*PL_Sock->pGetservbyname)(PL_Sock, n, p) #define PerlSock_getservbyport(port, p) \ (*PL_Sock->pGetservbyport)(PL_Sock, port, p) #define PerlSock_getservent() \ (*PL_Sock->pGetservent)(PL_Sock) #define PerlSock_getsockname(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) #define PerlSock_inet_addr(c) \ (*PL_Sock->pInetAddr)(PL_Sock, c) #define PerlSock_inet_ntoa(i) \ (*PL_Sock->pInetNtoa)(PL_Sock, i) #define PerlSock_listen(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) #define PerlSock_recvfrom(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) #define PerlSock_send(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) #define PerlSock_sethostent(f) \ (*PL_Sock->pSethostent)(PL_Sock, f) #define PerlSock_setnetent(f) \ (*PL_Sock->pSetnetent)(PL_Sock, f) #define PerlSock_setprotoent(f) \ (*PL_Sock->pSetprotoent)(PL_Sock, f) #define PerlSock_setservent(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) #define PerlSock_shutdown(s, h) \ (*PL_Sock->pShutdown)(PL_Sock, s, h) #define PerlSock_socket(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) #ifdef WIN32 #define PerlSock_closesocket(s) \ (*PL_Sock->pClosesocket)(PL_Sock, s) #endif #else /* PERL_IMPLICIT_SYS */ #define PerlSock_htonl(x) htonl(x) #define PerlSock_htons(x) htons(x) #define PerlSock_ntohl(x) ntohl(x) #define PerlSock_ntohs(x) ntohs(x) #define PerlSock_accept(s, a, l) accept(s, a, l) #define PerlSock_bind(s, n, l) bind(s, n, l) #define PerlSock_connect(s, n, l) connect(s, n, l) #define PerlSock_gethostbyaddr(a, l, t) gethostbyaddr(a, l, t) #define PerlSock_gethostbyname(n) gethostbyname(n) #define PerlSock_gethostent gethostent #define PerlSock_endhostent endhostent #define PerlSock_gethostname(n, l) gethostname(n, l) #define PerlSock_getnetbyaddr(n, t) getnetbyaddr(n, t) #define PerlSock_getnetbyname(n) getnetbyname(n) #define PerlSock_getnetent getnetent #define PerlSock_endnetent endnetent #define PerlSock_getpeername(s, n, l) getpeername(s, n, l) #define PerlSock_getprotobyname(n) getprotobyname(n) #define PerlSock_getprotobynumber(n) getprotobynumber(n) #define PerlSock_getprotoent getprotoent #define PerlSock_endprotoent endprotoent #define PerlSock_getservbyname(n, p) getservbyname(n, p) #define PerlSock_getservbyport(port, p) getservbyport(port, p) #define PerlSock_getservent getservent #define PerlSock_endservent endservent #define PerlSock_getsockname(s, n, l) getsockname(s, n, l) #define PerlSock_getsockopt(s,l,n,v,i) getsockopt(s, l, n, v, i) #define PerlSock_inet_addr(c) inet_addr(c) #define PerlSock_inet_ntoa(i) inet_ntoa(i) #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) #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) #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) #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) #ifdef WIN32 #define PerlSock_closesocket(s) closesocket(s) #endif #endif /* PERL_IMPLICIT_SYS */ #endif /* __Inc__IPerl___ */ /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */ perl-5.12.0-RC0/pp_ctl.c0000444000175000017500000036356211347003575013576 0ustar jessejesse/* pp_ctl.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * Now far ahead the Road has gone, * And I must follow, if I can, * Pursuing it with eager feet, * Until it joins some larger way * Where many paths and errands meet. * And whither then? I cannot say. * * [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"] */ /* This file contains control-oriented pp ("push/pop") functions that * execute the opcodes that make up a perl program. A typical pp function * expects to find its arguments on the stack, and usually pushes its * results onto the stack, hence the 'pp' terminology. Each OP structure * contains a pointer to the relevant pp_foo() function. * * Control-oriented means things like pp_enteriter() and pp_next(), which * alter the flow of control of the program. */ #include "EXTERN.h" #define PERL_IN_PP_CTL_C #include "perl.h" #ifndef WORD_ALIGN #define WORD_ALIGN sizeof(U32) #endif #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o)) #define dopoptosub(plop) dopoptosub_at(cxstack, (plop)) PP(pp_wantarray) { dVAR; dSP; I32 cxix; EXTEND(SP, 1); cxix = dopoptosub(cxstack_ix); if (cxix < 0) RETPUSHUNDEF; switch (cxstack[cxix].blk_gimme) { case G_ARRAY: RETPUSHYES; case G_SCALAR: RETPUSHNO; default: RETPUSHUNDEF; } } PP(pp_regcreset) { dVAR; /* XXXX Should store the old value to allow for tie/overload - and restore in regcomp, where marked with XXXX. */ PL_reginterp_cnt = 0; TAINT_NOT; return NORMAL; } PP(pp_regcomp) { dVAR; dSP; register PMOP *pm = (PMOP*)cLOGOP->op_other; SV *tmpstr; REGEXP *re = NULL; /* prevent recompiling under /o and ithreads. */ #if defined(USE_ITHREADS) if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) { if (PL_op->op_flags & OPf_STACKED) { dMARK; SP = MARK; } else (void)POPs; RETURN; } #endif #define tryAMAGICregexp(rx) \ STMT_START { \ if (SvROK(rx) && SvAMAGIC(rx)) { \ SV *sv = AMG_CALLun(rx, regexp); \ if (sv) { \ if (SvROK(sv)) \ sv = SvRV(sv); \ if (SvTYPE(sv) != SVt_REGEXP) \ Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); \ rx = sv; \ } \ } \ } STMT_END if (PL_op->op_flags & OPf_STACKED) { /* multiple args; concatentate them */ dMARK; dORIGMARK; tmpstr = PAD_SV(ARGTARG); sv_setpvs(tmpstr, ""); while (++MARK <= SP) { SV *msv = *MARK; if (PL_amagic_generation) { SV *sv; tryAMAGICregexp(msv); if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) && (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign))) { sv_setsv(tmpstr, sv); continue; } } sv_catsv(tmpstr, msv); } SvSETMAGIC(tmpstr); SP = ORIGMARK; } else { tmpstr = POPs; tryAMAGICregexp(tmpstr); } #undef tryAMAGICregexp if (SvROK(tmpstr)) { SV * const sv = SvRV(tmpstr); if (SvTYPE(sv) == SVt_REGEXP) re = (REGEXP*) sv; } else if (SvTYPE(tmpstr) == SVt_REGEXP) re = (REGEXP*) tmpstr; if (re) { /* The match's LHS's get-magic might need to access this op's reg- exp (as is sometimes the case with $'; see bug 70764). So we must call get-magic now before we replace the regexp. Hopeful- ly 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 = PL_tainted; if (pm->op_flags & OPf_STACKED) lhs = TOPs; else if (pm->op_private & OPpTARGET_MY) 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 further down. */ PL_tainted = was_tainted; } re = reg_temp_copy(NULL, re); ReREFCNT_dec(PM_GETRE(pm)); PM_SETRE(pm, re); } else { STRLEN len; const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : ""; re = PM_GETRE(pm); assert (re != (REGEXP*) &PL_sv_undef); /* Check against the last compiled regexp. */ if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len || memNE(RX_PRECOMP(re), t, len)) { const regexp_engine *eng = re ? RX_ENGINE(re) : NULL; U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME; if (re) { ReREFCNT_dec(re); #ifdef USE_ITHREADS PM_SETRE(pm, (REGEXP*) &PL_sv_undef); #else PM_SETRE(pm, NULL); /* crucial if regcomp aborts */ #endif } else if (PL_curcop->cop_hints_hash) { SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0, "regcomp", 7, 0, 0); if (ptr && SvIOK(ptr) && SvIV(ptr)) eng = INT2PTR(regexp_engine*,SvIV(ptr)); } if (PL_op->op_flags & OPf_SPECIAL) PL_reginterp_cnt = I32_MAX; /* Mark as safe. */ if (DO_UTF8(tmpstr)) { assert (SvUTF8(tmpstr)); } else if (SvUTF8(tmpstr)) { /* Not doing UTF-8, despite what the SV says. Is this only if we're trapped in use 'bytes'? */ /* Make a copy of the octet sequence, but without the flag on, as the compiler now honours the SvUTF8 flag on tmpstr. */ STRLEN len; const char *const p = SvPV(tmpstr, len); tmpstr = newSVpvn_flags(p, len, SVs_TEMP); } if (eng) PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags)); else PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags)); PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed inside tie/overload accessors. */ } } re = PM_GETRE(pm); #ifndef INCOMPLETE_TAINTS if (PL_tainting) { if (PL_tainted) RX_EXTFLAGS(re) |= RXf_TAINTED; else RX_EXTFLAGS(re) &= ~RXf_TAINTED; } #endif if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm) pm = PL_curpm; #if !defined(USE_ITHREADS) /* 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) { pm->op_private &= ~OPpRUNTIME; /* no point compiling again */ cLOGOP->op_first->op_next = PL_op->op_next; } #endif RETURN; } PP(pp_substcont) { dVAR; dSP; register PERL_CONTEXT *cx = &cxstack[cxstack_ix]; register PMOP * const pm = (PMOP*) cLOGOP->op_other; register SV * const dstr = cx->sb_dstr; register char *s = cx->sb_s; register char *m = cx->sb_m; char *orig = cx->sb_orig; register REGEXP * const rx = cx->sb_rx; SV *nsv = NULL; REGEXP *old = PM_GETRE(pm); if(old != rx) { if(old) ReREFCNT_dec(old); PM_SETRE(pm,ReREFCNT_inc(rx)); } rxres_restore(&cx->sb_rxres, rx); RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ)); if (cx->sb_iters++) { const I32 saviters = cx->sb_iters; if (cx->sb_iters > cx->sb_maxiters) DIE(aTHX_ "Substitution loop"); if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs)) cx->sb_rxtainted |= 2; sv_catsv(dstr, POPs); /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */ s -= RX_GOFS(rx); /* Are we done */ if (CxONCE(cx) || s < orig || !CALLREGEXEC(rx, s, cx->sb_strend, orig, (s == m) + RX_GOFS(rx), cx->sb_targ, NULL, ((cx->sb_rflags & REXEC_COPY_STR) ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST) : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST)))) { SV * const targ = cx->sb_targ; assert(cx->sb_strend >= s); if(cx->sb_strend > s) { if (DO_UTF8(dstr) && !SvUTF8(targ)) sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv); else sv_catpvn(dstr, s, cx->sb_strend - s); } cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); #ifdef PERL_OLD_COPY_ON_WRITE 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)); if (DO_UTF8(dstr)) SvUTF8_on(targ); SvPV_set(dstr, NULL); TAINT_IF(cx->sb_rxtainted & 1); mPUSHi(saviters - 1); (void)SvPOK_only_UTF8(targ); TAINT_IF(cx->sb_rxtainted); SvSETMAGIC(targ); SvTAINT(targ); LEAVE_SCOPE(cx->sb_oldsave); POPSUBST(cx); RETURNOP(pm->op_next); } cx->sb_iters = saviters; } if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) { m = s; s = orig; 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_utf8_upgrade(dstr, s, m - s, nsv); else sv_catpvn(dstr, s, m-s); } cx->sb_s = RX_OFFS(rx)[0].end + orig; { /* Update the pos() information. */ SV * const sv = cx->sb_targ; MAGIC *mg; SvUPGRADE(sv, SVt_PVMG); if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) { #ifdef PERL_OLD_COPY_ON_WRITE if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); #endif mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob, NULL, 0); } mg->mg_len = m - orig; } if (old != rx) (void)ReREFCNT_inc(rx); cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); rxres_save(&cx->sb_rxres, rx); RETURNOP(pm->op_pmstashstartu.op_pmreplstart); } void Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) { UV *p = (UV*)*rsp; U32 i; PERL_ARGS_ASSERT_RXRES_SAVE; PERL_UNUSED_CONTEXT; if (!p || p[1] < RX_NPARENS(rx)) { #ifdef PERL_OLD_COPY_ON_WRITE i = 7 + RX_NPARENS(rx) * 2; #else i = 6 + RX_NPARENS(rx) * 2; #endif if (!p) Newx(p, i, UV); else Renew(p, i, UV); *rsp = (void*)p; } *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL); RX_MATCH_COPIED_off(rx); #ifdef PERL_OLD_COPY_ON_WRITE *p++ = PTR2UV(RX_SAVED_COPY(rx)); RX_SAVED_COPY(rx) = NULL; #endif *p++ = RX_NPARENS(rx); *p++ = PTR2UV(RX_SUBBEG(rx)); *p++ = (UV)RX_SUBLEN(rx); for (i = 0; i <= RX_NPARENS(rx); ++i) { *p++ = (UV)RX_OFFS(rx)[i].start; *p++ = (UV)RX_OFFS(rx)[i].end; } } static void S_rxres_restore(pTHX_ void **rsp, REGEXP *rx) { UV *p = (UV*)*rsp; U32 i; PERL_ARGS_ASSERT_RXRES_RESTORE; PERL_UNUSED_CONTEXT; RX_MATCH_COPY_FREE(rx); RX_MATCH_COPIED_set(rx, *p); *p++ = 0; #ifdef PERL_OLD_COPY_ON_WRITE if (RX_SAVED_COPY(rx)) SvREFCNT_dec (RX_SAVED_COPY(rx)); RX_SAVED_COPY(rx) = INT2PTR(SV*,*p); *p++ = 0; #endif RX_NPARENS(rx) = *p++; RX_SUBBEG(rx) = INT2PTR(char*,*p++); RX_SUBLEN(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++); } } static void S_rxres_free(pTHX_ void **rsp) { UV * const p = (UV*)*rsp; PERL_ARGS_ASSERT_RXRES_FREE; PERL_UNUSED_CONTEXT; if (p) { #ifdef PERL_POISON void *tmp = INT2PTR(char*,*p); Safefree(tmp); if (*p) PoisonFree(*p, 1, sizeof(*p)); #else Safefree(INT2PTR(char*,*p)); #endif #ifdef PERL_OLD_COPY_ON_WRITE if (p[1]) { SvREFCNT_dec (INT2PTR(SV*,p[1])); } #endif Safefree(p); *rsp = NULL; } } PP(pp_formline) { dVAR; dSP; dMARK; dORIGMARK; register SV * const tmpForm = *++MARK; register U32 *fpc; register char *t; const char *f; register I32 arg; register SV *sv = NULL; const char *item = NULL; I32 itemsize = 0; I32 fieldsize = 0; I32 lines = 0; bool chopspace = (strchr(PL_chopset, ' ') != NULL); const char *chophere = NULL; char *linemark = NULL; NV value; bool gotsome = FALSE; STRLEN len; const STRLEN fudge = SvPOK(tmpForm) ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0; bool item_is_utf8 = FALSE; bool targ_is_utf8 = FALSE; SV * nsv = NULL; OP * parseres = NULL; const char *fmt; if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) { if (SvREADONLY(tmpForm)) { SvREADONLY_off(tmpForm); parseres = doparseform(tmpForm); SvREADONLY_on(tmpForm); } else parseres = doparseform(tmpForm); if (parseres) return parseres; } SvPV_force(PL_formtarget, len); if (DO_UTF8(PL_formtarget)) targ_is_utf8 = TRUE; t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */ t += len; f = SvPV_const(tmpForm, len); /* need to jump to the next word */ fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN); 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: linemark = t; lines++; gotsome = FALSE; break; case FF_LITERAL: arg = *fpc++; if (targ_is_utf8 && !SvUTF8(tmpForm)) { SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); *t = '\0'; sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv); t = SvEND(PL_formtarget); f += arg; break; } if (!targ_is_utf8 && DO_UTF8(tmpForm)) { SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); *t = '\0'; sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1); t = SvEND(PL_formtarget); targ_is_utf8 = TRUE; } while (arg--) *t++ = *f++; break; case FF_SKIP: f += *fpc++; break; case FF_FETCH: 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"); } break; case FF_CHECKNL: { const char *send; const char *s = item = SvPV_const(sv, len); itemsize = len; if (DO_UTF8(sv)) { itemsize = sv_len_utf8(sv); if (itemsize != (I32)len) { I32 itembytes; if (itemsize > fieldsize) { itemsize = fieldsize; itembytes = itemsize; sv_pos_u2b(sv, &itembytes, 0); } else itembytes = len; send = chophere = s + itembytes; while (s < send) { if (*s & ~31) gotsome = TRUE; else if (*s == '\n') break; s++; } item_is_utf8 = TRUE; itemsize = s - item; sv_pos_b2u(sv, &itemsize); break; } } item_is_utf8 = FALSE; if (itemsize > fieldsize) itemsize = fieldsize; send = chophere = s + itemsize; while (s < send) { if (*s & ~31) gotsome = TRUE; else if (*s == '\n') break; s++; } itemsize = s - item; break; } case FF_CHECKCHOP: { const char *s = item = SvPV_const(sv, len); itemsize = len; if (DO_UTF8(sv)) { itemsize = sv_len_utf8(sv); if (itemsize != (I32)len) { I32 itembytes; if (itemsize <= fieldsize) { const char *send = chophere = s + itemsize; while (s < send) { if (*s == '\r') { itemsize = s - item; chophere = s; break; } if (*s++ & ~31) gotsome = TRUE; } } else { const char *send; itemsize = fieldsize; itembytes = itemsize; sv_pos_u2b(sv, &itembytes, 0); send = chophere = s + itembytes; while (s < send || (s == send && isSPACE(*s))) { if (isSPACE(*s)) { if (chopspace) chophere = s; if (*s == '\r') break; } else { if (*s & ~31) gotsome = TRUE; if (strchr(PL_chopset, *s)) chophere = s + 1; } s++; } itemsize = chophere - item; sv_pos_b2u(sv, &itemsize); } item_is_utf8 = TRUE; break; } } item_is_utf8 = FALSE; if (itemsize <= fieldsize) { const char *const send = chophere = s + itemsize; while (s < send) { if (*s == '\r') { itemsize = s - item; chophere = s; break; } if (*s++ & ~31) gotsome = TRUE; } } else { const char *send; itemsize = fieldsize; send = chophere = s + itemsize; while (s < send || (s == send && isSPACE(*s))) { if (isSPACE(*s)) { if (chopspace) chophere = s; if (*s == '\r') break; } else { if (*s & ~31) gotsome = TRUE; if (strchr(PL_chopset, *s)) chophere = s + 1; } s++; } itemsize = chophere - item; } break; } case FF_SPACE: arg = fieldsize - itemsize; if (arg) { fieldsize -= arg; while (arg-- > 0) *t++ = ' '; } break; case FF_HALFSPACE: arg = fieldsize - itemsize; if (arg) { arg /= 2; fieldsize -= arg; while (arg-- > 0) *t++ = ' '; } break; case FF_ITEM: { const char *s = item; arg = itemsize; if (item_is_utf8) { if (!targ_is_utf8) { SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); *t = '\0'; sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1); t = SvEND(PL_formtarget); targ_is_utf8 = TRUE; } while (arg--) { if (UTF8_IS_CONTINUED(*s)) { STRLEN skip = UTF8SKIP(s); switch (skip) { default: Move(s,t,skip,char); s += skip; t += skip; break; case 7: *t++ = *s++; case 6: *t++ = *s++; case 5: *t++ = *s++; case 4: *t++ = *s++; case 3: *t++ = *s++; case 2: *t++ = *s++; case 1: *t++ = *s++; } } else { if ( !((*t++ = *s++) & ~31) ) t[-1] = ' '; } } break; } if (targ_is_utf8 && !item_is_utf8) { SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); *t = '\0'; sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv); for (; t < SvEND(PL_formtarget); t++) { #ifdef EBCDIC const int ch = *t; if (iscntrl(ch)) #else if (!(*t & ~31)) #endif *t = ' '; } break; } while (arg--) { #ifdef EBCDIC const int ch = *t++ = *s++; if (iscntrl(ch)) #else if ( !((*t++ = *s++) & ~31) ) #endif t[-1] = ' '; } break; } case FF_CHOP: { const char *s = chophere; if (chopspace) { while (isSPACE(*s)) s++; } sv_chop(sv,s); SvSETMAGIC(sv); break; } case FF_LINESNGL: chopspace = 0; case FF_LINEGLOB: { const bool oneline = fpc[-1] == FF_LINESNGL; const char *s = item = SvPV_const(sv, len); item_is_utf8 = DO_UTF8(sv); itemsize = len; if (itemsize) { STRLEN to_copy = itemsize; const char *const send = s + len; const U8 *source = (const U8 *) s; U8 *tmp = NULL; gotsome = TRUE; chophere = s + itemsize; while (s < send) { if (*s++ == '\n') { if (oneline) { to_copy = s - SvPVX_const(sv) - 1; chophere = s; break; } else { if (s == send) { itemsize--; to_copy--; } else lines++; } } } if (targ_is_utf8 && !item_is_utf8) { source = tmp = bytes_to_utf8(source, &to_copy); SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); } else { if (item_is_utf8 && !targ_is_utf8) { /* Upgrade targ to UTF8, and then we reduce it to a problem we have a simple solution for. */ SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); targ_is_utf8 = TRUE; /* Don't need get magic. */ sv_utf8_upgrade_nomg(PL_formtarget); } else { SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); } /* Easy. They agree. */ assert (item_is_utf8 == targ_is_utf8); } SvGROW(PL_formtarget, SvCUR(PL_formtarget) + to_copy + fudge + 1); t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget); Copy(source, t, to_copy, char); t += to_copy; SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy); if (item_is_utf8) { if (SvGMAGICAL(sv)) { /* Mustn't call sv_pos_b2u() as it does a second mg_get(). Is this a bug? Do we need a _flags() variant? */ itemsize = utf8_length(source, source + itemsize); } else { sv_pos_b2u(sv, &itemsize); } assert(!tmp); } else if (tmp) { Safefree(tmp); } } break; } case FF_0DECIMAL: arg = *fpc++; #if defined(USE_LONG_DOUBLE) fmt = (const char *) ((arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl); #else fmt = (const char *) ((arg & 256) ? "%#0*.*f" : "%0*.*f"); #endif goto ff_dec; case FF_DECIMAL: arg = *fpc++; #if defined(USE_LONG_DOUBLE) fmt = (const char *) ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl); #else fmt = (const char *) ((arg & 256) ? "%#*.*f" : "%*.*f"); #endif ff_dec: /* If the field is marked with ^ and the value is undefined, blank it out. */ if ((arg & 512) && !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". */ { STORE_NUMERIC_STANDARD_SET_LOCAL(); my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value); RESTORE_NUMERIC_STANDARD(); } t += fieldsize; break; case FF_NEWLINE: f++; while (t-- > linemark && *t == ' ') ; t++; *t++ = '\n'; break; case FF_BLANK: arg = *fpc++; if (gotsome) { if (arg) { /* repeat until fields exhausted? */ *t = '\0'; SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); lines += FmLINES(PL_formtarget); if (targ_is_utf8) SvUTF8_on(PL_formtarget); FmLINES(PL_formtarget) = lines; SP = ORIGMARK; RETURNOP(cLISTOP->op_first); } } else { t = linemark; lines--; } break; case FF_MORE: { 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 (strnEQ(s1," ",3)) { while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1])) s1--; } *s1++ = '.'; *s1++ = '.'; *s1++ = '.'; } break; } case FF_END: *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; RETPUSHYES; } } } PP(pp_grepstart) { dVAR; dSP; SV *src; if (PL_stack_base + *PL_markstack_ptr == SP) { (void)POPMARK; if (GIMME_V == G_SCALAR) mXPUSHi(0); RETURNOP(PL_op->op_next->op_next); } PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1; pp_pushmark(); /* push dst */ pp_pushmark(); /* push src */ ENTER_with_name("grep"); /* enter outer scope */ SAVETMPS; if (PL_op->op_private & OPpGREP_LEX) SAVESPTR(PAD_SVl(PL_op->op_targ)); else SAVE_DEFSV; ENTER_with_name("grep_item"); /* enter inner scope */ SAVEVPTR(PL_curpm); src = PL_stack_base[*PL_markstack_ptr]; SvTEMP_off(src); if (PL_op->op_private & OPpGREP_LEX) PAD_SVl(PL_op->op_targ) = src; else DEFSV_set(src); PUTBACK; if (PL_op->op_type == OP_MAPSTART) pp_pushmark(); /* push top */ return ((LOGOP*)PL_op->op_next)->op_other; } PP(pp_mapwhile) { dVAR; dSP; const I32 gimme = GIMME_V; I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */ I32 count; I32 shift; SV** src; SV** dst; /* first, move source pointer to the next item in the source list */ ++PL_markstack_ptr[-1]; /* 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 */ 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) { while (items-- > 0) *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs); } 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; } } } LEAVE_with_name("grep_item"); /* exit inner scope */ /* All done yet? */ if (PL_markstack_ptr[-1] > *PL_markstack_ptr) { (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) { if (PL_op->op_private & OPpGREP_LEX) { SV* sv = sv_newmortal(); sv_setiv(sv, items); PUSHs(sv); } else { dTARGET; XPUSHi(items); } } else if (gimme == G_ARRAY) SP += items; RETURN; } else { SV *src; 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]]; SvTEMP_off(src); if (PL_op->op_private & OPpGREP_LEX) PAD_SVl(PL_op->op_targ) = src; else DEFSV_set(src); RETURNOP(cLOGOP->op_other); } } /* Range stuff. */ PP(pp_range) { dVAR; if (GIMME == G_ARRAY) return NORMAL; if (SvTRUEx(PAD_SV(PL_op->op_targ))) return cLOGOP->op_other; else return NORMAL; } PP(pp_flip) { dVAR; dSP; if (GIMME == G_ARRAY) { 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(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); } } sv_setpvs(TARG, ""); SETs(targ); RETURN; } } /* This code tries to decide if "$left .. $right" should use the magical string increment, or if the range is numeric (we make an exception for .."0" [#18165]). AMS 20021031. */ #define RANGE_IS_NUMERIC(left,right) ( \ 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')) \ && (!SvOK(right) || looks_like_number(right)))) PP(pp_flop) { dVAR; dSP; if (GIMME == G_ARRAY) { dPOPPOPssrl; SvGETMAGIC(left); SvGETMAGIC(right); if (RANGE_IS_NUMERIC(left,right)) { register IV i, j; IV max; if ((SvOK(left) && SvNV(left) < IV_MIN) || (SvOK(right) && SvNV(right) > IV_MAX)) DIE(aTHX_ "Range iterator outside integer range"); i = SvIV(left); max = SvIV(right); if (max >= i) { j = max - i + 1; EXTEND_MORTAL(j); EXTEND(SP, j); } else j = 0; while (j--) { SV * const sv = sv_2mortal(newSViv(i++)); PUSHs(sv); } } else { SV * const final = sv_mortalcopy(right); STRLEN len; const char * const tmps = SvPV_const(final, len); SV *sv = sv_mortalcopy(left); SvPV_force_nolen(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(sv); } if (flop) { sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0); sv_catpvs(targ, "E0"); } SETs(targ); } RETURN; } /* Control. */ static const char * const context_name[] = { "pseudo-block", NULL, /* CXt_WHEN never actually needs "block" */ NULL, /* CXt_BLOCK never actually needs "block" */ NULL, /* CXt_GIVEN never actually needs "block" */ NULL, /* CXt_LOOP_FOR never actually needs "loop" */ NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */ NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */ NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */ "subroutine", "format", "eval", "substitution", }; STATIC I32 S_dopoptolabel(pTHX_ const char *label) { dVAR; register I32 i; PERL_ARGS_ASSERT_DOPOPTOLABEL; for (i = cxstack_ix; i >= 0; i--) { register 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: Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", context_name[CxTYPE(cx)], OP_NAME(PL_op)); if (CxTYPE(cx) == CXt_NULL) return -1; break; case CXt_LOOP_LAZYIV: case CXt_LOOP_LAZYSV: case CXt_LOOP_FOR: case CXt_LOOP_PLAIN: { const char *cx_label = CxLABEL(cx); if (!cx_label || strNE(label, cx_label) ) { DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n", (long)i, cx_label)); continue; } DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label)); return i; } } } return i; } I32 Perl_dowantarray(pTHX) { dVAR; const I32 gimme = block_gimme(); return (gimme == G_VOID) ? G_SCALAR : gimme; } I32 Perl_block_gimme(pTHX) { dVAR; const I32 cxix = dopoptosub(cxstack_ix); if (cxix < 0) return G_VOID; switch (cxstack[cxix].blk_gimme) { case G_VOID: return G_VOID; case G_SCALAR: return G_SCALAR; case G_ARRAY: return G_ARRAY; default: Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme); /* NOTREACHED */ return 0; } } I32 Perl_is_lvalue_sub(pTHX) { dVAR; const I32 cxix = dopoptosub(cxstack_ix); 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); else return 0; } STATIC I32 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock) { dVAR; I32 i; PERL_ARGS_ASSERT_DOPOPTOSUB_AT; for (i = startingblock; i >= 0; i--) { register const PERL_CONTEXT * const cx = &cxstk[i]; switch (CxTYPE(cx)) { default: continue; case CXt_EVAL: case CXt_SUB: case CXt_FORMAT: DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i)); return i; } } return i; } STATIC I32 S_dopoptoeval(pTHX_ I32 startingblock) { dVAR; I32 i; for (i = startingblock; i >= 0; i--) { register const PERL_CONTEXT *cx = &cxstack[i]; switch (CxTYPE(cx)) { default: continue; case CXt_EVAL: DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i)); return i; } } return i; } STATIC I32 S_dopoptoloop(pTHX_ I32 startingblock) { dVAR; I32 i; for (i = startingblock; i >= 0; i--) { register 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: Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", context_name[CxTYPE(cx)], OP_NAME(PL_op)); if ((CxTYPE(cx)) == CXt_NULL) return -1; break; case CXt_LOOP_LAZYIV: case CXt_LOOP_LAZYSV: case CXt_LOOP_FOR: case CXt_LOOP_PLAIN: DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i)); return i; } } return i; } STATIC I32 S_dopoptogiven(pTHX_ I32 startingblock) { dVAR; I32 i; for (i = startingblock; i >= 0; i--) { register const PERL_CONTEXT *cx = &cxstack[i]; switch (CxTYPE(cx)) { default: continue; case CXt_GIVEN: DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i)); return i; case CXt_LOOP_PLAIN: assert(!CxFOREACHDEF(cx)); break; case CXt_LOOP_LAZYIV: case CXt_LOOP_LAZYSV: case CXt_LOOP_FOR: if (CxFOREACHDEF(cx)) { DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i)); return i; } } } return i; } STATIC I32 S_dopoptowhen(pTHX_ I32 startingblock) { dVAR; I32 i; for (i = startingblock; i >= 0; i--) { register const PERL_CONTEXT *cx = &cxstack[i]; switch (CxTYPE(cx)) { default: continue; case CXt_WHEN: DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i)); return i; } } return i; } void Perl_dounwind(pTHX_ I32 cxix) { dVAR; I32 optype; while (cxstack_ix > cxix) { SV *sv; register PERL_CONTEXT *cx = &cxstack[cxstack_ix]; DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n", (long) cxstack_ix, PL_block_type[CxTYPE(cx)])); /* Note: we don't need to restore the base context info till the end. */ switch (CxTYPE(cx)) { case CXt_SUBST: POPSUBST(cx); continue; /* not break */ case CXt_SUB: POPSUB(cx,sv); LEAVESUB(sv); break; case CXt_EVAL: POPEVAL(cx); break; case CXt_LOOP_LAZYIV: case CXt_LOOP_LAZYSV: case CXt_LOOP_FOR: case CXt_LOOP_PLAIN: POPLOOP(cx); break; case CXt_NULL: break; case CXt_FORMAT: POPFORMAT(cx); break; } cxstack_ix--; } PERL_UNUSED_VAR(optype); } void Perl_qerror(pTHX_ SV *err) { dVAR; PERL_ARGS_ASSERT_QERROR; if (PL_in_eval) sv_catsv(ERRSV, err); else if (PL_errors) sv_catsv(PL_errors, err); else Perl_warn(aTHX_ "%"SVf, SVfARG(err)); if (PL_parser) ++PL_parser->error_count; } void Perl_die_where(pTHX_ SV *msv) { dVAR; if (PL_in_eval) { I32 cxix; I32 gimme; if (msv) { if (PL_in_eval & EVAL_KEEPERR) { static const char prefix[] = "\t(in cleanup) "; SV * const err = ERRSV; const char *e = NULL; if (!SvPOK(err)) sv_setpvs(err,""); else if (SvCUR(err) >= sizeof(prefix)+SvCUR(msv)-1) { STRLEN len; STRLEN msglen; const char* message = SvPV_const(msv, msglen); e = SvPV_const(err, len); e += len - msglen; if (*e != *message || strNE(e,message)) e = NULL; } if (!e) { STRLEN start; SvGROW(err, SvCUR(err)+sizeof(prefix)+SvCUR(msv)); sv_catpvn(err, prefix, sizeof(prefix)-1); sv_catsv(err, msv); start = SvCUR(err)-SvCUR(msv)-sizeof(prefix)+1; Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "%s", SvPVX_const(err)+start); } } else { STRLEN msglen; const char* message = SvPV_const(msv, msglen); sv_setpvn(ERRSV, message, msglen); SvFLAGS(ERRSV) |= SvFLAGS(msv) & SVf_UTF8; } } while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) { dounwind(-1); POPSTACK; } if (cxix >= 0) { I32 optype; register PERL_CONTEXT *cx; SV **newsp; if (cxix < cxstack_ix) dounwind(cxix); POPBLOCK(cx,PL_curpm); if (CxTYPE(cx) != CXt_EVAL) { STRLEN msglen; const char* message = SvPVx_const( msv ? msv : ERRSV, msglen); PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11); PerlIO_write(Perl_error_log, message, msglen); my_exit(1); } POPEVAL(cx); if (gimme == G_SCALAR) *++newsp = &PL_sv_undef; PL_stack_sp = newsp; LEAVE; /* LEAVE could clobber PL_curcop (see save_re_context()) * XXX it might be better to find a way to avoid messing with * PL_curcop in save_re_context() instead, but this is a more * minimal fix --GSAR */ PL_curcop = cx->blk_oldcop; if (optype == OP_REQUIRE) { const char* const msg = SvPVx_nolen_const(ERRSV); SV * const nsv = cx->blk_eval.old_namesv; (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), &PL_sv_undef, 0); DIE(aTHX_ "%sCompilation failed in require", *msg ? msg : "Unknown error\n"); } assert(CxTYPE(cx) == CXt_EVAL); PL_restartop = cx->blk_eval.retop; JMPENV_JUMP(3); /* NOTREACHED */ } } write_to_stderr( msv ? msv : ERRSV ); my_failure_exit(); /* NOTREACHED */ } PP(pp_xor) { dVAR; dSP; dPOPTOPssrl; if (SvTRUE(left) != SvTRUE(right)) RETSETYES; else RETSETNO; } PP(pp_caller) { dVAR; dSP; register I32 cxix = dopoptosub(cxstack_ix); register const PERL_CONTEXT *cx; register const PERL_CONTEXT *ccstack = cxstack; const PERL_SI *top_si = PL_curstackinfo; I32 gimme; const char *stashname; I32 count = 0; if (MAXARG) count = POPi; 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) { if (GIMME != G_ARRAY) { EXTEND(SP, 1); RETPUSHUNDEF; } RETURN; } /* 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]; 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]; } stashname = CopSTASHPV(cx->blk_oldcop); if (GIMME != G_ARRAY) { EXTEND(SP, 1); if (!stashname) PUSHs(&PL_sv_undef); else { dTARGET; sv_setpv(TARG, stashname); PUSHs(TARG); } RETURN; } EXTEND(SP, 11); if (!stashname) PUSHs(&PL_sv_undef); else mPUSHs(newSVpv(stashname, 0)); mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0)); mPUSHi((I32)CopLINE(cx->blk_oldcop)); if (!MAXARG) RETURN; if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv); /* So is ccstack[dbcxix]. */ if (isGV(cvgv)) { SV * const sv = newSV(0); gv_efullname3(sv, cvgv, NULL); mPUSHs(sv); PUSHs(boolSV(CxHASARGS(cx))); } else { PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP)); PUSHs(boolSV(CxHASARGS(cx))); } } else { PUSHs(newSVpvs_flags("(eval)", SVs_TEMP)); mPUSHi(0); } gimme = (I32)cx->blk_gimme; if (gimme == G_VOID) PUSHs(&PL_sv_undef); else PUSHs(boolSV((gimme & G_WANT) == G_ARRAY)); if (CxTYPE(cx) == CXt_EVAL) { /* eval STRING */ if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) { PUSHs(cx->blk_eval.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); } } else { PUSHs(&PL_sv_undef); PUSHs(&PL_sv_undef); } if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx) && CopSTASH_eq(PL_curcop, PL_debstash)) { AV * const ary = cx->blk_sub.argarray; const int off = AvARRAY(ary) - AvALLOC(ary); if (!PL_dbargs) { PL_dbargs = GvAV(gv_AVadd(gv_fetchpvs("DB::args", GV_ADDMULTI, SVt_PVAV))); AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */ } if (AvMAX(PL_dbargs) < AvFILLp(ary) + off) av_extend(PL_dbargs, AvFILLp(ary) + off); Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*); AvFILLp(PL_dbargs) = AvFILLp(ary) + off; } /* XXX only hints propagated via op_private are currently * visible (others are not easily accessible, since they * use the global PL_hints) */ mPUSHi(CopHINTS_get(cx->blk_oldcop)); { SV * mask ; STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ; if (old_warnings == pWARN_NONE || (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)) mask = newSVpvn(WARN_NONEstring, WARNsize) ; else if (old_warnings == pWARN_ALL || (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) { /* Get the bit mask for $warnings::Bits{all}, because * it could have been extended by warnings::register */ SV **bits_all; HV * const bits = get_hv("warnings::Bits", 0); if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) { mask = newSVsv(*bits_all); } else { 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(Perl_refcounted_he_chain_2hv(aTHX_ cx->blk_oldcop->cop_hints_hash)))) : &PL_sv_undef); RETURN; } PP(pp_reset) { dVAR; dSP; const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx; sv_reset(tmps, CopSTASH(PL_curcop)); PUSHs(&PL_sv_yes); RETURN; } /* like pp_nextstate, but used instead when the debugger is active */ PP(pp_dbstate) { dVAR; PL_curcop = (COP*)PL_op; TAINT_NOT; /* Each statement is presumed innocent */ PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; FREETMPS; if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */ || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace)) { dSP; register PERL_CONTEXT *cx; const I32 gimme = G_ARRAY; U8 hasargs; GV * const gv = PL_DBgv; register CV * const cv = GvCV(gv); if (!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; ENTER; SAVETMPS; SAVEI32(PL_debug); SAVESTACK_POS(); PL_debug = 0; hasargs = 0; SPAGAIN; if (CvISXSUB(cv)) { CvDEPTH(cv)++; PUSHMARK(SP); (void)(*CvXSUB(cv))(aTHX_ cv); CvDEPTH(cv)--; FREETMPS; LEAVE; return NORMAL; } else { PUSHBLOCK(cx, CXt_SUB, SP); PUSHSUB_DB(cx); cx->blk_sub.retop = PL_op->op_next; CvDEPTH(cv)++; SAVECOMPPAD(); PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1); RETURNOP(CvSTART(cv)); } } else return NORMAL; } PP(pp_enteriter) { dVAR; dSP; dMARK; register PERL_CONTEXT *cx; const I32 gimme = GIMME_V; SV **svp; U8 cxtype = CXt_LOOP_FOR; #ifdef USE_ITHREADS PAD *iterdata; #endif ENTER_with_name("loop1"); SAVETMPS; if (PL_op->op_targ) { if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */ SvPADSTALE_off(PAD_SVl(PL_op->op_targ)); SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ), SVs_PADSTALE, SVs_PADSTALE); } SAVEPADSVANDMORTALIZE(PL_op->op_targ); #ifndef USE_ITHREADS svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */ #else iterdata = NULL; #endif } else { GV * const gv = MUTABLE_GV(POPs); svp = &GvSV(gv); /* symbol table variable */ SAVEGENERICSV(*svp); *svp = newSV(0); #ifdef USE_ITHREADS iterdata = (PAD*)gv; #endif } if (PL_op->op_private & OPpITER_DEF) cxtype |= CXp_FOR_DEF; ENTER_with_name("loop2"); PUSHBLOCK(cx, cxtype, SP); #ifdef USE_ITHREADS PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ); #else PUSHLOOP_FOR(cx, svp, MARK, 0); #endif if (PL_op->op_flags & OPf_STACKED) { SV *maybe_ary = POPs; if (SvTYPE(maybe_ary) != SVt_PVAV) { dPOPss; SV * const right = maybe_ary; SvGETMAGIC(sv); SvGETMAGIC(right); if (RANGE_IS_NUMERIC(sv,right)) { cx->cx_type &= ~CXTYPEMASK; cx->cx_type |= CXt_LOOP_LAZYIV; /* Make sure that no-one re-orders cop.h and breaks our assumptions */ assert(CxTYPE(cx) == CXt_LOOP_LAZYIV); #ifdef NV_PRESERVES_UV if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) || (SvNV(sv) > (NV)IV_MAX))) || (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) || (SvNV(right) < (NV)IV_MIN)))) #else if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN) || ((SvNV(sv) > 0) && ((SvUV(sv) > (UV)IV_MAX) || (SvNV(sv) > (NV)UV_MAX))))) || (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN) || ((SvNV(right) > 0) && ((SvUV(right) > (UV)IV_MAX) || (SvNV(right) > (NV)UV_MAX)))))) #endif DIE(aTHX_ "Range iterator outside integer range"); cx->blk_loop.state_u.lazyiv.cur = SvIV(sv); cx->blk_loop.state_u.lazyiv.end = SvIV(right); #ifdef DEBUGGING /* for correct -Dstv display */ cx->blk_oldsp = sp - PL_stack_base; #endif } else { cx->cx_type &= ~CXTYPEMASK; cx->cx_type |= CXt_LOOP_LAZYSV; /* Make sure that no-one re-orders cop.h and breaks our assumptions */ assert(CxTYPE(cx) == CXt_LOOP_LAZYSV); cx->blk_loop.state_u.lazysv.cur = newSVsv(sv); cx->blk_loop.state_u.lazysv.end = right; SvREFCNT_inc(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 */ { cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary); SvREFCNT_inc(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; } } else { /* iterating over items on the stack */ cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */ if (PL_op->op_private & OPpITER_REVERSED) { cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1; } else { cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base; } } RETURN; } PP(pp_enterloop) { dVAR; dSP; register PERL_CONTEXT *cx; const I32 gimme = GIMME_V; ENTER_with_name("loop1"); SAVETMPS; ENTER_with_name("loop2"); PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP); PUSHLOOP_PLAIN(cx, SP); RETURN; } PP(pp_leaveloop) { dVAR; dSP; register PERL_CONTEXT *cx; I32 gimme; SV **newsp; PMOP *newpm; SV **mark; POPBLOCK(cx,newpm); assert(CxTYPE_is_LOOP(cx)); mark = newsp; newsp = PL_stack_base + cx->blk_loop.resetsp; TAINT_NOT; if (gimme == G_VOID) NOOP; else if (gimme == G_SCALAR) { if (mark < SP) *++newsp = sv_mortalcopy(*SP); else *++newsp = &PL_sv_undef; } else { while (mark < SP) { *++newsp = sv_mortalcopy(*++mark); TAINT_NOT; /* Each item is independent */ } } SP = newsp; PUTBACK; POPLOOP(cx); /* Stack values are safe: release loop vars ... */ PL_curpm = newpm; /* ... and pop $1 et al */ LEAVE_with_name("loop2"); LEAVE_with_name("loop1"); return NORMAL; } PP(pp_return) { dVAR; dSP; dMARK; register PERL_CONTEXT *cx; bool popsub2 = FALSE; bool clear_errsv = FALSE; I32 gimme; SV **newsp; PMOP *newpm; I32 optype = 0; SV *sv; OP *retop = NULL; const I32 cxix = dopoptosub(cxstack_ix); if (cxix < 0) { if (CxMULTICALL(cxstack)) { /* In this case we must be in a * sort block, which is a CXt_NULL * not a CXt_SUB */ dounwind(0); PL_stack_base[1] = *PL_stack_sp; PL_stack_sp = PL_stack_base + 1; return 0; } else DIE(aTHX_ "Can't return outside a subroutine"); } if (cxix < cxstack_ix) dounwind(cxix); if (CxMULTICALL(&cxstack[cxix])) { gimme = cxstack[cxix].blk_gimme; if (gimme == G_VOID) PL_stack_sp = PL_stack_base; else if (gimme == G_SCALAR) { PL_stack_base[1] = *PL_stack_sp; PL_stack_sp = PL_stack_base + 1; } return 0; } POPBLOCK(cx,newpm); switch (CxTYPE(cx)) { case CXt_SUB: popsub2 = TRUE; retop = cx->blk_sub.retop; cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */ break; case CXt_EVAL: if (!(PL_in_eval & EVAL_KEEPERR)) clear_errsv = TRUE; POPEVAL(cx); retop = cx->blk_eval.retop; if (CxTRYBLOCK(cx)) break; lex_end(); if (optype == OP_REQUIRE && (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) ) { /* Unassume the success we assumed earlier. */ SV * const nsv = cx->blk_eval.old_namesv; (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD); DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv)); } break; case CXt_FORMAT: POPFORMAT(cx); retop = cx->blk_sub.retop; break; default: DIE(aTHX_ "panic: return"); } TAINT_NOT; if (gimme == G_SCALAR) { if (MARK < SP) { if (popsub2) { if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) { if (SvTEMP(TOPs)) { *++newsp = SvREFCNT_inc(*SP); FREETMPS; sv_2mortal(*newsp); } else { sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */ FREETMPS; *++newsp = sv_mortalcopy(sv); SvREFCNT_dec(sv); } } else *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP); } else *++newsp = sv_mortalcopy(*SP); } else *++newsp = &PL_sv_undef; } else if (gimme == G_ARRAY) { while (++MARK <= SP) { *++newsp = (popsub2 && SvTEMP(*MARK)) ? *MARK : sv_mortalcopy(*MARK); TAINT_NOT; /* Each item is independent */ } } PL_stack_sp = newsp; LEAVE; /* Stack values are safe: */ if (popsub2) { cxstack_ix--; POPSUB(cx,sv); /* release CV and @_ ... */ } else sv = NULL; PL_curpm = newpm; /* ... and pop $1 et al */ LEAVESUB(sv); if (clear_errsv) { CLEAR_ERRSV(); } return retop; } PP(pp_last) { dVAR; dSP; I32 cxix; register PERL_CONTEXT *cx; I32 pop2 = 0; I32 gimme; I32 optype; OP *nextop = NULL; SV **newsp; PMOP *newpm; SV **mark; SV *sv = NULL; if (PL_op->op_flags & OPf_SPECIAL) { cxix = dopoptoloop(cxstack_ix); if (cxix < 0) DIE(aTHX_ "Can't \"last\" outside a loop block"); } else { cxix = dopoptolabel(cPVOP->op_pv); if (cxix < 0) DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv); } if (cxix < cxstack_ix) dounwind(cxix); POPBLOCK(cx,newpm); cxstack_ix++; /* temporarily protect top context */ mark = newsp; switch (CxTYPE(cx)) { case CXt_LOOP_LAZYIV: case CXt_LOOP_LAZYSV: case CXt_LOOP_FOR: case CXt_LOOP_PLAIN: pop2 = CxTYPE(cx); newsp = PL_stack_base + cx->blk_loop.resetsp; nextop = cx->blk_loop.my_op->op_lastop->op_next; break; case CXt_SUB: pop2 = CXt_SUB; nextop = cx->blk_sub.retop; break; case CXt_EVAL: POPEVAL(cx); nextop = cx->blk_eval.retop; break; case CXt_FORMAT: POPFORMAT(cx); nextop = cx->blk_sub.retop; break; default: DIE(aTHX_ "panic: last"); } TAINT_NOT; if (gimme == G_SCALAR) { if (MARK < SP) *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP); else *++newsp = &PL_sv_undef; } else if (gimme == G_ARRAY) { while (++MARK <= SP) { *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK)) ? *MARK : sv_mortalcopy(*MARK); TAINT_NOT; /* Each item is independent */ } } SP = newsp; PUTBACK; LEAVE; cxstack_ix--; /* Stack values are safe: */ switch (pop2) { case CXt_LOOP_LAZYIV: case CXt_LOOP_PLAIN: case CXt_LOOP_LAZYSV: case CXt_LOOP_FOR: POPLOOP(cx); /* release loop vars ... */ LEAVE; break; case CXt_SUB: POPSUB(cx,sv); /* release CV and @_ ... */ break; } PL_curpm = newpm; /* ... and pop $1 et al */ LEAVESUB(sv); PERL_UNUSED_VAR(optype); PERL_UNUSED_VAR(gimme); return nextop; } PP(pp_next) { dVAR; I32 cxix; register PERL_CONTEXT *cx; I32 inner; if (PL_op->op_flags & OPf_SPECIAL) { cxix = dopoptoloop(cxstack_ix); if (cxix < 0) DIE(aTHX_ "Can't \"next\" outside a loop block"); } else { cxix = dopoptolabel(cPVOP->op_pv); if (cxix < 0) DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv); } if (cxix < cxstack_ix) dounwind(cxix); /* clear off anything above the scope we're re-entering, but * save the rest until after a possible continue block */ inner = PL_scopestack_ix; TOPBLOCK(cx); if (PL_scopestack_ix < inner) leave_scope(PL_scopestack[PL_scopestack_ix]); PL_curcop = cx->blk_oldcop; return CX_LOOP_NEXTOP_GET(cx); } PP(pp_redo) { dVAR; I32 cxix; register PERL_CONTEXT *cx; I32 oldsave; OP* redo_op; if (PL_op->op_flags & OPf_SPECIAL) { cxix = dopoptoloop(cxstack_ix); if (cxix < 0) DIE(aTHX_ "Can't \"redo\" outside a loop block"); } else { cxix = dopoptolabel(cPVOP->op_pv); if (cxix < 0) DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv); } if (cxix < cxstack_ix) dounwind(cxix); redo_op = cxstack[cxix].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++; assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK); redo_op = redo_op->op_next; } TOPBLOCK(cx); oldsave = PL_scopestack[PL_scopestack_ix - 1]; LEAVE_SCOPE(oldsave); FREETMPS; PL_curcop = cx->blk_oldcop; return redo_op; } STATIC OP * S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit) { dVAR; OP **ops = opstack; static const char too_deep[] = "Target of goto is too deeply nested"; PERL_ARGS_ASSERT_DOFINDLABEL; if (ops >= oplimit) Perl_croak(aTHX_ 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) { *ops++ = cUNOPo->op_first; if (ops >= oplimit) Perl_croak(aTHX_ too_deep); } *ops = 0; if (o->op_flags & OPf_KIDS) { OP *kid; /* First try all the kids at this level, since that's likeliest. */ for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { const char *kid_label = CopLABEL(kCOP); if (kid_label && strEQ(kid_label, label)) return kid; } } for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { 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]->op_type == OP_NEXTSTATE || ops[-1]->op_type == OP_DBSTATE) ops[-1] = kid; else *ops++ = kid; } if ((o = dofindlabel(kid, label, ops, oplimit))) return o; } } *ops = 0; return 0; } PP(pp_goto) { dVAR; dSP; OP *retop = NULL; I32 ix; register PERL_CONTEXT *cx; #define GOTO_DEPTH 64 OP *enterops[GOTO_DEPTH]; const char *label = NULL; const bool do_dump = (PL_op->op_type == OP_DUMP); static const char must_have_label[] = "goto must have label"; if (PL_op->op_flags & OPf_STACKED) { SV * const sv = POPs; /* This egregious kludge implements goto &subroutine */ if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) { I32 cxix; register PERL_CONTEXT *cx; CV *cv = MUTABLE_CV(SvRV(sv)); SV** mark; I32 items = 0; I32 oldsave; bool reified = 0; retry: if (!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))) goto retry; autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE); if (autogv && (cv = GvCV(autogv))) goto retry; tmpstr = sv_newmortal(); gv_efullname3(tmpstr, gv, NULL); DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr)); } DIE(aTHX_ "Goto undefined subroutine"); } /* First do some returnish stuff. */ SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */ FREETMPS; cxix = dopoptosub(cxstack_ix); if (cxix < 0) DIE(aTHX_ "Can't goto subroutine outside a subroutine"); if (cxix < cxstack_ix) dounwind(cxix); TOPBLOCK(cx); SPAGAIN; /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */ if (CxTYPE(cx) == CXt_EVAL) { if (CxREALEVAL(cx)) DIE(aTHX_ "Can't goto subroutine from an eval-string"); else 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)"); if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) { /* put @_ back onto stack */ AV* av = cx->blk_sub.argarray; items = AvFILLp(av) + 1; EXTEND(SP, items+1); /* @_ could have been extended. */ Copy(AvARRAY(av), SP + 1, items, SV*); SvREFCNT_dec(GvAV(PL_defgv)); GvAV(PL_defgv) = cx->blk_sub.savearray; CLEAR_ARGARRAY(av); /* abandon @_ if it got reified */ if (AvREAL(av)) { reified = 1; SvREFCNT_dec(av); av = newAV(); av_extend(av, items-1); AvREIFY_only(av); PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av); } } else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */ AV* const av = GvAV(PL_defgv); items = AvFILLp(av) + 1; EXTEND(SP, items+1); /* @_ could have been extended. */ Copy(AvARRAY(av), SP + 1, items, SV*); } mark = SP; SP += items; if (CxTYPE(cx) == CXt_SUB && !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) SvREFCNT_dec(cx->blk_sub.cv); oldsave = PL_scopestack[PL_scopestack_ix - 1]; LEAVE_SCOPE(oldsave); /* Now do some callish stuff. */ SAVETMPS; SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */ if (CvISXSUB(cv)) { OP* const retop = cx->blk_sub.retop; SV **newsp; I32 gimme; if (reified) { I32 index; for (index=0; indexblk_eval.old_eval_root; cx->cx_type = CXt_SUB; } cx->blk_sub.cv = cv; cx->blk_sub.olddepth = CvDEPTH(cv); CvDEPTH(cv)++; if (CvDEPTH(cv) < 2) SvREFCNT_inc_simple_void_NN(cv); else { if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)) sub_crush_depth(cv); pad_push(padlist, CvDEPTH(cv)); } SAVECOMPPAD(); PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); if (CxHASARGS(cx)) { AV *const av = MUTABLE_AV(PAD_SVl(0)); cx->blk_sub.savearray = GvAV(PL_defgv); GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av)); CX_CURPAD_SAVE(cx->blk_sub); cx->blk_sub.argarray = av; if (items >= AvMAX(av) + 1) { SV **ary = AvALLOC(av); if (AvARRAY(av) != ary) { AvMAX(av) += AvARRAY(av) - AvALLOC(av); AvARRAY(av) = ary; } if (items >= AvMAX(av) + 1) { AvMAX(av) = items - 1; Renew(ary,items+1,SV*); AvALLOC(av) = ary; AvARRAY(av) = ary; } } ++mark; Copy(mark,AvARRAY(av),items,SV*); AvFILLp(av) = items - 1; assert(!AvREAL(av)); if (reified) { /* transfer 'ownership' of refcnts to new @_ */ AvREAL_on(av); AvREIFY_off(av); } while (items--) { if (*mark) SvTEMP_off(*mark); mark++; } } 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--; } } } RETURNOP(CvSTART(cv)); } } else { label = SvPV_nolen_const(sv); if (!(do_dump || *label)) DIE(aTHX_ must_have_label); } } else if (PL_op->op_flags & OPf_SPECIAL) { if (! do_dump) DIE(aTHX_ must_have_label); } else label = cPVOP->op_pv; if (label && *label) { OP *gotoprobe = NULL; bool leaving_eval = FALSE; bool in_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; } /* else fall through */ case CXt_LOOP_LAZYIV: case CXt_LOOP_LAZYSV: case CXt_LOOP_FOR: case CXt_LOOP_PLAIN: case CXt_GIVEN: case CXt_WHEN: gotoprobe = cx->blk_oldcop->op_sibling; break; case CXt_SUBST: continue; case CXt_BLOCK: if (ix) { gotoprobe = cx->blk_oldcop->op_sibling; in_block = TRUE; } else gotoprobe = PL_main_root; break; case CXt_SUB: if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) { gotoprobe = CvROOT(cx->blk_sub.cv); break; } /* FALL THROUGH */ case CXt_FORMAT: case CXt_NULL: DIE(aTHX_ "Can't \"goto\" out of a pseudo block"); default: if (ix) DIE(aTHX_ "panic: goto"); gotoprobe = PL_main_root; break; } if (gotoprobe) { retop = dofindlabel(gotoprobe, label, enterops, enterops + GOTO_DEPTH); if (retop) break; } PL_lastgotoprobe = gotoprobe; } if (!retop) DIE(aTHX_ "Can't find label %s", 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 */ if (leaving_eval && *enterops && enterops[1]) { I32 i; for (i = 1; enterops[i]; i++) if (enterops[i]->op_type == OP_ENTERITER) DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop"); } if (*enterops && enterops[1]) { I32 i = 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) { I32 oldsave; if (ix < 0) ix = 0; dounwind(ix); TOPBLOCK(cx); oldsave = PL_scopestack[PL_scopestack_ix]; LEAVE_SCOPE(oldsave); } /* push wanted frames */ if (*enterops && enterops[1]) { OP * const oldop = PL_op; ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1; for (; enterops[ix]; ix++) { PL_op = enterops[ix]; /* Eventually we may want to stack the needed arguments * for each op. For now, we punt on the hard ones. */ if (PL_op->op_type == OP_ENTERITER) DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop"); CALL_FPTR(PL_op->op_ppaddr)(aTHX); } PL_op = oldop; } } if (do_dump) { #ifdef VMS if (!retop) retop = PL_main_start; #endif PL_restartop = retop; PL_do_undump = TRUE; my_unexec(); PL_restartop = 0; /* hmm, must be GNU unexec().. */ PL_do_undump = FALSE; } RETURNOP(retop); } PP(pp_exit) { dVAR; dSP; I32 anum; if (MAXARG < 1) anum = 0; else { anum = SvIVx(POPs); #ifdef VMS if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH)) anum = 0; VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH); #endif } PL_exit_flags |= PERL_EXIT_EXPECTED; #ifdef PERL_MAD /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */ if (anum || !(PL_minus_c && PL_madskills)) my_exit(anum); #else my_exit(anum); #endif PUSHs(&PL_sv_undef); RETURN; } /* Eval. */ STATIC void S_save_lines(pTHX_ AV *array, SV *sv) { const char *s = SvPVX_const(sv); const char * const send = SvPVX_const(sv) + SvCUR(sv); I32 line = 1; PERL_ARGS_ASSERT_SAVE_LINES; while (s && s < send) { const char *t; SV * const tmpstr = newSV_type(SVt_PVMG); 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; } } /* =for apidoc docatch Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context. 0 is used as continue inside eval, 3 is used for a die caught by an inner eval - continue inner loop See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must establish a local jmpenv to handle exception traps. =cut */ STATIC OP * S_docatch(pTHX_ OP *o) { dVAR; int ret; OP * const oldop = PL_op; dJMPENV; #ifdef DEBUGGING assert(CATCH_GET == TRUE); #endif PL_op = o; JMPENV_PUSH(ret); switch (ret) { case 0: assert(cxstack_ix >= 0); assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env; redo_body: CALLRUNOPS(aTHX); break; case 3: /* die caught by an inner eval - continue inner loop */ /* NB XXX we rely on the old popped CxEVAL still being at the top * of the stack; the way die_where() currently works, this * assumption is valid. In theory The cur_top_env value should be * returned in another global, the way retop (aka PL_restartop) * is. */ assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL); if (PL_restartop && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env) { PL_op = PL_restartop; PL_restartop = 0; goto redo_body; } /* FALL THROUGH */ default: JMPENV_POP; PL_op = oldop; JMPENV_JUMP(ret); /* NOTREACHED */ } JMPENV_POP; PL_op = oldop; return NULL; } /* James Bond: Do you expect me to talk? Auric Goldfinger: No, Mr. Bond. I expect you to die. This code is an ugly hack, doesn't work with lexicals in subroutines that are called more than once, and is only used by regcomp.c, for (?{}) blocks. Currently it is not used outside the core code. Best if it stays that way. */ OP * Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) /* sv Text to convert to OP tree. */ /* startop op_free() this to undo. */ /* code Short string id of the caller. */ { dVAR; dSP; /* Make POPBLOCK work. */ PERL_CONTEXT *cx; SV **newsp; I32 gimme = G_VOID; I32 optype; OP dummy; char tbuf[TYPE_DIGITS(long) + 12 + 10]; char *tmpbuf = tbuf; char *safestr; int runtime; CV* runcv = NULL; /* initialise to avoid compiler warnings */ STRLEN len; PERL_ARGS_ASSERT_SV_COMPILE_2OP; ENTER_with_name("eval"); lex_start(sv, NULL, FALSE); SAVETMPS; /* switch to eval mode */ if (IN_PERL_COMPILETIME) { SAVECOPSTASH_FREE(&PL_compiling); CopSTASH_set(&PL_compiling, PL_curstash); } if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { SV * const sv = sv_newmortal(); Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]", code, (unsigned long)++PL_evalseq, CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); tmpbuf = SvPVX(sv); len = SvCUR(sv); } else len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq); SAVECOPFILE_FREE(&PL_compiling); CopFILE_set(&PL_compiling, tmpbuf+2); SAVECOPLINE(&PL_compiling); CopLINE_set(&PL_compiling, 1); /* XXX For Cs 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 */ safestr = savepvn(tmpbuf, len); SAVEDELETE(PL_defstash, safestr, len); SAVEHINTS(); #ifdef OP_IN_REGISTER PL_opsave = op; #else SAVEVPTR(PL_op); #endif /* we get here either during compilation, or via pp_regcomp at runtime */ runtime = IN_PERL_RUNTIME; if (runtime) runcv = find_runcv(NULL); PL_op = &dummy; PL_op->op_type = OP_ENTEREVAL; PL_op->op_flags = 0; /* Avoid uninit warning. */ PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP); PUSHEVAL(cx, 0); if (runtime) (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq); else (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax); POPBLOCK(cx,PL_curpm); POPEVAL(cx); (*startop)->op_type = OP_NULL; (*startop)->op_ppaddr = PL_ppaddr[OP_NULL]; lex_end(); /* XXX DAPM do this properly one year */ *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad)); LEAVE_with_name("eval"); if (IN_PERL_COMPILETIME) CopHINTS_set(&PL_compiling, PL_hints); #ifdef OP_IN_REGISTER op = PL_opsave; #endif PERL_UNUSED_VAR(newsp); PERL_UNUSED_VAR(optype); return PL_eval_start; } /* =for apidoc find_runcv Locate the CV corresponding to the currently executing sub or eval. If db_seqp is non_null, skip CVs that are in the DB package and populate *db_seqp with the cop sequence number at the point that the DB:: code was entered. (allows debuggers to eval in the scope of the breakpoint rather than in the scope of the debugger itself). =cut */ CV* Perl_find_runcv(pTHX_ U32 *db_seqp) { dVAR; PERL_SI *si; if (db_seqp) *db_seqp = 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]); if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { CV * const 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; } return cv; } else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx)) return PL_compcv; } } return PL_main_cv; } /* Compile a require/do, an eval '', or a /(?{...})/. * In the last case, startop is non-null, and contains the address of * a pointer that should be set to the just-compiled code. * outside is the lexically enclosing CV (if any) that invoked us. * Returns a bool indicating whether the compile was successful; if so, * PL_eval_start contains the first op of the compiled ocde; otherwise, * pushes undef (also croaks if startop != NULL). */ STATIC bool S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) { dVAR; dSP; OP * const saveop = PL_op; PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE) ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL)) : EVAL_INEVAL); PUSHMARK(SP); SAVESPTR(PL_compcv); PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV)); CvEVAL_on(PL_compcv); assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); cxstack[cxstack_ix].blk_eval.cv = PL_compcv; CvOUTSIDE_SEQ(PL_compcv) = seq; CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside)); /* set up a scratch pad */ CvPADLIST(PL_compcv) = pad_new(padnew_SAVE); PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */ if (!PL_madskills) SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */ /* make sure we compile in the right package */ if (CopSTASH_ne(PL_curcop, PL_curstash)) { SAVESPTR(PL_curstash); PL_curstash = CopSTASH(PL_curcop); } /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */ SAVESPTR(PL_beginav); PL_beginav = newAV(); SAVEFREESV(PL_beginav); SAVESPTR(PL_unitcheckav); PL_unitcheckav = newAV(); SAVEFREESV(PL_unitcheckav); #ifdef PERL_MAD SAVEBOOL(PL_madskills); PL_madskills = 0; #endif /* try to compile it */ PL_eval_root = NULL; PL_curcop = &PL_compiling; CopARYBASE_set(PL_curcop, 0); if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL)) PL_in_eval |= EVAL_KEEPERR; else CLEAR_ERRSV(); if (yyparse() || PL_parser->error_count || !PL_eval_root) { SV **newsp; /* Used by POPBLOCK. */ PERL_CONTEXT *cx = &cxstack[cxstack_ix]; I32 optype = 0; /* Might be reset by POPEVAL. */ const char *msg; PL_op = saveop; if (PL_eval_root) { op_free(PL_eval_root); PL_eval_root = NULL; } SP = PL_stack_base + POPMARK; /* pop original mark */ if (!startop) { POPBLOCK(cx,PL_curpm); POPEVAL(cx); } lex_end(); LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */ msg = SvPVx_nolen_const(ERRSV); if (optype == OP_REQUIRE) { const SV * const nsv = cx->blk_eval.old_namesv; (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), &PL_sv_undef, 0); Perl_croak(aTHX_ "%sCompilation failed in require", *msg ? msg : "Unknown error\n"); } else if (startop) { POPBLOCK(cx,PL_curpm); POPEVAL(cx); Perl_croak(aTHX_ "%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n")); } else { if (!*msg) { sv_setpvs(ERRSV, "Compilation error"); } } PERL_UNUSED_VAR(newsp); PUSHs(&PL_sv_undef); PUTBACK; return FALSE; } CopLINE_set(&PL_compiling, 0); if (startop) { *startop = PL_eval_root; } else SAVEFREEOP(PL_eval_root); /* Set the context for this new optree. * Propagate the context from the eval(). */ if ((gimme & G_WANT) == G_VOID) scalarvoid(PL_eval_root); else if ((gimme & G_WANT) == G_ARRAY) list(PL_eval_root); else scalar(PL_eval_root); DEBUG_x(dump_eval()); /* Register with debugger: */ if (PERLDB_INTER && saveop && 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); } } if (PL_unitcheckav) call_list(PL_scopestack_ix, PL_unitcheckav); /* compiled okay, so do it */ CvDEPTH(PL_compcv) = 1; SP = PL_stack_base + POPMARK; /* pop original mark */ PL_op = saveop; /* The caller may need it. */ PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */ PUTBACK; return TRUE; } STATIC PerlIO * S_check_type_and_open(pTHX_ const char *name) { Stat_t st; const int st_rc = PerlLIO_stat(name, &st); PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN; if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) { return NULL; } return PerlIO_open(name, PERL_SCRIPT_MODE); } #ifndef PERL_DISABLE_PMC STATIC PerlIO * S_doopen_pm(pTHX_ const char *name, const STRLEN namelen) { PerlIO *fp; PERL_ARGS_ASSERT_DOOPEN_PM; if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) { SV *const pmcsv = newSV(namelen + 2); char *const pmc = SvPVX(pmcsv); Stat_t pmcstat; memcpy(pmc, name, namelen); pmc[namelen] = 'c'; pmc[namelen + 1] = '\0'; if (PerlLIO_stat(pmc, &pmcstat) < 0) { fp = check_type_and_open(name); } else { fp = check_type_and_open(pmc); } SvREFCNT_dec(pmcsv); } else { fp = check_type_and_open(name); } return fp; } #else # define doopen_pm(name, namelen) check_type_and_open(name) #endif /* !PERL_DISABLE_PMC */ PP(pp_require) { dVAR; dSP; register PERL_CONTEXT *cx; SV *sv; const char *name; STRLEN len; char * unixname; STRLEN unixlen; #ifdef VMS int vms_unixname = 0; #endif const char *tryname = NULL; SV *namesv = NULL; const I32 gimme = GIMME_V; int filter_has_file = 0; PerlIO *tryrsfp = NULL; SV *filter_cache = NULL; SV *filter_state = NULL; SV *filter_sub = NULL; SV *hook_sv = NULL; SV *encoding; OP *op; sv = POPs; if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) { sv = new_version(sv); if (!sv_derived_from(PL_patchlevel, "version")) upg_version(PL_patchlevel, TRUE); if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) { if ( vcmp(sv,PL_patchlevel) <= 0 ) DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped", SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel))); } else { if ( vcmp(sv,PL_patchlevel) > 0 ) { I32 first = 0; AV *lav; SV * const req = SvRV(sv); SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE); /* get the left hand term */ lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE))); first = SvIV(*av_fetch(lav,0,0)); if ( first > (int)PERL_REVISION /* probably 'use 6.0' */ || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */ || av_len(lav) > 1 /* FP with > 3 digits */ || strstr(SvPVX(pv),".0") /* FP with leading 0 */ ) { DIE(aTHX_ "Perl %"SVf" required--this is only " "%"SVf", stopped", SVfARG(vnormal(req)), SVfARG(vnormal(PL_patchlevel))); } else { /* probably 'use 5.10' or 'use 5.8' */ SV *hintsv; I32 second = 0; if (av_len(lav)>=1) second = SvIV(*av_fetch(lav,1,0)); second /= second >= 600 ? 100 : 10; hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0", (int)first, (int)second); upg_version(hintsv, TRUE); DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)" "--this is only %"SVf", stopped", SVfARG(vnormal(req)), SVfARG(vnormal(sv_2mortal(hintsv))), SVfARG(vnormal(PL_patchlevel))); } } } /* We do this only with use, not require. */ if (PL_compcv && /* If we request a version >= 5.9.5, load feature.pm with the * feature bundle that corresponds to the required version. */ vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) { SV *const importsv = vnormal(sv); *SvPVX_mutable(importsv) = ':'; ENTER_with_name("load_feature"); Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL); LEAVE_with_name("load_feature"); } /* If a version >= 5.11.0 is requested, strictures are on by default! */ if (PL_compcv && vcmp(sv, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) { PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS); } RETPUSHYES; } name = SvPV_const(sv, len); if (!(name && len > 0 && *name)) DIE(aTHX_ "Null filename used"); TAINT_PROPER("require"); #ifdef VMS /* The key in the %ENV hash is in the syntax of file passed as the argument * usually this is in UNIX format, but sometimes in VMS format, which * can result in a module being pulled in more than once. * To prevent this, the key must be stored in UNIX format if the VMS * name can be translated to UNIX. */ if ((unixname = tounixspec(name, NULL)) != 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; } if (PL_op->op_type == OP_REQUIRE) { SV * const * const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0); if ( svp ) { if (*svp != &PL_sv_undef) RETPUSHYES; else DIE(aTHX_ "Attempt to reload %s aborted.\n" "Compilation failed in require", unixname); } } /* prepare to compile file */ if (path_is_absolute(name)) { tryname = name; tryrsfp = doopen_pm(name, len); } if (!tryrsfp) { AV * const ar = GvAVn(PL_incgv); I32 i; #ifdef VMS if (vms_unixname) #endif { namesv = newSV_type(SVt_PV); for (i = 0; i <= AvFILL(ar); i++) { SV * const dirsv = *av_fetch(ar, i, TRUE); if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied)) mg_get(dirsv); if (SvROK(dirsv)) { int count; SV **svp; SV *loader = dirsv; if (SvTYPE(SvRV(loader)) == SVt_PVAV && !sv_isobject(loader)) { loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE); } Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s", PTR2UV(SvRV(dirsv)), name); tryname = SvPVX_const(namesv); tryrsfp = NULL; ENTER_with_name("call_INC"); SAVETMPS; EXTEND(SP, 2); PUSHMARK(SP); PUSHs(dirsv); PUSHs(sv); PUTBACK; if (sv_isobject(loader)) count = call_method("INC", G_ARRAY); else count = call_sv(loader, G_ARRAY); SPAGAIN; /* Adjust file name if the hook has set a me